This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Use grok_atou instead of atoi.
[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_static.c"
90 #include "charclass_invlists.h"
91 #include "inline_invlist.c"
92 #include "unicode_constants.h"
93
94 #define HAS_NONLATIN1_FOLD_CLOSURE(i) \
95  _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
96 #define HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(i) \
97  _HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
98 #define IS_NON_FINAL_FOLD(c) _IS_NON_FINAL_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
99 #define IS_IN_SOME_FOLD_L1(c) _IS_IN_SOME_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
100
101 #ifndef STATIC
102 #define STATIC  static
103 #endif
104
105
106 struct RExC_state_t {
107     U32         flags;                  /* RXf_* are we folding, multilining? */
108     U32         pm_flags;               /* PMf_* stuff from the calling PMOP */
109     char        *precomp;               /* uncompiled string. */
110     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
111     regexp      *rx;                    /* perl core regexp structure */
112     regexp_internal     *rxi;           /* internal data for regexp object
113                                            pprivate field */
114     char        *start;                 /* Start of input for compile */
115     char        *end;                   /* End of input for compile */
116     char        *parse;                 /* Input-scan pointer. */
117     SSize_t     whilem_seen;            /* number of WHILEM in this expr */
118     regnode     *emit_start;            /* Start of emitted-code area */
119     regnode     *emit_bound;            /* First regnode outside of the
120                                            allocated space */
121     regnode     *emit;                  /* Code-emit pointer; if = &emit_dummy,
122                                            implies compiling, so don't emit */
123     regnode_ssc emit_dummy;             /* placeholder for emit to point to;
124                                            large enough for the largest
125                                            non-EXACTish node, so can use it as
126                                            scratch in pass1 */
127     I32         naughty;                /* How bad is this pattern? */
128     I32         sawback;                /* Did we see \1, ...? */
129     U32         seen;
130     SSize_t     size;                   /* Code size. */
131     I32                npar;            /* Capture buffer count, (OPEN) plus
132                                            one. ("par" 0 is the whole
133                                            pattern)*/
134     I32         nestroot;               /* root parens we are in - used by
135                                            accept */
136     I32         extralen;
137     I32         seen_zerolen;
138     regnode     **open_parens;          /* pointers to open parens */
139     regnode     **close_parens;         /* pointers to close parens */
140     regnode     *opend;                 /* END node in program */
141     I32         utf8;           /* whether the pattern is utf8 or not */
142     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
143                                 /* XXX use this for future optimisation of case
144                                  * where pattern must be upgraded to utf8. */
145     I32         uni_semantics;  /* If a d charset modifier should use unicode
146                                    rules, even if the pattern is not in
147                                    utf8 */
148     HV          *paren_names;           /* Paren names */
149
150     regnode     **recurse;              /* Recurse regops */
151     I32         recurse_count;          /* Number of recurse regops */
152     U8          *study_chunk_recursed;  /* bitmap of which parens we have moved
153                                            through */
154     U32         study_chunk_recursed_bytes;  /* bytes in bitmap */
155     I32         in_lookbehind;
156     I32         contains_locale;
157     I32         contains_i;
158     I32         override_recoding;
159     I32         in_multi_char_class;
160     struct reg_code_block *code_blocks; /* positions of literal (?{})
161                                             within pattern */
162     int         num_code_blocks;        /* size of code_blocks[] */
163     int         code_index;             /* next code_blocks[] slot */
164     SSize_t     maxlen;                        /* mininum possible number of chars in string to match */
165 #ifdef ADD_TO_REGEXEC
166     char        *starttry;              /* -Dr: where regtry was called. */
167 #define RExC_starttry   (pRExC_state->starttry)
168 #endif
169     SV          *runtime_code_qr;       /* qr with the runtime code blocks */
170 #ifdef DEBUGGING
171     const char  *lastparse;
172     I32         lastnum;
173     AV          *paren_name_list;       /* idx -> name */
174 #define RExC_lastparse  (pRExC_state->lastparse)
175 #define RExC_lastnum    (pRExC_state->lastnum)
176 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
177 #endif
178 };
179
180 #define RExC_flags      (pRExC_state->flags)
181 #define RExC_pm_flags   (pRExC_state->pm_flags)
182 #define RExC_precomp    (pRExC_state->precomp)
183 #define RExC_rx_sv      (pRExC_state->rx_sv)
184 #define RExC_rx         (pRExC_state->rx)
185 #define RExC_rxi        (pRExC_state->rxi)
186 #define RExC_start      (pRExC_state->start)
187 #define RExC_end        (pRExC_state->end)
188 #define RExC_parse      (pRExC_state->parse)
189 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
190 #ifdef RE_TRACK_PATTERN_OFFSETS
191 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the
192                                                          others */
193 #endif
194 #define RExC_emit       (pRExC_state->emit)
195 #define RExC_emit_dummy (pRExC_state->emit_dummy)
196 #define RExC_emit_start (pRExC_state->emit_start)
197 #define RExC_emit_bound (pRExC_state->emit_bound)
198 #define RExC_naughty    (pRExC_state->naughty)
199 #define RExC_sawback    (pRExC_state->sawback)
200 #define RExC_seen       (pRExC_state->seen)
201 #define RExC_size       (pRExC_state->size)
202 #define RExC_maxlen        (pRExC_state->maxlen)
203 #define RExC_npar       (pRExC_state->npar)
204 #define RExC_nestroot   (pRExC_state->nestroot)
205 #define RExC_extralen   (pRExC_state->extralen)
206 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
207 #define RExC_utf8       (pRExC_state->utf8)
208 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
209 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
210 #define RExC_open_parens        (pRExC_state->open_parens)
211 #define RExC_close_parens       (pRExC_state->close_parens)
212 #define RExC_opend      (pRExC_state->opend)
213 #define RExC_paren_names        (pRExC_state->paren_names)
214 #define RExC_recurse    (pRExC_state->recurse)
215 #define RExC_recurse_count      (pRExC_state->recurse_count)
216 #define RExC_study_chunk_recursed        (pRExC_state->study_chunk_recursed)
217 #define RExC_study_chunk_recursed_bytes  \
218                                    (pRExC_state->study_chunk_recursed_bytes)
219 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
220 #define RExC_contains_locale    (pRExC_state->contains_locale)
221 #define RExC_contains_i (pRExC_state->contains_i)
222 #define RExC_override_recoding (pRExC_state->override_recoding)
223 #define RExC_in_multi_char_class (pRExC_state->in_multi_char_class)
224
225
226 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
227 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
228         ((*s) == '{' && regcurly(s)))
229
230 /*
231  * Flags to be passed up and down.
232  */
233 #define WORST           0       /* Worst case. */
234 #define HASWIDTH        0x01    /* Known to match non-null strings. */
235
236 /* Simple enough to be STAR/PLUS operand; in an EXACTish node must be a single
237  * character.  (There needs to be a case: in the switch statement in regexec.c
238  * for any node marked SIMPLE.)  Note that this is not the same thing as
239  * REGNODE_SIMPLE */
240 #define SIMPLE          0x02
241 #define SPSTART         0x04    /* Starts with * or + */
242 #define POSTPONED       0x08    /* (?1),(?&name), (??{...}) or similar */
243 #define TRYAGAIN        0x10    /* Weeded out a declaration. */
244 #define RESTART_UTF8    0x20    /* Restart, need to calcuate sizes as UTF-8 */
245
246 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
247
248 /* whether trie related optimizations are enabled */
249 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
250 #define TRIE_STUDY_OPT
251 #define FULL_TRIE_STUDY
252 #define TRIE_STCLASS
253 #endif
254
255
256
257 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
258 #define PBITVAL(paren) (1 << ((paren) & 7))
259 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
260 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
261 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
262
263 #define REQUIRE_UTF8    STMT_START {                                       \
264                                      if (!UTF) {                           \
265                                          *flagp = RESTART_UTF8;            \
266                                          return NULL;                      \
267                                      }                                     \
268                         } STMT_END
269
270 /* This converts the named class defined in regcomp.h to its equivalent class
271  * number defined in handy.h. */
272 #define namedclass_to_classnum(class)  ((int) ((class) / 2))
273 #define classnum_to_namedclass(classnum)  ((classnum) * 2)
274
275 #define _invlist_union_complement_2nd(a, b, output) \
276                         _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
277 #define _invlist_intersection_complement_2nd(a, b, output) \
278                  _invlist_intersection_maybe_complement_2nd(a, b, TRUE, output)
279
280 /* About scan_data_t.
281
282   During optimisation we recurse through the regexp program performing
283   various inplace (keyhole style) optimisations. In addition study_chunk
284   and scan_commit populate this data structure with information about
285   what strings MUST appear in the pattern. We look for the longest
286   string that must appear at a fixed location, and we look for the
287   longest string that may appear at a floating location. So for instance
288   in the pattern:
289
290     /FOO[xX]A.*B[xX]BAR/
291
292   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
293   strings (because they follow a .* construct). study_chunk will identify
294   both FOO and BAR as being the longest fixed and floating strings respectively.
295
296   The strings can be composites, for instance
297
298      /(f)(o)(o)/
299
300   will result in a composite fixed substring 'foo'.
301
302   For each string some basic information is maintained:
303
304   - offset or min_offset
305     This is the position the string must appear at, or not before.
306     It also implicitly (when combined with minlenp) tells us how many
307     characters must match before the string we are searching for.
308     Likewise when combined with minlenp and the length of the string it
309     tells us how many characters must appear after the string we have
310     found.
311
312   - max_offset
313     Only used for floating strings. This is the rightmost point that
314     the string can appear at. If set to SSize_t_MAX it indicates that the
315     string can occur infinitely far to the right.
316
317   - minlenp
318     A pointer to the minimum number of characters of the pattern that the
319     string was found inside. This is important as in the case of positive
320     lookahead or positive lookbehind we can have multiple patterns
321     involved. Consider
322
323     /(?=FOO).*F/
324
325     The minimum length of the pattern overall is 3, the minimum length
326     of the lookahead part is 3, but the minimum length of the part that
327     will actually match is 1. So 'FOO's minimum length is 3, but the
328     minimum length for the F is 1. This is important as the minimum length
329     is used to determine offsets in front of and behind the string being
330     looked for.  Since strings can be composites this is the length of the
331     pattern at the time it was committed with a scan_commit. Note that
332     the length is calculated by study_chunk, so that the minimum lengths
333     are not known until the full pattern has been compiled, thus the
334     pointer to the value.
335
336   - lookbehind
337
338     In the case of lookbehind the string being searched for can be
339     offset past the start point of the final matching string.
340     If this value was just blithely removed from the min_offset it would
341     invalidate some of the calculations for how many chars must match
342     before or after (as they are derived from min_offset and minlen and
343     the length of the string being searched for).
344     When the final pattern is compiled and the data is moved from the
345     scan_data_t structure into the regexp structure the information
346     about lookbehind is factored in, with the information that would
347     have been lost precalculated in the end_shift field for the
348     associated string.
349
350   The fields pos_min and pos_delta are used to store the minimum offset
351   and the delta to the maximum offset at the current point in the pattern.
352
353 */
354
355 typedef struct scan_data_t {
356     /*I32 len_min;      unused */
357     /*I32 len_delta;    unused */
358     SSize_t pos_min;
359     SSize_t pos_delta;
360     SV *last_found;
361     SSize_t last_end;       /* min value, <0 unless valid. */
362     SSize_t last_start_min;
363     SSize_t last_start_max;
364     SV **longest;           /* Either &l_fixed, or &l_float. */
365     SV *longest_fixed;      /* longest fixed string found in pattern */
366     SSize_t offset_fixed;   /* offset where it starts */
367     SSize_t *minlen_fixed;  /* pointer to the minlen relevant to the string */
368     I32 lookbehind_fixed;   /* is the position of the string modfied by LB */
369     SV *longest_float;      /* longest floating string found in pattern */
370     SSize_t offset_float_min; /* earliest point in string it can appear */
371     SSize_t offset_float_max; /* latest point in string it can appear */
372     SSize_t *minlen_float;  /* pointer to the minlen relevant to the string */
373     SSize_t lookbehind_float; /* is the pos of the string modified by LB */
374     I32 flags;
375     I32 whilem_c;
376     SSize_t *last_closep;
377     regnode_ssc *start_class;
378 } scan_data_t;
379
380 /* The below is perhaps overboard, but this allows us to save a test at the
381  * expense of a mask.  This is because on both EBCDIC and ASCII machines, 'A'
382  * and 'a' differ by a single bit; the same with the upper and lower case of
383  * all other ASCII-range alphabetics.  On ASCII platforms, they are 32 apart;
384  * on EBCDIC, they are 64.  This uses an exclusive 'or' to find that bit and
385  * then inverts it to form a mask, with just a single 0, in the bit position
386  * where the upper- and lowercase differ.  XXX There are about 40 other
387  * instances in the Perl core where this micro-optimization could be used.
388  * Should decide if maintenance cost is worse, before changing those
389  *
390  * Returns a boolean as to whether or not 'v' is either a lowercase or
391  * uppercase instance of 'c', where 'c' is in [A-Za-z].  If 'c' is a
392  * compile-time constant, the generated code is better than some optimizing
393  * compilers figure out, amounting to a mask and test.  The results are
394  * meaningless if 'c' is not one of [A-Za-z] */
395 #define isARG2_lower_or_UPPER_ARG1(c, v) \
396                               (((v) & ~('A' ^ 'a')) ==  ((c) & ~('A' ^ 'a')))
397
398 /*
399  * Forward declarations for pregcomp()'s friends.
400  */
401
402 static const scan_data_t zero_scan_data =
403   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
404
405 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
406 #define SF_BEFORE_SEOL          0x0001
407 #define SF_BEFORE_MEOL          0x0002
408 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
409 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
410
411 #define SF_FIX_SHIFT_EOL        (+2)
412 #define SF_FL_SHIFT_EOL         (+4)
413
414 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
415 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
416
417 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
418 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
419 #define SF_IS_INF               0x0040
420 #define SF_HAS_PAR              0x0080
421 #define SF_IN_PAR               0x0100
422 #define SF_HAS_EVAL             0x0200
423 #define SCF_DO_SUBSTR           0x0400
424 #define SCF_DO_STCLASS_AND      0x0800
425 #define SCF_DO_STCLASS_OR       0x1000
426 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
427 #define SCF_WHILEM_VISITED_POS  0x2000
428
429 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
430 #define SCF_SEEN_ACCEPT         0x8000
431 #define SCF_TRIE_DOING_RESTUDY 0x10000
432
433 #define UTF cBOOL(RExC_utf8)
434
435 /* The enums for all these are ordered so things work out correctly */
436 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
437 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags)                    \
438                                                      == REGEX_DEPENDS_CHARSET)
439 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
440 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags)                \
441                                                      >= REGEX_UNICODE_CHARSET)
442 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags)                      \
443                                             == REGEX_ASCII_RESTRICTED_CHARSET)
444 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags)             \
445                                             >= REGEX_ASCII_RESTRICTED_CHARSET)
446 #define ASCII_FOLD_RESTRICTED (get_regex_charset(RExC_flags)                 \
447                                         == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
448
449 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
450
451 /* For programs that want to be strictly Unicode compatible by dying if any
452  * attempt is made to match a non-Unicode code point against a Unicode
453  * property.  */
454 #define ALWAYS_WARN_SUPER  ckDEAD(packWARN(WARN_NON_UNICODE))
455
456 #define OOB_NAMEDCLASS          -1
457
458 /* There is no code point that is out-of-bounds, so this is problematic.  But
459  * its only current use is to initialize a variable that is always set before
460  * looked at. */
461 #define OOB_UNICODE             0xDEADBEEF
462
463 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
464 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
465
466
467 /* length of regex to show in messages that don't mark a position within */
468 #define RegexLengthToShowInErrorMessages 127
469
470 /*
471  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
472  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
473  * op/pragma/warn/regcomp.
474  */
475 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
476 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
477
478 #define REPORT_LOCATION " in regex; marked by " MARKER1    \
479                         " in m/%"UTF8f MARKER2 "%"UTF8f"/"
480
481 #define REPORT_LOCATION_ARGS(offset)            \
482                 UTF8fARG(UTF, offset, RExC_precomp), \
483                 UTF8fARG(UTF, RExC_end - RExC_precomp - offset, RExC_precomp + offset)
484
485 /*
486  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
487  * arg. Show regex, up to a maximum length. If it's too long, chop and add
488  * "...".
489  */
490 #define _FAIL(code) STMT_START {                                        \
491     const char *ellipses = "";                                          \
492     IV len = RExC_end - RExC_precomp;                                   \
493                                                                         \
494     if (!SIZE_ONLY)                                                     \
495         SAVEFREESV(RExC_rx_sv);                                         \
496     if (len > RegexLengthToShowInErrorMessages) {                       \
497         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
498         len = RegexLengthToShowInErrorMessages - 10;                    \
499         ellipses = "...";                                               \
500     }                                                                   \
501     code;                                                               \
502 } STMT_END
503
504 #define FAIL(msg) _FAIL(                            \
505     Perl_croak(aTHX_ "%s in regex m/%"UTF8f"%s/",           \
506             msg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
507
508 #define FAIL2(msg,arg) _FAIL(                       \
509     Perl_croak(aTHX_ msg " in regex m/%"UTF8f"%s/",         \
510             arg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
511
512 /*
513  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
514  */
515 #define Simple_vFAIL(m) STMT_START {                                    \
516     const IV offset = RExC_parse - RExC_precomp;                        \
517     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
518             m, REPORT_LOCATION_ARGS(offset));   \
519 } STMT_END
520
521 /*
522  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
523  */
524 #define vFAIL(m) STMT_START {                           \
525     if (!SIZE_ONLY)                                     \
526         SAVEFREESV(RExC_rx_sv);                         \
527     Simple_vFAIL(m);                                    \
528 } STMT_END
529
530 /*
531  * Like Simple_vFAIL(), but accepts two arguments.
532  */
533 #define Simple_vFAIL2(m,a1) STMT_START {                        \
534     const IV offset = RExC_parse - RExC_precomp;                        \
535     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,                      \
536                       REPORT_LOCATION_ARGS(offset));    \
537 } STMT_END
538
539 /*
540  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
541  */
542 #define vFAIL2(m,a1) STMT_START {                       \
543     if (!SIZE_ONLY)                                     \
544         SAVEFREESV(RExC_rx_sv);                         \
545     Simple_vFAIL2(m, a1);                               \
546 } STMT_END
547
548
549 /*
550  * Like Simple_vFAIL(), but accepts three arguments.
551  */
552 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
553     const IV offset = RExC_parse - RExC_precomp;                \
554     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,          \
555             REPORT_LOCATION_ARGS(offset));      \
556 } STMT_END
557
558 /*
559  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
560  */
561 #define vFAIL3(m,a1,a2) STMT_START {                    \
562     if (!SIZE_ONLY)                                     \
563         SAVEFREESV(RExC_rx_sv);                         \
564     Simple_vFAIL3(m, a1, a2);                           \
565 } STMT_END
566
567 /*
568  * Like Simple_vFAIL(), but accepts four arguments.
569  */
570 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
571     const IV offset = RExC_parse - RExC_precomp;                \
572     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2, a3,              \
573             REPORT_LOCATION_ARGS(offset));      \
574 } STMT_END
575
576 #define vFAIL4(m,a1,a2,a3) STMT_START {                 \
577     if (!SIZE_ONLY)                                     \
578         SAVEFREESV(RExC_rx_sv);                         \
579     Simple_vFAIL4(m, a1, a2, a3);                       \
580 } STMT_END
581
582 /* A specialized version of vFAIL2 that works with UTF8f */
583 #define vFAIL2utf8f(m, a1) STMT_START { \
584     const IV offset = RExC_parse - RExC_precomp;   \
585     if (!SIZE_ONLY)                                \
586         SAVEFREESV(RExC_rx_sv);                    \
587     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, \
588             REPORT_LOCATION_ARGS(offset));         \
589 } STMT_END
590
591
592 /* m is not necessarily a "literal string", in this macro */
593 #define reg_warn_non_literal_string(loc, m) STMT_START {                \
594     const IV offset = loc - RExC_precomp;                               \
595     Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s" REPORT_LOCATION,      \
596             m, REPORT_LOCATION_ARGS(offset));       \
597 } STMT_END
598
599 #define ckWARNreg(loc,m) STMT_START {                                   \
600     const IV offset = loc - RExC_precomp;                               \
601     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
602             REPORT_LOCATION_ARGS(offset));              \
603 } STMT_END
604
605 #define vWARN_dep(loc, m) STMT_START {                                  \
606     const IV offset = loc - RExC_precomp;                               \
607     Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), m REPORT_LOCATION,     \
608             REPORT_LOCATION_ARGS(offset));              \
609 } STMT_END
610
611 #define ckWARNdep(loc,m) STMT_START {                                   \
612     const IV offset = loc - RExC_precomp;                               \
613     Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),                   \
614             m REPORT_LOCATION,                                          \
615             REPORT_LOCATION_ARGS(offset));              \
616 } STMT_END
617
618 #define ckWARNregdep(loc,m) STMT_START {                                \
619     const IV offset = loc - RExC_precomp;                               \
620     Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),     \
621             m REPORT_LOCATION,                                          \
622             REPORT_LOCATION_ARGS(offset));              \
623 } STMT_END
624
625 #define ckWARN2reg_d(loc,m, a1) STMT_START {                            \
626     const IV offset = loc - RExC_precomp;                               \
627     Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP),                       \
628             m REPORT_LOCATION,                                          \
629             a1, REPORT_LOCATION_ARGS(offset));  \
630 } STMT_END
631
632 #define ckWARN2reg(loc, m, a1) STMT_START {                             \
633     const IV offset = loc - RExC_precomp;                               \
634     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
635             a1, REPORT_LOCATION_ARGS(offset));  \
636 } STMT_END
637
638 #define vWARN3(loc, m, a1, a2) STMT_START {                             \
639     const IV offset = loc - RExC_precomp;                               \
640     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
641             a1, a2, REPORT_LOCATION_ARGS(offset));      \
642 } STMT_END
643
644 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                         \
645     const IV offset = loc - RExC_precomp;                               \
646     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
647             a1, a2, REPORT_LOCATION_ARGS(offset));      \
648 } STMT_END
649
650 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
651     const IV offset = loc - RExC_precomp;                               \
652     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
653             a1, a2, a3, REPORT_LOCATION_ARGS(offset)); \
654 } STMT_END
655
656 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
657     const IV offset = loc - RExC_precomp;                               \
658     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
659             a1, a2, a3, REPORT_LOCATION_ARGS(offset)); \
660 } STMT_END
661
662 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
663     const IV offset = loc - RExC_precomp;                               \
664     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
665             a1, a2, a3, a4, REPORT_LOCATION_ARGS(offset)); \
666 } STMT_END
667
668
669 /* Allow for side effects in s */
670 #define REGC(c,s) STMT_START {                  \
671     if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
672 } STMT_END
673
674 /* Macros for recording node offsets.   20001227 mjd@plover.com
675  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
676  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
677  * Element 0 holds the number n.
678  * Position is 1 indexed.
679  */
680 #ifndef RE_TRACK_PATTERN_OFFSETS
681 #define Set_Node_Offset_To_R(node,byte)
682 #define Set_Node_Offset(node,byte)
683 #define Set_Cur_Node_Offset
684 #define Set_Node_Length_To_R(node,len)
685 #define Set_Node_Length(node,len)
686 #define Set_Node_Cur_Length(node,start)
687 #define Node_Offset(n)
688 #define Node_Length(n)
689 #define Set_Node_Offset_Length(node,offset,len)
690 #define ProgLen(ri) ri->u.proglen
691 #define SetProgLen(ri,x) ri->u.proglen = x
692 #else
693 #define ProgLen(ri) ri->u.offsets[0]
694 #define SetProgLen(ri,x) ri->u.offsets[0] = x
695 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
696     if (! SIZE_ONLY) {                                                  \
697         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
698                     __LINE__, (int)(node), (int)(byte)));               \
699         if((node) < 0) {                                                \
700             Perl_croak(aTHX_ "value of node is %d in Offset macro",     \
701                                          (int)(node));                  \
702         } else {                                                        \
703             RExC_offsets[2*(node)-1] = (byte);                          \
704         }                                                               \
705     }                                                                   \
706 } STMT_END
707
708 #define Set_Node_Offset(node,byte) \
709     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
710 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
711
712 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
713     if (! SIZE_ONLY) {                                                  \
714         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
715                 __LINE__, (int)(node), (int)(len)));                    \
716         if((node) < 0) {                                                \
717             Perl_croak(aTHX_ "value of node is %d in Length macro",     \
718                                          (int)(node));                  \
719         } else {                                                        \
720             RExC_offsets[2*(node)] = (len);                             \
721         }                                                               \
722     }                                                                   \
723 } STMT_END
724
725 #define Set_Node_Length(node,len) \
726     Set_Node_Length_To_R((node)-RExC_emit_start, len)
727 #define Set_Node_Cur_Length(node, start)                \
728     Set_Node_Length(node, RExC_parse - start)
729
730 /* Get offsets and lengths */
731 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
732 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
733
734 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
735     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
736     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
737 } STMT_END
738 #endif
739
740 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
741 #define EXPERIMENTAL_INPLACESCAN
742 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
743
744 #define DEBUG_RExC_seen() \
745         DEBUG_OPTIMISE_MORE_r({                                             \
746             PerlIO_printf(Perl_debug_log,"RExC_seen: ");                    \
747                                                                             \
748             if (RExC_seen & REG_ZERO_LEN_SEEN)                              \
749                 PerlIO_printf(Perl_debug_log,"REG_ZERO_LEN_SEEN ");         \
750                                                                             \
751             if (RExC_seen & REG_LOOKBEHIND_SEEN)                            \
752                 PerlIO_printf(Perl_debug_log,"REG_LOOKBEHIND_SEEN ");       \
753                                                                             \
754             if (RExC_seen & REG_GPOS_SEEN)                                  \
755                 PerlIO_printf(Perl_debug_log,"REG_GPOS_SEEN ");             \
756                                                                             \
757             if (RExC_seen & REG_CANY_SEEN)                                  \
758                 PerlIO_printf(Perl_debug_log,"REG_CANY_SEEN ");             \
759                                                                             \
760             if (RExC_seen & REG_RECURSE_SEEN)                               \
761                 PerlIO_printf(Perl_debug_log,"REG_RECURSE_SEEN ");          \
762                                                                             \
763             if (RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)                         \
764                 PerlIO_printf(Perl_debug_log,"REG_TOP_LEVEL_BRANCHES_SEEN ");    \
765                                                                             \
766             if (RExC_seen & REG_VERBARG_SEEN)                               \
767                 PerlIO_printf(Perl_debug_log,"REG_VERBARG_SEEN ");          \
768                                                                             \
769             if (RExC_seen & REG_CUTGROUP_SEEN)                              \
770                 PerlIO_printf(Perl_debug_log,"REG_CUTGROUP_SEEN ");         \
771                                                                             \
772             if (RExC_seen & REG_RUN_ON_COMMENT_SEEN)                        \
773                 PerlIO_printf(Perl_debug_log,"REG_RUN_ON_COMMENT_SEEN ");   \
774                                                                             \
775             if (RExC_seen & REG_UNFOLDED_MULTI_SEEN)                        \
776                 PerlIO_printf(Perl_debug_log,"REG_UNFOLDED_MULTI_SEEN ");   \
777                                                                             \
778             if (RExC_seen & REG_GOSTART_SEEN)                               \
779                 PerlIO_printf(Perl_debug_log,"REG_GOSTART_SEEN ");          \
780                                                                             \
781             if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)                               \
782                 PerlIO_printf(Perl_debug_log,"REG_UNBOUNDED_QUANTIFIER_SEEN ");          \
783                                                                             \
784             PerlIO_printf(Perl_debug_log,"\n");                             \
785         });
786
787 #define DEBUG_STUDYDATA(str,data,depth)                              \
788 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
789     PerlIO_printf(Perl_debug_log,                                    \
790         "%*s" str "Pos:%"IVdf"/%"IVdf                                \
791         " Flags: 0x%"UVXf" Whilem_c: %"IVdf" Lcp: %"IVdf" %s",       \
792         (int)(depth)*2, "",                                          \
793         (IV)((data)->pos_min),                                       \
794         (IV)((data)->pos_delta),                                     \
795         (UV)((data)->flags),                                         \
796         (IV)((data)->whilem_c),                                      \
797         (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
798         is_inf ? "INF " : ""                                         \
799     );                                                               \
800     if ((data)->last_found)                                          \
801         PerlIO_printf(Perl_debug_log,                                \
802             "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
803             " %sFloat: '%s' @ %"IVdf"/%"IVdf"",                      \
804             SvPVX_const((data)->last_found),                         \
805             (IV)((data)->last_end),                                  \
806             (IV)((data)->last_start_min),                            \
807             (IV)((data)->last_start_max),                            \
808             ((data)->longest &&                                      \
809              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
810             SvPVX_const((data)->longest_fixed),                      \
811             (IV)((data)->offset_fixed),                              \
812             ((data)->longest &&                                      \
813              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
814             SvPVX_const((data)->longest_float),                      \
815             (IV)((data)->offset_float_min),                          \
816             (IV)((data)->offset_float_max)                           \
817         );                                                           \
818     PerlIO_printf(Perl_debug_log,"\n");                              \
819 });
820
821 /* Mark that we cannot extend a found fixed substring at this point.
822    Update the longest found anchored substring and the longest found
823    floating substrings if needed. */
824
825 STATIC void
826 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data,
827                     SSize_t *minlenp, int is_inf)
828 {
829     const STRLEN l = CHR_SVLEN(data->last_found);
830     const STRLEN old_l = CHR_SVLEN(*data->longest);
831     GET_RE_DEBUG_FLAGS_DECL;
832
833     PERL_ARGS_ASSERT_SCAN_COMMIT;
834
835     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
836         SvSetMagicSV(*data->longest, data->last_found);
837         if (*data->longest == data->longest_fixed) {
838             data->offset_fixed = l ? data->last_start_min : data->pos_min;
839             if (data->flags & SF_BEFORE_EOL)
840                 data->flags
841                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
842             else
843                 data->flags &= ~SF_FIX_BEFORE_EOL;
844             data->minlen_fixed=minlenp;
845             data->lookbehind_fixed=0;
846         }
847         else { /* *data->longest == data->longest_float */
848             data->offset_float_min = l ? data->last_start_min : data->pos_min;
849             data->offset_float_max = (l
850                                       ? data->last_start_max
851                                       : (data->pos_delta == SSize_t_MAX
852                                          ? SSize_t_MAX
853                                          : data->pos_min + data->pos_delta));
854             if (is_inf
855                  || (STRLEN)data->offset_float_max > (STRLEN)SSize_t_MAX)
856                 data->offset_float_max = SSize_t_MAX;
857             if (data->flags & SF_BEFORE_EOL)
858                 data->flags
859                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
860             else
861                 data->flags &= ~SF_FL_BEFORE_EOL;
862             data->minlen_float=minlenp;
863             data->lookbehind_float=0;
864         }
865     }
866     SvCUR_set(data->last_found, 0);
867     {
868         SV * const sv = data->last_found;
869         if (SvUTF8(sv) && SvMAGICAL(sv)) {
870             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
871             if (mg)
872                 mg->mg_len = 0;
873         }
874     }
875     data->last_end = -1;
876     data->flags &= ~SF_BEFORE_EOL;
877     DEBUG_STUDYDATA("commit: ",data,0);
878 }
879
880 /* An SSC is just a regnode_charclass_posix with an extra field: the inversion
881  * list that describes which code points it matches */
882
883 STATIC void
884 S_ssc_anything(pTHX_ regnode_ssc *ssc)
885 {
886     /* Set the SSC 'ssc' to match an empty string or any code point */
887
888     PERL_ARGS_ASSERT_SSC_ANYTHING;
889
890     assert(is_ANYOF_SYNTHETIC(ssc));
891
892     ssc->invlist = sv_2mortal(_new_invlist(2)); /* mortalize so won't leak */
893     _append_range_to_invlist(ssc->invlist, 0, UV_MAX);
894     ANYOF_FLAGS(ssc) |= ANYOF_EMPTY_STRING;    /* Plus match empty string */
895 }
896
897 STATIC int
898 S_ssc_is_anything(const regnode_ssc *ssc)
899 {
900     /* Returns TRUE if the SSC 'ssc' can match the empty string and any code
901      * point; FALSE otherwise.  Thus, this is used to see if using 'ssc' buys
902      * us anything: if the function returns TRUE, 'ssc' hasn't been restricted
903      * in any way, so there's no point in using it */
904
905     UV start, end;
906     bool ret;
907
908     PERL_ARGS_ASSERT_SSC_IS_ANYTHING;
909
910     assert(is_ANYOF_SYNTHETIC(ssc));
911
912     if (! (ANYOF_FLAGS(ssc) & ANYOF_EMPTY_STRING)) {
913         return FALSE;
914     }
915
916     /* See if the list consists solely of the range 0 - Infinity */
917     invlist_iterinit(ssc->invlist);
918     ret = invlist_iternext(ssc->invlist, &start, &end)
919           && start == 0
920           && end == UV_MAX;
921
922     invlist_iterfinish(ssc->invlist);
923
924     if (ret) {
925         return TRUE;
926     }
927
928     /* If e.g., both \w and \W are set, matches everything */
929     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
930         int i;
931         for (i = 0; i < ANYOF_POSIXL_MAX; i += 2) {
932             if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i+1)) {
933                 return TRUE;
934             }
935         }
936     }
937
938     return FALSE;
939 }
940
941 STATIC void
942 S_ssc_init(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc)
943 {
944     /* Initializes the SSC 'ssc'.  This includes setting it to match an empty
945      * string, any code point, or any posix class under locale */
946
947     PERL_ARGS_ASSERT_SSC_INIT;
948
949     Zero(ssc, 1, regnode_ssc);
950     set_ANYOF_SYNTHETIC(ssc);
951     ARG_SET(ssc, ANYOF_NONBITMAP_EMPTY);
952     ssc_anything(ssc);
953
954     /* If any portion of the regex is to operate under locale rules,
955      * initialization includes it.  The reason this isn't done for all regexes
956      * is that the optimizer was written under the assumption that locale was
957      * all-or-nothing.  Given the complexity and lack of documentation in the
958      * optimizer, and that there are inadequate test cases for locale, many
959      * parts of it may not work properly, it is safest to avoid locale unless
960      * necessary. */
961     if (RExC_contains_locale) {
962         ANYOF_POSIXL_SETALL(ssc);
963     }
964     else {
965         ANYOF_POSIXL_ZERO(ssc);
966     }
967 }
968
969 STATIC int
970 S_ssc_is_cp_posixl_init(const RExC_state_t *pRExC_state,
971                         const regnode_ssc *ssc)
972 {
973     /* Returns TRUE if the SSC 'ssc' is in its initial state with regard only
974      * to the list of code points matched, and locale posix classes; hence does
975      * not check its flags) */
976
977     UV start, end;
978     bool ret;
979
980     PERL_ARGS_ASSERT_SSC_IS_CP_POSIXL_INIT;
981
982     assert(is_ANYOF_SYNTHETIC(ssc));
983
984     invlist_iterinit(ssc->invlist);
985     ret = invlist_iternext(ssc->invlist, &start, &end)
986           && start == 0
987           && end == UV_MAX;
988
989     invlist_iterfinish(ssc->invlist);
990
991     if (! ret) {
992         return FALSE;
993     }
994
995     if (RExC_contains_locale && ! ANYOF_POSIXL_SSC_TEST_ALL_SET(ssc)) {
996         return FALSE;
997     }
998
999     return TRUE;
1000 }
1001
1002 STATIC SV*
1003 S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state,
1004                                const regnode_charclass* const node)
1005 {
1006     /* Returns a mortal inversion list defining which code points are matched
1007      * by 'node', which is of type ANYOF.  Handles complementing the result if
1008      * appropriate.  If some code points aren't knowable at this time, the
1009      * returned list must, and will, contain every code point that is a
1010      * possibility. */
1011
1012     SV* invlist = sv_2mortal(_new_invlist(0));
1013     SV* only_utf8_locale_invlist = NULL;
1014     unsigned int i;
1015     const U32 n = ARG(node);
1016     bool new_node_has_latin1 = FALSE;
1017
1018     PERL_ARGS_ASSERT_GET_ANYOF_CP_LIST_FOR_SSC;
1019
1020     /* Look at the data structure created by S_set_ANYOF_arg() */
1021     if (n != ANYOF_NONBITMAP_EMPTY) {
1022         SV * const rv = MUTABLE_SV(RExC_rxi->data->data[n]);
1023         AV * const av = MUTABLE_AV(SvRV(rv));
1024         SV **const ary = AvARRAY(av);
1025         assert(RExC_rxi->data->what[n] == 's');
1026
1027         if (ary[1] && ary[1] != &PL_sv_undef) { /* Has compile-time swash */
1028             invlist = sv_2mortal(invlist_clone(_get_swash_invlist(ary[1])));
1029         }
1030         else if (ary[0] && ary[0] != &PL_sv_undef) {
1031
1032             /* Here, no compile-time swash, and there are things that won't be
1033              * known until runtime -- we have to assume it could be anything */
1034             return _add_range_to_invlist(invlist, 0, UV_MAX);
1035         }
1036         else if (ary[3] && ary[3] != &PL_sv_undef) {
1037
1038             /* Here no compile-time swash, and no run-time only data.  Use the
1039              * node's inversion list */
1040             invlist = sv_2mortal(invlist_clone(ary[3]));
1041         }
1042
1043         /* Get the code points valid only under UTF-8 locales */
1044         if ((ANYOF_FLAGS(node) & ANYOF_LOC_FOLD)
1045             && ary[2] && ary[2] != &PL_sv_undef)
1046         {
1047             only_utf8_locale_invlist = ary[2];
1048         }
1049     }
1050
1051     /* An ANYOF node contains a bitmap for the first 256 code points, and an
1052      * inversion list for the others, but if there are code points that should
1053      * match only conditionally on the target string being UTF-8, those are
1054      * placed in the inversion list, and not the bitmap.  Since there are
1055      * circumstances under which they could match, they are included in the
1056      * SSC.  But if the ANYOF node is to be inverted, we have to exclude them
1057      * here, so that when we invert below, the end result actually does include
1058      * them.  (Think about "\xe0" =~ /[^\xc0]/di;).  We have to do this here
1059      * before we add the unconditionally matched code points */
1060     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1061         _invlist_intersection_complement_2nd(invlist,
1062                                              PL_UpperLatin1,
1063                                              &invlist);
1064     }
1065
1066     /* Add in the points from the bit map */
1067     for (i = 0; i < 256; i++) {
1068         if (ANYOF_BITMAP_TEST(node, i)) {
1069             invlist = add_cp_to_invlist(invlist, i);
1070             new_node_has_latin1 = TRUE;
1071         }
1072     }
1073
1074     /* If this can match all upper Latin1 code points, have to add them
1075      * as well */
1076     if (ANYOF_FLAGS(node) & ANYOF_NON_UTF8_NON_ASCII_ALL) {
1077         _invlist_union(invlist, PL_UpperLatin1, &invlist);
1078     }
1079
1080     /* Similarly for these */
1081     if (ANYOF_FLAGS(node) & ANYOF_ABOVE_LATIN1_ALL) {
1082         invlist = _add_range_to_invlist(invlist, 256, UV_MAX);
1083     }
1084
1085     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1086         _invlist_invert(invlist);
1087     }
1088     else if (new_node_has_latin1 && ANYOF_FLAGS(node) & ANYOF_LOC_FOLD) {
1089
1090         /* Under /li, any 0-255 could fold to any other 0-255, depending on the
1091          * locale.  We can skip this if there are no 0-255 at all. */
1092         _invlist_union(invlist, PL_Latin1, &invlist);
1093     }
1094
1095     /* Similarly add the UTF-8 locale possible matches.  These have to be
1096      * deferred until after the non-UTF-8 locale ones are taken care of just
1097      * above, or it leads to wrong results under ANYOF_INVERT */
1098     if (only_utf8_locale_invlist) {
1099         _invlist_union_maybe_complement_2nd(invlist,
1100                                             only_utf8_locale_invlist,
1101                                             ANYOF_FLAGS(node) & ANYOF_INVERT,
1102                                             &invlist);
1103     }
1104
1105     return invlist;
1106 }
1107
1108 /* These two functions currently do the exact same thing */
1109 #define ssc_init_zero           ssc_init
1110
1111 #define ssc_add_cp(ssc, cp)   ssc_add_range((ssc), (cp), (cp))
1112 #define ssc_match_all_cp(ssc) ssc_add_range(ssc, 0, UV_MAX)
1113
1114 /* 'AND' a given class with another one.  Can create false positives.  'ssc'
1115  * should not be inverted.  'and_with->flags & ANYOF_POSIXL' should be 0 if
1116  * 'and_with' is a regnode_charclass instead of a regnode_ssc. */
1117
1118 STATIC void
1119 S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1120                 const regnode_charclass *and_with)
1121 {
1122     /* Accumulate into SSC 'ssc' its 'AND' with 'and_with', which is either
1123      * another SSC or a regular ANYOF class.  Can create false positives. */
1124
1125     SV* anded_cp_list;
1126     U8  anded_flags;
1127
1128     PERL_ARGS_ASSERT_SSC_AND;
1129
1130     assert(is_ANYOF_SYNTHETIC(ssc));
1131
1132     /* 'and_with' is used as-is if it too is an SSC; otherwise have to extract
1133      * the code point inversion list and just the relevant flags */
1134     if (is_ANYOF_SYNTHETIC(and_with)) {
1135         anded_cp_list = ((regnode_ssc *)and_with)->invlist;
1136         anded_flags = ANYOF_FLAGS(and_with);
1137
1138         /* XXX This is a kludge around what appears to be deficiencies in the
1139          * optimizer.  If we make S_ssc_anything() add in the WARN_SUPER flag,
1140          * there are paths through the optimizer where it doesn't get weeded
1141          * out when it should.  And if we don't make some extra provision for
1142          * it like the code just below, it doesn't get added when it should.
1143          * This solution is to add it only when AND'ing, which is here, and
1144          * only when what is being AND'ed is the pristine, original node
1145          * matching anything.  Thus it is like adding it to ssc_anything() but
1146          * only when the result is to be AND'ed.  Probably the same solution
1147          * could be adopted for the same problem we have with /l matching,
1148          * which is solved differently in S_ssc_init(), and that would lead to
1149          * fewer false positives than that solution has.  But if this solution
1150          * creates bugs, the consequences are only that a warning isn't raised
1151          * that should be; while the consequences for having /l bugs is
1152          * incorrect matches */
1153         if (ssc_is_anything((regnode_ssc *)and_with)) {
1154             anded_flags |= ANYOF_WARN_SUPER;
1155         }
1156     }
1157     else {
1158         anded_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, and_with);
1159         anded_flags = ANYOF_FLAGS(and_with) & ANYOF_COMMON_FLAGS;
1160     }
1161
1162     ANYOF_FLAGS(ssc) &= anded_flags;
1163
1164     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1165      * C2 is the list of code points in 'and-with'; P2, its posix classes.
1166      * 'and_with' may be inverted.  When not inverted, we have the situation of
1167      * computing:
1168      *  (C1 | P1) & (C2 | P2)
1169      *                     =  (C1 & (C2 | P2)) | (P1 & (C2 | P2))
1170      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1171      *                    <=  ((C1 & C2) |       P2)) | ( P1       | (P1 & P2))
1172      *                    <=  ((C1 & C2) | P1 | P2)
1173      * Alternatively, the last few steps could be:
1174      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1175      *                    <=  ((C1 & C2) |  C1      ) | (      C2  | (P1 & P2))
1176      *                    <=  (C1 | C2 | (P1 & P2))
1177      * We favor the second approach if either P1 or P2 is non-empty.  This is
1178      * because these components are a barrier to doing optimizations, as what
1179      * they match cannot be known until the moment of matching as they are
1180      * dependent on the current locale, 'AND"ing them likely will reduce or
1181      * eliminate them.
1182      * But we can do better if we know that C1,P1 are in their initial state (a
1183      * frequent occurrence), each matching everything:
1184      *  (<everything>) & (C2 | P2) =  C2 | P2
1185      * Similarly, if C2,P2 are in their initial state (again a frequent
1186      * occurrence), the result is a no-op
1187      *  (C1 | P1) & (<everything>) =  C1 | P1
1188      *
1189      * Inverted, we have
1190      *  (C1 | P1) & ~(C2 | P2)  =  (C1 | P1) & (~C2 & ~P2)
1191      *                          =  (C1 & (~C2 & ~P2)) | (P1 & (~C2 & ~P2))
1192      *                         <=  (C1 & ~C2) | (P1 & ~P2)
1193      * */
1194
1195     if ((ANYOF_FLAGS(and_with) & ANYOF_INVERT)
1196         && ! is_ANYOF_SYNTHETIC(and_with))
1197     {
1198         unsigned int i;
1199
1200         ssc_intersection(ssc,
1201                          anded_cp_list,
1202                          FALSE /* Has already been inverted */
1203                          );
1204
1205         /* If either P1 or P2 is empty, the intersection will be also; can skip
1206          * the loop */
1207         if (! (ANYOF_FLAGS(and_with) & ANYOF_POSIXL)) {
1208             ANYOF_POSIXL_ZERO(ssc);
1209         }
1210         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1211
1212             /* Note that the Posix class component P from 'and_with' actually
1213              * looks like:
1214              *      P = Pa | Pb | ... | Pn
1215              * where each component is one posix class, such as in [\w\s].
1216              * Thus
1217              *      ~P = ~(Pa | Pb | ... | Pn)
1218              *         = ~Pa & ~Pb & ... & ~Pn
1219              *        <= ~Pa | ~Pb | ... | ~Pn
1220              * The last is something we can easily calculate, but unfortunately
1221              * is likely to have many false positives.  We could do better
1222              * in some (but certainly not all) instances if two classes in
1223              * P have known relationships.  For example
1224              *      :lower: <= :alpha: <= :alnum: <= \w <= :graph: <= :print:
1225              * So
1226              *      :lower: & :print: = :lower:
1227              * And similarly for classes that must be disjoint.  For example,
1228              * since \s and \w can have no elements in common based on rules in
1229              * the POSIX standard,
1230              *      \w & ^\S = nothing
1231              * Unfortunately, some vendor locales do not meet the Posix
1232              * standard, in particular almost everything by Microsoft.
1233              * The loop below just changes e.g., \w into \W and vice versa */
1234
1235             regnode_charclass_posixl temp;
1236             int add = 1;    /* To calculate the index of the complement */
1237
1238             ANYOF_POSIXL_ZERO(&temp);
1239             for (i = 0; i < ANYOF_MAX; i++) {
1240                 assert(i % 2 != 0
1241                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)
1242                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i + 1));
1243
1244                 if (ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)) {
1245                     ANYOF_POSIXL_SET(&temp, i + add);
1246                 }
1247                 add = 0 - add; /* 1 goes to -1; -1 goes to 1 */
1248             }
1249             ANYOF_POSIXL_AND(&temp, ssc);
1250
1251         } /* else ssc already has no posixes */
1252     } /* else: Not inverted.  This routine is a no-op if 'and_with' is an SSC
1253          in its initial state */
1254     else if (! is_ANYOF_SYNTHETIC(and_with)
1255              || ! ssc_is_cp_posixl_init(pRExC_state, (regnode_ssc *)and_with))
1256     {
1257         /* But if 'ssc' is in its initial state, the result is just 'and_with';
1258          * copy it over 'ssc' */
1259         if (ssc_is_cp_posixl_init(pRExC_state, ssc)) {
1260             if (is_ANYOF_SYNTHETIC(and_with)) {
1261                 StructCopy(and_with, ssc, regnode_ssc);
1262             }
1263             else {
1264                 ssc->invlist = anded_cp_list;
1265                 ANYOF_POSIXL_ZERO(ssc);
1266                 if (ANYOF_FLAGS(and_with) & ANYOF_POSIXL) {
1267                     ANYOF_POSIXL_OR((regnode_charclass_posixl*) and_with, ssc);
1268                 }
1269             }
1270         }
1271         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)
1272                  || (ANYOF_FLAGS(and_with) & ANYOF_POSIXL))
1273         {
1274             /* One or the other of P1, P2 is non-empty. */
1275             if (ANYOF_FLAGS(and_with) & ANYOF_POSIXL) {
1276                 ANYOF_POSIXL_AND((regnode_charclass_posixl*) and_with, ssc);
1277             }
1278             ssc_union(ssc, anded_cp_list, FALSE);
1279         }
1280         else { /* P1 = P2 = empty */
1281             ssc_intersection(ssc, anded_cp_list, FALSE);
1282         }
1283     }
1284 }
1285
1286 STATIC void
1287 S_ssc_or(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1288                const regnode_charclass *or_with)
1289 {
1290     /* Accumulate into SSC 'ssc' its 'OR' with 'or_with', which is either
1291      * another SSC or a regular ANYOF class.  Can create false positives if
1292      * 'or_with' is to be inverted. */
1293
1294     SV* ored_cp_list;
1295     U8 ored_flags;
1296
1297     PERL_ARGS_ASSERT_SSC_OR;
1298
1299     assert(is_ANYOF_SYNTHETIC(ssc));
1300
1301     /* 'or_with' is used as-is if it too is an SSC; otherwise have to extract
1302      * the code point inversion list and just the relevant flags */
1303     if (is_ANYOF_SYNTHETIC(or_with)) {
1304         ored_cp_list = ((regnode_ssc*) or_with)->invlist;
1305         ored_flags = ANYOF_FLAGS(or_with);
1306     }
1307     else {
1308         ored_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, or_with);
1309         ored_flags = ANYOF_FLAGS(or_with) & ANYOF_COMMON_FLAGS;
1310     }
1311
1312     ANYOF_FLAGS(ssc) |= ored_flags;
1313
1314     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1315      * C2 is the list of code points in 'or-with'; P2, its posix classes.
1316      * 'or_with' may be inverted.  When not inverted, we have the simple
1317      * situation of computing:
1318      *  (C1 | P1) | (C2 | P2)  =  (C1 | C2) | (P1 | P2)
1319      * If P1|P2 yields a situation with both a class and its complement are
1320      * set, like having both \w and \W, this matches all code points, and we
1321      * can delete these from the P component of the ssc going forward.  XXX We
1322      * might be able to delete all the P components, but I (khw) am not certain
1323      * about this, and it is better to be safe.
1324      *
1325      * Inverted, we have
1326      *  (C1 | P1) | ~(C2 | P2)  =  (C1 | P1) | (~C2 & ~P2)
1327      *                         <=  (C1 | P1) | ~C2
1328      *                         <=  (C1 | ~C2) | P1
1329      * (which results in actually simpler code than the non-inverted case)
1330      * */
1331
1332     if ((ANYOF_FLAGS(or_with) & ANYOF_INVERT)
1333         && ! is_ANYOF_SYNTHETIC(or_with))
1334     {
1335         /* We ignore P2, leaving P1 going forward */
1336     }   /* else  Not inverted */
1337     else if (ANYOF_FLAGS(or_with) & ANYOF_POSIXL) {
1338         ANYOF_POSIXL_OR((regnode_charclass_posixl*)or_with, ssc);
1339         if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1340             unsigned int i;
1341             for (i = 0; i < ANYOF_MAX; i += 2) {
1342                 if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i + 1))
1343                 {
1344                     ssc_match_all_cp(ssc);
1345                     ANYOF_POSIXL_CLEAR(ssc, i);
1346                     ANYOF_POSIXL_CLEAR(ssc, i+1);
1347                 }
1348             }
1349         }
1350     }
1351
1352     ssc_union(ssc,
1353               ored_cp_list,
1354               FALSE /* Already has been inverted */
1355               );
1356 }
1357
1358 PERL_STATIC_INLINE void
1359 S_ssc_union(pTHX_ regnode_ssc *ssc, SV* const invlist, const bool invert2nd)
1360 {
1361     PERL_ARGS_ASSERT_SSC_UNION;
1362
1363     assert(is_ANYOF_SYNTHETIC(ssc));
1364
1365     _invlist_union_maybe_complement_2nd(ssc->invlist,
1366                                         invlist,
1367                                         invert2nd,
1368                                         &ssc->invlist);
1369 }
1370
1371 PERL_STATIC_INLINE void
1372 S_ssc_intersection(pTHX_ regnode_ssc *ssc,
1373                          SV* const invlist,
1374                          const bool invert2nd)
1375 {
1376     PERL_ARGS_ASSERT_SSC_INTERSECTION;
1377
1378     assert(is_ANYOF_SYNTHETIC(ssc));
1379
1380     _invlist_intersection_maybe_complement_2nd(ssc->invlist,
1381                                                invlist,
1382                                                invert2nd,
1383                                                &ssc->invlist);
1384 }
1385
1386 PERL_STATIC_INLINE void
1387 S_ssc_add_range(pTHX_ regnode_ssc *ssc, const UV start, const UV end)
1388 {
1389     PERL_ARGS_ASSERT_SSC_ADD_RANGE;
1390
1391     assert(is_ANYOF_SYNTHETIC(ssc));
1392
1393     ssc->invlist = _add_range_to_invlist(ssc->invlist, start, end);
1394 }
1395
1396 PERL_STATIC_INLINE void
1397 S_ssc_cp_and(pTHX_ regnode_ssc *ssc, const UV cp)
1398 {
1399     /* AND just the single code point 'cp' into the SSC 'ssc' */
1400
1401     SV* cp_list = _new_invlist(2);
1402
1403     PERL_ARGS_ASSERT_SSC_CP_AND;
1404
1405     assert(is_ANYOF_SYNTHETIC(ssc));
1406
1407     cp_list = add_cp_to_invlist(cp_list, cp);
1408     ssc_intersection(ssc, cp_list,
1409                      FALSE /* Not inverted */
1410                      );
1411     SvREFCNT_dec_NN(cp_list);
1412 }
1413
1414 PERL_STATIC_INLINE void
1415 S_ssc_clear_locale(regnode_ssc *ssc)
1416 {
1417     /* Set the SSC 'ssc' to not match any locale things */
1418     PERL_ARGS_ASSERT_SSC_CLEAR_LOCALE;
1419
1420     assert(is_ANYOF_SYNTHETIC(ssc));
1421
1422     ANYOF_POSIXL_ZERO(ssc);
1423     ANYOF_FLAGS(ssc) &= ~ANYOF_LOCALE_FLAGS;
1424 }
1425
1426 STATIC void
1427 S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc)
1428 {
1429     /* The inversion list in the SSC is marked mortal; now we need a more
1430      * permanent copy, which is stored the same way that is done in a regular
1431      * ANYOF node, with the first 256 code points in a bit map */
1432
1433     SV* invlist = invlist_clone(ssc->invlist);
1434
1435     PERL_ARGS_ASSERT_SSC_FINALIZE;
1436
1437     assert(is_ANYOF_SYNTHETIC(ssc));
1438
1439     /* The code in this file assumes that all but these flags aren't relevant
1440      * to the SSC, except ANYOF_EMPTY_STRING, which should be cleared by the
1441      * time we reach here */
1442     assert(! (ANYOF_FLAGS(ssc) & ~ANYOF_COMMON_FLAGS));
1443
1444     populate_ANYOF_from_invlist( (regnode *) ssc, &invlist);
1445
1446     set_ANYOF_arg(pRExC_state, (regnode *) ssc, invlist,
1447                                 NULL, NULL, NULL, FALSE);
1448
1449     /* Make sure is clone-safe */
1450     ssc->invlist = NULL;
1451
1452     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1453         ANYOF_FLAGS(ssc) |= ANYOF_POSIXL;
1454     }
1455
1456     assert(! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE_FLAGS) || RExC_contains_locale);
1457 }
1458
1459 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1460 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
1461 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1462 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list         \
1463                                ? (TRIE_LIST_CUR( idx ) - 1)           \
1464                                : 0 )
1465
1466
1467 #ifdef DEBUGGING
1468 /*
1469    dump_trie(trie,widecharmap,revcharmap)
1470    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1471    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1472
1473    These routines dump out a trie in a somewhat readable format.
1474    The _interim_ variants are used for debugging the interim
1475    tables that are used to generate the final compressed
1476    representation which is what dump_trie expects.
1477
1478    Part of the reason for their existence is to provide a form
1479    of documentation as to how the different representations function.
1480
1481 */
1482
1483 /*
1484   Dumps the final compressed table form of the trie to Perl_debug_log.
1485   Used for debugging make_trie().
1486 */
1487
1488 STATIC void
1489 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1490             AV *revcharmap, U32 depth)
1491 {
1492     U32 state;
1493     SV *sv=sv_newmortal();
1494     int colwidth= widecharmap ? 6 : 4;
1495     U16 word;
1496     GET_RE_DEBUG_FLAGS_DECL;
1497
1498     PERL_ARGS_ASSERT_DUMP_TRIE;
1499
1500     PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
1501         (int)depth * 2 + 2,"",
1502         "Match","Base","Ofs" );
1503
1504     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1505         SV ** const tmp = av_fetch( revcharmap, state, 0);
1506         if ( tmp ) {
1507             PerlIO_printf( Perl_debug_log, "%*s",
1508                 colwidth,
1509                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1510                             PL_colors[0], PL_colors[1],
1511                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1512                             PERL_PV_ESCAPE_FIRSTCHAR
1513                 )
1514             );
1515         }
1516     }
1517     PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
1518         (int)depth * 2 + 2,"");
1519
1520     for( state = 0 ; state < trie->uniquecharcount ; state++ )
1521         PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
1522     PerlIO_printf( Perl_debug_log, "\n");
1523
1524     for( state = 1 ; state < trie->statecount ; state++ ) {
1525         const U32 base = trie->states[ state ].trans.base;
1526
1527         PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|",
1528                                        (int)depth * 2 + 2,"", (UV)state);
1529
1530         if ( trie->states[ state ].wordnum ) {
1531             PerlIO_printf( Perl_debug_log, " W%4X",
1532                                            trie->states[ state ].wordnum );
1533         } else {
1534             PerlIO_printf( Perl_debug_log, "%6s", "" );
1535         }
1536
1537         PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
1538
1539         if ( base ) {
1540             U32 ofs = 0;
1541
1542             while( ( base + ofs  < trie->uniquecharcount ) ||
1543                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
1544                      && trie->trans[ base + ofs - trie->uniquecharcount ].check
1545                                                                     != state))
1546                     ofs++;
1547
1548             PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
1549
1550             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
1551                 if ( ( base + ofs >= trie->uniquecharcount )
1552                         && ( base + ofs - trie->uniquecharcount
1553                                                         < trie->lasttrans )
1554                         && trie->trans[ base + ofs
1555                                     - trie->uniquecharcount ].check == state )
1556                 {
1557                    PerlIO_printf( Perl_debug_log, "%*"UVXf,
1558                     colwidth,
1559                     (UV)trie->trans[ base + ofs
1560                                              - trie->uniquecharcount ].next );
1561                 } else {
1562                     PerlIO_printf( Perl_debug_log, "%*s",colwidth,"   ." );
1563                 }
1564             }
1565
1566             PerlIO_printf( Perl_debug_log, "]");
1567
1568         }
1569         PerlIO_printf( Perl_debug_log, "\n" );
1570     }
1571     PerlIO_printf(Perl_debug_log, "%*sword_info N:(prev,len)=",
1572                                 (int)depth*2, "");
1573     for (word=1; word <= trie->wordcount; word++) {
1574         PerlIO_printf(Perl_debug_log, " %d:(%d,%d)",
1575             (int)word, (int)(trie->wordinfo[word].prev),
1576             (int)(trie->wordinfo[word].len));
1577     }
1578     PerlIO_printf(Perl_debug_log, "\n" );
1579 }
1580 /*
1581   Dumps a fully constructed but uncompressed trie in list form.
1582   List tries normally only are used for construction when the number of
1583   possible chars (trie->uniquecharcount) is very high.
1584   Used for debugging make_trie().
1585 */
1586 STATIC void
1587 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
1588                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
1589                          U32 depth)
1590 {
1591     U32 state;
1592     SV *sv=sv_newmortal();
1593     int colwidth= widecharmap ? 6 : 4;
1594     GET_RE_DEBUG_FLAGS_DECL;
1595
1596     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
1597
1598     /* print out the table precompression.  */
1599     PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
1600         (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
1601         "------:-----+-----------------\n" );
1602
1603     for( state=1 ; state < next_alloc ; state ++ ) {
1604         U16 charid;
1605
1606         PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
1607             (int)depth * 2 + 2,"", (UV)state  );
1608         if ( ! trie->states[ state ].wordnum ) {
1609             PerlIO_printf( Perl_debug_log, "%5s| ","");
1610         } else {
1611             PerlIO_printf( Perl_debug_log, "W%4x| ",
1612                 trie->states[ state ].wordnum
1613             );
1614         }
1615         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
1616             SV ** const tmp = av_fetch( revcharmap,
1617                                         TRIE_LIST_ITEM(state,charid).forid, 0);
1618             if ( tmp ) {
1619                 PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
1620                     colwidth,
1621                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp),
1622                               colwidth,
1623                               PL_colors[0], PL_colors[1],
1624                               (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
1625                               | PERL_PV_ESCAPE_FIRSTCHAR
1626                     ) ,
1627                     TRIE_LIST_ITEM(state,charid).forid,
1628                     (UV)TRIE_LIST_ITEM(state,charid).newstate
1629                 );
1630                 if (!(charid % 10))
1631                     PerlIO_printf(Perl_debug_log, "\n%*s| ",
1632                         (int)((depth * 2) + 14), "");
1633             }
1634         }
1635         PerlIO_printf( Perl_debug_log, "\n");
1636     }
1637 }
1638
1639 /*
1640   Dumps a fully constructed but uncompressed trie in table form.
1641   This is the normal DFA style state transition table, with a few
1642   twists to facilitate compression later.
1643   Used for debugging make_trie().
1644 */
1645 STATIC void
1646 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
1647                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
1648                           U32 depth)
1649 {
1650     U32 state;
1651     U16 charid;
1652     SV *sv=sv_newmortal();
1653     int colwidth= widecharmap ? 6 : 4;
1654     GET_RE_DEBUG_FLAGS_DECL;
1655
1656     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
1657
1658     /*
1659        print out the table precompression so that we can do a visual check
1660        that they are identical.
1661      */
1662
1663     PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
1664
1665     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1666         SV ** const tmp = av_fetch( revcharmap, charid, 0);
1667         if ( tmp ) {
1668             PerlIO_printf( Perl_debug_log, "%*s",
1669                 colwidth,
1670                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1671                             PL_colors[0], PL_colors[1],
1672                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1673                             PERL_PV_ESCAPE_FIRSTCHAR
1674                 )
1675             );
1676         }
1677     }
1678
1679     PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
1680
1681     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
1682         PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
1683     }
1684
1685     PerlIO_printf( Perl_debug_log, "\n" );
1686
1687     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
1688
1689         PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ",
1690             (int)depth * 2 + 2,"",
1691             (UV)TRIE_NODENUM( state ) );
1692
1693         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1694             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
1695             if (v)
1696                 PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
1697             else
1698                 PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
1699         }
1700         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1701             PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n",
1702                                             (UV)trie->trans[ state ].check );
1703         } else {
1704             PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n",
1705                                             (UV)trie->trans[ state ].check,
1706             trie->states[ TRIE_NODENUM( state ) ].wordnum );
1707         }
1708     }
1709 }
1710
1711 #endif
1712
1713
1714 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
1715   startbranch: the first branch in the whole branch sequence
1716   first      : start branch of sequence of branch-exact nodes.
1717                May be the same as startbranch
1718   last       : Thing following the last branch.
1719                May be the same as tail.
1720   tail       : item following the branch sequence
1721   count      : words in the sequence
1722   flags      : currently the OP() type we will be building one of /EXACT(|F|FA|FU|FU_SS)/
1723   depth      : indent depth
1724
1725 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
1726
1727 A trie is an N'ary tree where the branches are determined by digital
1728 decomposition of the key. IE, at the root node you look up the 1st character and
1729 follow that branch repeat until you find the end of the branches. Nodes can be
1730 marked as "accepting" meaning they represent a complete word. Eg:
1731
1732   /he|she|his|hers/
1733
1734 would convert into the following structure. Numbers represent states, letters
1735 following numbers represent valid transitions on the letter from that state, if
1736 the number is in square brackets it represents an accepting state, otherwise it
1737 will be in parenthesis.
1738
1739       +-h->+-e->[3]-+-r->(8)-+-s->[9]
1740       |    |
1741       |   (2)
1742       |    |
1743      (1)   +-i->(6)-+-s->[7]
1744       |
1745       +-s->(3)-+-h->(4)-+-e->[5]
1746
1747       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
1748
1749 This shows that when matching against the string 'hers' we will begin at state 1
1750 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
1751 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
1752 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
1753 single traverse. We store a mapping from accepting to state to which word was
1754 matched, and then when we have multiple possibilities we try to complete the
1755 rest of the regex in the order in which they occured in the alternation.
1756
1757 The only prior NFA like behaviour that would be changed by the TRIE support is
1758 the silent ignoring of duplicate alternations which are of the form:
1759
1760  / (DUPE|DUPE) X? (?{ ... }) Y /x
1761
1762 Thus EVAL blocks following a trie may be called a different number of times with
1763 and without the optimisation. With the optimisations dupes will be silently
1764 ignored. This inconsistent behaviour of EVAL type nodes is well established as
1765 the following demonstrates:
1766
1767  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
1768
1769 which prints out 'word' three times, but
1770
1771  'words'=~/(word|word|word)(?{ print $1 })S/
1772
1773 which doesnt print it out at all. This is due to other optimisations kicking in.
1774
1775 Example of what happens on a structural level:
1776
1777 The regexp /(ac|ad|ab)+/ will produce the following debug output:
1778
1779    1: CURLYM[1] {1,32767}(18)
1780    5:   BRANCH(8)
1781    6:     EXACT <ac>(16)
1782    8:   BRANCH(11)
1783    9:     EXACT <ad>(16)
1784   11:   BRANCH(14)
1785   12:     EXACT <ab>(16)
1786   16:   SUCCEED(0)
1787   17:   NOTHING(18)
1788   18: END(0)
1789
1790 This would be optimizable with startbranch=5, first=5, last=16, tail=16
1791 and should turn into:
1792
1793    1: CURLYM[1] {1,32767}(18)
1794    5:   TRIE(16)
1795         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
1796           <ac>
1797           <ad>
1798           <ab>
1799   16:   SUCCEED(0)
1800   17:   NOTHING(18)
1801   18: END(0)
1802
1803 Cases where tail != last would be like /(?foo|bar)baz/:
1804
1805    1: BRANCH(4)
1806    2:   EXACT <foo>(8)
1807    4: BRANCH(7)
1808    5:   EXACT <bar>(8)
1809    7: TAIL(8)
1810    8: EXACT <baz>(10)
1811   10: END(0)
1812
1813 which would be optimizable with startbranch=1, first=1, last=7, tail=8
1814 and would end up looking like:
1815
1816     1: TRIE(8)
1817       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
1818         <foo>
1819         <bar>
1820    7: TAIL(8)
1821    8: EXACT <baz>(10)
1822   10: END(0)
1823
1824     d = uvchr_to_utf8_flags(d, uv, 0);
1825
1826 is the recommended Unicode-aware way of saying
1827
1828     *(d++) = uv;
1829 */
1830
1831 #define TRIE_STORE_REVCHAR(val)                                            \
1832     STMT_START {                                                           \
1833         if (UTF) {                                                         \
1834             SV *zlopp = newSV(7); /* XXX: optimize me */                   \
1835             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
1836             unsigned const char *const kapow = uvchr_to_utf8(flrbbbbb, val); \
1837             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
1838             SvPOK_on(zlopp);                                               \
1839             SvUTF8_on(zlopp);                                              \
1840             av_push(revcharmap, zlopp);                                    \
1841         } else {                                                           \
1842             char ooooff = (char)val;                                           \
1843             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
1844         }                                                                  \
1845         } STMT_END
1846
1847 /* This gets the next character from the input, folding it if not already
1848  * folded. */
1849 #define TRIE_READ_CHAR STMT_START {                                           \
1850     wordlen++;                                                                \
1851     if ( UTF ) {                                                              \
1852         /* if it is UTF then it is either already folded, or does not need    \
1853          * folding */                                                         \
1854         uvc = valid_utf8_to_uvchr( (const U8*) uc, &len);                     \
1855     }                                                                         \
1856     else if (folder == PL_fold_latin1) {                                      \
1857         /* This folder implies Unicode rules, which in the range expressible  \
1858          *  by not UTF is the lower case, with the two exceptions, one of     \
1859          *  which should have been taken care of before calling this */       \
1860         assert(*uc != LATIN_SMALL_LETTER_SHARP_S);                            \
1861         uvc = toLOWER_L1(*uc);                                                \
1862         if (UNLIKELY(uvc == MICRO_SIGN)) uvc = GREEK_SMALL_LETTER_MU;         \
1863         len = 1;                                                              \
1864     } else {                                                                  \
1865         /* raw data, will be folded later if needed */                        \
1866         uvc = (U32)*uc;                                                       \
1867         len = 1;                                                              \
1868     }                                                                         \
1869 } STMT_END
1870
1871
1872
1873 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
1874     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
1875         U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
1876         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
1877     }                                                           \
1878     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
1879     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
1880     TRIE_LIST_CUR( state )++;                                   \
1881 } STMT_END
1882
1883 #define TRIE_LIST_NEW(state) STMT_START {                       \
1884     Newxz( trie->states[ state ].trans.list,               \
1885         4, reg_trie_trans_le );                                 \
1886      TRIE_LIST_CUR( state ) = 1;                                \
1887      TRIE_LIST_LEN( state ) = 4;                                \
1888 } STMT_END
1889
1890 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
1891     U16 dupe= trie->states[ state ].wordnum;                    \
1892     regnode * const noper_next = regnext( noper );              \
1893                                                                 \
1894     DEBUG_r({                                                   \
1895         /* store the word for dumping */                        \
1896         SV* tmp;                                                \
1897         if (OP(noper) != NOTHING)                               \
1898             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
1899         else                                                    \
1900             tmp = newSVpvn_utf8( "", 0, UTF );                  \
1901         av_push( trie_words, tmp );                             \
1902     });                                                         \
1903                                                                 \
1904     curword++;                                                  \
1905     trie->wordinfo[curword].prev   = 0;                         \
1906     trie->wordinfo[curword].len    = wordlen;                   \
1907     trie->wordinfo[curword].accept = state;                     \
1908                                                                 \
1909     if ( noper_next < tail ) {                                  \
1910         if (!trie->jump)                                        \
1911             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, \
1912                                                  sizeof(U16) ); \
1913         trie->jump[curword] = (U16)(noper_next - convert);      \
1914         if (!jumper)                                            \
1915             jumper = noper_next;                                \
1916         if (!nextbranch)                                        \
1917             nextbranch= regnext(cur);                           \
1918     }                                                           \
1919                                                                 \
1920     if ( dupe ) {                                               \
1921         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
1922         /* chain, so that when the bits of chain are later    */\
1923         /* linked together, the dups appear in the chain      */\
1924         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
1925         trie->wordinfo[dupe].prev = curword;                    \
1926     } else {                                                    \
1927         /* we haven't inserted this word yet.                */ \
1928         trie->states[ state ].wordnum = curword;                \
1929     }                                                           \
1930 } STMT_END
1931
1932
1933 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
1934      ( ( base + charid >=  ucharcount                                   \
1935          && base + charid < ubound                                      \
1936          && state == trie->trans[ base - ucharcount + charid ].check    \
1937          && trie->trans[ base - ucharcount + charid ].next )            \
1938            ? trie->trans[ base - ucharcount + charid ].next             \
1939            : ( state==1 ? special : 0 )                                 \
1940       )
1941
1942 #define MADE_TRIE       1
1943 #define MADE_JUMP_TRIE  2
1944 #define MADE_EXACT_TRIE 4
1945
1946 STATIC I32
1947 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch,
1948                   regnode *first, regnode *last, regnode *tail,
1949                   U32 word_count, U32 flags, U32 depth)
1950 {
1951     /* first pass, loop through and scan words */
1952     reg_trie_data *trie;
1953     HV *widecharmap = NULL;
1954     AV *revcharmap = newAV();
1955     regnode *cur;
1956     STRLEN len = 0;
1957     UV uvc = 0;
1958     U16 curword = 0;
1959     U32 next_alloc = 0;
1960     regnode *jumper = NULL;
1961     regnode *nextbranch = NULL;
1962     regnode *convert = NULL;
1963     U32 *prev_states; /* temp array mapping each state to previous one */
1964     /* we just use folder as a flag in utf8 */
1965     const U8 * folder = NULL;
1966
1967 #ifdef DEBUGGING
1968     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tuuu"));
1969     AV *trie_words = NULL;
1970     /* along with revcharmap, this only used during construction but both are
1971      * useful during debugging so we store them in the struct when debugging.
1972      */
1973 #else
1974     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tu"));
1975     STRLEN trie_charcount=0;
1976 #endif
1977     SV *re_trie_maxbuff;
1978     GET_RE_DEBUG_FLAGS_DECL;
1979
1980     PERL_ARGS_ASSERT_MAKE_TRIE;
1981 #ifndef DEBUGGING
1982     PERL_UNUSED_ARG(depth);
1983 #endif
1984
1985     switch (flags) {
1986         case EXACT: break;
1987         case EXACTFA:
1988         case EXACTFU_SS:
1989         case EXACTFU: folder = PL_fold_latin1; break;
1990         case EXACTF:  folder = PL_fold; break;
1991         default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
1992     }
1993
1994     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
1995     trie->refcount = 1;
1996     trie->startstate = 1;
1997     trie->wordcount = word_count;
1998     RExC_rxi->data->data[ data_slot ] = (void*)trie;
1999     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
2000     if (flags == EXACT)
2001         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
2002     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
2003                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
2004
2005     DEBUG_r({
2006         trie_words = newAV();
2007     });
2008
2009     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2010     assert(re_trie_maxbuff);
2011     if (!SvIOK(re_trie_maxbuff)) {
2012         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2013     }
2014     DEBUG_TRIE_COMPILE_r({
2015         PerlIO_printf( Perl_debug_log,
2016           "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
2017           (int)depth * 2 + 2, "",
2018           REG_NODE_NUM(startbranch),REG_NODE_NUM(first),
2019           REG_NODE_NUM(last), REG_NODE_NUM(tail), (int)depth);
2020     });
2021
2022    /* Find the node we are going to overwrite */
2023     if ( first == startbranch && OP( last ) != BRANCH ) {
2024         /* whole branch chain */
2025         convert = first;
2026     } else {
2027         /* branch sub-chain */
2028         convert = NEXTOPER( first );
2029     }
2030
2031     /*  -- First loop and Setup --
2032
2033        We first traverse the branches and scan each word to determine if it
2034        contains widechars, and how many unique chars there are, this is
2035        important as we have to build a table with at least as many columns as we
2036        have unique chars.
2037
2038        We use an array of integers to represent the character codes 0..255
2039        (trie->charmap) and we use a an HV* to store Unicode characters. We use
2040        the native representation of the character value as the key and IV's for
2041        the coded index.
2042
2043        *TODO* If we keep track of how many times each character is used we can
2044        remap the columns so that the table compression later on is more
2045        efficient in terms of memory by ensuring the most common value is in the
2046        middle and the least common are on the outside.  IMO this would be better
2047        than a most to least common mapping as theres a decent chance the most
2048        common letter will share a node with the least common, meaning the node
2049        will not be compressible. With a middle is most common approach the worst
2050        case is when we have the least common nodes twice.
2051
2052      */
2053
2054     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2055         regnode *noper = NEXTOPER( cur );
2056         const U8 *uc = (U8*)STRING( noper );
2057         const U8 *e  = uc + STR_LEN( noper );
2058         int foldlen = 0;
2059         U32 wordlen      = 0;         /* required init */
2060         STRLEN minchars = 0;
2061         STRLEN maxchars = 0;
2062         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the
2063                                                bitmap?*/
2064
2065         if (OP(noper) == NOTHING) {
2066             regnode *noper_next= regnext(noper);
2067             if (noper_next != tail && OP(noper_next) == flags) {
2068                 noper = noper_next;
2069                 uc= (U8*)STRING(noper);
2070                 e= uc + STR_LEN(noper);
2071                 trie->minlen= STR_LEN(noper);
2072             } else {
2073                 trie->minlen= 0;
2074                 continue;
2075             }
2076         }
2077
2078         if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
2079             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
2080                                           regardless of encoding */
2081             if (OP( noper ) == EXACTFU_SS) {
2082                 /* false positives are ok, so just set this */
2083                 TRIE_BITMAP_SET(trie, LATIN_SMALL_LETTER_SHARP_S);
2084             }
2085         }
2086         for ( ; uc < e ; uc += len ) {  /* Look at each char in the current
2087                                            branch */
2088             TRIE_CHARCOUNT(trie)++;
2089             TRIE_READ_CHAR;
2090
2091             /* TRIE_READ_CHAR returns the current character, or its fold if /i
2092              * is in effect.  Under /i, this character can match itself, or
2093              * anything that folds to it.  If not under /i, it can match just
2094              * itself.  Most folds are 1-1, for example k, K, and KELVIN SIGN
2095              * all fold to k, and all are single characters.   But some folds
2096              * expand to more than one character, so for example LATIN SMALL
2097              * LIGATURE FFI folds to the three character sequence 'ffi'.  If
2098              * the string beginning at 'uc' is 'ffi', it could be matched by
2099              * three characters, or just by the one ligature character. (It
2100              * could also be matched by two characters: LATIN SMALL LIGATURE FF
2101              * followed by 'i', or by 'f' followed by LATIN SMALL LIGATURE FI).
2102              * (Of course 'I' and/or 'F' instead of 'i' and 'f' can also
2103              * match.)  The trie needs to know the minimum and maximum number
2104              * of characters that could match so that it can use size alone to
2105              * quickly reject many match attempts.  The max is simple: it is
2106              * the number of folded characters in this branch (since a fold is
2107              * never shorter than what folds to it. */
2108
2109             maxchars++;
2110
2111             /* And the min is equal to the max if not under /i (indicated by
2112              * 'folder' being NULL), or there are no multi-character folds.  If
2113              * there is a multi-character fold, the min is incremented just
2114              * once, for the character that folds to the sequence.  Each
2115              * character in the sequence needs to be added to the list below of
2116              * characters in the trie, but we count only the first towards the
2117              * min number of characters needed.  This is done through the
2118              * variable 'foldlen', which is returned by the macros that look
2119              * for these sequences as the number of bytes the sequence
2120              * occupies.  Each time through the loop, we decrement 'foldlen' by
2121              * how many bytes the current char occupies.  Only when it reaches
2122              * 0 do we increment 'minchars' or look for another multi-character
2123              * sequence. */
2124             if (folder == NULL) {
2125                 minchars++;
2126             }
2127             else if (foldlen > 0) {
2128                 foldlen -= (UTF) ? UTF8SKIP(uc) : 1;
2129             }
2130             else {
2131                 minchars++;
2132
2133                 /* See if *uc is the beginning of a multi-character fold.  If
2134                  * so, we decrement the length remaining to look at, to account
2135                  * for the current character this iteration.  (We can use 'uc'
2136                  * instead of the fold returned by TRIE_READ_CHAR because for
2137                  * non-UTF, the latin1_safe macro is smart enough to account
2138                  * for all the unfolded characters, and because for UTF, the
2139                  * string will already have been folded earlier in the
2140                  * compilation process */
2141                 if (UTF) {
2142                     if ((foldlen = is_MULTI_CHAR_FOLD_utf8_safe(uc, e))) {
2143                         foldlen -= UTF8SKIP(uc);
2144                     }
2145                 }
2146                 else if ((foldlen = is_MULTI_CHAR_FOLD_latin1_safe(uc, e))) {
2147                     foldlen--;
2148                 }
2149             }
2150
2151             /* The current character (and any potential folds) should be added
2152              * to the possible matching characters for this position in this
2153              * branch */
2154             if ( uvc < 256 ) {
2155                 if ( folder ) {
2156                     U8 folded= folder[ (U8) uvc ];
2157                     if ( !trie->charmap[ folded ] ) {
2158                         trie->charmap[ folded ]=( ++trie->uniquecharcount );
2159                         TRIE_STORE_REVCHAR( folded );
2160                     }
2161                 }
2162                 if ( !trie->charmap[ uvc ] ) {
2163                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
2164                     TRIE_STORE_REVCHAR( uvc );
2165                 }
2166                 if ( set_bit ) {
2167                     /* store the codepoint in the bitmap, and its folded
2168                      * equivalent. */
2169                     TRIE_BITMAP_SET(trie, uvc);
2170
2171                     /* store the folded codepoint */
2172                     if ( folder ) TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);
2173
2174                     if ( !UTF ) {
2175                         /* store first byte of utf8 representation of
2176                            variant codepoints */
2177                         if (! UVCHR_IS_INVARIANT(uvc)) {
2178                             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));
2179                         }
2180                     }
2181                     set_bit = 0; /* We've done our bit :-) */
2182                 }
2183             } else {
2184
2185                 /* XXX We could come up with the list of code points that fold
2186                  * to this using PL_utf8_foldclosures, except not for
2187                  * multi-char folds, as there may be multiple combinations
2188                  * there that could work, which needs to wait until runtime to
2189                  * resolve (The comment about LIGATURE FFI above is such an
2190                  * example */
2191
2192                 SV** svpp;
2193                 if ( !widecharmap )
2194                     widecharmap = newHV();
2195
2196                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
2197
2198                 if ( !svpp )
2199                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
2200
2201                 if ( !SvTRUE( *svpp ) ) {
2202                     sv_setiv( *svpp, ++trie->uniquecharcount );
2203                     TRIE_STORE_REVCHAR(uvc);
2204                 }
2205             }
2206         } /* end loop through characters in this branch of the trie */
2207
2208         /* We take the min and max for this branch and combine to find the min
2209          * and max for all branches processed so far */
2210         if( cur == first ) {
2211             trie->minlen = minchars;
2212             trie->maxlen = maxchars;
2213         } else if (minchars < trie->minlen) {
2214             trie->minlen = minchars;
2215         } else if (maxchars > trie->maxlen) {
2216             trie->maxlen = maxchars;
2217         }
2218     } /* end first pass */
2219     DEBUG_TRIE_COMPILE_r(
2220         PerlIO_printf( Perl_debug_log,
2221                 "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
2222                 (int)depth * 2 + 2,"",
2223                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
2224                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
2225                 (int)trie->minlen, (int)trie->maxlen )
2226     );
2227
2228     /*
2229         We now know what we are dealing with in terms of unique chars and
2230         string sizes so we can calculate how much memory a naive
2231         representation using a flat table  will take. If it's over a reasonable
2232         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
2233         conservative but potentially much slower representation using an array
2234         of lists.
2235
2236         At the end we convert both representations into the same compressed
2237         form that will be used in regexec.c for matching with. The latter
2238         is a form that cannot be used to construct with but has memory
2239         properties similar to the list form and access properties similar
2240         to the table form making it both suitable for fast searches and
2241         small enough that its feasable to store for the duration of a program.
2242
2243         See the comment in the code where the compressed table is produced
2244         inplace from the flat tabe representation for an explanation of how
2245         the compression works.
2246
2247     */
2248
2249
2250     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
2251     prev_states[1] = 0;
2252
2253     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1)
2254                                                     > SvIV(re_trie_maxbuff) )
2255     {
2256         /*
2257             Second Pass -- Array Of Lists Representation
2258
2259             Each state will be represented by a list of charid:state records
2260             (reg_trie_trans_le) the first such element holds the CUR and LEN
2261             points of the allocated array. (See defines above).
2262
2263             We build the initial structure using the lists, and then convert
2264             it into the compressed table form which allows faster lookups
2265             (but cant be modified once converted).
2266         */
2267
2268         STRLEN transcount = 1;
2269
2270         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
2271             "%*sCompiling trie using list compiler\n",
2272             (int)depth * 2 + 2, ""));
2273
2274         trie->states = (reg_trie_state *)
2275             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2276                                   sizeof(reg_trie_state) );
2277         TRIE_LIST_NEW(1);
2278         next_alloc = 2;
2279
2280         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2281
2282             regnode *noper   = NEXTOPER( cur );
2283             U8 *uc           = (U8*)STRING( noper );
2284             const U8 *e      = uc + STR_LEN( noper );
2285             U32 state        = 1;         /* required init */
2286             U16 charid       = 0;         /* sanity init */
2287             U32 wordlen      = 0;         /* required init */
2288
2289             if (OP(noper) == NOTHING) {
2290                 regnode *noper_next= regnext(noper);
2291                 if (noper_next != tail && OP(noper_next) == flags) {
2292                     noper = noper_next;
2293                     uc= (U8*)STRING(noper);
2294                     e= uc + STR_LEN(noper);
2295                 }
2296             }
2297
2298             if (OP(noper) != NOTHING) {
2299                 for ( ; uc < e ; uc += len ) {
2300
2301                     TRIE_READ_CHAR;
2302
2303                     if ( uvc < 256 ) {
2304                         charid = trie->charmap[ uvc ];
2305                     } else {
2306                         SV** const svpp = hv_fetch( widecharmap,
2307                                                     (char*)&uvc,
2308                                                     sizeof( UV ),
2309                                                     0);
2310                         if ( !svpp ) {
2311                             charid = 0;
2312                         } else {
2313                             charid=(U16)SvIV( *svpp );
2314                         }
2315                     }
2316                     /* charid is now 0 if we dont know the char read, or
2317                      * nonzero if we do */
2318                     if ( charid ) {
2319
2320                         U16 check;
2321                         U32 newstate = 0;
2322
2323                         charid--;
2324                         if ( !trie->states[ state ].trans.list ) {
2325                             TRIE_LIST_NEW( state );
2326                         }
2327                         for ( check = 1;
2328                               check <= TRIE_LIST_USED( state );
2329                               check++ )
2330                         {
2331                             if ( TRIE_LIST_ITEM( state, check ).forid
2332                                                                     == charid )
2333                             {
2334                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
2335                                 break;
2336                             }
2337                         }
2338                         if ( ! newstate ) {
2339                             newstate = next_alloc++;
2340                             prev_states[newstate] = state;
2341                             TRIE_LIST_PUSH( state, charid, newstate );
2342                             transcount++;
2343                         }
2344                         state = newstate;
2345                     } else {
2346                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
2347                     }
2348                 }
2349             }
2350             TRIE_HANDLE_WORD(state);
2351
2352         } /* end second pass */
2353
2354         /* next alloc is the NEXT state to be allocated */
2355         trie->statecount = next_alloc;
2356         trie->states = (reg_trie_state *)
2357             PerlMemShared_realloc( trie->states,
2358                                    next_alloc
2359                                    * sizeof(reg_trie_state) );
2360
2361         /* and now dump it out before we compress it */
2362         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
2363                                                          revcharmap, next_alloc,
2364                                                          depth+1)
2365         );
2366
2367         trie->trans = (reg_trie_trans *)
2368             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
2369         {
2370             U32 state;
2371             U32 tp = 0;
2372             U32 zp = 0;
2373
2374
2375             for( state=1 ; state < next_alloc ; state ++ ) {
2376                 U32 base=0;
2377
2378                 /*
2379                 DEBUG_TRIE_COMPILE_MORE_r(
2380                     PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
2381                 );
2382                 */
2383
2384                 if (trie->states[state].trans.list) {
2385                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
2386                     U16 maxid=minid;
2387                     U16 idx;
2388
2389                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2390                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
2391                         if ( forid < minid ) {
2392                             minid=forid;
2393                         } else if ( forid > maxid ) {
2394                             maxid=forid;
2395                         }
2396                     }
2397                     if ( transcount < tp + maxid - minid + 1) {
2398                         transcount *= 2;
2399                         trie->trans = (reg_trie_trans *)
2400                             PerlMemShared_realloc( trie->trans,
2401                                                      transcount
2402                                                      * sizeof(reg_trie_trans) );
2403                         Zero( trie->trans + (transcount / 2),
2404                               transcount / 2,
2405                               reg_trie_trans );
2406                     }
2407                     base = trie->uniquecharcount + tp - minid;
2408                     if ( maxid == minid ) {
2409                         U32 set = 0;
2410                         for ( ; zp < tp ; zp++ ) {
2411                             if ( ! trie->trans[ zp ].next ) {
2412                                 base = trie->uniquecharcount + zp - minid;
2413                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state,
2414                                                                    1).newstate;
2415                                 trie->trans[ zp ].check = state;
2416                                 set = 1;
2417                                 break;
2418                             }
2419                         }
2420                         if ( !set ) {
2421                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state,
2422                                                                    1).newstate;
2423                             trie->trans[ tp ].check = state;
2424                             tp++;
2425                             zp = tp;
2426                         }
2427                     } else {
2428                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2429                             const U32 tid = base
2430                                            - trie->uniquecharcount
2431                                            + TRIE_LIST_ITEM( state, idx ).forid;
2432                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state,
2433                                                                 idx ).newstate;
2434                             trie->trans[ tid ].check = state;
2435                         }
2436                         tp += ( maxid - minid + 1 );
2437                     }
2438                     Safefree(trie->states[ state ].trans.list);
2439                 }
2440                 /*
2441                 DEBUG_TRIE_COMPILE_MORE_r(
2442                     PerlIO_printf( Perl_debug_log, " base: %d\n",base);
2443                 );
2444                 */
2445                 trie->states[ state ].trans.base=base;
2446             }
2447             trie->lasttrans = tp + 1;
2448         }
2449     } else {
2450         /*
2451            Second Pass -- Flat Table Representation.
2452
2453            we dont use the 0 slot of either trans[] or states[] so we add 1 to
2454            each.  We know that we will need Charcount+1 trans at most to store
2455            the data (one row per char at worst case) So we preallocate both
2456            structures assuming worst case.
2457
2458            We then construct the trie using only the .next slots of the entry
2459            structs.
2460
2461            We use the .check field of the first entry of the node temporarily
2462            to make compression both faster and easier by keeping track of how
2463            many non zero fields are in the node.
2464
2465            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
2466            transition.
2467
2468            There are two terms at use here: state as a TRIE_NODEIDX() which is
2469            a number representing the first entry of the node, and state as a
2470            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1)
2471            and TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3)
2472            if there are 2 entrys per node. eg:
2473
2474              A B       A B
2475           1. 2 4    1. 3 7
2476           2. 0 3    3. 0 5
2477           3. 0 0    5. 0 0
2478           4. 0 0    7. 0 0
2479
2480            The table is internally in the right hand, idx form. However as we
2481            also have to deal with the states array which is indexed by nodenum
2482            we have to use TRIE_NODENUM() to convert.
2483
2484         */
2485         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
2486             "%*sCompiling trie using table compiler\n",
2487             (int)depth * 2 + 2, ""));
2488
2489         trie->trans = (reg_trie_trans *)
2490             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
2491                                   * trie->uniquecharcount + 1,
2492                                   sizeof(reg_trie_trans) );
2493         trie->states = (reg_trie_state *)
2494             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2495                                   sizeof(reg_trie_state) );
2496         next_alloc = trie->uniquecharcount + 1;
2497
2498
2499         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2500
2501             regnode *noper   = NEXTOPER( cur );
2502             const U8 *uc     = (U8*)STRING( noper );
2503             const U8 *e      = uc + STR_LEN( noper );
2504
2505             U32 state        = 1;         /* required init */
2506
2507             U16 charid       = 0;         /* sanity init */
2508             U32 accept_state = 0;         /* sanity init */
2509
2510             U32 wordlen      = 0;         /* required init */
2511
2512             if (OP(noper) == NOTHING) {
2513                 regnode *noper_next= regnext(noper);
2514                 if (noper_next != tail && OP(noper_next) == flags) {
2515                     noper = noper_next;
2516                     uc= (U8*)STRING(noper);
2517                     e= uc + STR_LEN(noper);
2518                 }
2519             }
2520
2521             if ( OP(noper) != NOTHING ) {
2522                 for ( ; uc < e ; uc += len ) {
2523
2524                     TRIE_READ_CHAR;
2525
2526                     if ( uvc < 256 ) {
2527                         charid = trie->charmap[ uvc ];
2528                     } else {
2529                         SV* const * const svpp = hv_fetch( widecharmap,
2530                                                            (char*)&uvc,
2531                                                            sizeof( UV ),
2532                                                            0);
2533                         charid = svpp ? (U16)SvIV(*svpp) : 0;
2534                     }
2535                     if ( charid ) {
2536                         charid--;
2537                         if ( !trie->trans[ state + charid ].next ) {
2538                             trie->trans[ state + charid ].next = next_alloc;
2539                             trie->trans[ state ].check++;
2540                             prev_states[TRIE_NODENUM(next_alloc)]
2541                                     = TRIE_NODENUM(state);
2542                             next_alloc += trie->uniquecharcount;
2543                         }
2544                         state = trie->trans[ state + charid ].next;
2545                     } else {
2546                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
2547                     }
2548                     /* charid is now 0 if we dont know the char read, or
2549                      * nonzero if we do */
2550                 }
2551             }
2552             accept_state = TRIE_NODENUM( state );
2553             TRIE_HANDLE_WORD(accept_state);
2554
2555         } /* end second pass */
2556
2557         /* and now dump it out before we compress it */
2558         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
2559                                                           revcharmap,
2560                                                           next_alloc, depth+1));
2561
2562         {
2563         /*
2564            * Inplace compress the table.*
2565
2566            For sparse data sets the table constructed by the trie algorithm will
2567            be mostly 0/FAIL transitions or to put it another way mostly empty.
2568            (Note that leaf nodes will not contain any transitions.)
2569
2570            This algorithm compresses the tables by eliminating most such
2571            transitions, at the cost of a modest bit of extra work during lookup:
2572
2573            - Each states[] entry contains a .base field which indicates the
2574            index in the state[] array wheres its transition data is stored.
2575
2576            - If .base is 0 there are no valid transitions from that node.
2577
2578            - If .base is nonzero then charid is added to it to find an entry in
2579            the trans array.
2580
2581            -If trans[states[state].base+charid].check!=state then the
2582            transition is taken to be a 0/Fail transition. Thus if there are fail
2583            transitions at the front of the node then the .base offset will point
2584            somewhere inside the previous nodes data (or maybe even into a node
2585            even earlier), but the .check field determines if the transition is
2586            valid.
2587
2588            XXX - wrong maybe?
2589            The following process inplace converts the table to the compressed
2590            table: We first do not compress the root node 1,and mark all its
2591            .check pointers as 1 and set its .base pointer as 1 as well. This
2592            allows us to do a DFA construction from the compressed table later,
2593            and ensures that any .base pointers we calculate later are greater
2594            than 0.
2595
2596            - We set 'pos' to indicate the first entry of the second node.
2597
2598            - We then iterate over the columns of the node, finding the first and
2599            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
2600            and set the .check pointers accordingly, and advance pos
2601            appropriately and repreat for the next node. Note that when we copy
2602            the next pointers we have to convert them from the original
2603            NODEIDX form to NODENUM form as the former is not valid post
2604            compression.
2605
2606            - If a node has no transitions used we mark its base as 0 and do not
2607            advance the pos pointer.
2608
2609            - If a node only has one transition we use a second pointer into the
2610            structure to fill in allocated fail transitions from other states.
2611            This pointer is independent of the main pointer and scans forward
2612            looking for null transitions that are allocated to a state. When it
2613            finds one it writes the single transition into the "hole".  If the
2614            pointer doesnt find one the single transition is appended as normal.
2615
2616            - Once compressed we can Renew/realloc the structures to release the
2617            excess space.
2618
2619            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
2620            specifically Fig 3.47 and the associated pseudocode.
2621
2622            demq
2623         */
2624         const U32 laststate = TRIE_NODENUM( next_alloc );
2625         U32 state, charid;
2626         U32 pos = 0, zp=0;
2627         trie->statecount = laststate;
2628
2629         for ( state = 1 ; state < laststate ; state++ ) {
2630             U8 flag = 0;
2631             const U32 stateidx = TRIE_NODEIDX( state );
2632             const U32 o_used = trie->trans[ stateidx ].check;
2633             U32 used = trie->trans[ stateidx ].check;
2634             trie->trans[ stateidx ].check = 0;
2635
2636             for ( charid = 0;
2637                   used && charid < trie->uniquecharcount;
2638                   charid++ )
2639             {
2640                 if ( flag || trie->trans[ stateidx + charid ].next ) {
2641                     if ( trie->trans[ stateidx + charid ].next ) {
2642                         if (o_used == 1) {
2643                             for ( ; zp < pos ; zp++ ) {
2644                                 if ( ! trie->trans[ zp ].next ) {
2645                                     break;
2646                                 }
2647                             }
2648                             trie->states[ state ].trans.base
2649                                                     = zp
2650                                                       + trie->uniquecharcount
2651                                                       - charid ;
2652                             trie->trans[ zp ].next
2653                                 = SAFE_TRIE_NODENUM( trie->trans[ stateidx
2654                                                              + charid ].next );
2655                             trie->trans[ zp ].check = state;
2656                             if ( ++zp > pos ) pos = zp;
2657                             break;
2658                         }
2659                         used--;
2660                     }
2661                     if ( !flag ) {
2662                         flag = 1;
2663                         trie->states[ state ].trans.base
2664                                        = pos + trie->uniquecharcount - charid ;
2665                     }
2666                     trie->trans[ pos ].next
2667                         = SAFE_TRIE_NODENUM(
2668                                        trie->trans[ stateidx + charid ].next );
2669                     trie->trans[ pos ].check = state;
2670                     pos++;
2671                 }
2672             }
2673         }
2674         trie->lasttrans = pos + 1;
2675         trie->states = (reg_trie_state *)
2676             PerlMemShared_realloc( trie->states, laststate
2677                                    * sizeof(reg_trie_state) );
2678         DEBUG_TRIE_COMPILE_MORE_r(
2679             PerlIO_printf( Perl_debug_log,
2680                 "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
2681                 (int)depth * 2 + 2,"",
2682                 (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount
2683                        + 1 ),
2684                 (IV)next_alloc,
2685                 (IV)pos,
2686                 ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
2687             );
2688
2689         } /* end table compress */
2690     }
2691     DEBUG_TRIE_COMPILE_MORE_r(
2692             PerlIO_printf(Perl_debug_log,
2693                 "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
2694                 (int)depth * 2 + 2, "",
2695                 (UV)trie->statecount,
2696                 (UV)trie->lasttrans)
2697     );
2698     /* resize the trans array to remove unused space */
2699     trie->trans = (reg_trie_trans *)
2700         PerlMemShared_realloc( trie->trans, trie->lasttrans
2701                                * sizeof(reg_trie_trans) );
2702
2703     {   /* Modify the program and insert the new TRIE node */
2704         U8 nodetype =(U8)(flags & 0xFF);
2705         char *str=NULL;
2706
2707 #ifdef DEBUGGING
2708         regnode *optimize = NULL;
2709 #ifdef RE_TRACK_PATTERN_OFFSETS
2710
2711         U32 mjd_offset = 0;
2712         U32 mjd_nodelen = 0;
2713 #endif /* RE_TRACK_PATTERN_OFFSETS */
2714 #endif /* DEBUGGING */
2715         /*
2716            This means we convert either the first branch or the first Exact,
2717            depending on whether the thing following (in 'last') is a branch
2718            or not and whther first is the startbranch (ie is it a sub part of
2719            the alternation or is it the whole thing.)
2720            Assuming its a sub part we convert the EXACT otherwise we convert
2721            the whole branch sequence, including the first.
2722          */
2723         /* Find the node we are going to overwrite */
2724         if ( first != startbranch || OP( last ) == BRANCH ) {
2725             /* branch sub-chain */
2726             NEXT_OFF( first ) = (U16)(last - first);
2727 #ifdef RE_TRACK_PATTERN_OFFSETS
2728             DEBUG_r({
2729                 mjd_offset= Node_Offset((convert));
2730                 mjd_nodelen= Node_Length((convert));
2731             });
2732 #endif
2733             /* whole branch chain */
2734         }
2735 #ifdef RE_TRACK_PATTERN_OFFSETS
2736         else {
2737             DEBUG_r({
2738                 const  regnode *nop = NEXTOPER( convert );
2739                 mjd_offset= Node_Offset((nop));
2740                 mjd_nodelen= Node_Length((nop));
2741             });
2742         }
2743         DEBUG_OPTIMISE_r(
2744             PerlIO_printf(Perl_debug_log,
2745                 "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
2746                 (int)depth * 2 + 2, "",
2747                 (UV)mjd_offset, (UV)mjd_nodelen)
2748         );
2749 #endif
2750         /* But first we check to see if there is a common prefix we can
2751            split out as an EXACT and put in front of the TRIE node.  */
2752         trie->startstate= 1;
2753         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
2754             U32 state;
2755             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
2756                 U32 ofs = 0;
2757                 I32 idx = -1;
2758                 U32 count = 0;
2759                 const U32 base = trie->states[ state ].trans.base;
2760
2761                 if ( trie->states[state].wordnum )
2762                         count = 1;
2763
2764                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2765                     if ( ( base + ofs >= trie->uniquecharcount ) &&
2766                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
2767                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
2768                     {
2769                         if ( ++count > 1 ) {
2770                             SV **tmp = av_fetch( revcharmap, ofs, 0);
2771                             const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
2772                             if ( state == 1 ) break;
2773                             if ( count == 2 ) {
2774                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
2775                                 DEBUG_OPTIMISE_r(
2776                                     PerlIO_printf(Perl_debug_log,
2777                                         "%*sNew Start State=%"UVuf" Class: [",
2778                                         (int)depth * 2 + 2, "",
2779                                         (UV)state));
2780                                 if (idx >= 0) {
2781                                     SV ** const tmp = av_fetch( revcharmap, idx, 0);
2782                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
2783
2784                                     TRIE_BITMAP_SET(trie,*ch);
2785                                     if ( folder )
2786                                         TRIE_BITMAP_SET(trie, folder[ *ch ]);
2787                                     DEBUG_OPTIMISE_r(
2788                                         PerlIO_printf(Perl_debug_log, "%s", (char*)ch)
2789                                     );
2790                                 }
2791                             }
2792                             TRIE_BITMAP_SET(trie,*ch);
2793                             if ( folder )
2794                                 TRIE_BITMAP_SET(trie,folder[ *ch ]);
2795                             DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
2796                         }
2797                         idx = ofs;
2798                     }
2799                 }
2800                 if ( count == 1 ) {
2801                     SV **tmp = av_fetch( revcharmap, idx, 0);
2802                     STRLEN len;
2803                     char *ch = SvPV( *tmp, len );
2804                     DEBUG_OPTIMISE_r({
2805                         SV *sv=sv_newmortal();
2806                         PerlIO_printf( Perl_debug_log,
2807                             "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
2808                             (int)depth * 2 + 2, "",
2809                             (UV)state, (UV)idx,
2810                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6,
2811                                 PL_colors[0], PL_colors[1],
2812                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2813                                 PERL_PV_ESCAPE_FIRSTCHAR
2814                             )
2815                         );
2816                     });
2817                     if ( state==1 ) {
2818                         OP( convert ) = nodetype;
2819                         str=STRING(convert);
2820                         STR_LEN(convert)=0;
2821                     }
2822                     STR_LEN(convert) += len;
2823                     while (len--)
2824                         *str++ = *ch++;
2825                 } else {
2826 #ifdef DEBUGGING
2827                     if (state>1)
2828                         DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
2829 #endif
2830                     break;
2831                 }
2832             }
2833             trie->prefixlen = (state-1);
2834             if (str) {
2835                 regnode *n = convert+NODE_SZ_STR(convert);
2836                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
2837                 trie->startstate = state;
2838                 trie->minlen -= (state - 1);
2839                 trie->maxlen -= (state - 1);
2840 #ifdef DEBUGGING
2841                /* At least the UNICOS C compiler choked on this
2842                 * being argument to DEBUG_r(), so let's just have
2843                 * it right here. */
2844                if (
2845 #ifdef PERL_EXT_RE_BUILD
2846                    1
2847 #else
2848                    DEBUG_r_TEST
2849 #endif
2850                    ) {
2851                    regnode *fix = convert;
2852                    U32 word = trie->wordcount;
2853                    mjd_nodelen++;
2854                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
2855                    while( ++fix < n ) {
2856                        Set_Node_Offset_Length(fix, 0, 0);
2857                    }
2858                    while (word--) {
2859                        SV ** const tmp = av_fetch( trie_words, word, 0 );
2860                        if (tmp) {
2861                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
2862                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
2863                            else
2864                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
2865                        }
2866                    }
2867                }
2868 #endif
2869                 if (trie->maxlen) {
2870                     convert = n;
2871                 } else {
2872                     NEXT_OFF(convert) = (U16)(tail - convert);
2873                     DEBUG_r(optimize= n);
2874                 }
2875             }
2876         }
2877         if (!jumper)
2878             jumper = last;
2879         if ( trie->maxlen ) {
2880             NEXT_OFF( convert ) = (U16)(tail - convert);
2881             ARG_SET( convert, data_slot );
2882             /* Store the offset to the first unabsorbed branch in
2883                jump[0], which is otherwise unused by the jump logic.
2884                We use this when dumping a trie and during optimisation. */
2885             if (trie->jump)
2886                 trie->jump[0] = (U16)(nextbranch - convert);
2887
2888             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
2889              *   and there is a bitmap
2890              *   and the first "jump target" node we found leaves enough room
2891              * then convert the TRIE node into a TRIEC node, with the bitmap
2892              * embedded inline in the opcode - this is hypothetically faster.
2893              */
2894             if ( !trie->states[trie->startstate].wordnum
2895                  && trie->bitmap
2896                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
2897             {
2898                 OP( convert ) = TRIEC;
2899                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
2900                 PerlMemShared_free(trie->bitmap);
2901                 trie->bitmap= NULL;
2902             } else
2903                 OP( convert ) = TRIE;
2904
2905             /* store the type in the flags */
2906             convert->flags = nodetype;
2907             DEBUG_r({
2908             optimize = convert
2909                       + NODE_STEP_REGNODE
2910                       + regarglen[ OP( convert ) ];
2911             });
2912             /* XXX We really should free up the resource in trie now,
2913                    as we won't use them - (which resources?) dmq */
2914         }
2915         /* needed for dumping*/
2916         DEBUG_r(if (optimize) {
2917             regnode *opt = convert;
2918
2919             while ( ++opt < optimize) {
2920                 Set_Node_Offset_Length(opt,0,0);
2921             }
2922             /*
2923                 Try to clean up some of the debris left after the
2924                 optimisation.
2925              */
2926             while( optimize < jumper ) {
2927                 mjd_nodelen += Node_Length((optimize));
2928                 OP( optimize ) = OPTIMIZED;
2929                 Set_Node_Offset_Length(optimize,0,0);
2930                 optimize++;
2931             }
2932             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
2933         });
2934     } /* end node insert */
2935
2936     /*  Finish populating the prev field of the wordinfo array.  Walk back
2937      *  from each accept state until we find another accept state, and if
2938      *  so, point the first word's .prev field at the second word. If the
2939      *  second already has a .prev field set, stop now. This will be the
2940      *  case either if we've already processed that word's accept state,
2941      *  or that state had multiple words, and the overspill words were
2942      *  already linked up earlier.
2943      */
2944     {
2945         U16 word;
2946         U32 state;
2947         U16 prev;
2948
2949         for (word=1; word <= trie->wordcount; word++) {
2950             prev = 0;
2951             if (trie->wordinfo[word].prev)
2952                 continue;
2953             state = trie->wordinfo[word].accept;
2954             while (state) {
2955                 state = prev_states[state];
2956                 if (!state)
2957                     break;
2958                 prev = trie->states[state].wordnum;
2959                 if (prev)
2960                     break;
2961             }
2962             trie->wordinfo[word].prev = prev;
2963         }
2964         Safefree(prev_states);
2965     }
2966
2967
2968     /* and now dump out the compressed format */
2969     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
2970
2971     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
2972 #ifdef DEBUGGING
2973     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
2974     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
2975 #else
2976     SvREFCNT_dec_NN(revcharmap);
2977 #endif
2978     return trie->jump
2979            ? MADE_JUMP_TRIE
2980            : trie->startstate>1
2981              ? MADE_EXACT_TRIE
2982              : MADE_TRIE;
2983 }
2984
2985 STATIC regnode *
2986 S_construct_ahocorasick_from_trie(pTHX_ RExC_state_t *pRExC_state, regnode *source, U32 depth)
2987 {
2988 /* The Trie is constructed and compressed now so we can build a fail array if
2989  * it's needed
2990
2991    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and
2992    3.32 in the
2993    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi,
2994    Ullman 1985/88
2995    ISBN 0-201-10088-6
2996
2997    We find the fail state for each state in the trie, this state is the longest
2998    proper suffix of the current state's 'word' that is also a proper prefix of
2999    another word in our trie. State 1 represents the word '' and is thus the
3000    default fail state. This allows the DFA not to have to restart after its
3001    tried and failed a word at a given point, it simply continues as though it
3002    had been matching the other word in the first place.
3003    Consider
3004       'abcdgu'=~/abcdefg|cdgu/
3005    When we get to 'd' we are still matching the first word, we would encounter
3006    'g' which would fail, which would bring us to the state representing 'd' in
3007    the second word where we would try 'g' and succeed, proceeding to match
3008    'cdgu'.
3009  */
3010  /* add a fail transition */
3011     const U32 trie_offset = ARG(source);
3012     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
3013     U32 *q;
3014     const U32 ucharcount = trie->uniquecharcount;
3015     const U32 numstates = trie->statecount;
3016     const U32 ubound = trie->lasttrans + ucharcount;
3017     U32 q_read = 0;
3018     U32 q_write = 0;
3019     U32 charid;
3020     U32 base = trie->states[ 1 ].trans.base;
3021     U32 *fail;
3022     reg_ac_data *aho;
3023     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("T"));
3024     regnode *stclass;
3025     GET_RE_DEBUG_FLAGS_DECL;
3026
3027     PERL_ARGS_ASSERT_CONSTRUCT_AHOCORASICK_FROM_TRIE;
3028     PERL_UNUSED_CONTEXT;
3029 #ifndef DEBUGGING
3030     PERL_UNUSED_ARG(depth);
3031 #endif
3032
3033     if ( OP(source) == TRIE ) {
3034         struct regnode_1 *op = (struct regnode_1 *)
3035             PerlMemShared_calloc(1, sizeof(struct regnode_1));
3036         StructCopy(source,op,struct regnode_1);
3037         stclass = (regnode *)op;
3038     } else {
3039         struct regnode_charclass *op = (struct regnode_charclass *)
3040             PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
3041         StructCopy(source,op,struct regnode_charclass);
3042         stclass = (regnode *)op;
3043     }
3044     OP(stclass)+=2; /* covert the TRIE type to its AHO-CORASICK equivalent */
3045
3046     ARG_SET( stclass, data_slot );
3047     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
3048     RExC_rxi->data->data[ data_slot ] = (void*)aho;
3049     aho->trie=trie_offset;
3050     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
3051     Copy( trie->states, aho->states, numstates, reg_trie_state );
3052     Newxz( q, numstates, U32);
3053     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
3054     aho->refcount = 1;
3055     fail = aho->fail;
3056     /* initialize fail[0..1] to be 1 so that we always have
3057        a valid final fail state */
3058     fail[ 0 ] = fail[ 1 ] = 1;
3059
3060     for ( charid = 0; charid < ucharcount ; charid++ ) {
3061         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
3062         if ( newstate ) {
3063             q[ q_write ] = newstate;
3064             /* set to point at the root */
3065             fail[ q[ q_write++ ] ]=1;
3066         }
3067     }
3068     while ( q_read < q_write) {
3069         const U32 cur = q[ q_read++ % numstates ];
3070         base = trie->states[ cur ].trans.base;
3071
3072         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
3073             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
3074             if (ch_state) {
3075                 U32 fail_state = cur;
3076                 U32 fail_base;
3077                 do {
3078                     fail_state = fail[ fail_state ];
3079                     fail_base = aho->states[ fail_state ].trans.base;
3080                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
3081
3082                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
3083                 fail[ ch_state ] = fail_state;
3084                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
3085                 {
3086                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
3087                 }
3088                 q[ q_write++ % numstates] = ch_state;
3089             }
3090         }
3091     }
3092     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
3093        when we fail in state 1, this allows us to use the
3094        charclass scan to find a valid start char. This is based on the principle
3095        that theres a good chance the string being searched contains lots of stuff
3096        that cant be a start char.
3097      */
3098     fail[ 0 ] = fail[ 1 ] = 0;
3099     DEBUG_TRIE_COMPILE_r({
3100         PerlIO_printf(Perl_debug_log,
3101                       "%*sStclass Failtable (%"UVuf" states): 0",
3102                       (int)(depth * 2), "", (UV)numstates
3103         );
3104         for( q_read=1; q_read<numstates; q_read++ ) {
3105             PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
3106         }
3107         PerlIO_printf(Perl_debug_log, "\n");
3108     });
3109     Safefree(q);
3110     /*RExC_seen |= REG_TRIEDFA_SEEN;*/
3111     return stclass;
3112 }
3113
3114
3115 #define DEBUG_PEEP(str,scan,depth) \
3116     DEBUG_OPTIMISE_r({if (scan){ \
3117        SV * const mysv=sv_newmortal(); \
3118        regnode *Next = regnext(scan); \
3119        regprop(RExC_rx, mysv, scan, NULL); \
3120        PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
3121        (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
3122        Next ? (REG_NODE_NUM(Next)) : 0 ); \
3123    }});
3124
3125
3126 /* The below joins as many adjacent EXACTish nodes as possible into a single
3127  * one.  The regop may be changed if the node(s) contain certain sequences that
3128  * require special handling.  The joining is only done if:
3129  * 1) there is room in the current conglomerated node to entirely contain the
3130  *    next one.
3131  * 2) they are the exact same node type
3132  *
3133  * The adjacent nodes actually may be separated by NOTHING-kind nodes, and
3134  * these get optimized out
3135  *
3136  * If a node is to match under /i (folded), the number of characters it matches
3137  * can be different than its character length if it contains a multi-character
3138  * fold.  *min_subtract is set to the total delta number of characters of the
3139  * input nodes.
3140  *
3141  * And *unfolded_multi_char is set to indicate whether or not the node contains
3142  * an unfolded multi-char fold.  This happens when whether the fold is valid or
3143  * not won't be known until runtime; namely for EXACTF nodes that contain LATIN
3144  * SMALL LETTER SHARP S, as only if the target string being matched against
3145  * turns out to be UTF-8 is that fold valid; and also for EXACTFL nodes whose
3146  * folding rules depend on the locale in force at runtime.  (Multi-char folds
3147  * whose components are all above the Latin1 range are not run-time locale
3148  * dependent, and have already been folded by the time this function is
3149  * called.)
3150  *
3151  * This is as good a place as any to discuss the design of handling these
3152  * multi-character fold sequences.  It's been wrong in Perl for a very long
3153  * time.  There are three code points in Unicode whose multi-character folds
3154  * were long ago discovered to mess things up.  The previous designs for
3155  * dealing with these involved assigning a special node for them.  This
3156  * approach doesn't always work, as evidenced by this example:
3157  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
3158  * Both sides fold to "sss", but if the pattern is parsed to create a node that
3159  * would match just the \xDF, it won't be able to handle the case where a
3160  * successful match would have to cross the node's boundary.  The new approach
3161  * that hopefully generally solves the problem generates an EXACTFU_SS node
3162  * that is "sss" in this case.
3163  *
3164  * It turns out that there are problems with all multi-character folds, and not
3165  * just these three.  Now the code is general, for all such cases.  The
3166  * approach taken is:
3167  * 1)   This routine examines each EXACTFish node that could contain multi-
3168  *      character folded sequences.  Since a single character can fold into
3169  *      such a sequence, the minimum match length for this node is less than
3170  *      the number of characters in the node.  This routine returns in
3171  *      *min_subtract how many characters to subtract from the the actual
3172  *      length of the string to get a real minimum match length; it is 0 if
3173  *      there are no multi-char foldeds.  This delta is used by the caller to
3174  *      adjust the min length of the match, and the delta between min and max,
3175  *      so that the optimizer doesn't reject these possibilities based on size
3176  *      constraints.
3177  * 2)   For the sequence involving the Sharp s (\xDF), the node type EXACTFU_SS
3178  *      is used for an EXACTFU node that contains at least one "ss" sequence in
3179  *      it.  For non-UTF-8 patterns and strings, this is the only case where
3180  *      there is a possible fold length change.  That means that a regular
3181  *      EXACTFU node without UTF-8 involvement doesn't have to concern itself
3182  *      with length changes, and so can be processed faster.  regexec.c takes
3183  *      advantage of this.  Generally, an EXACTFish node that is in UTF-8 is
3184  *      pre-folded by regcomp.c (except EXACTFL, some of whose folds aren't
3185  *      known until runtime).  This saves effort in regex matching.  However,
3186  *      the pre-folding isn't done for non-UTF8 patterns because the fold of
3187  *      the MICRO SIGN requires UTF-8, and we don't want to slow things down by
3188  *      forcing the pattern into UTF8 unless necessary.  Also what EXACTF (and,
3189  *      again, EXACTFL) nodes fold to isn't known until runtime.  The fold
3190  *      possibilities for the non-UTF8 patterns are quite simple, except for
3191  *      the sharp s.  All the ones that don't involve a UTF-8 target string are
3192  *      members of a fold-pair, and arrays are set up for all of them so that
3193  *      the other member of the pair can be found quickly.  Code elsewhere in
3194  *      this file makes sure that in EXACTFU nodes, the sharp s gets folded to
3195  *      'ss', even if the pattern isn't UTF-8.  This avoids the issues
3196  *      described in the next item.
3197  * 3)   A problem remains for unfolded multi-char folds. (These occur when the
3198  *      validity of the fold won't be known until runtime, and so must remain
3199  *      unfolded for now.  This happens for the sharp s in EXACTF and EXACTFA
3200  *      nodes when the pattern isn't in UTF-8.  (Note, BTW, that there cannot
3201  *      be an EXACTF node with a UTF-8 pattern.)  They also occur for various
3202  *      folds in EXACTFL nodes, regardless of the UTF-ness of the pattern.)
3203  *      The reason this is a problem is that the optimizer part of regexec.c
3204  *      (probably unwittingly, in Perl_regexec_flags()) makes an assumption
3205  *      that a character in the pattern corresponds to at most a single
3206  *      character in the target string.  (And I do mean character, and not byte
3207  *      here, unlike other parts of the documentation that have never been
3208  *      updated to account for multibyte Unicode.)  sharp s in EXACTF and
3209  *      EXACTFL nodes can match the two character string 'ss'; in EXACTFA nodes
3210  *      it can match "\x{17F}\x{17F}".  These, along with other ones in EXACTFL
3211  *      nodes, violate the assumption, and they are the only instances where it
3212  *      is violated.  I'm reluctant to try to change the assumption, as the
3213  *      code involved is impenetrable to me (khw), so instead the code here
3214  *      punts.  This routine examines EXACTFL nodes, and (when the pattern
3215  *      isn't UTF-8) EXACTF and EXACTFA for such unfolded folds, and returns a
3216  *      boolean indicating whether or not the node contains such a fold.  When
3217  *      it is true, the caller sets a flag that later causes the optimizer in
3218  *      this file to not set values for the floating and fixed string lengths,
3219  *      and thus avoids the optimizer code in regexec.c that makes the invalid
3220  *      assumption.  Thus, there is no optimization based on string lengths for
3221  *      EXACTFL nodes that contain these few folds, nor for non-UTF8-pattern
3222  *      EXACTF and EXACTFA nodes that contain the sharp s.  (The reason the
3223  *      assumption is wrong only in these cases is that all other non-UTF-8
3224  *      folds are 1-1; and, for UTF-8 patterns, we pre-fold all other folds to
3225  *      their expanded versions.  (Again, we can't prefold sharp s to 'ss' in
3226  *      EXACTF nodes because we don't know at compile time if it actually
3227  *      matches 'ss' or not.  For EXACTF nodes it will match iff the target
3228  *      string is in UTF-8.  This is in contrast to EXACTFU nodes, where it
3229  *      always matches; and EXACTFA where it never does.  In an EXACTFA node in
3230  *      a UTF-8 pattern, sharp s is folded to "\x{17F}\x{17F}, avoiding the
3231  *      problem; but in a non-UTF8 pattern, folding it to that above-Latin1
3232  *      string would require the pattern to be forced into UTF-8, the overhead
3233  *      of which we want to avoid.  Similarly the unfolded multi-char folds in
3234  *      EXACTFL nodes will match iff the locale at the time of match is a UTF-8
3235  *      locale.)
3236  *
3237  *      Similarly, the code that generates tries doesn't currently handle
3238  *      not-already-folded multi-char folds, and it looks like a pain to change
3239  *      that.  Therefore, trie generation of EXACTFA nodes with the sharp s
3240  *      doesn't work.  Instead, such an EXACTFA is turned into a new regnode,
3241  *      EXACTFA_NO_TRIE, which the trie code knows not to handle.  Most people
3242  *      using /iaa matching will be doing so almost entirely with ASCII
3243  *      strings, so this should rarely be encountered in practice */
3244
3245 #define JOIN_EXACT(scan,min_subtract,unfolded_multi_char, flags) \
3246     if (PL_regkind[OP(scan)] == EXACT) \
3247         join_exact(pRExC_state,(scan),(min_subtract),unfolded_multi_char, (flags),NULL,depth+1)
3248
3249 STATIC U32
3250 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan,
3251                    UV *min_subtract, bool *unfolded_multi_char,
3252                    U32 flags,regnode *val, U32 depth)
3253 {
3254     /* Merge several consecutive EXACTish nodes into one. */
3255     regnode *n = regnext(scan);
3256     U32 stringok = 1;
3257     regnode *next = scan + NODE_SZ_STR(scan);
3258     U32 merged = 0;
3259     U32 stopnow = 0;
3260 #ifdef DEBUGGING
3261     regnode *stop = scan;
3262     GET_RE_DEBUG_FLAGS_DECL;
3263 #else
3264     PERL_UNUSED_ARG(depth);
3265 #endif
3266
3267     PERL_ARGS_ASSERT_JOIN_EXACT;
3268 #ifndef EXPERIMENTAL_INPLACESCAN
3269     PERL_UNUSED_ARG(flags);
3270     PERL_UNUSED_ARG(val);
3271 #endif
3272     DEBUG_PEEP("join",scan,depth);
3273
3274     /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
3275      * EXACT ones that are mergeable to the current one. */
3276     while (n
3277            && (PL_regkind[OP(n)] == NOTHING
3278                || (stringok && OP(n) == OP(scan)))
3279            && NEXT_OFF(n)
3280            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
3281     {
3282
3283         if (OP(n) == TAIL || n > next)
3284             stringok = 0;
3285         if (PL_regkind[OP(n)] == NOTHING) {
3286             DEBUG_PEEP("skip:",n,depth);
3287             NEXT_OFF(scan) += NEXT_OFF(n);
3288             next = n + NODE_STEP_REGNODE;
3289 #ifdef DEBUGGING
3290             if (stringok)
3291                 stop = n;
3292 #endif
3293             n = regnext(n);
3294         }
3295         else if (stringok) {
3296             const unsigned int oldl = STR_LEN(scan);
3297             regnode * const nnext = regnext(n);
3298
3299             /* XXX I (khw) kind of doubt that this works on platforms (should
3300              * Perl ever run on one) where U8_MAX is above 255 because of lots
3301              * of other assumptions */
3302             /* Don't join if the sum can't fit into a single node */
3303             if (oldl + STR_LEN(n) > U8_MAX)
3304                 break;
3305
3306             DEBUG_PEEP("merg",n,depth);
3307             merged++;
3308
3309             NEXT_OFF(scan) += NEXT_OFF(n);
3310             STR_LEN(scan) += STR_LEN(n);
3311             next = n + NODE_SZ_STR(n);
3312             /* Now we can overwrite *n : */
3313             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
3314 #ifdef DEBUGGING
3315             stop = next - 1;
3316 #endif
3317             n = nnext;
3318             if (stopnow) break;
3319         }
3320
3321 #ifdef EXPERIMENTAL_INPLACESCAN
3322         if (flags && !NEXT_OFF(n)) {
3323             DEBUG_PEEP("atch", val, depth);
3324             if (reg_off_by_arg[OP(n)]) {
3325                 ARG_SET(n, val - n);
3326             }
3327             else {
3328                 NEXT_OFF(n) = val - n;
3329             }
3330             stopnow = 1;
3331         }
3332 #endif
3333     }
3334
3335     *min_subtract = 0;
3336     *unfolded_multi_char = FALSE;
3337
3338     /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
3339      * can now analyze for sequences of problematic code points.  (Prior to
3340      * this final joining, sequences could have been split over boundaries, and
3341      * hence missed).  The sequences only happen in folding, hence for any
3342      * non-EXACT EXACTish node */
3343     if (OP(scan) != EXACT) {
3344         U8* s0 = (U8*) STRING(scan);
3345         U8* s = s0;
3346         U8* s_end = s0 + STR_LEN(scan);
3347
3348         int total_count_delta = 0;  /* Total delta number of characters that
3349                                        multi-char folds expand to */
3350
3351         /* One pass is made over the node's string looking for all the
3352          * possibilities.  To avoid some tests in the loop, there are two main
3353          * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
3354          * non-UTF-8 */
3355         if (UTF) {
3356             U8* folded = NULL;
3357
3358             if (OP(scan) == EXACTFL) {
3359                 U8 *d;
3360
3361                 /* An EXACTFL node would already have been changed to another
3362                  * node type unless there is at least one character in it that
3363                  * is problematic; likely a character whose fold definition
3364                  * won't be known until runtime, and so has yet to be folded.
3365                  * For all but the UTF-8 locale, folds are 1-1 in length, but
3366                  * to handle the UTF-8 case, we need to create a temporary
3367                  * folded copy using UTF-8 locale rules in order to analyze it.
3368                  * This is because our macros that look to see if a sequence is
3369                  * a multi-char fold assume everything is folded (otherwise the
3370                  * tests in those macros would be too complicated and slow).
3371                  * Note that here, the non-problematic folds will have already
3372                  * been done, so we can just copy such characters.  We actually
3373                  * don't completely fold the EXACTFL string.  We skip the
3374                  * unfolded multi-char folds, as that would just create work
3375                  * below to figure out the size they already are */
3376
3377                 Newx(folded, UTF8_MAX_FOLD_CHAR_EXPAND * STR_LEN(scan) + 1, U8);
3378                 d = folded;
3379                 while (s < s_end) {
3380                     STRLEN s_len = UTF8SKIP(s);
3381                     if (! is_PROBLEMATIC_LOCALE_FOLD_utf8(s)) {
3382                         Copy(s, d, s_len, U8);
3383                         d += s_len;
3384                     }
3385                     else if (is_FOLDS_TO_MULTI_utf8(s)) {
3386                         *unfolded_multi_char = TRUE;
3387                         Copy(s, d, s_len, U8);
3388                         d += s_len;
3389                     }
3390                     else if (isASCII(*s)) {
3391                         *(d++) = toFOLD(*s);
3392                     }
3393                     else {
3394                         STRLEN len;
3395                         _to_utf8_fold_flags(s, d, &len, FOLD_FLAGS_FULL);
3396                         d += len;
3397                     }
3398                     s += s_len;
3399                 }
3400
3401                 /* Point the remainder of the routine to look at our temporary
3402                  * folded copy */
3403                 s = folded;
3404                 s_end = d;
3405             } /* End of creating folded copy of EXACTFL string */
3406
3407             /* Examine the string for a multi-character fold sequence.  UTF-8
3408              * patterns have all characters pre-folded by the time this code is
3409              * executed */
3410             while (s < s_end - 1) /* Can stop 1 before the end, as minimum
3411                                      length sequence we are looking for is 2 */
3412             {
3413                 int count = 0;  /* How many characters in a multi-char fold */
3414                 int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
3415                 if (! len) {    /* Not a multi-char fold: get next char */
3416                     s += UTF8SKIP(s);
3417                     continue;
3418                 }
3419
3420                 /* Nodes with 'ss' require special handling, except for
3421                  * EXACTFA-ish for which there is no multi-char fold to this */
3422                 if (len == 2 && *s == 's' && *(s+1) == 's'
3423                     && OP(scan) != EXACTFA
3424                     && OP(scan) != EXACTFA_NO_TRIE)
3425                 {
3426                     count = 2;
3427                     if (OP(scan) != EXACTFL) {
3428                         OP(scan) = EXACTFU_SS;
3429                     }
3430                     s += 2;
3431                 }
3432                 else { /* Here is a generic multi-char fold. */
3433                     U8* multi_end  = s + len;
3434
3435                     /* Count how many characters are in it.  In the case of
3436                      * /aa, no folds which contain ASCII code points are
3437                      * allowed, so check for those, and skip if found. */
3438                     if (OP(scan) != EXACTFA && OP(scan) != EXACTFA_NO_TRIE) {
3439                         count = utf8_length(s, multi_end);
3440                         s = multi_end;
3441                     }
3442                     else {
3443                         while (s < multi_end) {
3444                             if (isASCII(*s)) {
3445                                 s++;
3446                                 goto next_iteration;
3447                             }
3448                             else {
3449                                 s += UTF8SKIP(s);
3450                             }
3451                             count++;
3452                         }
3453                     }
3454                 }
3455
3456                 /* The delta is how long the sequence is minus 1 (1 is how long
3457                  * the character that folds to the sequence is) */
3458                 total_count_delta += count - 1;
3459               next_iteration: ;
3460             }
3461
3462             /* We created a temporary folded copy of the string in EXACTFL
3463              * nodes.  Therefore we need to be sure it doesn't go below zero,
3464              * as the real string could be shorter */
3465             if (OP(scan) == EXACTFL) {
3466                 int total_chars = utf8_length((U8*) STRING(scan),
3467                                            (U8*) STRING(scan) + STR_LEN(scan));
3468                 if (total_count_delta > total_chars) {
3469                     total_count_delta = total_chars;
3470                 }
3471             }
3472
3473             *min_subtract += total_count_delta;
3474             Safefree(folded);
3475         }
3476         else if (OP(scan) == EXACTFA) {
3477
3478             /* Non-UTF-8 pattern, EXACTFA node.  There can't be a multi-char
3479              * fold to the ASCII range (and there are no existing ones in the
3480              * upper latin1 range).  But, as outlined in the comments preceding
3481              * this function, we need to flag any occurrences of the sharp s.
3482              * This character forbids trie formation (because of added
3483              * complexity) */
3484             while (s < s_end) {
3485                 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3486                     OP(scan) = EXACTFA_NO_TRIE;
3487                     *unfolded_multi_char = TRUE;
3488                     break;
3489                 }
3490                 s++;
3491                 continue;
3492             }
3493         }
3494         else {
3495
3496             /* Non-UTF-8 pattern, not EXACTFA node.  Look for the multi-char
3497              * folds that are all Latin1.  As explained in the comments
3498              * preceding this function, we look also for the sharp s in EXACTF
3499              * and EXACTFL nodes; it can be in the final position.  Otherwise
3500              * we can stop looking 1 byte earlier because have to find at least
3501              * two characters for a multi-fold */
3502             const U8* upper = (OP(scan) == EXACTF || OP(scan) == EXACTFL)
3503                               ? s_end
3504                               : s_end -1;
3505
3506             while (s < upper) {
3507                 int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end);
3508                 if (! len) {    /* Not a multi-char fold. */
3509                     if (*s == LATIN_SMALL_LETTER_SHARP_S
3510                         && (OP(scan) == EXACTF || OP(scan) == EXACTFL))
3511                     {
3512                         *unfolded_multi_char = TRUE;
3513                     }
3514                     s++;
3515                     continue;
3516                 }
3517
3518                 if (len == 2
3519                     && isARG2_lower_or_UPPER_ARG1('s', *s)
3520                     && isARG2_lower_or_UPPER_ARG1('s', *(s+1)))
3521                 {
3522
3523                     /* EXACTF nodes need to know that the minimum length
3524                      * changed so that a sharp s in the string can match this
3525                      * ss in the pattern, but they remain EXACTF nodes, as they
3526                      * won't match this unless the target string is is UTF-8,
3527                      * which we don't know until runtime.  EXACTFL nodes can't
3528                      * transform into EXACTFU nodes */
3529                     if (OP(scan) != EXACTF && OP(scan) != EXACTFL) {
3530                         OP(scan) = EXACTFU_SS;
3531                     }
3532                 }
3533
3534                 *min_subtract += len - 1;
3535                 s += len;
3536             }
3537         }
3538     }
3539
3540 #ifdef DEBUGGING
3541     /* Allow dumping but overwriting the collection of skipped
3542      * ops and/or strings with fake optimized ops */
3543     n = scan + NODE_SZ_STR(scan);
3544     while (n <= stop) {
3545         OP(n) = OPTIMIZED;
3546         FLAGS(n) = 0;
3547         NEXT_OFF(n) = 0;
3548         n++;
3549     }
3550 #endif
3551     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
3552     return stopnow;
3553 }
3554
3555 /* REx optimizer.  Converts nodes into quicker variants "in place".
3556    Finds fixed substrings.  */
3557
3558 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
3559    to the position after last scanned or to NULL. */
3560
3561 #define INIT_AND_WITHP \
3562     assert(!and_withp); \
3563     Newx(and_withp,1, regnode_ssc); \
3564     SAVEFREEPV(and_withp)
3565
3566 /* this is a chain of data about sub patterns we are processing that
3567    need to be handled separately/specially in study_chunk. Its so
3568    we can simulate recursion without losing state.  */
3569 struct scan_frame;
3570 typedef struct scan_frame {
3571     regnode *last;  /* last node to process in this frame */
3572     regnode *next;  /* next node to process when last is reached */
3573     struct scan_frame *prev; /*previous frame*/
3574     U32 prev_recursed_depth;
3575     I32 stop; /* what stopparen do we use */
3576 } scan_frame;
3577
3578
3579 STATIC SSize_t
3580 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
3581                         SSize_t *minlenp, SSize_t *deltap,
3582                         regnode *last,
3583                         scan_data_t *data,
3584                         I32 stopparen,
3585                         U32 recursed_depth,
3586                         regnode_ssc *and_withp,
3587                         U32 flags, U32 depth)
3588                         /* scanp: Start here (read-write). */
3589                         /* deltap: Write maxlen-minlen here. */
3590                         /* last: Stop before this one. */
3591                         /* data: string data about the pattern */
3592                         /* stopparen: treat close N as END */
3593                         /* recursed: which subroutines have we recursed into */
3594                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
3595 {
3596     /* There must be at least this number of characters to match */
3597     SSize_t min = 0;
3598     I32 pars = 0, code;
3599     regnode *scan = *scanp, *next;
3600     SSize_t delta = 0;
3601     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
3602     int is_inf_internal = 0;            /* The studied chunk is infinite */
3603     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
3604     scan_data_t data_fake;
3605     SV *re_trie_maxbuff = NULL;
3606     regnode *first_non_open = scan;
3607     SSize_t stopmin = SSize_t_MAX;
3608     scan_frame *frame = NULL;
3609     GET_RE_DEBUG_FLAGS_DECL;
3610
3611     PERL_ARGS_ASSERT_STUDY_CHUNK;
3612
3613 #ifdef DEBUGGING
3614     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
3615 #endif
3616     if ( depth == 0 ) {
3617         while (first_non_open && OP(first_non_open) == OPEN)
3618             first_non_open=regnext(first_non_open);
3619     }
3620
3621
3622   fake_study_recurse:
3623     while ( scan && OP(scan) != END && scan < last ){
3624         UV min_subtract = 0;    /* How mmany chars to subtract from the minimum
3625                                    node length to get a real minimum (because
3626                                    the folded version may be shorter) */
3627         bool unfolded_multi_char = FALSE;
3628         /* Peephole optimizer: */
3629         DEBUG_OPTIMISE_MORE_r(
3630         {
3631             PerlIO_printf(Perl_debug_log,
3632                 "%*sstudy_chunk stopparen=%ld depth=%lu recursed_depth=%lu ",
3633                 ((int) depth*2), "", (long)stopparen,
3634                 (unsigned long)depth, (unsigned long)recursed_depth);
3635             if (recursed_depth) {
3636                 U32 i;
3637                 U32 j;
3638                 for ( j = 0 ; j < recursed_depth ; j++ ) {
3639                     PerlIO_printf(Perl_debug_log,"[");
3640                     for ( i = 0 ; i < (U32)RExC_npar ; i++ )
3641                         PerlIO_printf(Perl_debug_log,"%d",
3642                             PAREN_TEST(RExC_study_chunk_recursed +
3643                                        (j * RExC_study_chunk_recursed_bytes), i)
3644                             ? 1 : 0
3645                         );
3646                     PerlIO_printf(Perl_debug_log,"]");
3647                 }
3648             }
3649             PerlIO_printf(Perl_debug_log,"\n");
3650         }
3651         );
3652         DEBUG_STUDYDATA("Peep:", data, depth);
3653         DEBUG_PEEP("Peep", scan, depth);
3654
3655
3656         /* The reason we do this here we need to deal with things like /(?:f)(?:o)(?:o)/
3657          * which cant be dealt with by the normal EXACT parsing code, as each (?:..) is handled
3658          * by a different invocation of reg() -- Yves
3659          */
3660         JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
3661
3662         /* Follow the next-chain of the current node and optimize
3663            away all the NOTHINGs from it.  */
3664         if (OP(scan) != CURLYX) {
3665             const int max = (reg_off_by_arg[OP(scan)]
3666                        ? I32_MAX
3667                        /* I32 may be smaller than U16 on CRAYs! */
3668                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
3669             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
3670             int noff;
3671             regnode *n = scan;
3672
3673             /* Skip NOTHING and LONGJMP. */
3674             while ((n = regnext(n))
3675                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
3676                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
3677                    && off + noff < max)
3678                 off += noff;
3679             if (reg_off_by_arg[OP(scan)])
3680                 ARG(scan) = off;
3681             else
3682                 NEXT_OFF(scan) = off;
3683         }
3684
3685
3686
3687         /* The principal pseudo-switch.  Cannot be a switch, since we
3688            look into several different things.  */
3689         if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
3690                    || OP(scan) == IFTHEN) {
3691             next = regnext(scan);
3692             code = OP(scan);
3693             /* demq: the op(next)==code check is to see if we have
3694              * "branch-branch" AFAICT */
3695
3696             if (OP(next) == code || code == IFTHEN) {
3697                 /* NOTE - There is similar code to this block below for
3698                  * handling TRIE nodes on a re-study.  If you change stuff here
3699                  * check there too. */
3700                 SSize_t max1 = 0, min1 = SSize_t_MAX, num = 0;
3701                 regnode_ssc accum;
3702                 regnode * const startbranch=scan;
3703
3704                 if (flags & SCF_DO_SUBSTR) {
3705                     /* Cannot merge strings after this. */
3706                     scan_commit(pRExC_state, data, minlenp, is_inf);
3707                 }
3708
3709                 if (flags & SCF_DO_STCLASS)
3710                     ssc_init_zero(pRExC_state, &accum);
3711
3712                 while (OP(scan) == code) {
3713                     SSize_t deltanext, minnext, fake;
3714                     I32 f = 0;
3715                     regnode_ssc this_class;
3716
3717                     num++;
3718                     data_fake.flags = 0;
3719                     if (data) {
3720                         data_fake.whilem_c = data->whilem_c;
3721                         data_fake.last_closep = data->last_closep;
3722                     }
3723                     else
3724                         data_fake.last_closep = &fake;
3725
3726                     data_fake.pos_delta = delta;
3727                     next = regnext(scan);
3728                     scan = NEXTOPER(scan);
3729                     if (code != BRANCH)
3730                         scan = NEXTOPER(scan);
3731                     if (flags & SCF_DO_STCLASS) {
3732                         ssc_init(pRExC_state, &this_class);
3733                         data_fake.start_class = &this_class;
3734                         f = SCF_DO_STCLASS_AND;
3735                     }
3736                     if (flags & SCF_WHILEM_VISITED_POS)
3737                         f |= SCF_WHILEM_VISITED_POS;
3738
3739                     /* we suppose the run is continuous, last=next...*/
3740                     minnext = study_chunk(pRExC_state, &scan, minlenp,
3741                                       &deltanext, next, &data_fake, stopparen,
3742                                       recursed_depth, NULL, f,depth+1);
3743                     if (min1 > minnext)
3744                         min1 = minnext;
3745                     if (deltanext == SSize_t_MAX) {
3746                         is_inf = is_inf_internal = 1;
3747                         max1 = SSize_t_MAX;
3748                     } else if (max1 < minnext + deltanext)
3749                         max1 = minnext + deltanext;
3750                     scan = next;
3751                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3752                         pars++;
3753                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
3754                         if ( stopmin > minnext)
3755                             stopmin = min + min1;
3756                         flags &= ~SCF_DO_SUBSTR;
3757                         if (data)
3758                             data->flags |= SCF_SEEN_ACCEPT;
3759                     }
3760                     if (data) {
3761                         if (data_fake.flags & SF_HAS_EVAL)
3762                             data->flags |= SF_HAS_EVAL;
3763                         data->whilem_c = data_fake.whilem_c;
3764                     }
3765                     if (flags & SCF_DO_STCLASS)
3766                         ssc_or(pRExC_state, &accum, (regnode_charclass*)&this_class);
3767                 }
3768                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
3769                     min1 = 0;
3770                 if (flags & SCF_DO_SUBSTR) {
3771                     data->pos_min += min1;
3772                     if (data->pos_delta >= SSize_t_MAX - (max1 - min1))
3773                         data->pos_delta = SSize_t_MAX;
3774                     else
3775                         data->pos_delta += max1 - min1;
3776                     if (max1 != min1 || is_inf)
3777                         data->longest = &(data->longest_float);
3778                 }
3779                 min += min1;
3780                 if (delta == SSize_t_MAX
3781                  || SSize_t_MAX - delta - (max1 - min1) < 0)
3782                     delta = SSize_t_MAX;
3783                 else
3784                     delta += max1 - min1;
3785                 if (flags & SCF_DO_STCLASS_OR) {
3786                     ssc_or(pRExC_state, data->start_class, (regnode_charclass*) &accum);
3787                     if (min1) {
3788                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
3789                         flags &= ~SCF_DO_STCLASS;
3790                     }
3791                 }
3792                 else if (flags & SCF_DO_STCLASS_AND) {
3793                     if (min1) {
3794                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
3795                         flags &= ~SCF_DO_STCLASS;
3796                     }
3797                     else {
3798                         /* Switch to OR mode: cache the old value of
3799                          * data->start_class */
3800                         INIT_AND_WITHP;
3801                         StructCopy(data->start_class, and_withp, regnode_ssc);
3802                         flags &= ~SCF_DO_STCLASS_AND;
3803                         StructCopy(&accum, data->start_class, regnode_ssc);
3804                         flags |= SCF_DO_STCLASS_OR;
3805                     }
3806                 }
3807
3808                 if (PERL_ENABLE_TRIE_OPTIMISATION &&
3809                         OP( startbranch ) == BRANCH )
3810                 {
3811                 /* demq.
3812
3813                    Assuming this was/is a branch we are dealing with: 'scan'
3814                    now points at the item that follows the branch sequence,
3815                    whatever it is. We now start at the beginning of the
3816                    sequence and look for subsequences of
3817
3818                    BRANCH->EXACT=>x1
3819                    BRANCH->EXACT=>x2
3820                    tail
3821
3822                    which would be constructed from a pattern like
3823                    /A|LIST|OF|WORDS/
3824
3825                    If we can find such a subsequence we need to turn the first
3826                    element into a trie and then add the subsequent branch exact
3827                    strings to the trie.
3828
3829                    We have two cases
3830
3831                      1. patterns where the whole set of branches can be
3832                         converted.
3833
3834                      2. patterns where only a subset can be converted.
3835
3836                    In case 1 we can replace the whole set with a single regop
3837                    for the trie. In case 2 we need to keep the start and end
3838                    branches so
3839
3840                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
3841                      becomes BRANCH TRIE; BRANCH X;
3842
3843                   There is an additional case, that being where there is a
3844                   common prefix, which gets split out into an EXACT like node
3845                   preceding the TRIE node.
3846
3847                   If x(1..n)==tail then we can do a simple trie, if not we make
3848                   a "jump" trie, such that when we match the appropriate word
3849                   we "jump" to the appropriate tail node. Essentially we turn
3850                   a nested if into a case structure of sorts.
3851
3852                 */
3853
3854                     int made=0;
3855                     if (!re_trie_maxbuff) {
3856                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
3857                         if (!SvIOK(re_trie_maxbuff))
3858                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
3859                     }
3860                     if ( SvIV(re_trie_maxbuff)>=0  ) {
3861                         regnode *cur;
3862                         regnode *first = (regnode *)NULL;
3863                         regnode *last = (regnode *)NULL;
3864                         regnode *tail = scan;
3865                         U8 trietype = 0;
3866                         U32 count=0;
3867
3868 #ifdef DEBUGGING
3869                         SV * const mysv = sv_newmortal();   /* for dumping */
3870 #endif
3871                         /* var tail is used because there may be a TAIL
3872                            regop in the way. Ie, the exacts will point to the
3873                            thing following the TAIL, but the last branch will
3874                            point at the TAIL. So we advance tail. If we
3875                            have nested (?:) we may have to move through several
3876                            tails.
3877                          */
3878
3879                         while ( OP( tail ) == TAIL ) {
3880                             /* this is the TAIL generated by (?:) */
3881                             tail = regnext( tail );
3882                         }
3883
3884
3885                         DEBUG_TRIE_COMPILE_r({
3886                             regprop(RExC_rx, mysv, tail, NULL);
3887                             PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
3888                               (int)depth * 2 + 2, "",
3889                               "Looking for TRIE'able sequences. Tail node is: ",
3890                               SvPV_nolen_const( mysv )
3891                             );
3892                         });
3893
3894                         /*
3895
3896                             Step through the branches
3897                                 cur represents each branch,
3898                                 noper is the first thing to be matched as part
3899                                       of that branch
3900                                 noper_next is the regnext() of that node.
3901
3902                             We normally handle a case like this
3903                             /FOO[xyz]|BAR[pqr]/ via a "jump trie" but we also
3904                             support building with NOJUMPTRIE, which restricts
3905                             the trie logic to structures like /FOO|BAR/.
3906
3907                             If noper is a trieable nodetype then the branch is
3908                             a possible optimization target. If we are building
3909                             under NOJUMPTRIE then we require that noper_next is
3910                             the same as scan (our current position in the regex
3911                             program).
3912
3913                             Once we have two or more consecutive such branches
3914                             we can create a trie of the EXACT's contents and
3915                             stitch it in place into the program.
3916
3917                             If the sequence represents all of the branches in
3918                             the alternation we replace the entire thing with a
3919                             single TRIE node.
3920
3921                             Otherwise when it is a subsequence we need to
3922                             stitch it in place and replace only the relevant
3923                             branches. This means the first branch has to remain
3924                             as it is used by the alternation logic, and its
3925                             next pointer, and needs to be repointed at the item
3926                             on the branch chain following the last branch we
3927                             have optimized away.
3928
3929                             This could be either a BRANCH, in which case the
3930                             subsequence is internal, or it could be the item
3931                             following the branch sequence in which case the
3932                             subsequence is at the end (which does not
3933                             necessarily mean the first node is the start of the
3934                             alternation).
3935
3936                             TRIE_TYPE(X) is a define which maps the optype to a
3937                             trietype.
3938
3939                                 optype          |  trietype
3940                                 ----------------+-----------
3941                                 NOTHING         | NOTHING
3942                                 EXACT           | EXACT
3943                                 EXACTFU         | EXACTFU
3944                                 EXACTFU_SS      | EXACTFU
3945                                 EXACTFA         | EXACTFA
3946
3947
3948                         */
3949 #define TRIE_TYPE(X) ( ( NOTHING == (X) ) ? NOTHING :   \
3950                        ( EXACT == (X) )   ? EXACT :        \
3951                        ( EXACTFU == (X) || EXACTFU_SS == (X) ) ? EXACTFU :        \
3952                        ( EXACTFA == (X) ) ? EXACTFA :        \
3953                        0 )
3954
3955                         /* dont use tail as the end marker for this traverse */
3956                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
3957                             regnode * const noper = NEXTOPER( cur );
3958                             U8 noper_type = OP( noper );
3959                             U8 noper_trietype = TRIE_TYPE( noper_type );
3960 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
3961                             regnode * const noper_next = regnext( noper );
3962                             U8 noper_next_type = (noper_next && noper_next != tail) ? OP(noper_next) : 0;
3963                             U8 noper_next_trietype = (noper_next && noper_next != tail) ? TRIE_TYPE( noper_next_type ) :0;
3964 #endif
3965
3966                             DEBUG_TRIE_COMPILE_r({
3967                                 regprop(RExC_rx, mysv, cur, NULL);
3968                                 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
3969                                    (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
3970
3971                                 regprop(RExC_rx, mysv, noper, NULL);
3972                                 PerlIO_printf( Perl_debug_log, " -> %s",
3973                                     SvPV_nolen_const(mysv));
3974
3975                                 if ( noper_next ) {
3976                                   regprop(RExC_rx, mysv, noper_next, NULL);
3977                                   PerlIO_printf( Perl_debug_log,"\t=> %s\t",
3978                                     SvPV_nolen_const(mysv));
3979                                 }
3980                                 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d,tt==%s,nt==%s,nnt==%s)\n",
3981                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
3982                                    PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype]
3983                                 );
3984                             });
3985
3986                             /* Is noper a trieable nodetype that can be merged
3987                              * with the current trie (if there is one)? */
3988                             if ( noper_trietype
3989                                   &&
3990                                   (
3991                                         ( noper_trietype == NOTHING)
3992                                         || ( trietype == NOTHING )
3993                                         || ( trietype == noper_trietype )
3994                                   )
3995 #ifdef NOJUMPTRIE
3996                                   && noper_next == tail
3997 #endif
3998                                   && count < U16_MAX)
3999                             {
4000                                 /* Handle mergable triable node Either we are
4001                                  * the first node in a new trieable sequence,
4002                                  * in which case we do some bookkeeping,
4003                                  * otherwise we update the end pointer. */
4004                                 if ( !first ) {
4005                                     first = cur;
4006                                     if ( noper_trietype == NOTHING ) {
4007 #if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
4008                                         regnode * const noper_next = regnext( noper );
4009                                         U8 noper_next_type = (noper_next && noper_next!=tail) ? OP(noper_next) : 0;
4010                                         U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
4011 #endif
4012
4013                                         if ( noper_next_trietype ) {
4014                                             trietype = noper_next_trietype;
4015                                         } else if (noper_next_type)  {
4016                                             /* a NOTHING regop is 1 regop wide.
4017                                              * We need at least two for a trie
4018                                              * so we can't merge this in */
4019                                             first = NULL;
4020                                         }
4021                                     } else {
4022                                         trietype = noper_trietype;
4023                                     }
4024                                 } else {
4025                                     if ( trietype == NOTHING )
4026                                         trietype = noper_trietype;
4027                                     last = cur;
4028                                 }
4029                                 if (first)
4030                                     count++;
4031                             } /* end handle mergable triable node */
4032                             else {
4033                                 /* handle unmergable node -
4034                                  * noper may either be a triable node which can
4035                                  * not be tried together with the current trie,
4036                                  * or a non triable node */
4037                                 if ( last ) {
4038                                     /* If last is set and trietype is not
4039                                      * NOTHING then we have found at least two
4040                                      * triable branch sequences in a row of a
4041                                      * similar trietype so we can turn them
4042                                      * into a trie. If/when we allow NOTHING to
4043                                      * start a trie sequence this condition
4044                                      * will be required, and it isn't expensive
4045                                      * so we leave it in for now. */
4046                                     if ( trietype && trietype != NOTHING )
4047                                         make_trie( pRExC_state,
4048                                                 startbranch, first, cur, tail,
4049                                                 count, trietype, depth+1 );
4050                                     last = NULL; /* note: we clear/update
4051                                                     first, trietype etc below,
4052                                                     so we dont do it here */
4053                                 }
4054                                 if ( noper_trietype
4055 #ifdef NOJUMPTRIE
4056                                      && noper_next == tail
4057 #endif
4058                                 ){
4059                                     /* noper is triable, so we can start a new
4060                                      * trie sequence */
4061                                     count = 1;
4062                                     first = cur;
4063                                     trietype = noper_trietype;
4064                                 } else if (first) {
4065                                     /* if we already saw a first but the
4066                                      * current node is not triable then we have
4067                                      * to reset the first information. */
4068                                     count = 0;
4069                                     first = NULL;
4070                                     trietype = 0;
4071                                 }
4072                             } /* end handle unmergable node */
4073                         } /* loop over branches */
4074                         DEBUG_TRIE_COMPILE_r({
4075                             regprop(RExC_rx, mysv, cur, NULL);
4076                             PerlIO_printf( Perl_debug_log,
4077                               "%*s- %s (%d) <SCAN FINISHED>\n",
4078                               (int)depth * 2 + 2,
4079                               "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
4080
4081                         });
4082                         if ( last && trietype ) {
4083                             if ( trietype != NOTHING ) {
4084                                 /* the last branch of the sequence was part of
4085                                  * a trie, so we have to construct it here
4086                                  * outside of the loop */
4087                                 made= make_trie( pRExC_state, startbranch,
4088                                                  first, scan, tail, count,
4089                                                  trietype, depth+1 );
4090 #ifdef TRIE_STUDY_OPT
4091                                 if ( ((made == MADE_EXACT_TRIE &&
4092                                      startbranch == first)
4093                                      || ( first_non_open == first )) &&
4094                                      depth==0 ) {
4095                                     flags |= SCF_TRIE_RESTUDY;
4096                                     if ( startbranch == first
4097                                          && scan == tail )
4098                                     {
4099                                         RExC_seen &=~REG_TOP_LEVEL_BRANCHES_SEEN;
4100                                     }
4101                                 }
4102 #endif
4103                             } else {
4104                                 /* at this point we know whatever we have is a
4105                                  * NOTHING sequence/branch AND if 'startbranch'
4106                                  * is 'first' then we can turn the whole thing
4107                                  * into a NOTHING
4108                                  */
4109                                 if ( startbranch == first ) {
4110                                     regnode *opt;
4111                                     /* the entire thing is a NOTHING sequence,
4112                                      * something like this: (?:|) So we can
4113                                      * turn it into a plain NOTHING op. */
4114                                     DEBUG_TRIE_COMPILE_r({
4115                                         regprop(RExC_rx, mysv, cur, NULL);
4116                                         PerlIO_printf( Perl_debug_log,
4117                                           "%*s- %s (%d) <NOTHING BRANCH SEQUENCE>\n", (int)depth * 2 + 2,
4118                                           "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
4119
4120                                     });
4121                                     OP(startbranch)= NOTHING;
4122                                     NEXT_OFF(startbranch)= tail - startbranch;
4123                                     for ( opt= startbranch + 1; opt < tail ; opt++ )
4124                                         OP(opt)= OPTIMIZED;
4125                                 }
4126                             }
4127                         } /* end if ( last) */
4128                     } /* TRIE_MAXBUF is non zero */
4129
4130                 } /* do trie */
4131
4132             }
4133             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
4134                 scan = NEXTOPER(NEXTOPER(scan));
4135             } else                      /* single branch is optimized. */
4136                 scan = NEXTOPER(scan);
4137             continue;
4138         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
4139             scan_frame *newframe = NULL;
4140             I32 paren;
4141             regnode *start;
4142             regnode *end;
4143             U32 my_recursed_depth= recursed_depth;
4144
4145             if (OP(scan) != SUSPEND) {
4146                 /* set the pointer */
4147                 if (OP(scan) == GOSUB) {
4148                     paren = ARG(scan);
4149                     RExC_recurse[ARG2L(scan)] = scan;
4150                     start = RExC_open_parens[paren-1];
4151                     end   = RExC_close_parens[paren-1];
4152                 } else {
4153                     paren = 0;
4154                     start = RExC_rxi->program + 1;
4155                     end   = RExC_opend;
4156                 }
4157                 if (!recursed_depth
4158                     ||
4159                     !PAREN_TEST(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes), paren)
4160                 ) {
4161                     if (!recursed_depth) {
4162                         Zero(RExC_study_chunk_recursed, RExC_study_chunk_recursed_bytes, U8);
4163                     } else {
4164                         Copy(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes),
4165                              RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes),
4166                              RExC_study_chunk_recursed_bytes, U8);
4167                     }
4168                     /* we havent recursed into this paren yet, so recurse into it */
4169                     DEBUG_STUDYDATA("set:", data,depth);
4170                     PAREN_SET(RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes), paren);
4171                     my_recursed_depth= recursed_depth + 1;
4172                     Newx(newframe,1,scan_frame);
4173                 } else {
4174                     DEBUG_STUDYDATA("inf:", data,depth);
4175                     /* some form of infinite recursion, assume infinite length
4176                      * */
4177                     if (flags & SCF_DO_SUBSTR) {
4178                         scan_commit(pRExC_state, data, minlenp, is_inf);
4179                         data->longest = &(data->longest_float);
4180                     }
4181                     is_inf = is_inf_internal = 1;
4182                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4183                         ssc_anything(data->start_class);
4184                     flags &= ~SCF_DO_STCLASS;
4185                 }
4186             } else {
4187                 Newx(newframe,1,scan_frame);
4188                 paren = stopparen;
4189                 start = scan+2;
4190                 end = regnext(scan);
4191             }
4192             if (newframe) {
4193                 assert(start);
4194                 assert(end);
4195                 SAVEFREEPV(newframe);
4196                 newframe->next = regnext(scan);
4197                 newframe->last = last;
4198                 newframe->stop = stopparen;
4199                 newframe->prev = frame;
4200                 newframe->prev_recursed_depth = recursed_depth;
4201
4202                 DEBUG_STUDYDATA("frame-new:",data,depth);
4203                 DEBUG_PEEP("fnew", scan, depth);
4204
4205                 frame = newframe;
4206                 scan =  start;
4207                 stopparen = paren;
4208                 last = end;
4209                 depth = depth + 1;
4210                 recursed_depth= my_recursed_depth;
4211
4212                 continue;
4213             }
4214         }
4215         else if (OP(scan) == EXACT) {
4216             SSize_t l = STR_LEN(scan);
4217             UV uc;
4218             if (UTF) {
4219                 const U8 * const s = (U8*)STRING(scan);
4220                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
4221                 l = utf8_length(s, s + l);
4222             } else {
4223                 uc = *((U8*)STRING(scan));
4224             }
4225             min += l;
4226             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
4227                 /* The code below prefers earlier match for fixed
4228                    offset, later match for variable offset.  */
4229                 if (data->last_end == -1) { /* Update the start info. */
4230                     data->last_start_min = data->pos_min;
4231                     data->last_start_max = is_inf
4232                         ? SSize_t_MAX : data->pos_min + data->pos_delta;
4233                 }
4234                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
4235                 if (UTF)
4236                     SvUTF8_on(data->last_found);
4237                 {
4238                     SV * const sv = data->last_found;
4239                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4240                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
4241                     if (mg && mg->mg_len >= 0)
4242                         mg->mg_len += utf8_length((U8*)STRING(scan),
4243                                               (U8*)STRING(scan)+STR_LEN(scan));
4244                 }
4245                 data->last_end = data->pos_min + l;
4246                 data->pos_min += l; /* As in the first entry. */
4247                 data->flags &= ~SF_BEFORE_EOL;
4248             }
4249
4250             /* ANDing the code point leaves at most it, and not in locale, and
4251              * can't match null string */
4252             if (flags & SCF_DO_STCLASS_AND) {
4253                 ssc_cp_and(data->start_class, uc);
4254                 ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING;
4255                 ssc_clear_locale(data->start_class);
4256             }
4257             else if (flags & SCF_DO_STCLASS_OR) {
4258                 ssc_add_cp(data->start_class, uc);
4259                 ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4260
4261                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
4262                 ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING;
4263             }
4264             flags &= ~SCF_DO_STCLASS;
4265         }
4266         else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT!, so is
4267                                                      EXACTFish */
4268             SSize_t l = STR_LEN(scan);
4269             UV uc = *((U8*)STRING(scan));
4270             SV* EXACTF_invlist = _new_invlist(4); /* Start out big enough for 2
4271                                                      separate code points */
4272             const U8 * s = (U8*)STRING(scan);
4273
4274             /* Search for fixed substrings supports EXACT only. */
4275             if (flags & SCF_DO_SUBSTR) {
4276                 assert(data);
4277                 scan_commit(pRExC_state, data, minlenp, is_inf);
4278             }
4279             if (UTF) {
4280                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
4281                 l = utf8_length(s, s + l);
4282             }
4283             if (unfolded_multi_char) {
4284                 RExC_seen |= REG_UNFOLDED_MULTI_SEEN;
4285             }
4286             min += l - min_subtract;
4287             assert (min >= 0);
4288             delta += min_subtract;
4289             if (flags & SCF_DO_SUBSTR) {
4290                 data->pos_min += l - min_subtract;
4291                 if (data->pos_min < 0) {
4292                     data->pos_min = 0;
4293                 }
4294                 data->pos_delta += min_subtract;
4295                 if (min_subtract) {
4296                     data->longest = &(data->longest_float);
4297                 }
4298             }
4299
4300             if (OP(scan) != EXACTFL && flags & SCF_DO_STCLASS_AND) {
4301                 ssc_clear_locale(data->start_class);
4302             }
4303
4304             if (! UTF) {
4305
4306                 /* We punt and assume can match anything if the node begins
4307                  * with a multi-character fold.  Things are complicated.  For
4308                  * example, /ffi/i could match any of:
4309                  *  "\N{LATIN SMALL LIGATURE FFI}"
4310                  *  "\N{LATIN SMALL LIGATURE FF}I"
4311                  *  "F\N{LATIN SMALL LIGATURE FI}"
4312                  *  plus several other things; and making sure we have all the
4313                  *  possibilities is hard. */
4314                 if (is_MULTI_CHAR_FOLD_latin1_safe(s, s + STR_LEN(scan))) {
4315                     EXACTF_invlist =
4316                              _add_range_to_invlist(EXACTF_invlist, 0, UV_MAX);
4317                 }
4318                 else {
4319
4320                     /* Any Latin1 range character can potentially match any
4321                      * other depending on the locale */
4322                     if (OP(scan) == EXACTFL) {
4323                         _invlist_union(EXACTF_invlist, PL_Latin1,
4324                                                               &EXACTF_invlist);
4325                     }
4326                     else {
4327                         /* But otherwise, it matches at least itself.  We can
4328                          * quickly tell if it has a distinct fold, and if so,
4329                          * it matches that as well */
4330                         EXACTF_invlist = add_cp_to_invlist(EXACTF_invlist, uc);
4331                         if (IS_IN_SOME_FOLD_L1(uc)) {
4332                             EXACTF_invlist = add_cp_to_invlist(EXACTF_invlist,
4333                                                            PL_fold_latin1[uc]);
4334                         }
4335                     }
4336
4337                     /* Some characters match above-Latin1 ones under /i.  This
4338                      * is true of EXACTFL ones when the locale is UTF-8 */
4339                     if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(uc)
4340                         && (! isASCII(uc) || (OP(scan) != EXACTFA
4341                                             && OP(scan) != EXACTFA_NO_TRIE)))
4342                     {
4343                         add_above_Latin1_folds(pRExC_state,
4344                                                (U8) uc,
4345                                                &EXACTF_invlist);
4346                     }
4347                 }
4348             }
4349             else {  /* Pattern is UTF-8 */
4350                 U8 folded[UTF8_MAX_FOLD_CHAR_EXPAND * UTF8_MAXBYTES_CASE + 1] = { '\0' };
4351                 STRLEN foldlen = UTF8SKIP(s);
4352                 const U8* e = s + STR_LEN(scan);
4353                 SV** listp;
4354
4355                 /* The only code points that aren't folded in a UTF EXACTFish
4356                  * node are are the problematic ones in EXACTFL nodes */
4357                 if (OP(scan) == EXACTFL
4358                     && is_PROBLEMATIC_LOCALE_FOLDEDS_START_cp(uc))
4359                 {
4360                     /* We need to check for the possibility that this EXACTFL
4361                      * node begins with a multi-char fold.  Therefore we fold
4362                      * the first few characters of it so that we can make that
4363                      * check */
4364                     U8 *d = folded;
4365                     int i;
4366
4367                     for (i = 0; i < UTF8_MAX_FOLD_CHAR_EXPAND && s < e; i++) {
4368                         if (isASCII(*s)) {
4369                             *(d++) = (U8) toFOLD(*s);
4370                             s++;
4371                         }
4372                         else {
4373                             STRLEN len;
4374                             to_utf8_fold(s, d, &len);
4375                             d += len;
4376                             s += UTF8SKIP(s);
4377                         }
4378                     }
4379
4380                     /* And set up so the code below that looks in this folded
4381                      * buffer instead of the node's string */
4382                     e = d;
4383                     foldlen = UTF8SKIP(folded);
4384                     s = folded;
4385                 }
4386
4387                 /* When we reach here 's' points to the fold of the first
4388                  * character(s) of the node; and 'e' points to far enough along
4389                  * the folded string to be just past any possible multi-char
4390                  * fold. 'foldlen' is the length in bytes of the first
4391                  * character in 's'
4392                  *
4393                  * Unlike the non-UTF-8 case, the macro for determining if a
4394                  * string is a multi-char fold requires all the characters to
4395                  * already be folded.  This is because of all the complications
4396                  * if not.  Note that they are folded anyway, except in EXACTFL
4397                  * nodes.  Like the non-UTF case above, we punt if the node
4398                  * begins with a multi-char fold  */
4399
4400                 if (is_MULTI_CHAR_FOLD_utf8_safe(s, e)) {
4401                     EXACTF_invlist =
4402                              _add_range_to_invlist(EXACTF_invlist, 0, UV_MAX);
4403                 }
4404                 else {  /* Single char fold */
4405
4406                     /* It matches all the things that fold to it, which are
4407                      * found in PL_utf8_foldclosures (including itself) */
4408                     EXACTF_invlist = add_cp_to_invlist(EXACTF_invlist, uc);
4409                     if (! PL_utf8_foldclosures) {
4410                         _load_PL_utf8_foldclosures();
4411                     }
4412                     if ((listp = hv_fetch(PL_utf8_foldclosures,
4413                                         (char *) s, foldlen, FALSE)))
4414                     {
4415                         AV* list = (AV*) *listp;
4416                         IV k;
4417                         for (k = 0; k <= av_tindex(list); k++) {
4418                             SV** c_p = av_fetch(list, k, FALSE);
4419                             UV c;
4420                             assert(c_p);
4421
4422                             c = SvUV(*c_p);
4423
4424                             /* /aa doesn't allow folds between ASCII and non- */
4425                             if ((OP(scan) == EXACTFA || OP(scan) == EXACTFA_NO_TRIE)
4426                                 && isASCII(c) != isASCII(uc))
4427                             {
4428                                 continue;
4429                             }
4430
4431                             EXACTF_invlist = add_cp_to_invlist(EXACTF_invlist, c);
4432                         }
4433                     }
4434                 }
4435             }
4436             if (flags & SCF_DO_STCLASS_AND) {
4437                 ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING;
4438                 ANYOF_POSIXL_ZERO(data->start_class);
4439                 ssc_intersection(data->start_class, EXACTF_invlist, FALSE);
4440             }
4441             else if (flags & SCF_DO_STCLASS_OR) {
4442                 ssc_union(data->start_class, EXACTF_invlist, FALSE);
4443                 ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4444
4445                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
4446                 ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING;
4447             }
4448             flags &= ~SCF_DO_STCLASS;
4449             SvREFCNT_dec(EXACTF_invlist);
4450         }
4451         else if (REGNODE_VARIES(OP(scan))) {
4452             SSize_t mincount, maxcount, minnext, deltanext, pos_before = 0;
4453             I32 fl = 0, f = flags;
4454             regnode * const oscan = scan;
4455             regnode_ssc this_class;
4456             regnode_ssc *oclass = NULL;
4457             I32 next_is_eval = 0;
4458
4459             switch (PL_regkind[OP(scan)]) {
4460             case WHILEM:                /* End of (?:...)* . */
4461                 scan = NEXTOPER(scan);
4462                 goto finish;
4463             case PLUS:
4464                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
4465                     next = NEXTOPER(scan);
4466                     if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
4467                         mincount = 1;
4468                         maxcount = REG_INFTY;
4469                         next = regnext(scan);
4470                         scan = NEXTOPER(scan);
4471                         goto do_curly;
4472                     }
4473                 }
4474                 if (flags & SCF_DO_SUBSTR)
4475                     data->pos_min++;
4476                 min++;
4477                 /* FALLTHROUGH */
4478             case STAR:
4479                 if (flags & SCF_DO_STCLASS) {
4480                     mincount = 0;
4481                     maxcount = REG_INFTY;
4482                     next = regnext(scan);
4483                     scan = NEXTOPER(scan);
4484                     goto do_curly;
4485                 }
4486                 if (flags & SCF_DO_SUBSTR) {
4487                     scan_commit(pRExC_state, data, minlenp, is_inf);
4488                     /* Cannot extend fixed substrings */
4489                     data->longest = &(data->longest_float);
4490                 }
4491                 is_inf = is_inf_internal = 1;
4492                 scan = regnext(scan);
4493                 goto optimize_curly_tail;
4494             case CURLY:
4495                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
4496                     && (scan->flags == stopparen))
4497                 {
4498                     mincount = 1;
4499                     maxcount = 1;
4500                 } else {
4501                     mincount = ARG1(scan);
4502                     maxcount = ARG2(scan);
4503                 }
4504                 next = regnext(scan);
4505                 if (OP(scan) == CURLYX) {
4506                     I32 lp = (data ? *(data->last_closep) : 0);
4507                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
4508                 }
4509                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
4510                 next_is_eval = (OP(scan) == EVAL);
4511               do_curly:
4512                 if (flags & SCF_DO_SUBSTR) {
4513                     if (mincount == 0)
4514                         scan_commit(pRExC_state, data, minlenp, is_inf);
4515                     /* Cannot extend fixed substrings */
4516                     pos_before = data->pos_min;
4517                 }
4518                 if (data) {
4519                     fl = data->flags;
4520                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
4521                     if (is_inf)
4522                         data->flags |= SF_IS_INF;
4523                 }
4524                 if (flags & SCF_DO_STCLASS) {
4525                     ssc_init(pRExC_state, &this_class);
4526                     oclass = data->start_class;
4527                     data->start_class = &this_class;
4528                     f |= SCF_DO_STCLASS_AND;
4529                     f &= ~SCF_DO_STCLASS_OR;
4530                 }
4531                 /* Exclude from super-linear cache processing any {n,m}
4532                    regops for which the combination of input pos and regex
4533                    pos is not enough information to determine if a match
4534                    will be possible.
4535
4536                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
4537                    regex pos at the \s*, the prospects for a match depend not
4538                    only on the input position but also on how many (bar\s*)
4539                    repeats into the {4,8} we are. */
4540                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
4541                     f &= ~SCF_WHILEM_VISITED_POS;
4542
4543                 /* This will finish on WHILEM, setting scan, or on NULL: */
4544                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
4545                                   last, data, stopparen, recursed_depth, NULL,
4546                                   (mincount == 0
4547                                    ? (f & ~SCF_DO_SUBSTR)
4548                                    : f)
4549                                   ,depth+1);
4550
4551                 if (flags & SCF_DO_STCLASS)
4552                     data->start_class = oclass;
4553                 if (mincount == 0 || minnext == 0) {
4554                     if (flags & SCF_DO_STCLASS_OR) {
4555                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
4556                     }
4557                     else if (flags & SCF_DO_STCLASS_AND) {
4558                         /* Switch to OR mode: cache the old value of
4559                          * data->start_class */
4560                         INIT_AND_WITHP;
4561                         StructCopy(data->start_class, and_withp, regnode_ssc);
4562                         flags &= ~SCF_DO_STCLASS_AND;
4563                         StructCopy(&this_class, data->start_class, regnode_ssc);
4564                         flags |= SCF_DO_STCLASS_OR;
4565                         ANYOF_FLAGS(data->start_class) |= ANYOF_EMPTY_STRING;
4566                     }
4567                 } else {                /* Non-zero len */
4568                     if (flags & SCF_DO_STCLASS_OR) {
4569                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
4570                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4571                     }
4572                     else if (flags & SCF_DO_STCLASS_AND)
4573                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
4574                     flags &= ~SCF_DO_STCLASS;
4575                 }
4576                 if (!scan)              /* It was not CURLYX, but CURLY. */
4577                     scan = next;
4578                 if (!(flags & SCF_TRIE_DOING_RESTUDY)
4579                     /* ? quantifier ok, except for (?{ ... }) */
4580                     && (next_is_eval || !(mincount == 0 && maxcount == 1))
4581                     && (minnext == 0) && (deltanext == 0)
4582                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
4583                     && maxcount <= REG_INFTY/3) /* Complement check for big
4584                                                    count */
4585                 {
4586                     /* Fatal warnings may leak the regexp without this: */
4587                     SAVEFREESV(RExC_rx_sv);
4588                     ckWARNreg(RExC_parse,
4589                             "Quantifier unexpected on zero-length expression");
4590                     (void)ReREFCNT_inc(RExC_rx_sv);
4591                 }
4592
4593                 min += minnext * mincount;
4594                 is_inf_internal |= deltanext == SSize_t_MAX
4595                          || (maxcount == REG_INFTY && minnext + deltanext > 0);
4596                 is_inf |= is_inf_internal;
4597                 if (is_inf) {
4598                     delta = SSize_t_MAX;
4599                 } else {
4600                     delta += (minnext + deltanext) * maxcount
4601                              - minnext * mincount;
4602                 }
4603                 /* Try powerful optimization CURLYX => CURLYN. */
4604                 if (  OP(oscan) == CURLYX && data
4605                       && data->flags & SF_IN_PAR
4606                       && !(data->flags & SF_HAS_EVAL)
4607                       && !deltanext && minnext == 1 ) {
4608                     /* Try to optimize to CURLYN.  */
4609                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
4610                     regnode * const nxt1 = nxt;
4611 #ifdef DEBUGGING
4612                     regnode *nxt2;
4613 #endif
4614
4615                     /* Skip open. */
4616                     nxt = regnext(nxt);
4617                     if (!REGNODE_SIMPLE(OP(nxt))
4618                         && !(PL_regkind[OP(nxt)] == EXACT
4619                              && STR_LEN(nxt) == 1))
4620                         goto nogo;
4621 #ifdef DEBUGGING
4622                     nxt2 = nxt;
4623 #endif
4624                     nxt = regnext(nxt);
4625                     if (OP(nxt) != CLOSE)
4626                         goto nogo;
4627                     if (RExC_open_parens) {
4628                         RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
4629                         RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
4630                     }
4631                     /* Now we know that nxt2 is the only contents: */
4632                     oscan->flags = (U8)ARG(nxt);
4633                     OP(oscan) = CURLYN;
4634                     OP(nxt1) = NOTHING; /* was OPEN. */
4635
4636 #ifdef DEBUGGING
4637                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
4638                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
4639                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
4640                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
4641                     OP(nxt + 1) = OPTIMIZED; /* was count. */
4642                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
4643 #endif
4644                 }
4645               nogo:
4646
4647                 /* Try optimization CURLYX => CURLYM. */
4648                 if (  OP(oscan) == CURLYX && data
4649                       && !(data->flags & SF_HAS_PAR)
4650                       && !(data->flags & SF_HAS_EVAL)
4651                       && !deltanext     /* atom is fixed width */
4652                       && minnext != 0   /* CURLYM can't handle zero width */
4653
4654                          /* Nor characters whose fold at run-time may be
4655                           * multi-character */
4656                       && ! (RExC_seen & REG_UNFOLDED_MULTI_SEEN)
4657                 ) {
4658                     /* XXXX How to optimize if data == 0? */
4659                     /* Optimize to a simpler form.  */
4660                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
4661                     regnode *nxt2;
4662
4663                     OP(oscan) = CURLYM;
4664                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
4665                             && (OP(nxt2) != WHILEM))
4666                         nxt = nxt2;
4667                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
4668                     /* Need to optimize away parenths. */
4669                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
4670                         /* Set the parenth number.  */
4671                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
4672
4673                         oscan->flags = (U8)ARG(nxt);
4674                         if (RExC_open_parens) {
4675                             RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
4676                             RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
4677                         }
4678                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
4679                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
4680
4681 #ifdef DEBUGGING
4682                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
4683                         OP(nxt + 1) = OPTIMIZED; /* was count. */
4684                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
4685                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
4686 #endif
4687 #if 0
4688                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
4689                             regnode *nnxt = regnext(nxt1);
4690                             if (nnxt == nxt) {
4691                                 if (reg_off_by_arg[OP(nxt1)])
4692                                     ARG_SET(nxt1, nxt2 - nxt1);
4693                                 else if (nxt2 - nxt1 < U16_MAX)
4694                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
4695                                 else
4696                                     OP(nxt) = NOTHING;  /* Cannot beautify */
4697                             }
4698                             nxt1 = nnxt;
4699                         }
4700 #endif
4701                         /* Optimize again: */
4702                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
4703                                     NULL, stopparen, recursed_depth, NULL, 0,depth+1);
4704                     }
4705                     else
4706                         oscan->flags = 0;
4707                 }
4708                 else if ((OP(oscan) == CURLYX)
4709                          && (flags & SCF_WHILEM_VISITED_POS)
4710                          /* See the comment on a similar expression above.
4711                             However, this time it's not a subexpression
4712                             we care about, but the expression itself. */
4713                          && (maxcount == REG_INFTY)
4714                          && data && ++data->whilem_c < 16) {
4715                     /* This stays as CURLYX, we can put the count/of pair. */
4716                     /* Find WHILEM (as in regexec.c) */
4717                     regnode *nxt = oscan + NEXT_OFF(oscan);
4718
4719                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
4720                         nxt += ARG(nxt);
4721                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
4722                         | (RExC_whilem_seen << 4)); /* On WHILEM */
4723                 }
4724                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
4725                     pars++;
4726                 if (flags & SCF_DO_SUBSTR) {
4727                     SV *last_str = NULL;
4728                     STRLEN last_chrs = 0;
4729                     int counted = mincount != 0;
4730
4731                     if (data->last_end > 0 && mincount != 0) { /* Ends with a
4732                                                                   string. */
4733                         SSize_t b = pos_before >= data->last_start_min
4734                             ? pos_before : data->last_start_min;
4735                         STRLEN l;
4736                         const char * const s = SvPV_const(data->last_found, l);
4737                         SSize_t old = b - data->last_start_min;
4738
4739                         if (UTF)
4740                             old = utf8_hop((U8*)s, old) - (U8*)s;
4741                         l -= old;
4742                         /* Get the added string: */
4743                         last_str = newSVpvn_utf8(s  + old, l, UTF);
4744                         last_chrs = UTF ? utf8_length((U8*)(s + old),
4745                                             (U8*)(s + old + l)) : l;
4746                         if (deltanext == 0 && pos_before == b) {
4747                             /* What was added is a constant string */
4748                             if (mincount > 1) {
4749
4750                                 SvGROW(last_str, (mincount * l) + 1);
4751                                 repeatcpy(SvPVX(last_str) + l,
4752                                           SvPVX_const(last_str), l,
4753                                           mincount - 1);
4754                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
4755                                 /* Add additional parts. */
4756                                 SvCUR_set(data->last_found,
4757                                           SvCUR(data->last_found) - l);
4758                                 sv_catsv(data->last_found, last_str);
4759                                 {
4760                                     SV * sv = data->last_found;
4761                                     MAGIC *mg =
4762                                         SvUTF8(sv) && SvMAGICAL(sv) ?
4763                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
4764                                     if (mg && mg->mg_len >= 0)
4765                                         mg->mg_len += last_chrs * (mincount-1);
4766                                 }
4767                                 last_chrs *= mincount;
4768                                 data->last_end += l * (mincount - 1);
4769                             }
4770                         } else {
4771                             /* start offset must point into the last copy */
4772                             data->last_start_min += minnext * (mincount - 1);
4773                             data->last_start_max += is_inf ? SSize_t_MAX
4774                                 : (maxcount - 1) * (minnext + data->pos_delta);
4775                         }
4776                     }
4777                     /* It is counted once already... */
4778                     data->pos_min += minnext * (mincount - counted);
4779 #if 0
4780 PerlIO_printf(Perl_debug_log, "counted=%"UVuf" deltanext=%"UVuf
4781                               " SSize_t_MAX=%"UVuf" minnext=%"UVuf
4782                               " maxcount=%"UVuf" mincount=%"UVuf"\n",
4783     (UV)counted, (UV)deltanext, (UV)SSize_t_MAX, (UV)minnext, (UV)maxcount,
4784     (UV)mincount);
4785 if (deltanext != SSize_t_MAX)
4786 PerlIO_printf(Perl_debug_log, "LHS=%"UVuf" RHS=%"UVuf"\n",
4787     (UV)(-counted * deltanext + (minnext + deltanext) * maxcount
4788           - minnext * mincount), (UV)(SSize_t_MAX - data->pos_delta));
4789 #endif
4790                     if (deltanext == SSize_t_MAX
4791                         || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= SSize_t_MAX - data->pos_delta)
4792                         data->pos_delta = SSize_t_MAX;
4793                     else
4794                         data->pos_delta += - counted * deltanext +
4795                         (minnext + deltanext) * maxcount - minnext * mincount;
4796                     if (mincount != maxcount) {
4797                          /* Cannot extend fixed substrings found inside
4798                             the group.  */
4799                         scan_commit(pRExC_state, data, minlenp, is_inf);
4800                         if (mincount && last_str) {
4801                             SV * const sv = data->last_found;
4802                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4803                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
4804
4805                             if (mg)
4806                                 mg->mg_len = -1;
4807                             sv_setsv(sv, last_str);
4808                             data->last_end = data->pos_min;
4809                             data->last_start_min = data->pos_min - last_chrs;
4810                             data->last_start_max = is_inf
4811                                 ? SSize_t_MAX
4812                                 : data->pos_min + data->pos_delta - last_chrs;
4813                         }
4814                         data->longest = &(data->longest_float);
4815                     }
4816                     SvREFCNT_dec(last_str);
4817                 }
4818                 if (data && (fl & SF_HAS_EVAL))
4819                     data->flags |= SF_HAS_EVAL;
4820               optimize_curly_tail:
4821                 if (OP(oscan) != CURLYX) {
4822                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
4823                            && NEXT_OFF(next))
4824                         NEXT_OFF(oscan) += NEXT_OFF(next);
4825                 }
4826                 continue;
4827
4828             default:
4829 #ifdef DEBUGGING
4830                 Perl_croak(aTHX_ "panic: unexpected varying REx opcode %d",
4831                                                                     OP(scan));
4832 #endif
4833             case REF:
4834             case CLUMP:
4835                 if (flags & SCF_DO_SUBSTR) {
4836                     /* Cannot expect anything... */
4837                     scan_commit(pRExC_state, data, minlenp, is_inf);
4838                     data->longest = &(data->longest_float);
4839                 }
4840                 is_inf = is_inf_internal = 1;
4841                 if (flags & SCF_DO_STCLASS_OR) {
4842                     if (OP(scan) == CLUMP) {
4843                         /* Actually is any start char, but very few code points
4844                          * aren't start characters */
4845                         ssc_match_all_cp(data->start_class);
4846                     }
4847                     else {
4848                         ssc_anything(data->start_class);
4849                     }
4850                 }
4851                 flags &= ~SCF_DO_STCLASS;
4852                 break;
4853             }
4854         }
4855         else if (OP(scan) == LNBREAK) {
4856             if (flags & SCF_DO_STCLASS) {
4857                 if (flags & SCF_DO_STCLASS_AND) {
4858                     ssc_intersection(data->start_class,
4859                                     PL_XPosix_ptrs[_CC_VERTSPACE], FALSE);
4860                     ssc_clear_locale(data->start_class);
4861                     ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING;
4862                 }
4863                 else if (flags & SCF_DO_STCLASS_OR) {
4864                     ssc_union(data->start_class,
4865                               PL_XPosix_ptrs[_CC_VERTSPACE],
4866                               FALSE);
4867                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4868
4869                     /* See commit msg for
4870                      * 749e076fceedeb708a624933726e7989f2302f6a */
4871                     ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING;
4872                 }
4873                 flags &= ~SCF_DO_STCLASS;
4874             }
4875             min++;
4876             delta++;    /* Because of the 2 char string cr-lf */
4877             if (flags & SCF_DO_SUBSTR) {
4878                 /* Cannot expect anything... */
4879                 scan_commit(pRExC_state, data, minlenp, is_inf);
4880                 data->pos_min += 1;
4881                 data->pos_delta += 1;
4882                 data->longest = &(data->longest_float);
4883             }
4884         }
4885         else if (REGNODE_SIMPLE(OP(scan))) {
4886
4887             if (flags & SCF_DO_SUBSTR) {
4888                 scan_commit(pRExC_state, data, minlenp, is_inf);
4889                 data->pos_min++;
4890             }
4891             min++;
4892             if (flags & SCF_DO_STCLASS) {
4893                 bool invert = 0;
4894                 SV* my_invlist = sv_2mortal(_new_invlist(0));
4895                 U8 namedclass;
4896
4897                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
4898                 ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING;
4899
4900                 /* Some of the logic below assumes that switching
4901                    locale on will only add false positives. */
4902                 switch (OP(scan)) {
4903
4904                 default:
4905 #ifdef DEBUGGING
4906                    Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d",
4907                                                                      OP(scan));
4908 #endif
4909                 case CANY:
4910                 case SANY:
4911                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4912                         ssc_match_all_cp(data->start_class);
4913                     break;
4914
4915                 case REG_ANY:
4916                     {
4917                         SV* REG_ANY_invlist = _new_invlist(2);
4918                         REG_ANY_invlist = add_cp_to_invlist(REG_ANY_invlist,
4919                                                             '\n');
4920                         if (flags & SCF_DO_STCLASS_OR) {
4921                             ssc_union(data->start_class,
4922                                       REG_ANY_invlist,
4923                                       TRUE /* TRUE => invert, hence all but \n
4924                                             */
4925                                       );
4926                         }
4927                         else if (flags & SCF_DO_STCLASS_AND) {
4928                             ssc_intersection(data->start_class,
4929                                              REG_ANY_invlist,
4930                                              TRUE  /* TRUE => invert */
4931                                              );
4932                             ssc_clear_locale(data->start_class);
4933                         }
4934                         SvREFCNT_dec_NN(REG_ANY_invlist);
4935                     }
4936                     break;
4937
4938                 case ANYOF:
4939                     if (flags & SCF_DO_STCLASS_AND)
4940                         ssc_and(pRExC_state, data->start_class,
4941                                 (regnode_charclass *) scan);
4942                     else
4943                         ssc_or(pRExC_state, data->start_class,
4944                                                           (regnode_charclass *) scan);
4945                     break;
4946
4947                 case NPOSIXL:
4948                     invert = 1;
4949                     /* FALLTHROUGH */
4950
4951                 case POSIXL:
4952                     namedclass = classnum_to_namedclass(FLAGS(scan)) + invert;
4953                     if (flags & SCF_DO_STCLASS_AND) {
4954                         bool was_there = cBOOL(
4955                                           ANYOF_POSIXL_TEST(data->start_class,
4956                                                                  namedclass));
4957                         ANYOF_POSIXL_ZERO(data->start_class);
4958                         if (was_there) {    /* Do an AND */
4959                             ANYOF_POSIXL_SET(data->start_class, namedclass);
4960                         }
4961                         /* No individual code points can now match */
4962                         data->start_class->invlist
4963                                                 = sv_2mortal(_new_invlist(0));
4964                     }
4965                     else {
4966                         int complement = namedclass + ((invert) ? -1 : 1);
4967
4968                         assert(flags & SCF_DO_STCLASS_OR);
4969
4970                         /* If the complement of this class was already there,
4971                          * the result is that they match all code points,
4972                          * (\d + \D == everything).  Remove the classes from
4973                          * future consideration.  Locale is not relevant in
4974                          * this case */
4975                         if (ANYOF_POSIXL_TEST(data->start_class, complement)) {
4976                             ssc_match_all_cp(data->start_class);
4977                             ANYOF_POSIXL_CLEAR(data->start_class, namedclass);
4978                             ANYOF_POSIXL_CLEAR(data->start_class, complement);
4979                         }
4980                         else {  /* The usual case; just add this class to the
4981                                    existing set */
4982                             ANYOF_POSIXL_SET(data->start_class, namedclass);
4983                         }
4984                     }
4985                     break;
4986
4987                 case NPOSIXA:   /* For these, we always know the exact set of
4988                                    what's matched */
4989                     invert = 1;
4990                     /* FALLTHROUGH */
4991                 case POSIXA:
4992                     if (FLAGS(scan) == _CC_ASCII) {
4993                         my_invlist = PL_XPosix_ptrs[_CC_ASCII];
4994                     }
4995                     else {
4996                         _invlist_intersection(PL_XPosix_ptrs[FLAGS(scan)],
4997                                               PL_XPosix_ptrs[_CC_ASCII],
4998                                               &my_invlist);
4999                     }
5000                     goto join_posix;
5001
5002                 case NPOSIXD:
5003                 case NPOSIXU:
5004                     invert = 1;
5005                     /* FALLTHROUGH */
5006                 case POSIXD:
5007                 case POSIXU:
5008                     my_invlist = invlist_clone(PL_XPosix_ptrs[FLAGS(scan)]);
5009
5010                     /* NPOSIXD matches all upper Latin1 code points unless the
5011                      * target string being matched is UTF-8, which is
5012                      * unknowable until match time.  Since we are going to
5013                      * invert, we want to get rid of all of them so that the
5014                      * inversion will match all */
5015                     if (OP(scan) == NPOSIXD) {
5016                         _invlist_subtract(my_invlist, PL_UpperLatin1,
5017                                           &my_invlist);
5018                     }
5019
5020                   join_posix:
5021
5022                     if (flags & SCF_DO_STCLASS_AND) {
5023                         ssc_intersection(data->start_class, my_invlist, invert);
5024                         ssc_clear_locale(data->start_class);
5025                     }
5026                     else {
5027                         assert(flags & SCF_DO_STCLASS_OR);
5028                         ssc_union(data->start_class, my_invlist, invert);
5029                     }
5030                 }
5031                 if (flags & SCF_DO_STCLASS_OR)
5032                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5033                 flags &= ~SCF_DO_STCLASS;
5034             }
5035         }
5036         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
5037             data->flags |= (OP(scan) == MEOL
5038                             ? SF_BEFORE_MEOL
5039                             : SF_BEFORE_SEOL);
5040             scan_commit(pRExC_state, data, minlenp, is_inf);
5041
5042         }
5043         else if (  PL_regkind[OP(scan)] == BRANCHJ
5044                  /* Lookbehind, or need to calculate parens/evals/stclass: */
5045                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
5046                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
5047             if ( OP(scan) == UNLESSM &&
5048                  scan->flags == 0 &&
5049                  OP(NEXTOPER(NEXTOPER(scan))) == NOTHING &&
5050                  OP(regnext(NEXTOPER(NEXTOPER(scan)))) == SUCCEED
5051             ) {
5052                 regnode *opt;
5053                 regnode *upto= regnext(scan);
5054                 DEBUG_PARSE_r({
5055                     SV * const mysv_val=sv_newmortal();
5056                     DEBUG_STUDYDATA("OPFAIL",data,depth);
5057
5058                     /*DEBUG_PARSE_MSG("opfail");*/
5059                     regprop(RExC_rx, mysv_val, upto, NULL);
5060                     PerlIO_printf(Perl_debug_log,
5061                         "~ replace with OPFAIL pointed at %s (%"IVdf") offset %"IVdf"\n",
5062                         SvPV_nolen_const(mysv_val),
5063                         (IV)REG_NODE_NUM(upto),
5064                         (IV)(upto - scan)
5065                     );
5066                 });
5067                 OP(scan) = OPFAIL;
5068                 NEXT_OFF(scan) = upto - scan;
5069                 for (opt= scan + 1; opt < upto ; opt++)
5070                     OP(opt) = OPTIMIZED;
5071                 scan= upto;
5072                 continue;
5073             }
5074             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5075                 || OP(scan) == UNLESSM )
5076             {
5077                 /* Negative Lookahead/lookbehind
5078                    In this case we can't do fixed string optimisation.
5079                 */
5080
5081                 SSize_t deltanext, minnext, fake = 0;
5082                 regnode *nscan;
5083                 regnode_ssc intrnl;
5084                 int f = 0;
5085
5086                 data_fake.flags = 0;
5087                 if (data) {
5088                     data_fake.whilem_c = data->whilem_c;
5089                     data_fake.last_closep = data->last_closep;
5090                 }
5091                 else
5092                     data_fake.last_closep = &fake;
5093                 data_fake.pos_delta = delta;
5094                 if ( flags & SCF_DO_STCLASS && !scan->flags
5095                      && OP(scan) == IFMATCH ) { /* Lookahead */
5096                     ssc_init(pRExC_state, &intrnl);
5097                     data_fake.start_class = &intrnl;
5098                     f |= SCF_DO_STCLASS_AND;
5099                 }
5100                 if (flags & SCF_WHILEM_VISITED_POS)
5101                     f |= SCF_WHILEM_VISITED_POS;
5102                 next = regnext(scan);
5103                 nscan = NEXTOPER(NEXTOPER(scan));
5104                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
5105                                       last, &data_fake, stopparen,
5106                                       recursed_depth, NULL, f, depth+1);
5107                 if (scan->flags) {
5108                     if (deltanext) {
5109                         FAIL("Variable length lookbehind not implemented");
5110                     }
5111                     else if (minnext > (I32)U8_MAX) {
5112                         FAIL2("Lookbehind longer than %"UVuf" not implemented",
5113                               (UV)U8_MAX);
5114                     }
5115                     scan->flags = (U8)minnext;
5116                 }
5117                 if (data) {
5118                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5119                         pars++;
5120                     if (data_fake.flags & SF_HAS_EVAL)
5121                         data->flags |= SF_HAS_EVAL;
5122                     data->whilem_c = data_fake.whilem_c;
5123                 }
5124                 if (f & SCF_DO_STCLASS_AND) {
5125                     if (flags & SCF_DO_STCLASS_OR) {
5126                         /* OR before, AND after: ideally we would recurse with
5127                          * data_fake to get the AND applied by study of the
5128                          * remainder of the pattern, and then derecurse;
5129                          * *** HACK *** for now just treat as "no information".
5130                          * See [perl #56690].
5131                          */
5132                         ssc_init(pRExC_state, data->start_class);
5133                     }  else {
5134                         /* AND before and after: combine and continue */
5135                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5136                     }
5137                 }
5138             }
5139 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5140             else {
5141                 /* Positive Lookahead/lookbehind
5142                    In this case we can do fixed string optimisation,
5143                    but we must be careful about it. Note in the case of
5144                    lookbehind the positions will be offset by the minimum
5145                    length of the pattern, something we won't know about
5146                    until after the recurse.
5147                 */
5148                 SSize_t deltanext, fake = 0;
5149                 regnode *nscan;
5150                 regnode_ssc intrnl;
5151                 int f = 0;
5152                 /* We use SAVEFREEPV so that when the full compile
5153                     is finished perl will clean up the allocated
5154                     minlens when it's all done. This way we don't
5155                     have to worry about freeing them when we know
5156                     they wont be used, which would be a pain.
5157                  */
5158                 SSize_t *minnextp;
5159                 Newx( minnextp, 1, SSize_t );
5160                 SAVEFREEPV(minnextp);
5161
5162                 if (data) {
5163                     StructCopy(data, &data_fake, scan_data_t);
5164                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
5165                         f |= SCF_DO_SUBSTR;
5166                         if (scan->flags)
5167                             scan_commit(pRExC_state, &data_fake, minlenp, is_inf);
5168                         data_fake.last_found=newSVsv(data->last_found);
5169                     }
5170                 }
5171                 else
5172                     data_fake.last_closep = &fake;
5173                 data_fake.flags = 0;
5174                 data_fake.pos_delta = delta;
5175                 if (is_inf)
5176                     data_fake.flags |= SF_IS_INF;
5177                 if ( flags & SCF_DO_STCLASS && !scan->flags
5178                      && OP(scan) == IFMATCH ) { /* Lookahead */
5179                     ssc_init(pRExC_state, &intrnl);
5180                     data_fake.start_class = &intrnl;
5181                     f |= SCF_DO_STCLASS_AND;
5182                 }
5183                 if (flags & SCF_WHILEM_VISITED_POS)
5184                     f |= SCF_WHILEM_VISITED_POS;
5185                 next = regnext(scan);
5186                 nscan = NEXTOPER(NEXTOPER(scan));
5187
5188                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp,
5189                                         &deltanext, last, &data_fake,
5190                                         stopparen, recursed_depth, NULL,
5191                                         f,depth+1);
5192                 if (scan->flags) {
5193                     if (deltanext) {
5194                         FAIL("Variable length lookbehind not implemented");
5195                     }
5196                     else if (*minnextp > (I32)U8_MAX) {
5197                         FAIL2("Lookbehind longer than %"UVuf" not implemented",
5198                               (UV)U8_MAX);
5199                     }
5200                     scan->flags = (U8)*minnextp;
5201                 }
5202
5203                 *minnextp += min;
5204
5205                 if (f & SCF_DO_STCLASS_AND) {
5206                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5207                 }
5208                 if (data) {
5209                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5210                         pars++;
5211                     if (data_fake.flags & SF_HAS_EVAL)
5212                         data->flags |= SF_HAS_EVAL;
5213                     data->whilem_c = data_fake.whilem_c;
5214                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
5215                         if (RExC_rx->minlen<*minnextp)
5216                             RExC_rx->minlen=*minnextp;
5217                         scan_commit(pRExC_state, &data_fake, minnextp, is_inf);
5218                         SvREFCNT_dec_NN(data_fake.last_found);
5219
5220                         if ( data_fake.minlen_fixed != minlenp )
5221                         {
5222                             data->offset_fixed= data_fake.offset_fixed;
5223                             data->minlen_fixed= data_fake.minlen_fixed;
5224                             data->lookbehind_fixed+= scan->flags;
5225                         }
5226                         if ( data_fake.minlen_float != minlenp )
5227                         {
5228                             data->minlen_float= data_fake.minlen_float;
5229                             data->offset_float_min=data_fake.offset_float_min;
5230                             data->offset_float_max=data_fake.offset_float_max;
5231                             data->lookbehind_float+= scan->flags;
5232                         }
5233                     }
5234                 }
5235             }
5236 #endif
5237         }
5238         else if (OP(scan) == OPEN) {
5239             if (stopparen != (I32)ARG(scan))
5240                 pars++;
5241         }
5242         else if (OP(scan) == CLOSE) {
5243             if (stopparen == (I32)ARG(scan)) {
5244                 break;
5245             }
5246             if ((I32)ARG(scan) == is_par) {
5247                 next = regnext(scan);
5248
5249                 if ( next && (OP(next) != WHILEM) && next < last)
5250                     is_par = 0;         /* Disable optimization */
5251             }
5252             if (data)
5253                 *(data->last_closep) = ARG(scan);
5254         }
5255         else if (OP(scan) == EVAL) {
5256                 if (data)
5257                     data->flags |= SF_HAS_EVAL;
5258         }
5259         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
5260             if (flags & SCF_DO_SUBSTR) {
5261                 scan_commit(pRExC_state, data, minlenp, is_inf);
5262                 flags &= ~SCF_DO_SUBSTR;
5263             }
5264             if (data && OP(scan)==ACCEPT) {
5265                 data->flags |= SCF_SEEN_ACCEPT;
5266                 if (stopmin > min)
5267                     stopmin = min;
5268             }
5269         }
5270         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
5271         {
5272                 if (flags & SCF_DO_SUBSTR) {
5273                     scan_commit(pRExC_state, data, minlenp, is_inf);
5274                     data->longest = &(data->longest_float);
5275                 }
5276                 is_inf = is_inf_internal = 1;
5277                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5278                     ssc_anything(data->start_class);
5279                 flags &= ~SCF_DO_STCLASS;
5280         }
5281         else if (OP(scan) == GPOS) {
5282             if (!(RExC_rx->intflags & PREGf_GPOS_FLOAT) &&
5283                 !(delta || is_inf || (data && data->pos_delta)))
5284             {
5285                 if (!(RExC_rx->intflags & PREGf_ANCH) && (flags & SCF_DO_SUBSTR))
5286                     RExC_rx->intflags |= PREGf_ANCH_GPOS;
5287                 if (RExC_rx->gofs < (STRLEN)min)
5288                     RExC_rx->gofs = min;
5289             } else {
5290                 RExC_rx->intflags |= PREGf_GPOS_FLOAT;
5291                 RExC_rx->gofs = 0;
5292             }
5293         }
5294 #ifdef TRIE_STUDY_OPT
5295 #ifdef FULL_TRIE_STUDY
5296         else if (PL_regkind[OP(scan)] == TRIE) {
5297             /* NOTE - There is similar code to this block above for handling
5298                BRANCH nodes on the initial study.  If you change stuff here
5299                check there too. */
5300             regnode *trie_node= scan;
5301             regnode *tail= regnext(scan);
5302             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
5303             SSize_t max1 = 0, min1 = SSize_t_MAX;
5304             regnode_ssc accum;
5305
5306             if (flags & SCF_DO_SUBSTR) { /* XXXX Add !SUSPEND? */
5307                 /* Cannot merge strings after this. */
5308                 scan_commit(pRExC_state, data, minlenp, is_inf);
5309             }
5310             if (flags & SCF_DO_STCLASS)
5311                 ssc_init_zero(pRExC_state, &accum);
5312
5313             if (!trie->jump) {
5314                 min1= trie->minlen;
5315                 max1= trie->maxlen;
5316             } else {
5317                 const regnode *nextbranch= NULL;
5318                 U32 word;
5319
5320                 for ( word=1 ; word <= trie->wordcount ; word++)
5321                 {
5322                     SSize_t deltanext=0, minnext=0, f = 0, fake;
5323                     regnode_ssc this_class;
5324
5325                     data_fake.flags = 0;
5326                     if (data) {
5327                         data_fake.whilem_c = data->whilem_c;
5328                         data_fake.last_closep = data->last_closep;
5329                     }
5330                     else
5331                         data_fake.last_closep = &fake;
5332                     data_fake.pos_delta = delta;
5333                     if (flags & SCF_DO_STCLASS) {
5334                         ssc_init(pRExC_state, &this_class);
5335                         data_fake.start_class = &this_class;
5336                         f = SCF_DO_STCLASS_AND;
5337                     }
5338                     if (flags & SCF_WHILEM_VISITED_POS)
5339                         f |= SCF_WHILEM_VISITED_POS;
5340
5341                     if (trie->jump[word]) {
5342                         if (!nextbranch)
5343                             nextbranch = trie_node + trie->jump[0];
5344                         scan= trie_node + trie->jump[word];
5345                         /* We go from the jump point to the branch that follows
5346                            it. Note this means we need the vestigal unused
5347                            branches even though they arent otherwise used. */
5348                         minnext = study_chunk(pRExC_state, &scan, minlenp,
5349                             &deltanext, (regnode *)nextbranch, &data_fake,
5350                             stopparen, recursed_depth, NULL, f,depth+1);
5351                     }
5352                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
5353                         nextbranch= regnext((regnode*)nextbranch);
5354
5355                     if (min1 > (SSize_t)(minnext + trie->minlen))
5356                         min1 = minnext + trie->minlen;
5357                     if (deltanext == SSize_t_MAX) {
5358                         is_inf = is_inf_internal = 1;
5359                         max1 = SSize_t_MAX;
5360                     } else if (max1 < (SSize_t)(minnext + deltanext + trie->maxlen))
5361                         max1 = minnext + deltanext + trie->maxlen;
5362
5363                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5364                         pars++;
5365                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
5366                         if ( stopmin > min + min1)
5367                             stopmin = min + min1;
5368                         flags &= ~SCF_DO_SUBSTR;
5369                         if (data)
5370                             data->flags |= SCF_SEEN_ACCEPT;
5371                     }
5372                     if (data) {
5373                         if (data_fake.flags & SF_HAS_EVAL)
5374                             data->flags |= SF_HAS_EVAL;
5375                         data->whilem_c = data_fake.whilem_c;
5376                     }
5377                     if (flags & SCF_DO_STCLASS)
5378                         ssc_or(pRExC_state, &accum, (regnode_charclass *) &this_class);
5379                 }
5380             }
5381             if (flags & SCF_DO_SUBSTR) {
5382                 data->pos_min += min1;
5383                 data->pos_delta += max1 - min1;
5384                 if (max1 != min1 || is_inf)
5385                     data->longest = &(data->longest_float);
5386             }
5387             min += min1;
5388             delta += max1 - min1;
5389             if (flags & SCF_DO_STCLASS_OR) {
5390                 ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &accum);
5391                 if (min1) {
5392                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5393                     flags &= ~SCF_DO_STCLASS;
5394                 }
5395             }
5396             else if (flags & SCF_DO_STCLASS_AND) {
5397                 if (min1) {
5398                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
5399                     flags &= ~SCF_DO_STCLASS;
5400                 }
5401                 else {
5402                     /* Switch to OR mode: cache the old value of
5403                      * data->start_class */
5404                     INIT_AND_WITHP;
5405                     StructCopy(data->start_class, and_withp, regnode_ssc);
5406                     flags &= ~SCF_DO_STCLASS_AND;
5407                     StructCopy(&accum, data->start_class, regnode_ssc);
5408                     flags |= SCF_DO_STCLASS_OR;
5409                 }
5410             }
5411             scan= tail;
5412             continue;
5413         }
5414 #else
5415         else if (PL_regkind[OP(scan)] == TRIE) {
5416             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
5417             U8*bang=NULL;
5418
5419             min += trie->minlen;
5420             delta += (trie->maxlen - trie->minlen);
5421             flags &= ~SCF_DO_STCLASS; /* xxx */
5422             if (flags & SCF_DO_SUBSTR) {
5423                 /* Cannot expect anything... */
5424                 scan_commit(pRExC_state, data, minlenp, is_inf);
5425                 data->pos_min += trie->minlen;
5426                 data->pos_delta += (trie->maxlen - trie->minlen);
5427                 if (trie->maxlen != trie->minlen)
5428                     data->longest = &(data->longest_float);
5429             }
5430             if (trie->jump) /* no more substrings -- for now /grr*/
5431                flags &= ~SCF_DO_SUBSTR;
5432         }
5433 #endif /* old or new */
5434 #endif /* TRIE_STUDY_OPT */
5435
5436         /* Else: zero-length, ignore. */
5437         scan = regnext(scan);
5438     }
5439     /* If we are exiting a recursion we can unset its recursed bit
5440      * and allow ourselves to enter it again - no danger of an
5441      * infinite loop there.
5442     if (stopparen > -1 && recursed) {
5443         DEBUG_STUDYDATA("unset:", data,depth);
5444         PAREN_UNSET( recursed, stopparen);
5445     }
5446     */
5447     if (frame) {
5448         DEBUG_STUDYDATA("frame-end:",data,depth);
5449         DEBUG_PEEP("fend", scan, depth);
5450         /* restore previous context */
5451         last = frame->last;
5452         scan = frame->next;
5453         stopparen = frame->stop;
5454         recursed_depth = frame->prev_recursed_depth;
5455         depth = depth - 1;
5456
5457         frame = frame->prev;
5458         goto fake_study_recurse;
5459     }
5460
5461   finish:
5462     assert(!frame);
5463     DEBUG_STUDYDATA("pre-fin:",data,depth);
5464
5465     *scanp = scan;
5466     *deltap = is_inf_internal ? SSize_t_MAX : delta;
5467
5468     if (flags & SCF_DO_SUBSTR && is_inf)
5469         data->pos_delta = SSize_t_MAX - data->pos_min;
5470     if (is_par > (I32)U8_MAX)
5471         is_par = 0;
5472     if (is_par && pars==1 && data) {
5473         data->flags |= SF_IN_PAR;
5474         data->flags &= ~SF_HAS_PAR;
5475     }
5476     else if (pars && data) {
5477         data->flags |= SF_HAS_PAR;
5478         data->flags &= ~SF_IN_PAR;
5479     }
5480     if (flags & SCF_DO_STCLASS_OR)
5481         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5482     if (flags & SCF_TRIE_RESTUDY)
5483         data->flags |=  SCF_TRIE_RESTUDY;
5484
5485     DEBUG_STUDYDATA("post-fin:",data,depth);
5486
5487     {
5488         SSize_t final_minlen= min < stopmin ? min : stopmin;
5489
5490         if (!(RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) && (RExC_maxlen < final_minlen + delta)) {
5491             RExC_maxlen = final_minlen + delta;
5492         }
5493         return final_minlen;
5494     }
5495     /* not-reached */
5496 }
5497
5498 STATIC U32
5499 S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n)
5500 {
5501     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
5502
5503     PERL_ARGS_ASSERT_ADD_DATA;
5504
5505     Renewc(RExC_rxi->data,
5506            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
5507            char, struct reg_data);
5508     if(count)
5509         Renew(RExC_rxi->data->what, count + n, U8);
5510     else
5511         Newx(RExC_rxi->data->what, n, U8);
5512     RExC_rxi->data->count = count + n;
5513     Copy(s, RExC_rxi->data->what + count, n, U8);
5514     return count;
5515 }
5516
5517 /*XXX: todo make this not included in a non debugging perl, but appears to be
5518  * used anyway there, in 'use re' */
5519 #ifndef PERL_IN_XSUB_RE
5520 void
5521 Perl_reginitcolors(pTHX)
5522 {
5523     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
5524     if (s) {
5525         char *t = savepv(s);
5526         int i = 0;
5527         PL_colors[0] = t;
5528         while (++i < 6) {
5529             t = strchr(t, '\t');
5530             if (t) {
5531                 *t = '\0';
5532                 PL_colors[i] = ++t;
5533             }
5534             else
5535                 PL_colors[i] = t = (char *)"";
5536         }
5537     } else {
5538         int i = 0;
5539         while (i < 6)
5540             PL_colors[i++] = (char *)"";
5541     }
5542     PL_colorset = 1;
5543 }
5544 #endif
5545
5546
5547 #ifdef TRIE_STUDY_OPT
5548 #define CHECK_RESTUDY_GOTO_butfirst(dOsomething)            \
5549     STMT_START {                                            \
5550         if (                                                \
5551               (data.flags & SCF_TRIE_RESTUDY)               \
5552               && ! restudied++                              \
5553         ) {                                                 \
5554             dOsomething;                                    \
5555             goto reStudy;                                   \
5556         }                                                   \
5557     } STMT_END
5558 #else
5559 #define CHECK_RESTUDY_GOTO_butfirst
5560 #endif
5561
5562 /*
5563  * pregcomp - compile a regular expression into internal code
5564  *
5565  * Decides which engine's compiler to call based on the hint currently in
5566  * scope
5567  */
5568
5569 #ifndef PERL_IN_XSUB_RE
5570
5571 /* return the currently in-scope regex engine (or the default if none)  */
5572
5573 regexp_engine const *
5574 Perl_current_re_engine(pTHX)
5575 {
5576     if (IN_PERL_COMPILETIME) {
5577         HV * const table = GvHV(PL_hintgv);
5578         SV **ptr;
5579
5580         if (!table || !(PL_hints & HINT_LOCALIZE_HH))
5581             return &PL_core_reg_engine;
5582         ptr = hv_fetchs(table, "regcomp", FALSE);
5583         if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
5584             return &PL_core_reg_engine;
5585         return INT2PTR(regexp_engine*,SvIV(*ptr));
5586     }
5587     else {
5588         SV *ptr;
5589         if (!PL_curcop->cop_hints_hash)
5590             return &PL_core_reg_engine;
5591         ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
5592         if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
5593             return &PL_core_reg_engine;
5594         return INT2PTR(regexp_engine*,SvIV(ptr));
5595     }
5596 }
5597
5598
5599 REGEXP *
5600 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
5601 {
5602     regexp_engine const *eng = current_re_engine();
5603     GET_RE_DEBUG_FLAGS_DECL;
5604
5605     PERL_ARGS_ASSERT_PREGCOMP;
5606
5607     /* Dispatch a request to compile a regexp to correct regexp engine. */
5608     DEBUG_COMPILE_r({
5609         PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
5610                         PTR2UV(eng));
5611     });
5612     return CALLREGCOMP_ENG(eng, pattern, flags);
5613 }
5614 #endif
5615
5616 /* public(ish) entry point for the perl core's own regex compiling code.
5617  * It's actually a wrapper for Perl_re_op_compile that only takes an SV
5618  * pattern rather than a list of OPs, and uses the internal engine rather
5619  * than the current one */
5620
5621 REGEXP *
5622 Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
5623 {
5624     SV *pat = pattern; /* defeat constness! */
5625     PERL_ARGS_ASSERT_RE_COMPILE;
5626     return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
5627 #ifdef PERL_IN_XSUB_RE
5628                                 &my_reg_engine,
5629 #else
5630                                 &PL_core_reg_engine,
5631 #endif
5632                                 NULL, NULL, rx_flags, 0);
5633 }
5634
5635
5636 /* upgrade pattern pat_p of length plen_p to UTF8, and if there are code
5637  * blocks, recalculate the indices. Update pat_p and plen_p in-place to
5638  * point to the realloced string and length.
5639  *
5640  * This is essentially a copy of Perl_bytes_to_utf8() with the code index
5641  * stuff added */
5642
5643 static void
5644 S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state,
5645                     char **pat_p, STRLEN *plen_p, int num_code_blocks)
5646 {
5647     U8 *const src = (U8*)*pat_p;
5648     U8 *dst;
5649     int n=0;
5650     STRLEN s = 0, d = 0;
5651     bool do_end = 0;
5652     GET_RE_DEBUG_FLAGS_DECL;
5653
5654     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
5655         "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
5656
5657     Newx(dst, *plen_p * 2 + 1, U8);
5658
5659     while (s < *plen_p) {
5660         if (NATIVE_BYTE_IS_INVARIANT(src[s]))
5661             dst[d]   = src[s];
5662         else {
5663             dst[d++] = UTF8_EIGHT_BIT_HI(src[s]);
5664             dst[d]   = UTF8_EIGHT_BIT_LO(src[s]);
5665         }
5666         if (n < num_code_blocks) {
5667             if (!do_end && pRExC_state->code_blocks[n].start == s) {
5668                 pRExC_state->code_blocks[n].start = d;
5669                 assert(dst[d] == '(');
5670                 do_end = 1;
5671             }
5672             else if (do_end && pRExC_state->code_blocks[n].end == s) {
5673                 pRExC_state->code_blocks[n].end = d;
5674                 assert(dst[d] == ')');
5675                 do_end = 0;
5676                 n++;
5677             }
5678         }
5679         s++;
5680         d++;
5681     }
5682     dst[d] = '\0';
5683     *plen_p = d;
5684     *pat_p = (char*) dst;
5685     SAVEFREEPV(*pat_p);
5686     RExC_orig_utf8 = RExC_utf8 = 1;
5687 }
5688
5689
5690
5691 /* S_concat_pat(): concatenate a list of args to the pattern string pat,
5692  * while recording any code block indices, and handling overloading,
5693  * nested qr// objects etc.  If pat is null, it will allocate a new
5694  * string, or just return the first arg, if there's only one.
5695  *
5696  * Returns the malloced/updated pat.
5697  * patternp and pat_count is the array of SVs to be concatted;
5698  * oplist is the optional list of ops that generated the SVs;
5699  * recompile_p is a pointer to a boolean that will be set if
5700  *   the regex will need to be recompiled.
5701  * delim, if non-null is an SV that will be inserted between each element
5702  */
5703
5704 static SV*
5705 S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
5706                 SV *pat, SV ** const patternp, int pat_count,
5707                 OP *oplist, bool *recompile_p, SV *delim)
5708 {
5709     SV **svp;
5710     int n = 0;
5711     bool use_delim = FALSE;
5712     bool alloced = FALSE;
5713
5714     /* if we know we have at least two args, create an empty string,
5715      * then concatenate args to that. For no args, return an empty string */
5716     if (!pat && pat_count != 1) {
5717         pat = newSVpvs("");
5718         SAVEFREESV(pat);
5719         alloced = TRUE;
5720     }
5721
5722     for (svp = patternp; svp < patternp + pat_count; svp++) {
5723         SV *sv;
5724         SV *rx  = NULL;
5725         STRLEN orig_patlen = 0;
5726         bool code = 0;
5727         SV *msv = use_delim ? delim : *svp;
5728         if (!msv) msv = &PL_sv_undef;
5729
5730         /* if we've got a delimiter, we go round the loop twice for each
5731          * svp slot (except the last), using the delimiter the second
5732          * time round */
5733         if (use_delim) {
5734             svp--;
5735             use_delim = FALSE;
5736         }
5737         else if (delim)
5738             use_delim = TRUE;
5739
5740         if (SvTYPE(msv) == SVt_PVAV) {
5741             /* we've encountered an interpolated array within
5742              * the pattern, e.g. /...@a..../. Expand the list of elements,
5743              * then recursively append elements.
5744              * The code in this block is based on S_pushav() */
5745
5746             AV *const av = (AV*)msv;
5747             const SSize_t maxarg = AvFILL(av) + 1;
5748             SV **array;
5749
5750             if (oplist) {
5751                 assert(oplist->op_type == OP_PADAV
5752                     || oplist->op_type == OP_RV2AV);
5753                 oplist = OP_SIBLING(oplist);
5754             }
5755
5756             if (SvRMAGICAL(av)) {
5757                 SSize_t i;
5758
5759                 Newx(array, maxarg, SV*);
5760                 SAVEFREEPV(array);
5761                 for (i=0; i < maxarg; i++) {
5762                     SV ** const svp = av_fetch(av, i, FALSE);
5763                     array[i] = svp ? *svp : &PL_sv_undef;
5764                 }
5765             }
5766             else
5767                 array = AvARRAY(av);
5768
5769             pat = S_concat_pat(aTHX_ pRExC_state, pat,
5770                                 array, maxarg, NULL, recompile_p,
5771                                 /* $" */
5772                                 GvSV((gv_fetchpvs("\"", GV_ADDMULTI, SVt_PV))));
5773
5774             continue;
5775         }
5776
5777
5778         /* we make the assumption here that each op in the list of
5779          * op_siblings maps to one SV pushed onto the stack,
5780          * except for code blocks, with have both an OP_NULL and
5781          * and OP_CONST.
5782          * This allows us to match up the list of SVs against the
5783          * list of OPs to find the next code block.
5784          *
5785          * Note that       PUSHMARK PADSV PADSV ..
5786          * is optimised to
5787          *                 PADRANGE PADSV  PADSV  ..
5788          * so the alignment still works. */
5789
5790         if (oplist) {
5791             if (oplist->op_type == OP_NULL
5792                 && (oplist->op_flags & OPf_SPECIAL))
5793             {
5794                 assert(n < pRExC_state->num_code_blocks);
5795                 pRExC_state->code_blocks[n].start = pat ? SvCUR(pat) : 0;
5796                 pRExC_state->code_blocks[n].block = oplist;
5797                 pRExC_state->code_blocks[n].src_regex = NULL;
5798                 n++;
5799                 code = 1;
5800                 oplist = OP_SIBLING(oplist); /* skip CONST */
5801                 assert(oplist);
5802             }
5803             oplist = OP_SIBLING(oplist);;
5804         }
5805
5806         /* apply magic and QR overloading to arg */
5807
5808         SvGETMAGIC(msv);
5809         if (SvROK(msv) && SvAMAGIC(msv)) {
5810             SV *sv = AMG_CALLunary(msv, regexp_amg);
5811             if (sv) {
5812                 if (SvROK(sv))
5813                     sv = SvRV(sv);
5814                 if (SvTYPE(sv) != SVt_REGEXP)
5815                     Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
5816                 msv = sv;
5817             }
5818         }
5819
5820         /* try concatenation overload ... */
5821         if (pat && (SvAMAGIC(pat) || SvAMAGIC(msv)) &&
5822                 (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
5823         {
5824             sv_setsv(pat, sv);
5825             /* overloading involved: all bets are off over literal
5826              * code. Pretend we haven't seen it */
5827             pRExC_state->num_code_blocks -= n;
5828             n = 0;
5829         }
5830         else  {
5831             /* ... or failing that, try "" overload */
5832             while (SvAMAGIC(msv)
5833                     && (sv = AMG_CALLunary(msv, string_amg))
5834                     && sv != msv
5835                     &&  !(   SvROK(msv)
5836                           && SvROK(sv)
5837                           && SvRV(msv) == SvRV(sv))
5838             ) {
5839                 msv = sv;
5840                 SvGETMAGIC(msv);
5841             }
5842             if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
5843                 msv = SvRV(msv);
5844
5845             if (pat) {
5846                 /* this is a partially unrolled
5847                  *     sv_catsv_nomg(pat, msv);
5848                  * that allows us to adjust code block indices if
5849                  * needed */
5850                 STRLEN dlen;
5851                 char *dst = SvPV_force_nomg(pat, dlen);
5852                 orig_patlen = dlen;
5853                 if (SvUTF8(msv) && !SvUTF8(pat)) {
5854                     S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &dst, &dlen, n);
5855                     sv_setpvn(pat, dst, dlen);
5856                     SvUTF8_on(pat);
5857                 }
5858                 sv_catsv_nomg(pat, msv);
5859                 rx = msv;
5860             }
5861             else
5862                 pat = msv;
5863
5864             if (code)
5865                 pRExC_state->code_blocks[n-1].end = SvCUR(pat)-1;
5866         }
5867
5868         /* extract any code blocks within any embedded qr//'s */
5869         if (rx && SvTYPE(rx) == SVt_REGEXP
5870             && RX_ENGINE((REGEXP*)rx)->op_comp)
5871         {
5872
5873             RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
5874             if (ri->num_code_blocks) {
5875                 int i;
5876                 /* the presence of an embedded qr// with code means
5877                  * we should always recompile: the text of the
5878                  * qr// may not have changed, but it may be a
5879                  * different closure than last time */
5880                 *recompile_p = 1;
5881                 Renew(pRExC_state->code_blocks,
5882                     pRExC_state->num_code_blocks + ri->num_code_blocks,
5883                     struct reg_code_block);
5884                 pRExC_state->num_code_blocks += ri->num_code_blocks;
5885
5886                 for (i=0; i < ri->num_code_blocks; i++) {
5887                     struct reg_code_block *src, *dst;
5888                     STRLEN offset =  orig_patlen
5889                         + ReANY((REGEXP *)rx)->pre_prefix;
5890                     assert(n < pRExC_state->num_code_blocks);
5891                     src = &ri->code_blocks[i];
5892                     dst = &pRExC_state->code_blocks[n];
5893                     dst->start      = src->start + offset;
5894                     dst->end        = src->end   + offset;
5895                     dst->block      = src->block;
5896                     dst->src_regex  = (REGEXP*) SvREFCNT_inc( (SV*)
5897                                             src->src_regex
5898                                                 ? src->src_regex
5899                                                 : (REGEXP*)rx);
5900                     n++;
5901                 }
5902             }
5903         }
5904     }
5905     /* avoid calling magic multiple times on a single element e.g. =~ $qr */
5906     if (alloced)
5907         SvSETMAGIC(pat);
5908
5909     return pat;
5910 }
5911
5912
5913
5914 /* see if there are any run-time code blocks in the pattern.
5915  * False positives are allowed */
5916
5917 static bool
5918 S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
5919                     char *pat, STRLEN plen)
5920 {
5921     int n = 0;
5922     STRLEN s;
5923     
5924     PERL_UNUSED_CONTEXT;
5925
5926     for (s = 0; s < plen; s++) {
5927         if (n < pRExC_state->num_code_blocks
5928             && s == pRExC_state->code_blocks[n].start)
5929         {
5930             s = pRExC_state->code_blocks[n].end;
5931             n++;
5932             continue;
5933         }
5934         /* TODO ideally should handle [..], (#..), /#.../x to reduce false
5935          * positives here */
5936         if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' &&
5937             (pat[s+2] == '{'
5938                 || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{'))
5939         )
5940             return 1;
5941     }
5942     return 0;
5943 }
5944
5945 /* Handle run-time code blocks. We will already have compiled any direct
5946  * or indirect literal code blocks. Now, take the pattern 'pat' and make a
5947  * copy of it, but with any literal code blocks blanked out and
5948  * appropriate chars escaped; then feed it into
5949  *
5950  *    eval "qr'modified_pattern'"
5951  *
5952  * For example,
5953  *
5954  *       a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
5955  *
5956  * becomes
5957  *
5958  *    qr'a\\bc_______________________def\'ghi\\\\jkl(?{"this is runtime"})mno'
5959  *
5960  * After eval_sv()-ing that, grab any new code blocks from the returned qr
5961  * and merge them with any code blocks of the original regexp.
5962  *
5963  * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
5964  * instead, just save the qr and return FALSE; this tells our caller that
5965  * the original pattern needs upgrading to utf8.
5966  */
5967
5968 static bool
5969 S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
5970     char *pat, STRLEN plen)
5971 {
5972     SV *qr;
5973
5974     GET_RE_DEBUG_FLAGS_DECL;
5975
5976     if (pRExC_state->runtime_code_qr) {
5977         /* this is the second time we've been called; this should
5978          * only happen if the main pattern got upgraded to utf8
5979          * during compilation; re-use the qr we compiled first time
5980          * round (which should be utf8 too)
5981          */
5982         qr = pRExC_state->runtime_code_qr;
5983         pRExC_state->runtime_code_qr = NULL;
5984         assert(RExC_utf8 && SvUTF8(qr));
5985     }
5986     else {
5987         int n = 0;
5988         STRLEN s;
5989         char *p, *newpat;
5990         int newlen = plen + 6; /* allow for "qr''x\0" extra chars */
5991         SV *sv, *qr_ref;
5992         dSP;
5993
5994         /* determine how many extra chars we need for ' and \ escaping */
5995         for (s = 0; s < plen; s++) {
5996             if (pat[s] == '\'' || pat[s] == '\\')
5997                 newlen++;
5998         }
5999
6000         Newx(newpat, newlen, char);
6001         p = newpat;
6002         *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
6003
6004         for (s = 0; s < plen; s++) {
6005             if (n < pRExC_state->num_code_blocks
6006                 && s == pRExC_state->code_blocks[n].start)
6007             {
6008                 /* blank out literal code block */
6009                 assert(pat[s] == '(');
6010                 while (s <= pRExC_state->code_blocks[n].end) {
6011                     *p++ = '_';
6012                     s++;
6013                 }
6014                 s--;
6015                 n++;
6016                 continue;
6017             }
6018             if (pat[s] == '\'' || pat[s] == '\\')
6019                 *p++ = '\\';
6020             *p++ = pat[s];
6021         }
6022         *p++ = '\'';
6023         if (pRExC_state->pm_flags & RXf_PMf_EXTENDED)
6024             *p++ = 'x';
6025         *p++ = '\0';
6026         DEBUG_COMPILE_r({
6027             PerlIO_printf(Perl_debug_log,
6028                 "%sre-parsing pattern for runtime code:%s %s\n",
6029                 PL_colors[4],PL_colors[5],newpat);
6030         });
6031
6032         sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
6033         Safefree(newpat);
6034
6035         ENTER;
6036         SAVETMPS;
6037         save_re_context();
6038         PUSHSTACKi(PERLSI_REQUIRE);
6039         /* G_RE_REPARSING causes the toker to collapse \\ into \ when
6040          * parsing qr''; normally only q'' does this. It also alters
6041          * hints handling */
6042         eval_sv(sv, G_SCALAR|G_RE_REPARSING);
6043         SvREFCNT_dec_NN(sv);
6044         SPAGAIN;
6045         qr_ref = POPs;
6046         PUTBACK;
6047         {
6048             SV * const errsv = ERRSV;
6049             if (SvTRUE_NN(errsv))
6050             {
6051                 Safefree(pRExC_state->code_blocks);
6052                 /* use croak_sv ? */
6053                 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
6054             }
6055         }
6056         assert(SvROK(qr_ref));
6057         qr = SvRV(qr_ref);
6058         assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
6059         /* the leaving below frees the tmp qr_ref.
6060          * Give qr a life of its own */
6061         SvREFCNT_inc(qr);
6062         POPSTACK;
6063         FREETMPS;
6064         LEAVE;
6065
6066     }
6067
6068     if (!RExC_utf8 && SvUTF8(qr)) {
6069         /* first time through; the pattern got upgraded; save the
6070          * qr for the next time through */
6071         assert(!pRExC_state->runtime_code_qr);
6072         pRExC_state->runtime_code_qr = qr;
6073         return 0;
6074     }
6075
6076
6077     /* extract any code blocks within the returned qr//  */
6078
6079
6080     /* merge the main (r1) and run-time (r2) code blocks into one */
6081     {
6082         RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
6083         struct reg_code_block *new_block, *dst;
6084         RExC_state_t * const r1 = pRExC_state; /* convenient alias */
6085         int i1 = 0, i2 = 0;
6086
6087         if (!r2->num_code_blocks) /* we guessed wrong */
6088         {
6089             SvREFCNT_dec_NN(qr);
6090             return 1;
6091         }
6092
6093         Newx(new_block,
6094             r1->num_code_blocks + r2->num_code_blocks,
6095             struct reg_code_block);
6096         dst = new_block;
6097
6098         while (    i1 < r1->num_code_blocks
6099                 || i2 < r2->num_code_blocks)
6100         {
6101             struct reg_code_block *src;
6102             bool is_qr = 0;
6103
6104             if (i1 == r1->num_code_blocks) {
6105                 src = &r2->code_blocks[i2++];
6106                 is_qr = 1;
6107             }
6108             else if (i2 == r2->num_code_blocks)
6109                 src = &r1->code_blocks[i1++];
6110             else if (  r1->code_blocks[i1].start
6111                      < r2->code_blocks[i2].start)
6112             {
6113                 src = &r1->code_blocks[i1++];
6114                 assert(src->end < r2->code_blocks[i2].start);
6115             }
6116             else {
6117                 assert(  r1->code_blocks[i1].start
6118                        > r2->code_blocks[i2].start);
6119                 src = &r2->code_blocks[i2++];
6120                 is_qr = 1;
6121                 assert(src->end < r1->code_blocks[i1].start);
6122             }
6123
6124             assert(pat[src->start] == '(');
6125             assert(pat[src->end]   == ')');
6126             dst->start      = src->start;
6127             dst->end        = src->end;
6128             dst->block      = src->block;
6129             dst->src_regex  = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
6130                                     : src->src_regex;
6131             dst++;
6132         }
6133         r1->num_code_blocks += r2->num_code_blocks;
6134         Safefree(r1->code_blocks);
6135         r1->code_blocks = new_block;
6136     }
6137
6138     SvREFCNT_dec_NN(qr);
6139     return 1;
6140 }
6141
6142
6143 STATIC bool
6144 S_setup_longest(pTHX_ RExC_state_t *pRExC_state, SV* sv_longest,
6145                       SV** rx_utf8, SV** rx_substr, SSize_t* rx_end_shift,
6146                       SSize_t lookbehind, SSize_t offset, SSize_t *minlen,
6147                       STRLEN longest_length, bool eol, bool meol)
6148 {
6149     /* This is the common code for setting up the floating and fixed length
6150      * string data extracted from Perl_re_op_compile() below.  Returns a boolean
6151      * as to whether succeeded or not */
6152
6153     I32 t;
6154     SSize_t ml;
6155
6156     if (! (longest_length
6157            || (eol /* Can't have SEOL and MULTI */
6158                && (! meol || (RExC_flags & RXf_PMf_MULTILINE)))
6159           )
6160             /* See comments for join_exact for why REG_UNFOLDED_MULTI_SEEN */
6161         || (RExC_seen & REG_UNFOLDED_MULTI_SEEN))
6162     {
6163         return FALSE;
6164     }
6165
6166     /* copy the information about the longest from the reg_scan_data
6167         over to the program. */
6168     if (SvUTF8(sv_longest)) {
6169         *rx_utf8 = sv_longest;
6170         *rx_substr = NULL;
6171     } else {
6172         *rx_substr = sv_longest;
6173         *rx_utf8 = NULL;
6174     }
6175     /* end_shift is how many chars that must be matched that
6176         follow this item. We calculate it ahead of time as once the
6177         lookbehind offset is added in we lose the ability to correctly
6178         calculate it.*/
6179     ml = minlen ? *(minlen) : (SSize_t)longest_length;
6180     *rx_end_shift = ml - offset
6181         - longest_length + (SvTAIL(sv_longest) != 0)
6182         + lookbehind;
6183
6184     t = (eol/* Can't have SEOL and MULTI */
6185          && (! meol || (RExC_flags & RXf_PMf_MULTILINE)));
6186     fbm_compile(sv_longest, t ? FBMcf_TAIL : 0);
6187
6188     return TRUE;
6189 }
6190
6191 /*
6192  * Perl_re_op_compile - the perl internal RE engine's function to compile a
6193  * regular expression into internal code.
6194  * The pattern may be passed either as:
6195  *    a list of SVs (patternp plus pat_count)
6196  *    a list of OPs (expr)
6197  * If both are passed, the SV list is used, but the OP list indicates
6198  * which SVs are actually pre-compiled code blocks
6199  *
6200  * The SVs in the list have magic and qr overloading applied to them (and
6201  * the list may be modified in-place with replacement SVs in the latter
6202  * case).
6203  *
6204  * If the pattern hasn't changed from old_re, then old_re will be
6205  * returned.
6206  *
6207  * eng is the current engine. If that engine has an op_comp method, then
6208  * handle directly (i.e. we assume that op_comp was us); otherwise, just
6209  * do the initial concatenation of arguments and pass on to the external
6210  * engine.
6211  *
6212  * If is_bare_re is not null, set it to a boolean indicating whether the
6213  * arg list reduced (after overloading) to a single bare regex which has
6214  * been returned (i.e. /$qr/).
6215  *
6216  * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
6217  *
6218  * pm_flags contains the PMf_* flags, typically based on those from the
6219  * pm_flags field of the related PMOP. Currently we're only interested in
6220  * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL.
6221  *
6222  * We can't allocate space until we know how big the compiled form will be,
6223  * but we can't compile it (and thus know how big it is) until we've got a
6224  * place to put the code.  So we cheat:  we compile it twice, once with code
6225  * generation turned off and size counting turned on, and once "for real".
6226  * This also means that we don't allocate space until we are sure that the
6227  * thing really will compile successfully, and we never have to move the
6228  * code and thus invalidate pointers into it.  (Note that it has to be in
6229  * one piece because free() must be able to free it all.) [NB: not true in perl]
6230  *
6231  * Beware that the optimization-preparation code in here knows about some
6232  * of the structure of the compiled regexp.  [I'll say.]
6233  */
6234
6235 REGEXP *
6236 Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
6237                     OP *expr, const regexp_engine* eng, REGEXP *old_re,
6238                      bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags)
6239 {
6240     REGEXP *rx;
6241     struct regexp *r;
6242     regexp_internal *ri;
6243     STRLEN plen;
6244     char *exp;
6245     regnode *scan;
6246     I32 flags;
6247     SSize_t minlen = 0;
6248     U32 rx_flags;
6249     SV *pat;
6250     SV *code_blocksv = NULL;
6251     SV** new_patternp = patternp;
6252
6253     /* these are all flags - maybe they should be turned
6254      * into a single int with different bit masks */
6255     I32 sawlookahead = 0;
6256     I32 sawplus = 0;
6257     I32 sawopen = 0;
6258     I32 sawminmod = 0;
6259
6260     regex_charset initial_charset = get_regex_charset(orig_rx_flags);
6261     bool recompile = 0;
6262     bool runtime_code = 0;
6263     scan_data_t data;
6264     RExC_state_t RExC_state;
6265     RExC_state_t * const pRExC_state = &RExC_state;
6266 #ifdef TRIE_STUDY_OPT
6267     int restudied = 0;
6268     RExC_state_t copyRExC_state;
6269 #endif
6270     GET_RE_DEBUG_FLAGS_DECL;
6271
6272     PERL_ARGS_ASSERT_RE_OP_COMPILE;
6273
6274     DEBUG_r(if (!PL_colorset) reginitcolors());
6275
6276 #ifndef PERL_IN_XSUB_RE
6277     /* Initialize these here instead of as-needed, as is quick and avoids
6278      * having to test them each time otherwise */
6279     if (! PL_AboveLatin1) {
6280         PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
6281         PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
6282         PL_UpperLatin1 = _new_invlist_C_array(UpperLatin1_invlist);
6283         PL_utf8_foldable = _new_invlist_C_array(_Perl_Any_Folds_invlist);
6284         PL_HasMultiCharFold =
6285                        _new_invlist_C_array(_Perl_Folds_To_Multi_Char_invlist);
6286     }
6287 #endif
6288
6289     pRExC_state->code_blocks = NULL;
6290     pRExC_state->num_code_blocks = 0;
6291
6292     if (is_bare_re)
6293         *is_bare_re = FALSE;
6294
6295     if (expr && (expr->op_type == OP_LIST ||
6296                 (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
6297         /* allocate code_blocks if needed */
6298         OP *o;
6299         int ncode = 0;
6300
6301         for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o))
6302             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
6303                 ncode++; /* count of DO blocks */
6304         if (ncode) {
6305             pRExC_state->num_code_blocks = ncode;
6306             Newx(pRExC_state->code_blocks, ncode, struct reg_code_block);
6307         }
6308     }
6309
6310     if (!pat_count) {
6311         /* compile-time pattern with just OP_CONSTs and DO blocks */
6312
6313         int n;
6314         OP *o;
6315
6316         /* find how many CONSTs there are */
6317         assert(expr);
6318         n = 0;
6319         if (expr->op_type == OP_CONST)
6320             n = 1;
6321         else
6322             for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
6323                 if (o->op_type == OP_CONST)
6324                     n++;
6325             }
6326
6327         /* fake up an SV array */
6328
6329         assert(!new_patternp);
6330         Newx(new_patternp, n, SV*);
6331         SAVEFREEPV(new_patternp);
6332         pat_count = n;
6333
6334         n = 0;
6335         if (expr->op_type == OP_CONST)
6336             new_patternp[n] = cSVOPx_sv(expr);
6337         else
6338             for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
6339                 if (o->op_type == OP_CONST)
6340                     new_patternp[n++] = cSVOPo_sv;
6341             }
6342
6343     }
6344
6345     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
6346         "Assembling pattern from %d elements%s\n", pat_count,
6347             orig_rx_flags & RXf_SPLIT ? " for split" : ""));
6348
6349     /* set expr to the first arg op */
6350
6351     if (pRExC_state->num_code_blocks
6352          && expr->op_type != OP_CONST)
6353     {
6354             expr = cLISTOPx(expr)->op_first;
6355             assert(   expr->op_type == OP_PUSHMARK
6356                    || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK)
6357                    || expr->op_type == OP_PADRANGE);
6358             expr = OP_SIBLING(expr);
6359     }
6360
6361     pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count,
6362                         expr, &recompile, NULL);
6363
6364     /* handle bare (possibly after overloading) regex: foo =~ $re */
6365     {
6366         SV *re = pat;
6367         if (SvROK(re))
6368             re = SvRV(re);
6369         if (SvTYPE(re) == SVt_REGEXP) {
6370             if (is_bare_re)
6371                 *is_bare_re = TRUE;
6372             SvREFCNT_inc(re);
6373             Safefree(pRExC_state->code_blocks);
6374             DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
6375                 "Precompiled pattern%s\n",
6376                     orig_rx_flags & RXf_SPLIT ? " for split" : ""));
6377
6378             return (REGEXP*)re;
6379         }
6380     }
6381
6382     exp = SvPV_nomg(pat, plen);
6383
6384     if (!eng->op_comp) {
6385         if ((SvUTF8(pat) && IN_BYTES)
6386                 || SvGMAGICAL(pat) || SvAMAGIC(pat))
6387         {
6388             /* make a temporary copy; either to convert to bytes,
6389              * or to avoid repeating get-magic / overloaded stringify */
6390             pat = newSVpvn_flags(exp, plen, SVs_TEMP |
6391                                         (IN_BYTES ? 0 : SvUTF8(pat)));
6392         }
6393         Safefree(pRExC_state->code_blocks);
6394         return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
6395     }
6396
6397     /* ignore the utf8ness if the pattern is 0 length */
6398     RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
6399     RExC_uni_semantics = 0;
6400     RExC_contains_locale = 0;
6401     RExC_contains_i = 0;
6402     pRExC_state->runtime_code_qr = NULL;
6403
6404     DEBUG_COMPILE_r({
6405             SV *dsv= sv_newmortal();
6406             RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, 60);
6407             PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
6408                           PL_colors[4],PL_colors[5],s);
6409         });
6410
6411   redo_first_pass:
6412     /* we jump here if we upgrade the pattern to utf8 and have to
6413      * recompile */
6414
6415     if ((pm_flags & PMf_USE_RE_EVAL)
6416                 /* this second condition covers the non-regex literal case,
6417                  * i.e.  $foo =~ '(?{})'. */
6418                 || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
6419     )
6420         runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen);
6421
6422     /* return old regex if pattern hasn't changed */
6423     /* XXX: note in the below we have to check the flags as well as the
6424      * pattern.
6425      *
6426      * Things get a touch tricky as we have to compare the utf8 flag
6427      * independently from the compile flags.  */
6428
6429     if (   old_re
6430         && !recompile
6431         && !!RX_UTF8(old_re) == !!RExC_utf8
6432         && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) )
6433         && RX_PRECOMP(old_re)
6434         && RX_PRELEN(old_re) == plen
6435         && memEQ(RX_PRECOMP(old_re), exp, plen)
6436         && !runtime_code /* with runtime code, always recompile */ )
6437     {
6438         Safefree(pRExC_state->code_blocks);
6439         return old_re;
6440     }
6441
6442     rx_flags = orig_rx_flags;
6443
6444     if (rx_flags & PMf_FOLD) {
6445         RExC_contains_i = 1;
6446     }
6447     if (RExC_utf8 && initial_charset == REGEX_DEPENDS_CHARSET) {
6448
6449         /* Set to use unicode semantics if the pattern is in utf8 and has the
6450          * 'depends' charset specified, as it means unicode when utf8  */
6451         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
6452     }
6453
6454     RExC_precomp = exp;
6455     RExC_flags = rx_flags;
6456     RExC_pm_flags = pm_flags;
6457
6458     if (runtime_code) {
6459         if (TAINTING_get && TAINT_get)
6460             Perl_croak(aTHX_ "Eval-group in insecure regular expression");
6461
6462         if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
6463             /* whoops, we have a non-utf8 pattern, whilst run-time code
6464              * got compiled as utf8. Try again with a utf8 pattern */
6465             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
6466                                     pRExC_state->num_code_blocks);
6467             goto redo_first_pass;
6468         }
6469     }
6470     assert(!pRExC_state->runtime_code_qr);
6471
6472     RExC_sawback = 0;
6473
6474     RExC_seen = 0;
6475     RExC_maxlen = 0;
6476     RExC_in_lookbehind = 0;
6477     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
6478     RExC_extralen = 0;
6479     RExC_override_recoding = 0;
6480     RExC_in_multi_char_class = 0;
6481
6482     /* First pass: determine size, legality. */
6483     RExC_parse = exp;
6484     RExC_start = exp;
6485     RExC_end = exp + plen;
6486     RExC_naughty = 0;
6487     RExC_npar = 1;
6488     RExC_nestroot = 0;
6489     RExC_size = 0L;
6490     RExC_emit = (regnode *) &RExC_emit_dummy;
6491     RExC_whilem_seen = 0;
6492     RExC_open_parens = NULL;
6493     RExC_close_parens = NULL;
6494     RExC_opend = NULL;
6495     RExC_paren_names = NULL;
6496 #ifdef DEBUGGING
6497     RExC_paren_name_list = NULL;
6498 #endif
6499     RExC_recurse = NULL;
6500     RExC_study_chunk_recursed = NULL;
6501     RExC_study_chunk_recursed_bytes= 0;
6502     RExC_recurse_count = 0;
6503     pRExC_state->code_index = 0;
6504
6505 #if 0 /* REGC() is (currently) a NOP at the first pass.
6506        * Clever compilers notice this and complain. --jhi */
6507     REGC((U8)REG_MAGIC, (char*)RExC_emit);
6508 #endif
6509     DEBUG_PARSE_r(
6510         PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n");
6511         RExC_lastnum=0;
6512         RExC_lastparse=NULL;
6513     );
6514     /* reg may croak on us, not giving us a chance to free
6515        pRExC_state->code_blocks.  We cannot SAVEFREEPV it now, as we may
6516        need it to survive as long as the regexp (qr/(?{})/).
6517        We must check that code_blocksv is not already set, because we may
6518        have jumped back to restart the sizing pass. */
6519     if (pRExC_state->code_blocks && !code_blocksv) {
6520         code_blocksv = newSV_type(SVt_PV);
6521         SAVEFREESV(code_blocksv);
6522         SvPV_set(code_blocksv, (char *)pRExC_state->code_blocks);
6523         SvLEN_set(code_blocksv, 1); /*sufficient to make sv_clear free it*/
6524     }
6525     if (reg(pRExC_state, 0, &flags,1) == NULL) {
6526         /* It's possible to write a regexp in ascii that represents Unicode
6527         codepoints outside of the byte range, such as via \x{100}. If we
6528         detect such a sequence we have to convert the entire pattern to utf8
6529         and then recompile, as our sizing calculation will have been based
6530         on 1 byte == 1 character, but we will need to use utf8 to encode
6531         at least some part of the pattern, and therefore must convert the whole
6532         thing.
6533         -- dmq */
6534         if (flags & RESTART_UTF8) {
6535             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
6536                                     pRExC_state->num_code_blocks);
6537             goto redo_first_pass;
6538         }
6539         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for sizing pass, flags=%#"UVxf"", (UV) flags);
6540     }
6541     if (code_blocksv)
6542         SvLEN_set(code_blocksv,0); /* no you can't have it, sv_clear */
6543
6544     DEBUG_PARSE_r({
6545         PerlIO_printf(Perl_debug_log,
6546             "Required size %"IVdf" nodes\n"
6547             "Starting second pass (creation)\n",
6548             (IV)RExC_size);
6549         RExC_lastnum=0;
6550         RExC_lastparse=NULL;
6551     });
6552
6553     /* The first pass could have found things that force Unicode semantics */
6554     if ((RExC_utf8 || RExC_uni_semantics)
6555          && get_regex_charset(rx_flags) == REGEX_DEPENDS_CHARSET)
6556     {
6557         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
6558     }
6559
6560     /* Small enough for pointer-storage convention?
6561        If extralen==0, this means that we will not need long jumps. */
6562     if (RExC_size >= 0x10000L && RExC_extralen)
6563         RExC_size += RExC_extralen;
6564     else
6565         RExC_extralen = 0;
6566     if (RExC_whilem_seen > 15)
6567         RExC_whilem_seen = 15;
6568
6569     /* Allocate space and zero-initialize. Note, the two step process
6570        of zeroing when in debug mode, thus anything assigned has to
6571        happen after that */
6572     rx = (REGEXP*) newSV_type(SVt_REGEXP);
6573     r = ReANY(rx);
6574     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
6575          char, regexp_internal);
6576     if ( r == NULL || ri == NULL )
6577         FAIL("Regexp out of space");
6578 #ifdef DEBUGGING
6579     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
6580     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
6581          char);
6582 #else
6583     /* bulk initialize base fields with 0. */
6584     Zero(ri, sizeof(regexp_internal), char);
6585 #endif
6586
6587     /* non-zero initialization begins here */
6588     RXi_SET( r, ri );
6589     r->engine= eng;
6590     r->extflags = rx_flags;
6591     RXp_COMPFLAGS(r) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK;
6592
6593     if (pm_flags & PMf_IS_QR) {
6594         ri->code_blocks = pRExC_state->code_blocks;
6595         ri->num_code_blocks = pRExC_state->num_code_blocks;
6596     }
6597     else
6598     {
6599         int n;
6600         for (n = 0; n < pRExC_state->num_code_blocks; n++)
6601             if (pRExC_state->code_blocks[n].src_regex)
6602                 SAVEFREESV(pRExC_state->code_blocks[n].src_regex);
6603         SAVEFREEPV(pRExC_state->code_blocks);
6604     }
6605
6606     {
6607         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
6608         bool has_charset = (get_regex_charset(r->extflags)
6609                                                     != REGEX_DEPENDS_CHARSET);
6610
6611         /* The caret is output if there are any defaults: if not all the STD
6612          * flags are set, or if no character set specifier is needed */
6613         bool has_default =
6614                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
6615                     || ! has_charset);
6616         bool has_runon = ((RExC_seen & REG_RUN_ON_COMMENT_SEEN)
6617                                                    == REG_RUN_ON_COMMENT_SEEN);
6618         U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD)
6619                             >> RXf_PMf_STD_PMMOD_SHIFT);
6620         const char *fptr = STD_PAT_MODS;        /*"msix"*/
6621         char *p;
6622         /* Allocate for the worst case, which is all the std flags are turned
6623          * on.  If more precision is desired, we could do a population count of
6624          * the flags set.  This could be done with a small lookup table, or by
6625          * shifting, masking and adding, or even, when available, assembly
6626          * language for a machine-language population count.
6627          * We never output a minus, as all those are defaults, so are
6628          * covered by the caret */
6629         const STRLEN wraplen = plen + has_p + has_runon
6630             + has_default       /* If needs a caret */
6631
6632                 /* If needs a character set specifier */
6633             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
6634             + (sizeof(STD_PAT_MODS) - 1)
6635             + (sizeof("(?:)") - 1);
6636
6637         Newx(p, wraplen + 1, char); /* +1 for the ending NUL */
6638         r->xpv_len_u.xpvlenu_pv = p;
6639         if (RExC_utf8)
6640             SvFLAGS(rx) |= SVf_UTF8;
6641         *p++='('; *p++='?';
6642
6643         /* If a default, cover it using the caret */
6644         if (has_default) {
6645             *p++= DEFAULT_PAT_MOD;
6646         }
6647         if (has_charset) {
6648             STRLEN len;
6649             const char* const name = get_regex_charset_name(r->extflags, &len);
6650             Copy(name, p, len, char);
6651             p += len;
6652         }
6653         if (has_p)
6654             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
6655         {
6656             char ch;
6657             while((ch = *fptr++)) {
6658                 if(reganch & 1)
6659                     *p++ = ch;
6660                 reganch >>= 1;
6661             }
6662         }
6663
6664         *p++ = ':';
6665         Copy(RExC_precomp, p, plen, char);
6666         assert ((RX_WRAPPED(rx) - p) < 16);
6667         r->pre_prefix = p - RX_WRAPPED(rx);
6668         p += plen;
6669         if (has_runon)
6670             *p++ = '\n';
6671         *p++ = ')';
6672         *p = 0;
6673         SvCUR_set(rx, p - RX_WRAPPED(rx));
6674     }
6675
6676     r->intflags = 0;
6677     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
6678
6679     /* setup various meta data about recursion, this all requires
6680      * RExC_npar to be correctly set, and a bit later on we clear it */
6681     if (RExC_seen & REG_RECURSE_SEEN) {
6682         Newxz(RExC_open_parens, RExC_npar,regnode *);
6683         SAVEFREEPV(RExC_open_parens);
6684         Newxz(RExC_close_parens,RExC_npar,regnode *);
6685         SAVEFREEPV(RExC_close_parens);
6686     }
6687     if (RExC_seen & (REG_RECURSE_SEEN | REG_GOSTART_SEEN)) {
6688         /* Note, RExC_npar is 1 + the number of parens in a pattern.
6689          * So its 1 if there are no parens. */
6690         RExC_study_chunk_recursed_bytes= (RExC_npar >> 3) +
6691                                          ((RExC_npar & 0x07) != 0);
6692         Newx(RExC_study_chunk_recursed,
6693              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
6694         SAVEFREEPV(RExC_study_chunk_recursed);
6695     }
6696
6697     /* Useful during FAIL. */
6698 #ifdef RE_TRACK_PATTERN_OFFSETS
6699     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
6700     DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
6701                           "%s %"UVuf" bytes for offset annotations.\n",
6702                           ri->u.offsets ? "Got" : "Couldn't get",
6703                           (UV)((2*RExC_size+1) * sizeof(U32))));
6704 #endif
6705     SetProgLen(ri,RExC_size);
6706     RExC_rx_sv = rx;
6707     RExC_rx = r;
6708     RExC_rxi = ri;
6709
6710     /* Second pass: emit code. */
6711     RExC_flags = rx_flags;      /* don't let top level (?i) bleed */
6712     RExC_pm_flags = pm_flags;
6713     RExC_parse = exp;
6714     RExC_end = exp + plen;
6715     RExC_naughty = 0;
6716     RExC_npar = 1;
6717     RExC_emit_start = ri->program;
6718     RExC_emit = ri->program;
6719     RExC_emit_bound = ri->program + RExC_size + 1;
6720     pRExC_state->code_index = 0;
6721
6722     REGC((U8)REG_MAGIC, (char*) RExC_emit++);
6723     if (reg(pRExC_state, 0, &flags,1) == NULL) {
6724         ReREFCNT_dec(rx);
6725         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for generation pass, flags=%#"UVxf"", (UV) flags);
6726     }
6727     /* XXXX To minimize changes to RE engine we always allocate
6728        3-units-long substrs field. */
6729     Newx(r->substrs, 1, struct reg_substr_data);
6730     if (RExC_recurse_count) {
6731         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
6732         SAVEFREEPV(RExC_recurse);
6733     }
6734
6735 reStudy:
6736     r->minlen = minlen = sawlookahead = sawplus = sawopen = sawminmod = 0;
6737     Zero(r->substrs, 1, struct reg_substr_data);
6738     if (RExC_study_chunk_recursed)
6739         Zero(RExC_study_chunk_recursed,
6740              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
6741
6742 #ifdef TRIE_STUDY_OPT
6743     if (!restudied) {
6744         StructCopy(&zero_scan_data, &data, scan_data_t);
6745         copyRExC_state = RExC_state;
6746     } else {
6747         U32 seen=RExC_seen;
6748         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
6749
6750         RExC_state = copyRExC_state;
6751         if (seen & REG_TOP_LEVEL_BRANCHES_SEEN)
6752             RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
6753         else
6754             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES_SEEN;
6755         StructCopy(&zero_scan_data, &data, scan_data_t);
6756     }
6757 #else
6758     StructCopy(&zero_scan_data, &data, scan_data_t);
6759 #endif
6760
6761     /* Dig out information for optimizations. */
6762     r->extflags = RExC_flags; /* was pm_op */
6763     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
6764
6765     if (UTF)
6766         SvUTF8_on(rx);  /* Unicode in it? */
6767     ri->regstclass = NULL;
6768     if (RExC_naughty >= 10)     /* Probably an expensive pattern. */
6769         r->intflags |= PREGf_NAUGHTY;
6770     scan = ri->program + 1;             /* First BRANCH. */
6771
6772     /* testing for BRANCH here tells us whether there is "must appear"
6773        data in the pattern. If there is then we can use it for optimisations */
6774     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)) { /*  Only one top-level choice.
6775                                                   */
6776         SSize_t fake;
6777         STRLEN longest_float_length, longest_fixed_length;
6778         regnode_ssc ch_class; /* pointed to by data */
6779         int stclass_flag;
6780         SSize_t last_close = 0; /* pointed to by data */
6781         regnode *first= scan;
6782         regnode *first_next= regnext(first);
6783         /*
6784          * Skip introductions and multiplicators >= 1
6785          * so that we can extract the 'meat' of the pattern that must
6786          * match in the large if() sequence following.
6787          * NOTE that EXACT is NOT covered here, as it is normally
6788          * picked up by the optimiser separately.
6789          *
6790          * This is unfortunate as the optimiser isnt handling lookahead
6791          * properly currently.
6792          *
6793          */
6794         while ((OP(first) == OPEN && (sawopen = 1)) ||
6795                /* An OR of *one* alternative - should not happen now. */
6796             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
6797             /* for now we can't handle lookbehind IFMATCH*/
6798             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
6799             (OP(first) == PLUS) ||
6800             (OP(first) == MINMOD) ||
6801                /* An {n,m} with n>0 */
6802             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
6803             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
6804         {
6805                 /*
6806                  * the only op that could be a regnode is PLUS, all the rest
6807                  * will be regnode_1 or regnode_2.
6808                  *
6809                  * (yves doesn't think this is true)
6810                  */
6811                 if (OP(first) == PLUS)
6812                     sawplus = 1;
6813                 else {
6814                     if (OP(first) == MINMOD)
6815                         sawminmod = 1;
6816                     first += regarglen[OP(first)];
6817                 }
6818                 first = NEXTOPER(first);
6819                 first_next= regnext(first);
6820         }
6821
6822         /* Starting-point info. */
6823       again:
6824         DEBUG_PEEP("first:",first,0);
6825         /* Ignore EXACT as we deal with it later. */
6826         if (PL_regkind[OP(first)] == EXACT) {
6827             if (OP(first) == EXACT)
6828                 NOOP;   /* Empty, get anchored substr later. */
6829             else
6830                 ri->regstclass = first;
6831         }
6832 #ifdef TRIE_STCLASS
6833         else if (PL_regkind[OP(first)] == TRIE &&
6834                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0)
6835         {
6836             /* this can happen only on restudy */
6837             ri->regstclass = construct_ahocorasick_from_trie(pRExC_state, (regnode *)first, 0);
6838         }
6839 #endif
6840         else if (REGNODE_SIMPLE(OP(first)))
6841             ri->regstclass = first;
6842         else if (PL_regkind[OP(first)] == BOUND ||
6843                  PL_regkind[OP(first)] == NBOUND)
6844             ri->regstclass = first;
6845         else if (PL_regkind[OP(first)] == BOL) {
6846             r->intflags |= (OP(first) == MBOL
6847                            ? PREGf_ANCH_MBOL
6848                            : (OP(first) == SBOL
6849                               ? PREGf_ANCH_SBOL
6850                               : PREGf_ANCH_BOL));
6851             first = NEXTOPER(first);
6852             goto again;
6853         }
6854         else if (OP(first) == GPOS) {
6855             r->intflags |= PREGf_ANCH_GPOS;
6856             first = NEXTOPER(first);
6857             goto again;
6858         }
6859         else if ((!sawopen || !RExC_sawback) &&
6860             !sawlookahead &&
6861             (OP(first) == STAR &&
6862             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
6863             !(r->intflags & PREGf_ANCH) && !pRExC_state->num_code_blocks)
6864         {
6865             /* turn .* into ^.* with an implied $*=1 */
6866             const int type =
6867                 (OP(NEXTOPER(first)) == REG_ANY)
6868                     ? PREGf_ANCH_MBOL
6869                     : PREGf_ANCH_SBOL;
6870             r->intflags |= (type | PREGf_IMPLICIT);
6871             first = NEXTOPER(first);
6872             goto again;
6873         }
6874         if (sawplus && !sawminmod && !sawlookahead
6875             && (!sawopen || !RExC_sawback)
6876             && !pRExC_state->num_code_blocks) /* May examine pos and $& */
6877             /* x+ must match at the 1st pos of run of x's */
6878             r->intflags |= PREGf_SKIP;
6879
6880         /* Scan is after the zeroth branch, first is atomic matcher. */
6881 #ifdef TRIE_STUDY_OPT
6882         DEBUG_PARSE_r(
6883             if (!restudied)
6884                 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
6885                               (IV)(first - scan + 1))
6886         );
6887 #else
6888         DEBUG_PARSE_r(
6889             PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
6890                 (IV)(first - scan + 1))
6891         );
6892 #endif
6893
6894
6895         /*
6896         * If there's something expensive in the r.e., find the
6897         * longest literal string that must appear and make it the
6898         * regmust.  Resolve ties in favor of later strings, since
6899         * the regstart check works with the beginning of the r.e.
6900         * and avoiding duplication strengthens checking.  Not a
6901         * strong reason, but sufficient in the absence of others.
6902         * [Now we resolve ties in favor of the earlier string if
6903         * it happens that c_offset_min has been invalidated, since the
6904         * earlier string may buy us something the later one won't.]
6905         */
6906
6907         data.longest_fixed = newSVpvs("");
6908         data.longest_float = newSVpvs("");
6909         data.last_found = newSVpvs("");
6910         data.longest = &(data.longest_fixed);
6911         ENTER_with_name("study_chunk");
6912         SAVEFREESV(data.longest_fixed);
6913         SAVEFREESV(data.longest_float);
6914         SAVEFREESV(data.last_found);
6915         first = scan;
6916         if (!ri->regstclass) {
6917             ssc_init(pRExC_state, &ch_class);
6918             data.start_class = &ch_class;
6919             stclass_flag = SCF_DO_STCLASS_AND;
6920         } else                          /* XXXX Check for BOUND? */
6921             stclass_flag = 0;
6922         data.last_closep = &last_close;
6923
6924         DEBUG_RExC_seen();
6925         minlen = study_chunk(pRExC_state, &first, &minlen, &fake,
6926                              scan + RExC_size, /* Up to end */
6927             &data, -1, 0, NULL,
6928             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag
6929                           | (restudied ? SCF_TRIE_DOING_RESTUDY : 0),
6930             0);
6931
6932
6933         CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
6934
6935
6936         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
6937              && data.last_start_min == 0 && data.last_end > 0
6938              && !RExC_seen_zerolen
6939              && !(RExC_seen & REG_VERBARG_SEEN)
6940              && !(RExC_seen & REG_GPOS_SEEN)
6941         ){
6942             r->extflags |= RXf_CHECK_ALL;
6943         }
6944         scan_commit(pRExC_state, &data,&minlen,0);
6945
6946         longest_float_length = CHR_SVLEN(data.longest_float);
6947
6948         if (! ((SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
6949                    && data.offset_fixed == data.offset_float_min
6950                    && SvCUR(data.longest_fixed) == SvCUR(data.longest_float)))
6951             && S_setup_longest (aTHX_ pRExC_state,
6952                                     data.longest_float,
6953                                     &(r->float_utf8),
6954                                     &(r->float_substr),
6955                                     &(r->float_end_shift),
6956                                     data.lookbehind_float,
6957                                     data.offset_float_min,
6958                                     data.minlen_float,
6959                                     longest_float_length,
6960                                     cBOOL(data.flags & SF_FL_BEFORE_EOL),
6961                                     cBOOL(data.flags & SF_FL_BEFORE_MEOL)))
6962         {
6963             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
6964             r->float_max_offset = data.offset_float_max;
6965             if (data.offset_float_max < SSize_t_MAX) /* Don't offset infinity */
6966                 r->float_max_offset -= data.lookbehind_float;
6967             SvREFCNT_inc_simple_void_NN(data.longest_float);
6968         }
6969         else {
6970             r->float_substr = r->float_utf8 = NULL;
6971             longest_float_length = 0;
6972         }
6973
6974         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
6975
6976         if (S_setup_longest (aTHX_ pRExC_state,
6977                                 data.longest_fixed,
6978                                 &(r->anchored_utf8),
6979                                 &(r->anchored_substr),
6980                                 &(r->anchored_end_shift),
6981                                 data.lookbehind_fixed,
6982                                 data.offset_fixed,
6983                                 data.minlen_fixed,
6984                                 longest_fixed_length,
6985                                 cBOOL(data.flags & SF_FIX_BEFORE_EOL),
6986                                 cBOOL(data.flags & SF_FIX_BEFORE_MEOL)))
6987         {
6988             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
6989             SvREFCNT_inc_simple_void_NN(data.longest_fixed);
6990         }
6991         else {
6992             r->anchored_substr = r->anchored_utf8 = NULL;
6993             longest_fixed_length = 0;
6994         }
6995         LEAVE_with_name("study_chunk");
6996
6997         if (ri->regstclass
6998             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
6999             ri->regstclass = NULL;
7000
7001         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
7002             && stclass_flag
7003             && ! (ANYOF_FLAGS(data.start_class) & ANYOF_EMPTY_STRING)
7004             && !ssc_is_anything(data.start_class))
7005         {
7006             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7007
7008             ssc_finalize(pRExC_state, data.start_class);
7009
7010             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7011             StructCopy(data.start_class,
7012                        (regnode_ssc*)RExC_rxi->data->data[n],
7013                        regnode_ssc);
7014             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7015             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7016             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
7017                       regprop(r, sv, (regnode*)data.start_class, NULL);
7018                       PerlIO_printf(Perl_debug_log,
7019                                     "synthetic stclass \"%s\".\n",
7020                                     SvPVX_const(sv));});
7021             data.start_class = NULL;
7022         }
7023
7024         /* A temporary algorithm prefers floated substr to fixed one to dig
7025          * more info. */
7026         if (longest_fixed_length > longest_float_length) {
7027             r->substrs->check_ix = 0;
7028             r->check_end_shift = r->anchored_end_shift;
7029             r->check_substr = r->anchored_substr;
7030             r->check_utf8 = r->anchored_utf8;
7031             r->check_offset_min = r->check_offset_max = r->anchored_offset;
7032             if (r->intflags & (PREGf_ANCH_SBOL|PREGf_ANCH_GPOS))
7033                 r->intflags |= PREGf_NOSCAN;
7034         }
7035         else {
7036             r->substrs->check_ix = 1;
7037             r->check_end_shift = r->float_end_shift;
7038             r->check_substr = r->float_substr;
7039             r->check_utf8 = r->float_utf8;
7040             r->check_offset_min = r->float_min_offset;
7041             r->check_offset_max = r->float_max_offset;
7042         }
7043         if ((r->check_substr || r->check_utf8) ) {
7044             r->extflags |= RXf_USE_INTUIT;
7045             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
7046                 r->extflags |= RXf_INTUIT_TAIL;
7047         }
7048         r->substrs->data[0].max_offset = r->substrs->data[0].min_offset;
7049
7050         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
7051         if ( (STRLEN)minlen < longest_float_length )
7052             minlen= longest_float_length;
7053         if ( (STRLEN)minlen < longest_fixed_length )
7054             minlen= longest_fixed_length;
7055         */
7056     }
7057     else {
7058         /* Several toplevels. Best we can is to set minlen. */
7059         SSize_t fake;
7060         regnode_ssc ch_class;
7061         SSize_t last_close = 0;
7062
7063         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
7064
7065         scan = ri->program + 1;
7066         ssc_init(pRExC_state, &ch_class);
7067         data.start_class = &ch_class;
7068         data.last_closep = &last_close;
7069
7070         DEBUG_RExC_seen();
7071         minlen = study_chunk(pRExC_state,
7072             &scan, &minlen, &fake, scan + RExC_size, &data, -1, 0, NULL,
7073             SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied
7074                                                       ? SCF_TRIE_DOING_RESTUDY
7075                                                       : 0),
7076             0);
7077
7078         CHECK_RESTUDY_GOTO_butfirst(NOOP);
7079
7080         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
7081                 = r->float_substr = r->float_utf8 = NULL;
7082
7083         if (! (ANYOF_FLAGS(data.start_class) & ANYOF_EMPTY_STRING)
7084             && ! ssc_is_anything(data.start_class))
7085         {
7086             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7087
7088             ssc_finalize(pRExC_state, data.start_class);
7089
7090             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7091             StructCopy(data.start_class,
7092                        (regnode_ssc*)RExC_rxi->data->data[n],
7093                        regnode_ssc);
7094             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7095             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7096             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
7097                       regprop(r, sv, (regnode*)data.start_class, NULL);
7098                       PerlIO_printf(Perl_debug_log,
7099                                     "synthetic stclass \"%s\".\n",
7100                                     SvPVX_const(sv));});
7101             data.start_class = NULL;
7102         }
7103     }
7104
7105     if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) {
7106         r->extflags |= RXf_UNBOUNDED_QUANTIFIER_SEEN;
7107         r->maxlen = REG_INFTY;
7108     }
7109     else {
7110         r->maxlen = RExC_maxlen;
7111     }
7112
7113     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
7114        the "real" pattern. */
7115     DEBUG_OPTIMISE_r({
7116         PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf" maxlen:%ld\n",
7117                       (IV)minlen, (IV)r->minlen, RExC_maxlen);
7118     });
7119     r->minlenret = minlen;
7120     if (r->minlen < minlen)
7121         r->minlen = minlen;
7122
7123     if (RExC_seen & REG_GPOS_SEEN)
7124         r->intflags |= PREGf_GPOS_SEEN;
7125     if (RExC_seen & REG_LOOKBEHIND_SEEN)
7126         r->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the
7127                                                 lookbehind */
7128     if (pRExC_state->num_code_blocks)
7129         r->extflags |= RXf_EVAL_SEEN;
7130     if (RExC_seen & REG_CANY_SEEN)
7131         r->intflags |= PREGf_CANY_SEEN;
7132     if (RExC_seen & REG_VERBARG_SEEN)
7133     {
7134         r->intflags |= PREGf_VERBARG_SEEN;
7135         r->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */
7136     }
7137     if (RExC_seen & REG_CUTGROUP_SEEN)
7138         r->intflags |= PREGf_CUTGROUP_SEEN;
7139     if (pm_flags & PMf_USE_RE_EVAL)
7140         r->intflags |= PREGf_USE_RE_EVAL;
7141     if (RExC_paren_names)
7142         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
7143     else
7144         RXp_PAREN_NAMES(r) = NULL;
7145
7146     /* If we have seen an anchor in our pattern then we set the extflag RXf_IS_ANCHORED
7147      * so it can be used in pp.c */
7148     if (r->intflags & PREGf_ANCH)
7149         r->extflags |= RXf_IS_ANCHORED;
7150
7151
7152     {
7153         /* this is used to identify "special" patterns that might result
7154          * in Perl NOT calling the regex engine and instead doing the match "itself",
7155          * particularly special cases in split//. By having the regex compiler
7156          * do this pattern matching at a regop level (instead of by inspecting the pattern)
7157          * we avoid weird issues with equivalent patterns resulting in different behavior,
7158          * AND we allow non Perl engines to get the same optimizations by the setting the
7159          * flags appropriately - Yves */
7160         regnode *first = ri->program + 1;
7161         U8 fop = OP(first);
7162         regnode *next = NEXTOPER(first);
7163         U8 nop = OP(next);
7164
7165         if (PL_regkind[fop] == NOTHING && nop == END)
7166             r->extflags |= RXf_NULL;
7167         else if (PL_regkind[fop] == BOL && nop == END)
7168             r->extflags |= RXf_START_ONLY;
7169         else if (fop == PLUS
7170                  && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE
7171                  && OP(regnext(first)) == END)
7172             r->extflags |= RXf_WHITE;
7173         else if ( r->extflags & RXf_SPLIT
7174                   && fop == EXACT
7175                   && STR_LEN(first) == 1
7176                   && *(STRING(first)) == ' '
7177                   && OP(regnext(first)) == END )
7178             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
7179
7180     }
7181
7182     if (RExC_contains_locale) {
7183         RXp_EXTFLAGS(r) |= RXf_TAINTED;
7184     }
7185
7186 #ifdef DEBUGGING
7187     if (RExC_paren_names) {
7188         ri->name_list_idx = add_data( pRExC_state, STR_WITH_LEN("a"));
7189         ri->data->data[ri->name_list_idx]
7190                                    = (void*)SvREFCNT_inc(RExC_paren_name_list);
7191     } else
7192 #endif
7193         ri->name_list_idx = 0;
7194
7195     if (RExC_recurse_count) {
7196         for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
7197             const regnode *scan = RExC_recurse[RExC_recurse_count-1];
7198             ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
7199         }
7200     }
7201     Newxz(r->offs, RExC_npar, regexp_paren_pair);
7202     /* assume we don't need to swap parens around before we match */
7203
7204     DEBUG_DUMP_r({
7205         DEBUG_RExC_seen();
7206         PerlIO_printf(Perl_debug_log,"Final program:\n");
7207         regdump(r);
7208     });
7209 #ifdef RE_TRACK_PATTERN_OFFSETS
7210     DEBUG_OFFSETS_r(if (ri->u.offsets) {
7211         const STRLEN len = ri->u.offsets[0];
7212         STRLEN i;
7213         GET_RE_DEBUG_FLAGS_DECL;
7214         PerlIO_printf(Perl_debug_log,
7215                       "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
7216         for (i = 1; i <= len; i++) {
7217             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
7218                 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
7219                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
7220             }
7221         PerlIO_printf(Perl_debug_log, "\n");
7222     });
7223 #endif
7224
7225 #ifdef USE_ITHREADS
7226     /* under ithreads the ?pat? PMf_USED flag on the pmop is simulated
7227      * by setting the regexp SV to readonly-only instead. If the
7228      * pattern's been recompiled, the USEDness should remain. */
7229     if (old_re && SvREADONLY(old_re))
7230         SvREADONLY_on(rx);
7231 #endif
7232     return rx;
7233 }
7234
7235
7236 SV*
7237 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
7238                     const U32 flags)
7239 {
7240     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
7241
7242     PERL_UNUSED_ARG(value);
7243
7244     if (flags & RXapif_FETCH) {
7245         return reg_named_buff_fetch(rx, key, flags);
7246     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
7247         Perl_croak_no_modify();
7248         return NULL;
7249     } else if (flags & RXapif_EXISTS) {
7250         return reg_named_buff_exists(rx, key, flags)
7251             ? &PL_sv_yes
7252             : &PL_sv_no;
7253     } else if (flags & RXapif_REGNAMES) {
7254         return reg_named_buff_all(rx, flags);
7255     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
7256         return reg_named_buff_scalar(rx, flags);
7257     } else {
7258         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
7259         return NULL;
7260     }
7261 }
7262
7263 SV*
7264 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
7265                          const U32 flags)
7266 {
7267     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
7268     PERL_UNUSED_ARG(lastkey);
7269
7270     if (flags & RXapif_FIRSTKEY)
7271         return reg_named_buff_firstkey(rx, flags);
7272     else if (flags & RXapif_NEXTKEY)
7273         return reg_named_buff_nextkey(rx, flags);
7274     else {
7275         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter",
7276                                             (int)flags);
7277         return NULL;
7278     }
7279 }
7280
7281 SV*
7282 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
7283                           const U32 flags)
7284 {
7285     AV *retarray = NULL;
7286     SV *ret;
7287     struct regexp *const rx = ReANY(r);
7288
7289     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
7290
7291     if (flags & RXapif_ALL)
7292         retarray=newAV();
7293
7294     if (rx && RXp_PAREN_NAMES(rx)) {
7295         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
7296         if (he_str) {
7297             IV i;
7298             SV* sv_dat=HeVAL(he_str);
7299             I32 *nums=(I32*)SvPVX(sv_dat);
7300             for ( i=0; i<SvIVX(sv_dat); i++ ) {
7301                 if ((I32)(rx->nparens) >= nums[i]
7302                     && rx->offs[nums[i]].start != -1
7303                     && rx->offs[nums[i]].end != -1)
7304                 {
7305                     ret = newSVpvs("");
7306                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
7307                     if (!retarray)
7308                         return ret;
7309                 } else {
7310                     if (retarray)
7311                         ret = newSVsv(&PL_sv_undef);
7312                 }
7313                 if (retarray)
7314                     av_push(retarray, ret);
7315             }
7316             if (retarray)
7317                 return newRV_noinc(MUTABLE_SV(retarray));
7318         }
7319     }
7320     return NULL;
7321 }
7322
7323 bool
7324 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
7325                            const U32 flags)
7326 {
7327     struct regexp *const rx = ReANY(r);
7328
7329     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
7330
7331     if (rx && RXp_PAREN_NAMES(rx)) {
7332         if (flags & RXapif_ALL) {
7333             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
7334         } else {
7335             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
7336             if (sv) {
7337                 SvREFCNT_dec_NN(sv);
7338                 return TRUE;
7339             } else {
7340                 return FALSE;
7341             }
7342         }
7343     } else {
7344         return FALSE;
7345     }
7346 }
7347
7348 SV*
7349 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
7350 {
7351     struct regexp *const rx = ReANY(r);
7352
7353     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
7354
7355     if ( rx && RXp_PAREN_NAMES(rx) ) {
7356         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
7357
7358         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
7359     } else {
7360         return FALSE;
7361     }
7362 }
7363
7364 SV*
7365 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
7366 {
7367     struct regexp *const rx = ReANY(r);
7368     GET_RE_DEBUG_FLAGS_DECL;
7369
7370     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
7371
7372     if (rx && RXp_PAREN_NAMES(rx)) {
7373         HV *hv = RXp_PAREN_NAMES(rx);
7374         HE *temphe;
7375         while ( (temphe = hv_iternext_flags(hv,0)) ) {
7376             IV i;
7377             IV parno = 0;
7378             SV* sv_dat = HeVAL(temphe);
7379             I32 *nums = (I32*)SvPVX(sv_dat);
7380             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
7381                 if ((I32)(rx->lastparen) >= nums[i] &&
7382                     rx->offs[nums[i]].start != -1 &&
7383                     rx->offs[nums[i]].end != -1)
7384                 {
7385                     parno = nums[i];
7386                     break;
7387                 }
7388             }
7389             if (parno || flags & RXapif_ALL) {
7390                 return newSVhek(HeKEY_hek(temphe));
7391             }
7392         }
7393     }
7394     return NULL;
7395 }
7396
7397 SV*
7398 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
7399 {
7400     SV *ret;
7401     AV *av;
7402     SSize_t length;
7403     struct regexp *const rx = ReANY(r);
7404
7405     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
7406
7407     if (rx && RXp_PAREN_NAMES(rx)) {
7408         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
7409             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
7410         } else if (flags & RXapif_ONE) {
7411             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
7412             av = MUTABLE_AV(SvRV(ret));
7413             length = av_tindex(av);
7414             SvREFCNT_dec_NN(ret);
7415             return newSViv(length + 1);
7416         } else {
7417             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar",
7418                                                 (int)flags);
7419             return NULL;
7420         }
7421     }
7422     return &PL_sv_undef;
7423 }
7424
7425 SV*
7426 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
7427 {
7428     struct regexp *const rx = ReANY(r);
7429     AV *av = newAV();
7430
7431     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
7432
7433     if (rx && RXp_PAREN_NAMES(rx)) {
7434         HV *hv= RXp_PAREN_NAMES(rx);
7435         HE *temphe;
7436         (void)hv_iterinit(hv);
7437         while ( (temphe = hv_iternext_flags(hv,0)) ) {
7438             IV i;
7439             IV parno = 0;
7440             SV* sv_dat = HeVAL(temphe);
7441             I32 *nums = (I32*)SvPVX(sv_dat);
7442             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
7443                 if ((I32)(rx->lastparen) >= nums[i] &&
7444                     rx->offs[nums[i]].start != -1 &&
7445                     rx->offs[nums[i]].end != -1)
7446                 {
7447                     parno = nums[i];
7448                     break;
7449                 }
7450             }
7451             if (parno || flags & RXapif_ALL) {
7452                 av_push(av, newSVhek(HeKEY_hek(temphe)));
7453             }
7454         }
7455     }
7456
7457     return newRV_noinc(MUTABLE_SV(av));
7458 }
7459
7460 void
7461 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
7462                              SV * const sv)
7463 {
7464     struct regexp *const rx = ReANY(r);
7465     char *s = NULL;
7466     SSize_t i = 0;
7467     SSize_t s1, t1;
7468     I32 n = paren;
7469
7470     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
7471
7472     if (      n == RX_BUFF_IDX_CARET_PREMATCH
7473            || n == RX_BUFF_IDX_CARET_FULLMATCH
7474            || n == RX_BUFF_IDX_CARET_POSTMATCH
7475        )
7476     {
7477         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
7478         if (!keepcopy) {
7479             /* on something like
7480              *    $r = qr/.../;
7481              *    /$qr/p;
7482              * the KEEPCOPY is set on the PMOP rather than the regex */
7483             if (PL_curpm && r == PM_GETRE(PL_curpm))
7484                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
7485         }
7486         if (!keepcopy)
7487             goto ret_undef;
7488     }
7489
7490     if (!rx->subbeg)
7491         goto ret_undef;
7492
7493     if (n == RX_BUFF_IDX_CARET_FULLMATCH)
7494         /* no need to distinguish between them any more */
7495         n = RX_BUFF_IDX_FULLMATCH;
7496
7497     if ((n == RX_BUFF_IDX_PREMATCH || n == RX_BUFF_IDX_CARET_PREMATCH)
7498         && rx->offs[0].start != -1)
7499     {
7500         /* $`, ${^PREMATCH} */
7501         i = rx->offs[0].start;
7502         s = rx->subbeg;
7503     }
7504     else
7505     if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
7506         && rx->offs[0].end != -1)
7507     {
7508         /* $', ${^POSTMATCH} */
7509         s = rx->subbeg - rx->suboffset + rx->offs[0].end;
7510         i = rx->sublen + rx->suboffset - rx->offs[0].end;
7511     }
7512     else
7513     if ( 0 <= n && n <= (I32)rx->nparens &&
7514         (s1 = rx->offs[n].start) != -1 &&
7515         (t1 = rx->offs[n].end) != -1)
7516     {
7517         /* $&, ${^MATCH},  $1 ... */
7518         i = t1 - s1;
7519         s = rx->subbeg + s1 - rx->suboffset;
7520     } else {
7521         goto ret_undef;
7522     }
7523
7524     assert(s >= rx->subbeg);
7525     assert((STRLEN)rx->sublen >= (STRLEN)((s - rx->subbeg) + i) );
7526     if (i >= 0) {
7527 #ifdef NO_TAINT_SUPPORT
7528         sv_setpvn(sv, s, i);
7529 #else
7530         const int oldtainted = TAINT_get;
7531         TAINT_NOT;
7532         sv_setpvn(sv, s, i);
7533         TAINT_set(oldtainted);
7534 #endif
7535         if ( (rx->intflags & PREGf_CANY_SEEN)
7536             ? (RXp_MATCH_UTF8(rx)
7537                         && (!i || is_utf8_string((U8*)s, i)))
7538             : (RXp_MATCH_UTF8(rx)) )
7539         {
7540             SvUTF8_on(sv);
7541         }
7542         else
7543             SvUTF8_off(sv);
7544         if (TAINTING_get) {
7545             if (RXp_MATCH_TAINTED(rx)) {
7546                 if (SvTYPE(sv) >= SVt_PVMG) {
7547                     MAGIC* const mg = SvMAGIC(sv);
7548                     MAGIC* mgt;
7549                     TAINT;
7550                     SvMAGIC_set(sv, mg->mg_moremagic);
7551                     SvTAINT(sv);
7552                     if ((mgt = SvMAGIC(sv))) {
7553                         mg->mg_moremagic = mgt;
7554                         SvMAGIC_set(sv, mg);
7555                     }
7556                 } else {
7557                     TAINT;
7558                     SvTAINT(sv);
7559                 }
7560             } else
7561                 SvTAINTED_off(sv);
7562         }
7563     } else {
7564       ret_undef:
7565         sv_setsv(sv,&PL_sv_undef);
7566         return;
7567     }
7568 }
7569
7570 void
7571 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
7572                                                          SV const * const value)
7573 {
7574     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
7575
7576     PERL_UNUSED_ARG(rx);
7577     PERL_UNUSED_ARG(paren);
7578     PERL_UNUSED_ARG(value);
7579
7580     if (!PL_localizing)
7581         Perl_croak_no_modify();
7582 }
7583
7584 I32
7585 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
7586                               const I32 paren)
7587 {
7588     struct regexp *const rx = ReANY(r);
7589     I32 i;
7590     I32 s1, t1;
7591
7592     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
7593
7594     if (   paren == RX_BUFF_IDX_CARET_PREMATCH
7595         || paren == RX_BUFF_IDX_CARET_FULLMATCH
7596         || paren == RX_BUFF_IDX_CARET_POSTMATCH
7597     )
7598     {
7599         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
7600         if (!keepcopy) {
7601             /* on something like
7602              *    $r = qr/.../;
7603              *    /$qr/p;
7604              * the KEEPCOPY is set on the PMOP rather than the regex */
7605             if (PL_curpm && r == PM_GETRE(PL_curpm))
7606                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
7607         }
7608         if (!keepcopy)
7609             goto warn_undef;
7610     }
7611
7612     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
7613     switch (paren) {
7614       case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */
7615       case RX_BUFF_IDX_PREMATCH:       /* $` */
7616         if (rx->offs[0].start != -1) {
7617                         i = rx->offs[0].start;
7618                         if (i > 0) {
7619                                 s1 = 0;
7620                                 t1 = i;
7621                                 goto getlen;
7622                         }
7623             }
7624         return 0;
7625
7626       case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */
7627       case RX_BUFF_IDX_POSTMATCH:       /* $' */
7628             if (rx->offs[0].end != -1) {
7629                         i = rx->sublen - rx->offs[0].end;
7630                         if (i > 0) {
7631                                 s1 = rx->offs[0].end;
7632                                 t1 = rx->sublen;
7633                                 goto getlen;
7634                         }
7635             }
7636         return 0;
7637
7638       default: /* $& / ${^MATCH}, $1, $2, ... */
7639             if (paren <= (I32)rx->nparens &&
7640             (s1 = rx->offs[paren].start) != -1 &&
7641             (t1 = rx->offs[paren].end) != -1)
7642             {
7643             i = t1 - s1;
7644             goto getlen;
7645         } else {
7646           warn_undef:
7647             if (ckWARN(WARN_UNINITIALIZED))
7648                 report_uninit((const SV *)sv);
7649             return 0;
7650         }
7651     }
7652   getlen:
7653     if (i > 0 && RXp_MATCH_UTF8(rx)) {
7654         const char * const s = rx->subbeg - rx->suboffset + s1;
7655         const U8 *ep;
7656         STRLEN el;
7657
7658         i = t1 - s1;
7659         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
7660                         i = el;
7661     }
7662     return i;
7663 }
7664
7665 SV*
7666 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
7667 {
7668     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
7669         PERL_UNUSED_ARG(rx);
7670         if (0)
7671             return NULL;
7672         else
7673             return newSVpvs("Regexp");
7674 }
7675
7676 /* Scans the name of a named buffer from the pattern.
7677  * If flags is REG_RSN_RETURN_NULL returns null.
7678  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
7679  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
7680  * to the parsed name as looked up in the RExC_paren_names hash.
7681  * If there is an error throws a vFAIL().. type exception.
7682  */
7683
7684 #define REG_RSN_RETURN_NULL    0
7685 #define REG_RSN_RETURN_NAME    1
7686 #define REG_RSN_RETURN_DATA    2
7687
7688 STATIC SV*
7689 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
7690 {
7691     char *name_start = RExC_parse;
7692
7693     PERL_ARGS_ASSERT_REG_SCAN_NAME;
7694
7695     assert (RExC_parse <= RExC_end);
7696     if (RExC_parse == RExC_end) NOOP;
7697     else if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
7698          /* skip IDFIRST by using do...while */
7699         if (UTF)
7700             do {
7701                 RExC_parse += UTF8SKIP(RExC_parse);
7702             } while (isWORDCHAR_utf8((U8*)RExC_parse));
7703         else
7704             do {
7705                 RExC_parse++;
7706             } while (isWORDCHAR(*RExC_parse));
7707     } else {
7708         RExC_parse++; /* so the <- from the vFAIL is after the offending
7709                          character */
7710         vFAIL("Group name must start with a non-digit word character");
7711     }
7712     if ( flags ) {
7713         SV* sv_name
7714             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
7715                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
7716         if ( flags == REG_RSN_RETURN_NAME)
7717             return sv_name;
7718         else if (flags==REG_RSN_RETURN_DATA) {
7719             HE *he_str = NULL;
7720             SV *sv_dat = NULL;
7721             if ( ! sv_name )      /* should not happen*/
7722                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
7723             if (RExC_paren_names)
7724                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
7725             if ( he_str )
7726                 sv_dat = HeVAL(he_str);
7727             if ( ! sv_dat )
7728                 vFAIL("Reference to nonexistent named group");
7729             return sv_dat;
7730         }
7731         else {
7732             Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
7733                        (unsigned long) flags);
7734         }
7735         assert(0); /* NOT REACHED */
7736     }
7737     return NULL;
7738 }
7739
7740 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
7741     int rem=(int)(RExC_end - RExC_parse);                       \
7742     int cut;                                                    \
7743     int num;                                                    \
7744     int iscut=0;                                                \
7745     if (rem>10) {                                               \
7746         rem=10;                                                 \
7747         iscut=1;                                                \
7748     }                                                           \
7749     cut=10-rem;                                                 \
7750     if (RExC_lastparse!=RExC_parse)                             \
7751         PerlIO_printf(Perl_debug_log," >%.*s%-*s",              \
7752             rem, RExC_parse,                                    \
7753             cut + 4,                                            \
7754             iscut ? "..." : "<"                                 \
7755         );                                                      \
7756     else                                                        \
7757         PerlIO_printf(Perl_debug_log,"%16s","");                \
7758                                                                 \
7759     if (SIZE_ONLY)                                              \
7760        num = RExC_size + 1;                                     \
7761     else                                                        \
7762        num=REG_NODE_NUM(RExC_emit);                             \
7763     if (RExC_lastnum!=num)                                      \
7764        PerlIO_printf(Perl_debug_log,"|%4d",num);                \
7765     else                                                        \
7766        PerlIO_printf(Perl_debug_log,"|%4s","");                 \
7767     PerlIO_printf(Perl_debug_log,"|%*s%-4s",                    \
7768         (int)((depth*2)), "",                                   \
7769         (funcname)                                              \
7770     );                                                          \
7771     RExC_lastnum=num;                                           \
7772     RExC_lastparse=RExC_parse;                                  \
7773 })
7774
7775
7776
7777 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
7778     DEBUG_PARSE_MSG((funcname));                            \
7779     PerlIO_printf(Perl_debug_log,"%4s","\n");               \
7780 })
7781 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({           \
7782     DEBUG_PARSE_MSG((funcname));                            \
7783     PerlIO_printf(Perl_debug_log,fmt "\n",args);               \
7784 })
7785
7786 /* This section of code defines the inversion list object and its methods.  The
7787  * interfaces are highly subject to change, so as much as possible is static to
7788  * this file.  An inversion list is here implemented as a malloc'd C UV array
7789  * as an SVt_INVLIST scalar.
7790  *
7791  * An inversion list for Unicode is an array of code points, sorted by ordinal
7792  * number.  The zeroth element is the first code point in the list.  The 1th
7793  * element is the first element beyond that not in the list.  In other words,
7794  * the first range is
7795  *  invlist[0]..(invlist[1]-1)
7796  * The other ranges follow.  Thus every element whose index is divisible by two
7797  * marks the beginning of a range that is in the list, and every element not
7798  * divisible by two marks the beginning of a range not in the list.  A single
7799  * element inversion list that contains the single code point N generally
7800  * consists of two elements
7801  *  invlist[0] == N
7802  *  invlist[1] == N+1
7803  * (The exception is when N is the highest representable value on the
7804  * machine, in which case the list containing just it would be a single
7805  * element, itself.  By extension, if the last range in the list extends to
7806  * infinity, then the first element of that range will be in the inversion list
7807  * at a position that is divisible by two, and is the final element in the
7808  * list.)
7809  * Taking the complement (inverting) an inversion list is quite simple, if the
7810  * first element is 0, remove it; otherwise add a 0 element at the beginning.
7811  * This implementation reserves an element at the beginning of each inversion
7812  * list to always contain 0; there is an additional flag in the header which
7813  * indicates if the list begins at the 0, or is offset to begin at the next
7814  * element.
7815  *
7816  * More about inversion lists can be found in "Unicode Demystified"
7817  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
7818  * More will be coming when functionality is added later.
7819  *
7820  * The inversion list data structure is currently implemented as an SV pointing
7821  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
7822  * array of UV whose memory management is automatically handled by the existing
7823  * facilities for SV's.
7824  *
7825  * Some of the methods should always be private to the implementation, and some
7826  * should eventually be made public */
7827
7828 /* The header definitions are in F<inline_invlist.c> */
7829
7830 PERL_STATIC_INLINE UV*
7831 S__invlist_array_init(SV* const invlist, const bool will_have_0)
7832 {
7833     /* Returns a pointer to the first element in the inversion list's array.
7834      * This is called upon initialization of an inversion list.  Where the
7835      * array begins depends on whether the list has the code point U+0000 in it
7836      * or not.  The other parameter tells it whether the code that follows this
7837      * call is about to put a 0 in the inversion list or not.  The first
7838      * element is either the element reserved for 0, if TRUE, or the element
7839      * after it, if FALSE */
7840
7841     bool* offset = get_invlist_offset_addr(invlist);
7842     UV* zero_addr = (UV *) SvPVX(invlist);
7843
7844     PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
7845
7846     /* Must be empty */
7847     assert(! _invlist_len(invlist));
7848
7849     *zero_addr = 0;
7850
7851     /* 1^1 = 0; 1^0 = 1 */
7852     *offset = 1 ^ will_have_0;
7853     return zero_addr + *offset;
7854 }
7855
7856 PERL_STATIC_INLINE UV*
7857 S_invlist_array(SV* const invlist)
7858 {
7859     /* Returns the pointer to the inversion list's array.  Every time the
7860      * length changes, this needs to be called in case malloc or realloc moved
7861      * it */
7862
7863     PERL_ARGS_ASSERT_INVLIST_ARRAY;
7864
7865     /* Must not be empty.  If these fail, you probably didn't check for <len>
7866      * being non-zero before trying to get the array */
7867     assert(_invlist_len(invlist));
7868
7869     /* The very first element always contains zero, The array begins either
7870      * there, or if the inversion list is offset, at the element after it.
7871      * The offset header field determines which; it contains 0 or 1 to indicate
7872      * how much additionally to add */
7873     assert(0 == *(SvPVX(invlist)));
7874     return ((UV *) SvPVX(invlist) + *get_invlist_offset_addr(invlist));
7875 }
7876
7877 PERL_STATIC_INLINE void
7878 S_invlist_set_len(pTHX_ SV* const invlist, const UV len, const bool offset)
7879 {
7880     /* Sets the current number of elements stored in the inversion list.
7881      * Updates SvCUR correspondingly */
7882     PERL_UNUSED_CONTEXT;
7883     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
7884
7885     assert(SvTYPE(invlist) == SVt_INVLIST);
7886
7887     SvCUR_set(invlist,
7888               (len == 0)
7889                ? 0
7890                : TO_INTERNAL_SIZE(len + offset));
7891     assert(SvLEN(invlist) == 0 || SvCUR(invlist) <= SvLEN(invlist));
7892 }
7893
7894 PERL_STATIC_INLINE IV*
7895 S_get_invlist_previous_index_addr(SV* invlist)
7896 {
7897     /* Return the address of the IV that is reserved to hold the cached index
7898      * */
7899     PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR;
7900
7901     assert(SvTYPE(invlist) == SVt_INVLIST);
7902
7903     return &(((XINVLIST*) SvANY(invlist))->prev_index);
7904 }
7905
7906 PERL_STATIC_INLINE IV
7907 S_invlist_previous_index(SV* const invlist)
7908 {
7909     /* Returns cached index of previous search */
7910
7911     PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX;
7912
7913     return *get_invlist_previous_index_addr(invlist);
7914 }
7915
7916 PERL_STATIC_INLINE void
7917 S_invlist_set_previous_index(SV* const invlist, const IV index)
7918 {
7919     /* Caches <index> for later retrieval */
7920
7921     PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX;
7922
7923     assert(index == 0 || index < (int) _invlist_len(invlist));
7924
7925     *get_invlist_previous_index_addr(invlist) = index;
7926 }
7927
7928 PERL_STATIC_INLINE UV
7929 S_invlist_max(SV* const invlist)
7930 {
7931     /* Returns the maximum number of elements storable in the inversion list's
7932      * array, without having to realloc() */
7933
7934     PERL_ARGS_ASSERT_INVLIST_MAX;
7935
7936     assert(SvTYPE(invlist) == SVt_INVLIST);
7937
7938     /* Assumes worst case, in which the 0 element is not counted in the
7939      * inversion list, so subtracts 1 for that */
7940     return SvLEN(invlist) == 0  /* This happens under _new_invlist_C_array */
7941            ? FROM_INTERNAL_SIZE(SvCUR(invlist)) - 1
7942            : FROM_INTERNAL_SIZE(SvLEN(invlist)) - 1;
7943 }
7944
7945 #ifndef PERL_IN_XSUB_RE
7946 SV*
7947 Perl__new_invlist(pTHX_ IV initial_size)
7948 {
7949
7950     /* Return a pointer to a newly constructed inversion list, with enough
7951      * space to store 'initial_size' elements.  If that number is negative, a
7952      * system default is used instead */
7953
7954     SV* new_list;
7955
7956     if (initial_size < 0) {
7957         initial_size = 10;
7958     }
7959
7960     /* Allocate the initial space */
7961     new_list = newSV_type(SVt_INVLIST);
7962
7963     /* First 1 is in case the zero element isn't in the list; second 1 is for
7964      * trailing NUL */
7965     SvGROW(new_list, TO_INTERNAL_SIZE(initial_size + 1) + 1);
7966     invlist_set_len(new_list, 0, 0);
7967
7968     /* Force iterinit() to be used to get iteration to work */
7969     *get_invlist_iter_addr(new_list) = (STRLEN) UV_MAX;
7970
7971     *get_invlist_previous_index_addr(new_list) = 0;
7972
7973     return new_list;
7974 }
7975
7976 SV*
7977 Perl__new_invlist_C_array(pTHX_ const UV* const list)
7978 {
7979     /* Return a pointer to a newly constructed inversion list, initialized to
7980      * point to <list>, which has to be in the exact correct inversion list
7981      * form, including internal fields.  Thus this is a dangerous routine that
7982      * should not be used in the wrong hands.  The passed in 'list' contains
7983      * several header fields at the beginning that are not part of the
7984      * inversion list body proper */
7985
7986     const STRLEN length = (STRLEN) list[0];
7987     const UV version_id =          list[1];
7988     const bool offset   =    cBOOL(list[2]);
7989 #define HEADER_LENGTH 3
7990     /* If any of the above changes in any way, you must change HEADER_LENGTH
7991      * (if appropriate) and regenerate INVLIST_VERSION_ID by running
7992      *      perl -E 'say int(rand 2**31-1)'
7993      */
7994 #define INVLIST_VERSION_ID 148565664 /* This is a combination of a version and
7995                                         data structure type, so that one being
7996                                         passed in can be validated to be an
7997                                         inversion list of the correct vintage.
7998                                        */
7999
8000     SV* invlist = newSV_type(SVt_INVLIST);
8001
8002     PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
8003
8004     if (version_id != INVLIST_VERSION_ID) {
8005         Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
8006     }
8007
8008     /* The generated array passed in includes header elements that aren't part
8009      * of the list proper, so start it just after them */
8010     SvPV_set(invlist, (char *) (list + HEADER_LENGTH));
8011
8012     SvLEN_set(invlist, 0);  /* Means we own the contents, and the system
8013                                shouldn't touch it */
8014
8015     *(get_invlist_offset_addr(invlist)) = offset;
8016
8017     /* The 'length' passed to us is the physical number of elements in the
8018      * inversion list.  But if there is an offset the logical number is one
8019      * less than that */
8020     invlist_set_len(invlist, length  - offset, offset);
8021
8022     invlist_set_previous_index(invlist, 0);
8023
8024     /* Initialize the iteration pointer. */
8025     invlist_iterfinish(invlist);
8026
8027     SvREADONLY_on(invlist);
8028
8029     return invlist;
8030 }
8031 #endif /* ifndef PERL_IN_XSUB_RE */
8032
8033 STATIC void
8034 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
8035 {
8036     /* Grow the maximum size of an inversion list */
8037
8038     PERL_ARGS_ASSERT_INVLIST_EXTEND;
8039
8040     assert(SvTYPE(invlist) == SVt_INVLIST);
8041
8042     /* Add one to account for the zero element at the beginning which may not
8043      * be counted by the calling parameters */
8044     SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max + 1));
8045 }
8046
8047 PERL_STATIC_INLINE void
8048 S_invlist_trim(SV* const invlist)
8049 {
8050     PERL_ARGS_ASSERT_INVLIST_TRIM;
8051
8052     assert(SvTYPE(invlist) == SVt_INVLIST);
8053
8054     /* Change the length of the inversion list to how many entries it currently
8055      * has */
8056     SvPV_shrink_to_cur((SV *) invlist);
8057 }
8058
8059 STATIC void
8060 S__append_range_to_invlist(pTHX_ SV* const invlist,
8061                                  const UV start, const UV end)
8062 {
8063    /* Subject to change or removal.  Append the range from 'start' to 'end' at
8064     * the end of the inversion list.  The range must be above any existing
8065     * ones. */
8066
8067     UV* array;
8068     UV max = invlist_max(invlist);
8069     UV len = _invlist_len(invlist);
8070     bool offset;
8071
8072     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
8073
8074     if (len == 0) { /* Empty lists must be initialized */
8075         offset = start != 0;
8076         array = _invlist_array_init(invlist, ! offset);
8077     }
8078     else {
8079         /* Here, the existing list is non-empty. The current max entry in the
8080          * list is generally the first value not in the set, except when the
8081          * set extends to the end of permissible values, in which case it is
8082          * the first entry in that final set, and so this call is an attempt to
8083          * append out-of-order */
8084
8085         UV final_element = len - 1;
8086         array = invlist_array(invlist);
8087         if (array[final_element] > start
8088             || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
8089         {
8090             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",
8091                      array[final_element], start,
8092                      ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
8093         }
8094
8095         /* Here, it is a legal append.  If the new range begins with the first
8096          * value not in the set, it is extending the set, so the new first
8097          * value not in the set is one greater than the newly extended range.
8098          * */
8099         offset = *get_invlist_offset_addr(invlist);
8100         if (array[final_element] == start) {
8101             if (end != UV_MAX) {
8102                 array[final_element] = end + 1;
8103             }
8104             else {
8105                 /* But if the end is the maximum representable on the machine,
8106                  * just let the range that this would extend to have no end */
8107                 invlist_set_len(invlist, len - 1, offset);
8108             }
8109             return;
8110         }
8111     }
8112
8113     /* Here the new range doesn't extend any existing set.  Add it */
8114
8115     len += 2;   /* Includes an element each for the start and end of range */
8116
8117     /* If wll overflow the existing space, extend, which may cause the array to
8118      * be moved */
8119     if (max < len) {
8120         invlist_extend(invlist, len);
8121
8122         /* Have to set len here to avoid assert failure in invlist_array() */
8123         invlist_set_len(invlist, len, offset);
8124
8125         array = invlist_array(invlist);
8126     }
8127     else {
8128         invlist_set_len(invlist, len, offset);
8129     }
8130
8131     /* The next item on the list starts the range, the one after that is
8132      * one past the new range.  */
8133     array[len - 2] = start;
8134     if (end != UV_MAX) {
8135         array[len - 1] = end + 1;
8136     }
8137     else {
8138         /* But if the end is the maximum representable on the machine, just let
8139          * the range have no end */
8140         invlist_set_len(invlist, len - 1, offset);
8141     }
8142 }
8143
8144 #ifndef PERL_IN_XSUB_RE
8145
8146 IV
8147 Perl__invlist_search(SV* const invlist, const UV cp)
8148 {
8149     /* Searches the inversion list for the entry that contains the input code
8150      * point <cp>.  If <cp> is not in the list, -1 is returned.  Otherwise, the
8151      * return value is the index into the list's array of the range that
8152      * contains <cp> */
8153
8154     IV low = 0;
8155     IV mid;
8156     IV high = _invlist_len(invlist);
8157     const IV highest_element = high - 1;
8158     const UV* array;
8159
8160     PERL_ARGS_ASSERT__INVLIST_SEARCH;
8161
8162     /* If list is empty, return failure. */
8163     if (high == 0) {
8164         return -1;
8165     }
8166
8167     /* (We can't get the array unless we know the list is non-empty) */
8168     array = invlist_array(invlist);
8169
8170     mid = invlist_previous_index(invlist);
8171     assert(mid >=0 && mid <= highest_element);
8172
8173     /* <mid> contains the cache of the result of the previous call to this
8174      * function (0 the first time).  See if this call is for the same result,
8175      * or if it is for mid-1.  This is under the theory that calls to this
8176      * function will often be for related code points that are near each other.
8177      * And benchmarks show that caching gives better results.  We also test
8178      * here if the code point is within the bounds of the list.  These tests
8179      * replace others that would have had to be made anyway to make sure that
8180      * the array bounds were not exceeded, and these give us extra information
8181      * at the same time */
8182     if (cp >= array[mid]) {
8183         if (cp >= array[highest_element]) {
8184             return highest_element;
8185         }
8186
8187         /* Here, array[mid] <= cp < array[highest_element].  This means that
8188          * the final element is not the answer, so can exclude it; it also
8189          * means that <mid> is not the final element, so can refer to 'mid + 1'
8190          * safely */
8191         if (cp < array[mid + 1]) {
8192             return mid;
8193         }
8194         high--;
8195         low = mid + 1;
8196     }
8197     else { /* cp < aray[mid] */
8198         if (cp < array[0]) { /* Fail if outside the array */
8199             return -1;
8200         }
8201         high = mid;
8202         if (cp >= array[mid - 1]) {
8203             goto found_entry;
8204         }
8205     }
8206
8207     /* Binary search.  What we are looking for is <i> such that
8208      *  array[i] <= cp < array[i+1]
8209      * The loop below converges on the i+1.  Note that there may not be an
8210      * (i+1)th element in the array, and things work nonetheless */
8211     while (low < high) {
8212         mid = (low + high) / 2;
8213         assert(mid <= highest_element);
8214         if (array[mid] <= cp) { /* cp >= array[mid] */
8215             low = mid + 1;
8216
8217             /* We could do this extra test to exit the loop early.
8218             if (cp < array[low]) {
8219                 return mid;
8220             }
8221             */
8222         }
8223         else { /* cp < array[mid] */
8224             high = mid;
8225         }
8226     }
8227
8228   found_entry:
8229     high--;
8230     invlist_set_previous_index(invlist, high);
8231     return high;
8232 }
8233
8234 void
8235 Perl__invlist_populate_swatch(SV* const invlist,
8236                               const UV start, const UV end, U8* swatch)
8237 {
8238     /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
8239      * but is used when the swash has an inversion list.  This makes this much
8240      * faster, as it uses a binary search instead of a linear one.  This is
8241      * intimately tied to that function, and perhaps should be in utf8.c,
8242      * except it is intimately tied to inversion lists as well.  It assumes
8243      * that <swatch> is all 0's on input */
8244
8245     UV current = start;
8246     const IV len = _invlist_len(invlist);
8247     IV i;
8248     const UV * array;
8249
8250     PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
8251
8252     if (len == 0) { /* Empty inversion list */
8253         return;
8254     }
8255
8256     array = invlist_array(invlist);
8257
8258     /* Find which element it is */
8259     i = _invlist_search(invlist, start);
8260
8261     /* We populate from <start> to <end> */
8262     while (current < end) {
8263         UV upper;
8264
8265         /* The inversion list gives the results for every possible code point
8266          * after the first one in the list.  Only those ranges whose index is
8267          * even are ones that the inversion list matches.  For the odd ones,
8268          * and if the initial code point is not in the list, we have to skip
8269          * forward to the next element */
8270         if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
8271             i++;
8272             if (i >= len) { /* Finished if beyond the end of the array */
8273                 return;
8274             }
8275             current = array[i];
8276             if (current >= end) {   /* Finished if beyond the end of what we
8277                                        are populating */
8278                 if (LIKELY(end < UV_MAX)) {
8279                     return;
8280                 }
8281
8282                 /* We get here when the upper bound is the maximum
8283                  * representable on the machine, and we are looking for just
8284                  * that code point.  Have to special case it */
8285                 i = len;
8286                 goto join_end_of_list;
8287             }
8288         }
8289         assert(current >= start);
8290
8291         /* The current range ends one below the next one, except don't go past
8292          * <end> */
8293         i++;
8294         upper = (i < len && array[i] < end) ? array[i] : end;
8295
8296         /* Here we are in a range that matches.  Populate a bit in the 3-bit U8
8297          * for each code point in it */
8298         for (; current < upper; current++) {
8299             const STRLEN offset = (STRLEN)(current - start);
8300             swatch[offset >> 3] |= 1 << (offset & 7);
8301         }
8302
8303     join_end_of_list:
8304
8305         /* Quit if at the end of the list */
8306         if (i >= len) {
8307
8308             /* But first, have to deal with the highest possible code point on
8309              * the platform.  The previous code assumes that <end> is one
8310              * beyond where we want to populate, but that is impossible at the
8311              * platform's infinity, so have to handle it specially */
8312             if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
8313             {
8314                 const STRLEN offset = (STRLEN)(end - start);
8315                 swatch[offset >> 3] |= 1 << (offset & 7);
8316             }
8317             return;
8318         }
8319
8320         /* Advance to the next range, which will be for code points not in the
8321          * inversion list */
8322         current = array[i];
8323     }
8324
8325     return;
8326 }
8327
8328 void
8329 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
8330                                          const bool complement_b, SV** output)
8331 {
8332     /* Take the union of two inversion lists and point <output> to it.  *output
8333      * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
8334      * the reference count to that list will be decremented if not already a
8335      * temporary (mortal); otherwise *output will be made correspondingly
8336      * mortal.  The first list, <a>, may be NULL, in which case a copy of the
8337      * second list is returned.  If <complement_b> is TRUE, the union is taken
8338      * of the complement (inversion) of <b> instead of b itself.
8339      *
8340      * The basis for this comes from "Unicode Demystified" Chapter 13 by
8341      * Richard Gillam, published by Addison-Wesley, and explained at some
8342      * length there.  The preface says to incorporate its examples into your
8343      * code at your own risk.
8344      *
8345      * The algorithm is like a merge sort.
8346      *
8347      * XXX A potential performance improvement is to keep track as we go along
8348      * if only one of the inputs contributes to the result, meaning the other
8349      * is a subset of that one.  In that case, we can skip the final copy and
8350      * return the larger of the input lists, but then outside code might need
8351      * to keep track of whether to free the input list or not */
8352
8353     const UV* array_a;    /* a's array */
8354     const UV* array_b;
8355     UV len_a;       /* length of a's array */
8356     UV len_b;
8357
8358     SV* u;                      /* the resulting union */
8359     UV* array_u;
8360     UV len_u;
8361
8362     UV i_a = 0;             /* current index into a's array */
8363     UV i_b = 0;
8364     UV i_u = 0;
8365
8366     /* running count, as explained in the algorithm source book; items are
8367      * stopped accumulating and are output when the count changes to/from 0.
8368      * The count is incremented when we start a range that's in the set, and
8369      * decremented when we start a range that's not in the set.  So its range
8370      * is 0 to 2.  Only when the count is zero is something not in the set.
8371      */
8372     UV count = 0;
8373
8374     PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
8375     assert(a != b);
8376
8377     /* If either one is empty, the union is the other one */
8378     if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
8379         bool make_temp = FALSE; /* Should we mortalize the result? */
8380
8381         if (*output == a) {
8382             if (a != NULL) {
8383                 if (! (make_temp = cBOOL(SvTEMP(a)))) {
8384                     SvREFCNT_dec_NN(a);
8385                 }
8386             }
8387         }
8388         if (*output != b) {
8389             *output = invlist_clone(b);
8390             if (complement_b) {
8391                 _invlist_invert(*output);
8392             }
8393         } /* else *output already = b; */
8394
8395         if (make_temp) {
8396             sv_2mortal(*output);
8397         }
8398         return;
8399     }
8400     else if ((len_b = _invlist_len(b)) == 0) {
8401         bool make_temp = FALSE;
8402         if (*output == b) {
8403             if (! (make_temp = cBOOL(SvTEMP(b)))) {
8404                 SvREFCNT_dec_NN(b);
8405             }
8406         }
8407
8408         /* The complement of an empty list is a list that has everything in it,
8409          * so the union with <a> includes everything too */
8410         if (complement_b) {
8411             if (a == *output) {
8412                 if (! (make_temp = cBOOL(SvTEMP(a)))) {
8413                     SvREFCNT_dec_NN(a);
8414                 }
8415             }
8416             *output = _new_invlist(1);
8417             _append_range_to_invlist(*output, 0, UV_MAX);
8418         }
8419         else if (*output != a) {
8420             *output = invlist_clone(a);
8421         }
8422         /* else *output already = a; */
8423
8424         if (make_temp) {
8425             sv_2mortal(*output);
8426         }
8427         return;
8428     }
8429
8430     /* Here both lists exist and are non-empty */
8431     array_a = invlist_array(a);
8432     array_b = invlist_array(b);
8433
8434     /* If are to take the union of 'a' with the complement of b, set it
8435      * up so are looking at b's complement. */
8436     if (complement_b) {
8437
8438         /* To complement, we invert: if the first element is 0, remove it.  To
8439          * do this, we just pretend the array starts one later */
8440         if (array_b[0] == 0) {
8441             array_b++;
8442             len_b--;
8443         }
8444         else {
8445
8446             /* But if the first element is not zero, we pretend the list starts
8447              * at the 0 that is always stored immediately before the array. */
8448             array_b--;
8449             len_b++;
8450         }
8451     }
8452
8453     /* Size the union for the worst case: that the sets are completely
8454      * disjoint */
8455     u = _new_invlist(len_a + len_b);
8456
8457     /* Will contain U+0000 if either component does */
8458     array_u = _invlist_array_init(u, (len_a > 0 && array_a[0] == 0)
8459                                       || (len_b > 0 && array_b[0] == 0));
8460
8461     /* Go through each list item by item, stopping when exhausted one of
8462      * them */
8463     while (i_a < len_a && i_b < len_b) {
8464         UV cp;      /* The element to potentially add to the union's array */
8465         bool cp_in_set;   /* is it in the the input list's set or not */
8466
8467         /* We need to take one or the other of the two inputs for the union.
8468          * Since we are merging two sorted lists, we take the smaller of the
8469          * next items.  In case of a tie, we take the one that is in its set
8470          * first.  If we took one not in the set first, it would decrement the
8471          * count, possibly to 0 which would cause it to be output as ending the
8472          * range, and the next time through we would take the same number, and
8473          * output it again as beginning the next range.  By doing it the
8474          * opposite way, there is no possibility that the count will be
8475          * momentarily decremented to 0, and thus the two adjoining ranges will
8476          * be seamlessly merged.  (In a tie and both are in the set or both not
8477          * in the set, it doesn't matter which we take first.) */
8478         if (array_a[i_a] < array_b[i_b]
8479             || (array_a[i_a] == array_b[i_b]
8480                 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
8481         {
8482             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
8483             cp= array_a[i_a++];
8484         }
8485         else {
8486             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
8487             cp = array_b[i_b++];
8488         }
8489
8490         /* Here, have chosen which of the two inputs to look at.  Only output
8491          * if the running count changes to/from 0, which marks the
8492          * beginning/end of a range in that's in the set */
8493         if (cp_in_set) {
8494             if (count == 0) {
8495                 array_u[i_u++] = cp;
8496             }
8497             count++;
8498         }
8499         else {
8500             count--;
8501             if (count == 0) {
8502                 array_u[i_u++] = cp;
8503             }
8504         }
8505     }
8506
8507     /* Here, we are finished going through at least one of the lists, which
8508      * means there is something remaining in at most one.  We check if the list
8509      * that hasn't been exhausted is positioned such that we are in the middle
8510      * of a range in its set or not.  (i_a and i_b point to the element beyond
8511      * the one we care about.) If in the set, we decrement 'count'; if 0, there
8512      * is potentially more to output.
8513      * There are four cases:
8514      *  1) Both weren't in their sets, count is 0, and remains 0.  What's left
8515      *     in the union is entirely from the non-exhausted set.
8516      *  2) Both were in their sets, count is 2.  Nothing further should
8517      *     be output, as everything that remains will be in the exhausted
8518      *     list's set, hence in the union; decrementing to 1 but not 0 insures
8519      *     that
8520      *  3) the exhausted was in its set, non-exhausted isn't, count is 1.
8521      *     Nothing further should be output because the union includes
8522      *     everything from the exhausted set.  Not decrementing ensures that.
8523      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1;
8524      *     decrementing to 0 insures that we look at the remainder of the
8525      *     non-exhausted set */
8526     if ((i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
8527         || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
8528     {
8529         count--;
8530     }
8531
8532     /* The final length is what we've output so far, plus what else is about to
8533      * be output.  (If 'count' is non-zero, then the input list we exhausted
8534      * has everything remaining up to the machine's limit in its set, and hence
8535      * in the union, so there will be no further output. */
8536     len_u = i_u;
8537     if (count == 0) {
8538         /* At most one of the subexpressions will be non-zero */
8539         len_u += (len_a - i_a) + (len_b - i_b);
8540     }
8541
8542     /* Set result to final length, which can change the pointer to array_u, so
8543      * re-find it */
8544     if (len_u != _invlist_len(u)) {
8545         invlist_set_len(u, len_u, *get_invlist_offset_addr(u));
8546         invlist_trim(u);
8547         array_u = invlist_array(u);
8548     }
8549
8550     /* When 'count' is 0, the list that was exhausted (if one was shorter than
8551      * the other) ended with everything above it not in its set.  That means
8552      * that the remaining part of the union is precisely the same as the
8553      * non-exhausted list, so can just copy it unchanged.  (If both list were
8554      * exhausted at the same time, then the operations below will be both 0.)
8555      */
8556     if (count == 0) {
8557         IV copy_count; /* At most one will have a non-zero copy count */
8558         if ((copy_count = len_a - i_a) > 0) {
8559             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
8560         }
8561         else if ((copy_count = len_b - i_b) > 0) {
8562             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
8563         }
8564     }
8565
8566     /*  We may be removing a reference to one of the inputs.  If so, the output
8567      *  is made mortal if the input was.  (Mortal SVs shouldn't have their ref
8568      *  count decremented) */
8569     if (a == *output || b == *output) {
8570         assert(! invlist_is_iterating(*output));
8571         if ((SvTEMP(*output))) {
8572             sv_2mortal(u);
8573         }
8574         else {
8575             SvREFCNT_dec_NN(*output);
8576         }
8577     }
8578
8579     *output = u;
8580
8581     return;
8582 }
8583
8584 void
8585 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
8586                                                const bool complement_b, SV** i)
8587 {
8588     /* Take the intersection of two inversion lists and point <i> to it.  *i
8589      * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
8590      * the reference count to that list will be decremented if not already a
8591      * temporary (mortal); otherwise *i will be made correspondingly mortal.
8592      * The first list, <a>, may be NULL, in which case an empty list is
8593      * returned.  If <complement_b> is TRUE, the result will be the
8594      * intersection of <a> and the complement (or inversion) of <b> instead of
8595      * <b> directly.
8596      *
8597      * The basis for this comes from "Unicode Demystified" Chapter 13 by
8598      * Richard Gillam, published by Addison-Wesley, and explained at some
8599      * length there.  The preface says to incorporate its examples into your
8600      * code at your own risk.  In fact, it had bugs
8601      *
8602      * The algorithm is like a merge sort, and is essentially the same as the
8603      * union above
8604      */
8605
8606     const UV* array_a;          /* a's array */
8607     const UV* array_b;
8608     UV len_a;   /* length of a's array */
8609     UV len_b;
8610
8611     SV* r;                   /* the resulting intersection */
8612     UV* array_r;
8613     UV len_r;
8614
8615     UV i_a = 0;             /* current index into a's array */
8616     UV i_b = 0;
8617     UV i_r = 0;
8618
8619     /* running count, as explained in the algorithm source book; items are
8620      * stopped accumulating and are output when the count changes to/from 2.
8621      * The count is incremented when we start a range that's in the set, and
8622      * decremented when we start a range that's not in the set.  So its range
8623      * is 0 to 2.  Only when the count is 2 is something in the intersection.
8624      */
8625     UV count = 0;
8626
8627     PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
8628     assert(a != b);
8629
8630     /* Special case if either one is empty */
8631     len_a = (a == NULL) ? 0 : _invlist_len(a);
8632     if ((len_a == 0) || ((len_b = _invlist_len(b)) == 0)) {
8633         bool make_temp = FALSE;
8634
8635         if (len_a != 0 && complement_b) {
8636
8637             /* Here, 'a' is not empty, therefore from the above 'if', 'b' must
8638              * be empty.  Here, also we are using 'b's complement, which hence
8639              * must be every possible code point.  Thus the intersection is
8640              * simply 'a'. */
8641             if (*i != a) {
8642                 if (*i == b) {
8643                     if (! (make_temp = cBOOL(SvTEMP(b)))) {
8644                         SvREFCNT_dec_NN(b);
8645                     }
8646                 }
8647
8648                 *i = invlist_clone(a);
8649             }
8650             /* else *i is already 'a' */
8651
8652             if (make_temp) {
8653                 sv_2mortal(*i);
8654             }
8655             return;
8656         }
8657
8658         /* Here, 'a' or 'b' is empty and not using the complement of 'b'.  The
8659          * intersection must be empty */
8660         if (*i == a) {
8661             if (! (make_temp = cBOOL(SvTEMP(a)))) {
8662                 SvREFCNT_dec_NN(a);
8663             }
8664         }
8665         else if (*i == b) {
8666             if (! (make_temp = cBOOL(SvTEMP(b)))) {
8667                 SvREFCNT_dec_NN(b);
8668             }
8669         }
8670         *i = _new_invlist(0);
8671         if (make_temp) {
8672             sv_2mortal(*i);
8673         }
8674
8675         return;
8676     }
8677
8678     /* Here both lists exist and are non-empty */
8679     array_a = invlist_array(a);
8680     array_b = invlist_array(b);
8681
8682     /* If are to take the intersection of 'a' with the complement of b, set it
8683      * up so are looking at b's complement. */
8684     if (complement_b) {
8685
8686         /* To complement, we invert: if the first element is 0, remove it.  To
8687          * do this, we just pretend the array starts one later */
8688         if (array_b[0] == 0) {
8689             array_b++;
8690             len_b--;
8691         }
8692         else {
8693
8694             /* But if the first element is not zero, we pretend the list starts
8695              * at the 0 that is always stored immediately before the array. */
8696             array_b--;
8697             len_b++;
8698         }
8699     }
8700
8701     /* Size the intersection for the worst case: that the intersection ends up
8702      * fragmenting everything to be completely disjoint */
8703     r= _new_invlist(len_a + len_b);
8704
8705     /* Will contain U+0000 iff both components do */
8706     array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
8707                                      && len_b > 0 && array_b[0] == 0);
8708
8709     /* Go through each list item by item, stopping when exhausted one of
8710      * them */
8711     while (i_a < len_a && i_b < len_b) {
8712         UV cp;      /* The element to potentially add to the intersection's
8713                        array */
8714         bool cp_in_set; /* Is it in the input list's set or not */
8715
8716         /* We need to take one or the other of the two inputs for the
8717          * intersection.  Since we are merging two sorted lists, we take the
8718          * smaller of the next items.  In case of a tie, we take the one that
8719          * is not in its set first (a difference from the union algorithm).  If
8720          * we took one in the set first, it would increment the count, possibly
8721          * to 2 which would cause it to be output as starting a range in the
8722          * intersection, and the next time through we would take that same
8723          * number, and output it again as ending the set.  By doing it the
8724          * opposite of this, there is no possibility that the count will be
8725          * momentarily incremented to 2.  (In a tie and both are in the set or
8726          * both not in the set, it doesn't matter which we take first.) */
8727         if (array_a[i_a] < array_b[i_b]
8728             || (array_a[i_a] == array_b[i_b]
8729                 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
8730         {
8731             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
8732             cp= array_a[i_a++];
8733         }
8734         else {
8735             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
8736             cp= array_b[i_b++];
8737         }
8738
8739         /* Here, have chosen which of the two inputs to look at.  Only output
8740          * if the running count changes to/from 2, which marks the
8741          * beginning/end of a range that's in the intersection */
8742         if (cp_in_set) {
8743             count++;
8744             if (count == 2) {
8745                 array_r[i_r++] = cp;
8746             }
8747         }
8748         else {
8749             if (count == 2) {
8750                 array_r[i_r++] = cp;
8751             }
8752             count--;
8753         }
8754     }
8755
8756     /* Here, we are finished going through at least one of the lists, which
8757      * means there is something remaining in at most one.  We check if the list
8758      * that has been exhausted is positioned such that we are in the middle
8759      * of a range in its set or not.  (i_a and i_b point to elements 1 beyond
8760      * the ones we care about.)  There are four cases:
8761      *  1) Both weren't in their sets, count is 0, and remains 0.  There's
8762      *     nothing left in the intersection.
8763      *  2) Both were in their sets, count is 2 and perhaps is incremented to
8764      *     above 2.  What should be output is exactly that which is in the
8765      *     non-exhausted set, as everything it has is also in the intersection
8766      *     set, and everything it doesn't have can't be in the intersection
8767      *  3) The exhausted was in its set, non-exhausted isn't, count is 1, and
8768      *     gets incremented to 2.  Like the previous case, the intersection is
8769      *     everything that remains in the non-exhausted set.
8770      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1, and
8771      *     remains 1.  And the intersection has nothing more. */
8772     if ((i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
8773         || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
8774     {
8775         count++;
8776     }
8777
8778     /* The final length is what we've output so far plus what else is in the
8779      * intersection.  At most one of the subexpressions below will be non-zero
8780      * */
8781     len_r = i_r;
8782     if (count >= 2) {
8783         len_r += (len_a - i_a) + (len_b - i_b);
8784     }
8785
8786     /* Set result to final length, which can change the pointer to array_r, so
8787      * re-find it */
8788     if (len_r != _invlist_len(r)) {
8789         invlist_set_len(r, len_r, *get_invlist_offset_addr(r));
8790         invlist_trim(r);
8791         array_r = invlist_array(r);
8792     }
8793
8794     /* Finish outputting any remaining */
8795     if (count >= 2) { /* At most one will have a non-zero copy count */
8796         IV copy_count;
8797         if ((copy_count = len_a - i_a) > 0) {
8798             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
8799         }
8800         else if ((copy_count = len_b - i_b) > 0) {
8801             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
8802         }
8803     }
8804
8805     /*  We may be removing a reference to one of the inputs.  If so, the output
8806      *  is made mortal if the input was.  (Mortal SVs shouldn't have their ref
8807      *  count decremented) */
8808     if (a == *i || b == *i) {
8809         assert(! invlist_is_iterating(*i));
8810         if (SvTEMP(*i)) {
8811             sv_2mortal(r);
8812         }
8813         else {
8814             SvREFCNT_dec_NN(*i);
8815         }
8816     }
8817
8818     *i = r;
8819
8820     return;
8821 }
8822
8823 SV*
8824 Perl__add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end)
8825 {
8826     /* Add the range from 'start' to 'end' inclusive to the inversion list's
8827      * set.  A pointer to the inversion list is returned.  This may actually be
8828      * a new list, in which case the passed in one has been destroyed.  The
8829      * passed in inversion list can be NULL, in which case a new one is created
8830      * with just the one range in it */
8831
8832     SV* range_invlist;
8833     UV len;
8834
8835     if (invlist == NULL) {
8836         invlist = _new_invlist(2);
8837         len = 0;
8838     }
8839     else {
8840         len = _invlist_len(invlist);
8841     }
8842
8843     /* If comes after the final entry actually in the list, can just append it
8844      * to the end, */
8845     if (len == 0
8846         || (! ELEMENT_RANGE_MATCHES_INVLIST(len - 1)
8847             && start >= invlist_array(invlist)[len - 1]))
8848     {
8849         _append_range_to_invlist(invlist, start, end);
8850         return invlist;
8851     }
8852
8853     /* Here, can't just append things, create and return a new inversion list
8854      * which is the union of this range and the existing inversion list */
8855     range_invlist = _new_invlist(2);
8856     _append_range_to_invlist(range_invlist, start, end);
8857
8858     _invlist_union(invlist, range_invlist, &invlist);
8859
8860     /* The temporary can be freed */
8861     SvREFCNT_dec_NN(range_invlist);
8862
8863     return invlist;
8864 }
8865
8866 SV*
8867 Perl__setup_canned_invlist(pTHX_ const STRLEN size, const UV element0,
8868                                  UV** other_elements_ptr)
8869 {
8870     /* Create and return an inversion list whose contents are to be populated
8871      * by the caller.  The caller gives the number of elements (in 'size') and
8872      * the very first element ('element0').  This function will set
8873      * '*other_elements_ptr' to an array of UVs, where the remaining elements
8874      * are to be placed.
8875      *
8876      * Obviously there is some trust involved that the caller will properly
8877      * fill in the other elements of the array.
8878      *
8879      * (The first element needs to be passed in, as the underlying code does
8880      * things differently depending on whether it is zero or non-zero) */
8881
8882     SV* invlist = _new_invlist(size);
8883     bool offset;
8884
8885     PERL_ARGS_ASSERT__SETUP_CANNED_INVLIST;
8886
8887     _append_range_to_invlist(invlist, element0, element0);
8888     offset = *get_invlist_offset_addr(invlist);
8889
8890     invlist_set_len(invlist, size, offset);
8891     *other_elements_ptr = invlist_array(invlist) + 1;
8892     return invlist;
8893 }
8894
8895 #endif
8896
8897 PERL_STATIC_INLINE SV*
8898 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
8899     return _add_range_to_invlist(invlist, cp, cp);
8900 }
8901
8902 #ifndef PERL_IN_XSUB_RE
8903 void
8904 Perl__invlist_invert(pTHX_ SV* const invlist)
8905 {
8906     /* Complement the input inversion list.  This adds a 0 if the list didn't
8907      * have a zero; removes it otherwise.  As described above, the data
8908      * structure is set up so that this is very efficient */
8909
8910     PERL_ARGS_ASSERT__INVLIST_INVERT;
8911
8912     assert(! invlist_is_iterating(invlist));
8913
8914     /* The inverse of matching nothing is matching everything */
8915     if (_invlist_len(invlist) == 0) {
8916         _append_range_to_invlist(invlist, 0, UV_MAX);
8917         return;
8918     }
8919
8920     *get_invlist_offset_addr(invlist) = ! *get_invlist_offset_addr(invlist);
8921 }
8922
8923 #endif
8924
8925 PERL_STATIC_INLINE SV*
8926 S_invlist_clone(pTHX_ SV* const invlist)
8927 {
8928
8929     /* Return a new inversion list that is a copy of the input one, which is
8930      * unchanged.  The new list will not be mortal even if the old one was. */
8931
8932     /* Need to allocate extra space to accommodate Perl's addition of a
8933      * trailing NUL to SvPV's, since it thinks they are always strings */
8934     SV* new_invlist = _new_invlist(_invlist_len(invlist) + 1);
8935     STRLEN physical_length = SvCUR(invlist);
8936     bool offset = *(get_invlist_offset_addr(invlist));
8937
8938     PERL_ARGS_ASSERT_INVLIST_CLONE;
8939
8940     *(get_invlist_offset_addr(new_invlist)) = offset;
8941     invlist_set_len(new_invlist, _invlist_len(invlist), offset);
8942     Copy(SvPVX(invlist), SvPVX(new_invlist), physical_length, char);
8943
8944     return new_invlist;
8945 }
8946
8947 PERL_STATIC_INLINE STRLEN*
8948 S_get_invlist_iter_addr(SV* invlist)
8949 {
8950     /* Return the address of the UV that contains the current iteration
8951      * position */
8952
8953     PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
8954
8955     assert(SvTYPE(invlist) == SVt_INVLIST);
8956
8957     return &(((XINVLIST*) SvANY(invlist))->iterator);
8958 }
8959
8960 PERL_STATIC_INLINE void
8961 S_invlist_iterinit(SV* invlist) /* Initialize iterator for invlist */
8962 {
8963     PERL_ARGS_ASSERT_INVLIST_ITERINIT;
8964
8965     *get_invlist_iter_addr(invlist) = 0;
8966 }
8967
8968 PERL_STATIC_INLINE void
8969 S_invlist_iterfinish(SV* invlist)
8970 {
8971     /* Terminate iterator for invlist.  This is to catch development errors.
8972      * Any iteration that is interrupted before completed should call this
8973      * function.  Functions that add code points anywhere else but to the end
8974      * of an inversion list assert that they are not in the middle of an
8975      * iteration.  If they were, the addition would make the iteration
8976      * problematical: if the iteration hadn't reached the place where things
8977      * were being added, it would be ok */
8978
8979     PERL_ARGS_ASSERT_INVLIST_ITERFINISH;
8980
8981     *get_invlist_iter_addr(invlist) = (STRLEN) UV_MAX;
8982 }
8983
8984 STATIC bool
8985 S_invlist_iternext(SV* invlist, UV* start, UV* end)
8986 {
8987     /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
8988      * This call sets in <*start> and <*end>, the next range in <invlist>.
8989      * Returns <TRUE> if successful and the next call will return the next
8990      * range; <FALSE> if was already at the end of the list.  If the latter,
8991      * <*start> and <*end> are unchanged, and the next call to this function
8992      * will start over at the beginning of the list */
8993
8994     STRLEN* pos = get_invlist_iter_addr(invlist);
8995     UV len = _invlist_len(invlist);
8996     UV *array;
8997
8998     PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
8999
9000     if (*pos >= len) {
9001         *pos = (STRLEN) UV_MAX; /* Force iterinit() to be required next time */
9002         return FALSE;
9003     }
9004
9005     array = invlist_array(invlist);
9006
9007     *start = array[(*pos)++];
9008
9009     if (*pos >= len) {
9010         *end = UV_MAX;
9011     }
9012     else {
9013         *end = array[(*pos)++] - 1;
9014     }
9015
9016     return TRUE;
9017 }
9018
9019 PERL_STATIC_INLINE bool
9020 S_invlist_is_iterating(SV* const invlist)
9021 {
9022     PERL_ARGS_ASSERT_INVLIST_IS_ITERATING;
9023
9024     return *(get_invlist_iter_addr(invlist)) < (STRLEN) UV_MAX;
9025 }
9026
9027 PERL_STATIC_INLINE UV
9028 S_invlist_highest(SV* const invlist)
9029 {
9030     /* Returns the highest code point that matches an inversion list.  This API
9031      * has an ambiguity, as it returns 0 under either the highest is actually
9032      * 0, or if the list is empty.  If this distinction matters to you, check
9033      * for emptiness before calling this function */
9034
9035     UV len = _invlist_len(invlist);
9036     UV *array;
9037
9038     PERL_ARGS_ASSERT_INVLIST_HIGHEST;
9039
9040     if (len == 0) {
9041         return 0;
9042     }
9043
9044     array = invlist_array(invlist);
9045
9046     /* The last element in the array in the inversion list always starts a
9047      * range that goes to infinity.  That range may be for code points that are
9048      * matched in the inversion list, or it may be for ones that aren't
9049      * matched.  In the latter case, the highest code point in the set is one
9050      * less than the beginning of this range; otherwise it is the final element
9051      * of this range: infinity */
9052     return (ELEMENT_RANGE_MATCHES_INVLIST(len - 1))
9053            ? UV_MAX
9054            : array[len - 1] - 1;
9055 }
9056
9057 #ifndef PERL_IN_XSUB_RE
9058 SV *
9059 Perl__invlist_contents(pTHX_ SV* const invlist)
9060 {
9061     /* Get the contents of an inversion list into a string SV so that they can
9062      * be printed out.  It uses the format traditionally done for debug tracing
9063      */
9064
9065     UV start, end;
9066     SV* output = newSVpvs("\n");
9067
9068     PERL_ARGS_ASSERT__INVLIST_CONTENTS;
9069
9070     assert(! invlist_is_iterating(invlist));
9071
9072     invlist_iterinit(invlist);
9073     while (invlist_iternext(invlist, &start, &end)) {
9074         if (end == UV_MAX) {
9075             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\tINFINITY\n", start);
9076         }
9077         else if (end != start) {
9078             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\t%04"UVXf"\n",
9079                     start,       end);
9080         }
9081         else {
9082             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\n", start);
9083         }
9084     }
9085
9086     return output;
9087 }
9088 #endif
9089
9090 #ifndef PERL_IN_XSUB_RE
9091 void
9092 Perl__invlist_dump(pTHX_ PerlIO *file, I32 level,
9093                          const char * const indent, SV* const invlist)
9094 {
9095     /* Designed to be called only by do_sv_dump().  Dumps out the ranges of the
9096      * inversion list 'invlist' to 'file' at 'level'  Each line is prefixed by
9097      * the string 'indent'.  The output looks like this:
9098          [0] 0x000A .. 0x000D
9099          [2] 0x0085
9100          [4] 0x2028 .. 0x2029
9101          [6] 0x3104 .. INFINITY
9102      * This means that the first range of code points matched by the list are
9103      * 0xA through 0xD; the second range contains only the single code point
9104      * 0x85, etc.  An inversion list is an array of UVs.  Two array elements
9105      * are used to define each range (except if the final range extends to
9106      * infinity, only a single element is needed).  The array index of the
9107      * first element for the corresponding range is given in brackets. */
9108
9109     UV start, end;
9110     STRLEN count = 0;
9111
9112     PERL_ARGS_ASSERT__INVLIST_DUMP;
9113
9114     if (invlist_is_iterating(invlist)) {
9115         Perl_dump_indent(aTHX_ level, file,
9116              "%sCan't dump inversion list because is in middle of iterating\n",
9117              indent);
9118         return;
9119     }
9120
9121     invlist_iterinit(invlist);
9122     while (invlist_iternext(invlist, &start, &end)) {
9123         if (end == UV_MAX) {
9124             Perl_dump_indent(aTHX_ level, file,
9125                                        "%s[%"UVuf"] 0x%04"UVXf" .. INFINITY\n",
9126                                    indent, (UV)count, start);
9127         }
9128         else if (end != start) {
9129             Perl_dump_indent(aTHX_ level, file,
9130                                     "%s[%"UVuf"] 0x%04"UVXf" .. 0x%04"UVXf"\n",
9131                                 indent, (UV)count, start,         end);
9132         }
9133         else {
9134             Perl_dump_indent(aTHX_ level, file, "%s[%"UVuf"] 0x%04"UVXf"\n",
9135                                             indent, (UV)count, start);
9136         }
9137         count += 2;
9138     }
9139 }
9140
9141 void
9142 Perl__load_PL_utf8_foldclosures (pTHX)
9143 {
9144     assert(! PL_utf8_foldclosures);
9145
9146     /* If the folds haven't been read in, call a fold function
9147      * to force that */
9148     if (! PL_utf8_tofold) {
9149         U8 dummy[UTF8_MAXBYTES_CASE+1];
9150
9151         /* This string is just a short named one above \xff */
9152         to_utf8_fold((U8*) HYPHEN_UTF8, dummy, NULL);
9153         assert(PL_utf8_tofold); /* Verify that worked */
9154     }
9155     PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
9156 }
9157 #endif
9158
9159 #ifdef PERL_ARGS_ASSERT__INVLISTEQ
9160 bool
9161 S__invlistEQ(pTHX_ SV* const a, SV* const b, const bool complement_b)
9162 {
9163     /* Return a boolean as to if the two passed in inversion lists are
9164      * identical.  The final argument, if TRUE, says to take the complement of
9165      * the second inversion list before doing the comparison */
9166
9167     const UV* array_a = invlist_array(a);
9168     const UV* array_b = invlist_array(b);
9169     UV len_a = _invlist_len(a);
9170     UV len_b = _invlist_len(b);
9171
9172     UV i = 0;               /* current index into the arrays */
9173     bool retval = TRUE;     /* Assume are identical until proven otherwise */
9174
9175     PERL_ARGS_ASSERT__INVLISTEQ;
9176
9177     /* If are to compare 'a' with the complement of b, set it
9178      * up so are looking at b's complement. */
9179     if (complement_b) {
9180
9181         /* The complement of nothing is everything, so <a> would have to have
9182          * just one element, starting at zero (ending at infinity) */
9183         if (len_b == 0) {
9184             return (len_a == 1 && array_a[0] == 0);
9185         }
9186         else if (array_b[0] == 0) {
9187
9188             /* Otherwise, to complement, we invert.  Here, the first element is
9189              * 0, just remove it.  To do this, we just pretend the array starts
9190              * one later */
9191
9192             array_b++;
9193             len_b--;
9194         }
9195         else {
9196
9197             /* But if the first element is not zero, we pretend the list starts
9198              * at the 0 that is always stored immediately before the array. */
9199             array_b--;
9200             len_b++;
9201         }
9202     }
9203
9204     /* Make sure that the lengths are the same, as well as the final element
9205      * before looping through the remainder.  (Thus we test the length, final,
9206      * and first elements right off the bat) */
9207     if (len_a != len_b || array_a[len_a-1] != array_b[len_a-1]) {
9208         retval = FALSE;
9209     }
9210     else for (i = 0; i < len_a - 1; i++) {
9211         if (array_a[i] != array_b[i]) {
9212             retval = FALSE;
9213             break;
9214         }
9215     }
9216
9217     return retval;
9218 }
9219 #endif
9220
9221 #undef HEADER_LENGTH
9222 #undef TO_INTERNAL_SIZE
9223 #undef FROM_INTERNAL_SIZE
9224 #undef INVLIST_VERSION_ID
9225
9226 /* End of inversion list object */
9227
9228 STATIC void
9229 S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state)
9230 {
9231     /* This parses the flags that are in either the '(?foo)' or '(?foo:bar)'
9232      * constructs, and updates RExC_flags with them.  On input, RExC_parse
9233      * should point to the first flag; it is updated on output to point to the
9234      * final ')' or ':'.  There needs to be at least one flag, or this will
9235      * abort */
9236
9237     /* for (?g), (?gc), and (?o) warnings; warning
9238        about (?c) will warn about (?g) -- japhy    */
9239
9240 #define WASTED_O  0x01
9241 #define WASTED_G  0x02
9242 #define WASTED_C  0x04
9243 #define WASTED_GC (WASTED_G|WASTED_C)
9244     I32 wastedflags = 0x00;
9245     U32 posflags = 0, negflags = 0;
9246     U32 *flagsp = &posflags;
9247     char has_charset_modifier = '\0';
9248     regex_charset cs;
9249     bool has_use_defaults = FALSE;
9250     const char* const seqstart = RExC_parse - 1; /* Point to the '?' */
9251
9252     PERL_ARGS_ASSERT_PARSE_LPAREN_QUESTION_FLAGS;
9253
9254     /* '^' as an initial flag sets certain defaults */
9255     if (UCHARAT(RExC_parse) == '^') {
9256         RExC_parse++;
9257         has_use_defaults = TRUE;
9258         STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
9259         set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
9260                                         ? REGEX_UNICODE_CHARSET
9261                                         : REGEX_DEPENDS_CHARSET);
9262     }
9263
9264     cs = get_regex_charset(RExC_flags);
9265     if (cs == REGEX_DEPENDS_CHARSET
9266         && (RExC_utf8 || RExC_uni_semantics))
9267     {
9268         cs = REGEX_UNICODE_CHARSET;
9269     }
9270
9271     while (*RExC_parse) {
9272         /* && strchr("iogcmsx", *RExC_parse) */
9273         /* (?g), (?gc) and (?o) are useless here
9274            and must be globally applied -- japhy */
9275         switch (*RExC_parse) {
9276
9277             /* Code for the imsx flags */
9278             CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
9279
9280             case LOCALE_PAT_MOD:
9281                 if (has_charset_modifier) {
9282                     goto excess_modifier;
9283                 }
9284                 else if (flagsp == &negflags) {
9285                     goto neg_modifier;
9286                 }
9287                 cs = REGEX_LOCALE_CHARSET;
9288                 has_charset_modifier = LOCALE_PAT_MOD;
9289                 break;
9290             case UNICODE_PAT_MOD:
9291                 if (has_charset_modifier) {
9292                     goto excess_modifier;
9293                 }
9294                 else if (flagsp == &negflags) {
9295                     goto neg_modifier;
9296                 }
9297                 cs = REGEX_UNICODE_CHARSET;
9298                 has_charset_modifier = UNICODE_PAT_MOD;
9299                 break;
9300             case ASCII_RESTRICT_PAT_MOD:
9301                 if (flagsp == &negflags) {
9302                     goto neg_modifier;
9303                 }
9304                 if (has_charset_modifier) {
9305                     if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
9306                         goto excess_modifier;
9307                     }
9308                     /* Doubled modifier implies more restricted */
9309                     cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
9310                 }
9311                 else {
9312                     cs = REGEX_ASCII_RESTRICTED_CHARSET;
9313                 }
9314                 has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
9315                 break;
9316             case DEPENDS_PAT_MOD:
9317                 if (has_use_defaults) {
9318                     goto fail_modifiers;
9319                 }
9320                 else if (flagsp == &negflags) {
9321                     goto neg_modifier;
9322                 }
9323                 else if (has_charset_modifier) {
9324                     goto excess_modifier;
9325                 }
9326
9327                 /* The dual charset means unicode semantics if the
9328                  * pattern (or target, not known until runtime) are
9329                  * utf8, or something in the pattern indicates unicode
9330                  * semantics */
9331                 cs = (RExC_utf8 || RExC_uni_semantics)
9332                      ? REGEX_UNICODE_CHARSET
9333                      : REGEX_DEPENDS_CHARSET;
9334                 has_charset_modifier = DEPENDS_PAT_MOD;
9335                 break;
9336             excess_modifier:
9337                 RExC_parse++;
9338                 if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
9339                     vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
9340                 }
9341                 else if (has_charset_modifier == *(RExC_parse - 1)) {
9342                     vFAIL2("Regexp modifier \"%c\" may not appear twice",
9343                                         *(RExC_parse - 1));
9344                 }
9345                 else {
9346                     vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
9347                 }
9348                 /*NOTREACHED*/
9349             neg_modifier:
9350                 RExC_parse++;
9351                 vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"",
9352                                     *(RExC_parse - 1));
9353                 /*NOTREACHED*/
9354             case ONCE_PAT_MOD: /* 'o' */
9355             case GLOBAL_PAT_MOD: /* 'g' */
9356                 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
9357                     const I32 wflagbit = *RExC_parse == 'o'
9358                                          ? WASTED_O
9359                                          : WASTED_G;
9360                     if (! (wastedflags & wflagbit) ) {
9361                         wastedflags |= wflagbit;
9362                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
9363                         vWARN5(
9364                             RExC_parse + 1,
9365                             "Useless (%s%c) - %suse /%c modifier",
9366                             flagsp == &negflags ? "?-" : "?",
9367                             *RExC_parse,
9368                             flagsp == &negflags ? "don't " : "",
9369                             *RExC_parse
9370                         );
9371                     }
9372                 }
9373                 break;
9374
9375             case CONTINUE_PAT_MOD: /* 'c' */
9376                 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
9377                     if (! (wastedflags & WASTED_C) ) {
9378                         wastedflags |= WASTED_GC;
9379                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
9380                         vWARN3(
9381                             RExC_parse + 1,
9382                             "Useless (%sc) - %suse /gc modifier",
9383                             flagsp == &negflags ? "?-" : "?",
9384                             flagsp == &negflags ? "don't " : ""
9385                         );
9386                     }
9387                 }
9388                 break;
9389             case KEEPCOPY_PAT_MOD: /* 'p' */
9390                 if (flagsp == &negflags) {
9391                     if (SIZE_ONLY)
9392                         ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
9393                 } else {
9394                     *flagsp |= RXf_PMf_KEEPCOPY;
9395                 }
9396                 break;
9397             case '-':
9398                 /* A flag is a default iff it is following a minus, so
9399                  * if there is a minus, it means will be trying to
9400                  * re-specify a default which is an error */
9401                 if (has_use_defaults || flagsp == &negflags) {
9402                     goto fail_modifiers;
9403                 }
9404                 flagsp = &negflags;
9405                 wastedflags = 0;  /* reset so (?g-c) warns twice */
9406                 break;
9407             case ':':
9408             case ')':
9409                 RExC_flags |= posflags;
9410                 RExC_flags &= ~negflags;
9411                 set_regex_charset(&RExC_flags, cs);
9412                 if (RExC_flags & RXf_PMf_FOLD) {
9413                     RExC_contains_i = 1;
9414                 }
9415                 return;
9416                 /*NOTREACHED*/
9417             default:
9418             fail_modifiers:
9419                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
9420                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
9421                 vFAIL2utf8f("Sequence (%"UTF8f"...) not recognized",
9422                       UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
9423                 /*NOTREACHED*/
9424         }
9425
9426         ++RExC_parse;
9427     }
9428 }
9429
9430 /*
9431  - reg - regular expression, i.e. main body or parenthesized thing
9432  *
9433  * Caller must absorb opening parenthesis.
9434  *
9435  * Combining parenthesis handling with the base level of regular expression
9436  * is a trifle forced, but the need to tie the tails of the branches to what
9437  * follows makes it hard to avoid.
9438  */
9439 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
9440 #ifdef DEBUGGING
9441 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
9442 #else
9443 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
9444 #endif
9445
9446 /* Returns NULL, setting *flagp to TRYAGAIN at the end of (?) that only sets
9447    flags. Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan
9448    needs to be restarted.
9449    Otherwise would only return NULL if regbranch() returns NULL, which
9450    cannot happen.  */
9451 STATIC regnode *
9452 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
9453     /* paren: Parenthesized? 0=top; 1,2=inside '(': changed to letter.
9454      * 2 is like 1, but indicates that nextchar() has been called to advance
9455      * RExC_parse beyond the '('.  Things like '(?' are indivisible tokens, and
9456      * this flag alerts us to the need to check for that */
9457 {
9458     regnode *ret;               /* Will be the head of the group. */
9459     regnode *br;
9460     regnode *lastbr;
9461     regnode *ender = NULL;
9462     I32 parno = 0;
9463     I32 flags;
9464     U32 oregflags = RExC_flags;
9465     bool have_branch = 0;
9466     bool is_open = 0;
9467     I32 freeze_paren = 0;
9468     I32 after_freeze = 0;
9469     I32 num; /* numeric backreferences */
9470
9471     char * parse_start = RExC_parse; /* MJD */
9472     char * const oregcomp_parse = RExC_parse;
9473
9474     GET_RE_DEBUG_FLAGS_DECL;
9475
9476     PERL_ARGS_ASSERT_REG;
9477     DEBUG_PARSE("reg ");
9478
9479     *flagp = 0;                         /* Tentatively. */
9480
9481
9482     /* Make an OPEN node, if parenthesized. */
9483     if (paren) {
9484
9485         /* Under /x, space and comments can be gobbled up between the '(' and
9486          * here (if paren ==2).  The forms '(*VERB' and '(?...' disallow such
9487          * intervening space, as the sequence is a token, and a token should be
9488          * indivisible */
9489         bool has_intervening_patws = paren == 2 && *(RExC_parse - 1) != '(';
9490
9491         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
9492             char *start_verb = RExC_parse;
9493             STRLEN verb_len = 0;
9494             char *start_arg = NULL;
9495             unsigned char op = 0;
9496             int argok = 1;
9497             int internal_argval = 0; /* internal_argval is only useful if
9498                                         !argok */
9499
9500             if (has_intervening_patws) {
9501                 RExC_parse++;
9502                 vFAIL("In '(*VERB...)', the '(' and '*' must be adjacent");
9503             }
9504             while ( *RExC_parse && *RExC_parse != ')' ) {
9505                 if ( *RExC_parse == ':' ) {
9506                     start_arg = RExC_parse + 1;
9507                     break;
9508                 }
9509                 RExC_parse++;
9510             }
9511             ++start_verb;
9512             verb_len = RExC_parse - start_verb;
9513             if ( start_arg ) {
9514                 RExC_parse++;
9515                 while ( *RExC_parse && *RExC_parse != ')' )
9516                     RExC_parse++;
9517                 if ( *RExC_parse != ')' )
9518                     vFAIL("Unterminated verb pattern argument");
9519                 if ( RExC_parse == start_arg )
9520                     start_arg = NULL;
9521             } else {
9522                 if ( *RExC_parse != ')' )
9523                     vFAIL("Unterminated verb pattern");
9524             }
9525
9526             switch ( *start_verb ) {
9527             case 'A':  /* (*ACCEPT) */
9528                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
9529                     op = ACCEPT;
9530                     internal_argval = RExC_nestroot;
9531                 }
9532                 break;
9533             case 'C':  /* (*COMMIT) */
9534                 if ( memEQs(start_verb,verb_len,"COMMIT") )
9535                     op = COMMIT;
9536                 break;
9537             case 'F':  /* (*FAIL) */
9538                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
9539                     op = OPFAIL;
9540                     argok = 0;
9541                 }
9542                 break;
9543             case ':':  /* (*:NAME) */
9544             case 'M':  /* (*MARK:NAME) */
9545                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
9546                     op = MARKPOINT;
9547                     argok = -1;
9548                 }
9549                 break;
9550             case 'P':  /* (*PRUNE) */
9551                 if ( memEQs(start_verb,verb_len,"PRUNE") )
9552                     op = PRUNE;
9553                 break;
9554             case 'S':   /* (*SKIP) */
9555                 if ( memEQs(start_verb,verb_len,"SKIP") )
9556                     op = SKIP;
9557                 break;
9558             case 'T':  /* (*THEN) */
9559                 /* [19:06] <TimToady> :: is then */
9560                 if ( memEQs(start_verb,verb_len,"THEN") ) {
9561                     op = CUTGROUP;
9562                     RExC_seen |= REG_CUTGROUP_SEEN;
9563                 }
9564                 break;
9565             }
9566             if ( ! op ) {
9567                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
9568                 vFAIL2utf8f(
9569                     "Unknown verb pattern '%"UTF8f"'",
9570                     UTF8fARG(UTF, verb_len, start_verb));
9571             }
9572             if ( argok ) {
9573                 if ( start_arg && internal_argval ) {
9574                     vFAIL3("Verb pattern '%.*s' may not have an argument",
9575                         verb_len, start_verb);
9576                 } else if ( argok < 0 && !start_arg ) {
9577                     vFAIL3("Verb pattern '%.*s' has a mandatory argument",
9578                         verb_len, start_verb);
9579                 } else {
9580                     ret = reganode(pRExC_state, op, internal_argval);
9581                     if ( ! internal_argval && ! SIZE_ONLY ) {
9582                         if (start_arg) {
9583                             SV *sv = newSVpvn( start_arg,
9584                                                RExC_parse - start_arg);
9585                             ARG(ret) = add_data( pRExC_state,
9586                                                  STR_WITH_LEN("S"));
9587                             RExC_rxi->data->data[ARG(ret)]=(void*)sv;
9588                             ret->flags = 0;
9589                         } else {
9590                             ret->flags = 1;
9591                         }
9592                     }
9593                 }
9594                 if (!internal_argval)
9595                     RExC_seen |= REG_VERBARG_SEEN;
9596             } else if ( start_arg ) {
9597                 vFAIL3("Verb pattern '%.*s' may not have an argument",
9598                         verb_len, start_verb);
9599             } else {
9600                 ret = reg_node(pRExC_state, op);
9601             }
9602             nextchar(pRExC_state);
9603             return ret;
9604         }
9605         else if (*RExC_parse == '?') { /* (?...) */
9606             bool is_logical = 0;
9607             const char * const seqstart = RExC_parse;
9608             const char * endptr;
9609             if (has_intervening_patws) {
9610                 RExC_parse++;
9611                 vFAIL("In '(?...)', the '(' and '?' must be adjacent");
9612             }
9613
9614             RExC_parse++;
9615             paren = *RExC_parse++;
9616             ret = NULL;                 /* For look-ahead/behind. */
9617             switch (paren) {
9618
9619             case 'P':   /* (?P...) variants for those used to PCRE/Python */
9620                 paren = *RExC_parse++;
9621                 if ( paren == '<')         /* (?P<...>) named capture */
9622                     goto named_capture;
9623                 else if (paren == '>') {   /* (?P>name) named recursion */
9624                     goto named_recursion;
9625                 }
9626                 else if (paren == '=') {   /* (?P=...)  named backref */
9627                     /* this pretty much dupes the code for \k<NAME> in
9628                      * regatom(), if you change this make sure you change that
9629                      * */
9630                     char* name_start = RExC_parse;
9631                     U32 num = 0;
9632                     SV *sv_dat = reg_scan_name(pRExC_state,
9633                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
9634                     if (RExC_parse == name_start || *RExC_parse != ')')
9635                         /* diag_listed_as: Sequence ?P=... not terminated in regex; marked by <-- HERE in m/%s/ */
9636                         vFAIL2("Sequence %.3s... not terminated",parse_start);
9637
9638                     if (!SIZE_ONLY) {
9639                         num = add_data( pRExC_state, STR_WITH_LEN("S"));
9640                         RExC_rxi->data->data[num]=(void*)sv_dat;
9641                         SvREFCNT_inc_simple_void(sv_dat);
9642                     }
9643                     RExC_sawback = 1;
9644                     ret = reganode(pRExC_state,
9645                                    ((! FOLD)
9646                                      ? NREF
9647                                      : (ASCII_FOLD_RESTRICTED)
9648                                        ? NREFFA
9649                                        : (AT_LEAST_UNI_SEMANTICS)
9650                                          ? NREFFU
9651                                          : (LOC)
9652                                            ? NREFFL
9653                                            : NREFF),
9654                                     num);
9655                     *flagp |= HASWIDTH;
9656
9657                     Set_Node_Offset(ret, parse_start+1);
9658                     Set_Node_Cur_Length(ret, parse_start);
9659
9660                     nextchar(pRExC_state);
9661                     return ret;
9662                 }
9663                 RExC_parse++;
9664                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
9665                 vFAIL3("Sequence (%.*s...) not recognized",
9666                                 RExC_parse-seqstart, seqstart);
9667                 /*NOTREACHED*/
9668             case '<':           /* (?<...) */
9669                 if (*RExC_parse == '!')
9670                     paren = ',';
9671                 else if (*RExC_parse != '=')
9672               named_capture:
9673                 {               /* (?<...>) */
9674                     char *name_start;
9675                     SV *svname;
9676                     paren= '>';
9677             case '\'':          /* (?'...') */
9678                     name_start= RExC_parse;
9679                     svname = reg_scan_name(pRExC_state,
9680                         SIZE_ONLY    /* reverse test from the others */
9681                         ? REG_RSN_RETURN_NAME
9682                         : REG_RSN_RETURN_NULL);
9683                     if (RExC_parse == name_start || *RExC_parse != paren)
9684                         vFAIL2("Sequence (?%c... not terminated",
9685                             paren=='>' ? '<' : paren);
9686                     if (SIZE_ONLY) {
9687                         HE *he_str;
9688                         SV *sv_dat = NULL;
9689                         if (!svname) /* shouldn't happen */
9690                             Perl_croak(aTHX_
9691                                 "panic: reg_scan_name returned NULL");
9692                         if (!RExC_paren_names) {
9693                             RExC_paren_names= newHV();
9694                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
9695 #ifdef DEBUGGING
9696                             RExC_paren_name_list= newAV();
9697                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
9698 #endif
9699                         }
9700                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
9701                         if ( he_str )
9702                             sv_dat = HeVAL(he_str);
9703                         if ( ! sv_dat ) {
9704                             /* croak baby croak */
9705                             Perl_croak(aTHX_
9706                                 "panic: paren_name hash element allocation failed");
9707                         } else if ( SvPOK(sv_dat) ) {
9708                             /* (?|...) can mean we have dupes so scan to check
9709                                its already been stored. Maybe a flag indicating
9710                                we are inside such a construct would be useful,
9711                                but the arrays are likely to be quite small, so
9712                                for now we punt -- dmq */
9713                             IV count = SvIV(sv_dat);
9714                             I32 *pv = (I32*)SvPVX(sv_dat);
9715                             IV i;
9716                             for ( i = 0 ; i < count ; i++ ) {
9717                                 if ( pv[i] == RExC_npar ) {
9718                                     count = 0;
9719                                     break;
9720                                 }
9721                             }
9722                             if ( count ) {
9723                                 pv = (I32*)SvGROW(sv_dat,
9724                                                 SvCUR(sv_dat) + sizeof(I32)+1);
9725                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
9726                                 pv[count] = RExC_npar;
9727                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
9728                             }
9729                         } else {
9730                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
9731                             sv_setpvn(sv_dat, (char *)&(RExC_npar),
9732                                                                 sizeof(I32));
9733                             SvIOK_on(sv_dat);
9734                             SvIV_set(sv_dat, 1);
9735                         }
9736 #ifdef DEBUGGING
9737                         /* Yes this does cause a memory leak in debugging Perls
9738                          * */
9739                         if (!av_store(RExC_paren_name_list,
9740                                       RExC_npar, SvREFCNT_inc(svname)))
9741                             SvREFCNT_dec_NN(svname);
9742 #endif
9743
9744                         /*sv_dump(sv_dat);*/
9745                     }
9746                     nextchar(pRExC_state);
9747                     paren = 1;
9748                     goto capturing_parens;
9749                 }
9750                 RExC_seen |= REG_LOOKBEHIND_SEEN;
9751                 RExC_in_lookbehind++;
9752                 RExC_parse++;
9753                 /* FALLTHROUGH */
9754             case '=':           /* (?=...) */
9755                 RExC_seen_zerolen++;
9756                 break;
9757             case '!':           /* (?!...) */
9758                 RExC_seen_zerolen++;
9759                 if (*RExC_parse == ')') {
9760                     ret=reg_node(pRExC_state, OPFAIL);
9761                     nextchar(pRExC_state);
9762                     return ret;
9763                 }
9764                 break;
9765             case '|':           /* (?|...) */
9766                 /* branch reset, behave like a (?:...) except that
9767                    buffers in alternations share the same numbers */
9768                 paren = ':';
9769                 after_freeze = freeze_paren = RExC_npar;
9770                 break;
9771             case ':':           /* (?:...) */
9772             case '>':           /* (?>...) */
9773                 break;
9774             case '$':           /* (?$...) */
9775             case '@':           /* (?@...) */
9776                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
9777                 break;
9778             case '0' :           /* (?0) */
9779             case 'R' :           /* (?R) */
9780                 if (*RExC_parse != ')')
9781                     FAIL("Sequence (?R) not terminated");
9782                 ret = reg_node(pRExC_state, GOSTART);
9783                     RExC_seen |= REG_GOSTART_SEEN;
9784                 *flagp |= POSTPONED;
9785                 nextchar(pRExC_state);
9786                 return ret;
9787                 /*notreached*/
9788             /* named and numeric backreferences */
9789             case '&':            /* (?&NAME) */
9790                 parse_start = RExC_parse - 1;
9791               named_recursion:
9792                 {
9793                     SV *sv_dat = reg_scan_name(pRExC_state,
9794                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
9795                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
9796                 }
9797                 if (RExC_parse == RExC_end || *RExC_parse != ')')
9798                     vFAIL("Sequence (?&... not terminated");
9799                 goto gen_recurse_regop;
9800                 assert(0); /* NOT REACHED */
9801             case '+':
9802                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
9803                     RExC_parse++;
9804                     vFAIL("Illegal pattern");
9805                 }
9806                 goto parse_recursion;
9807                 /* NOT REACHED*/
9808             case '-': /* (?-1) */
9809                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
9810                     RExC_parse--; /* rewind to let it be handled later */
9811                     goto parse_flags;
9812                 }
9813                 /* FALLTHROUGH */
9814             case '1': case '2': case '3': case '4': /* (?1) */
9815             case '5': case '6': case '7': case '8': case '9':
9816                 RExC_parse--;
9817               parse_recursion:
9818                 {
9819                     bool is_neg = FALSE;
9820                     parse_start = RExC_parse - 1; /* MJD */
9821                     if (*RExC_parse == '-') {
9822                         RExC_parse++;
9823                         is_neg = TRUE;
9824                     }
9825                     num = grok_atou(RExC_parse, &endptr);
9826                     if (endptr)
9827                         RExC_parse = (char*)endptr;
9828                     if (is_neg) {
9829                         /* Some limit for num? */
9830                         num = -num;
9831                     }
9832                 }
9833                 if (*RExC_parse!=')')
9834                     vFAIL("Expecting close bracket");
9835
9836               gen_recurse_regop:
9837                 if ( paren == '-' ) {
9838                     /*
9839                     Diagram of capture buffer numbering.
9840                     Top line is the normal capture buffer numbers
9841                     Bottom line is the negative indexing as from
9842                     the X (the (?-2))
9843
9844                     +   1 2    3 4 5 X          6 7
9845                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
9846                     -   5 4    3 2 1 X          x x
9847
9848                     */
9849                     num = RExC_npar + num;
9850                     if (num < 1)  {
9851                         RExC_parse++;
9852                         vFAIL("Reference to nonexistent group");
9853                     }
9854                 } else if ( paren == '+' ) {
9855                     num = RExC_npar + num - 1;
9856                 }
9857
9858                 ret = reganode(pRExC_state, GOSUB, num);
9859                 if (!SIZE_ONLY) {
9860                     if (num > (I32)RExC_rx->nparens) {
9861                         RExC_parse++;
9862                         vFAIL("Reference to nonexistent group");
9863                     }
9864                     ARG2L_SET( ret, RExC_recurse_count++);
9865                     RExC_emit++;
9866                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
9867                         "Recurse #%"UVuf" to %"IVdf"\n",
9868                               (UV)ARG(ret), (IV)ARG2L(ret)));
9869                 } else {
9870                     RExC_size++;
9871                 }
9872                     RExC_seen |= REG_RECURSE_SEEN;
9873                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
9874                 Set_Node_Offset(ret, parse_start); /* MJD */
9875
9876                 *flagp |= POSTPONED;
9877                 nextchar(pRExC_state);
9878                 return ret;
9879
9880             assert(0); /* NOT REACHED */
9881
9882             case '?':           /* (??...) */
9883                 is_logical = 1;
9884                 if (*RExC_parse != '{') {
9885                     RExC_parse++;
9886                     /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
9887                     vFAIL2utf8f(
9888                         "Sequence (%"UTF8f"...) not recognized",
9889                         UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
9890                     /*NOTREACHED*/
9891                 }
9892                 *flagp |= POSTPONED;
9893                 paren = *RExC_parse++;
9894                 /* FALLTHROUGH */
9895             case '{':           /* (?{...}) */
9896             {
9897                 U32 n = 0;
9898                 struct reg_code_block *cb;
9899
9900                 RExC_seen_zerolen++;
9901
9902                 if (   !pRExC_state->num_code_blocks
9903                     || pRExC_state->code_index >= pRExC_state->num_code_blocks
9904                     || pRExC_state->code_blocks[pRExC_state->code_index].start
9905                         != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
9906                             - RExC_start)
9907                 ) {
9908                     if (RExC_pm_flags & PMf_USE_RE_EVAL)
9909                         FAIL("panic: Sequence (?{...}): no code block found\n");
9910                     FAIL("Eval-group not allowed at runtime, use re 'eval'");
9911                 }
9912                 /* this is a pre-compiled code block (?{...}) */
9913                 cb = &pRExC_state->code_blocks[pRExC_state->code_index];
9914                 RExC_parse = RExC_start + cb->end;
9915                 if (!SIZE_ONLY) {
9916                     OP *o = cb->block;
9917                     if (cb->src_regex) {
9918                         n = add_data(pRExC_state, STR_WITH_LEN("rl"));
9919                         RExC_rxi->data->data[n] =
9920                             (void*)SvREFCNT_inc((SV*)cb->src_regex);
9921                         RExC_rxi->data->data[n+1] = (void*)o;
9922                     }
9923                     else {
9924                         n = add_data(pRExC_state,
9925                                (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l", 1);
9926                         RExC_rxi->data->data[n] = (void*)o;
9927                     }
9928                 }
9929                 pRExC_state->code_index++;
9930                 nextchar(pRExC_state);
9931
9932                 if (is_logical) {
9933                     regnode *eval;
9934                     ret = reg_node(pRExC_state, LOGICAL);
9935                     eval = reganode(pRExC_state, EVAL, n);
9936                     if (!SIZE_ONLY) {
9937                         ret->flags = 2;
9938                         /* for later propagation into (??{}) return value */
9939                         eval->flags = (U8) (RExC_flags & RXf_PMf_COMPILETIME);
9940                     }
9941                     REGTAIL(pRExC_state, ret, eval);
9942                     /* deal with the length of this later - MJD */
9943                     return ret;
9944                 }
9945                 ret = reganode(pRExC_state, EVAL, n);
9946                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
9947                 Set_Node_Offset(ret, parse_start);
9948                 return ret;
9949             }
9950             case '(':           /* (?(?{...})...) and (?(?=...)...) */
9951             {
9952                 int is_define= 0;
9953                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
9954                     if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
9955                         || RExC_parse[1] == '<'
9956                         || RExC_parse[1] == '{') { /* Lookahead or eval. */
9957                         I32 flag;
9958                         regnode *tail;
9959
9960                         ret = reg_node(pRExC_state, LOGICAL);
9961                         if (!SIZE_ONLY)
9962                             ret->flags = 1;
9963
9964                         tail = reg(pRExC_state, 1, &flag, depth+1);
9965                         if (flag & RESTART_UTF8) {
9966                             *flagp = RESTART_UTF8;
9967                             return NULL;
9968                         }
9969                         REGTAIL(pRExC_state, ret, tail);
9970                         goto insert_if;
9971                     }
9972                 }
9973                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
9974                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
9975                 {
9976                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
9977                     char *name_start= RExC_parse++;
9978                     U32 num = 0;
9979                     SV *sv_dat=reg_scan_name(pRExC_state,
9980                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
9981                     if (RExC_parse == name_start || *RExC_parse != ch)
9982                         vFAIL2("Sequence (?(%c... not terminated",
9983                             (ch == '>' ? '<' : ch));
9984                     RExC_parse++;
9985                     if (!SIZE_ONLY) {
9986                         num = add_data( pRExC_state, STR_WITH_LEN("S"));
9987                         RExC_rxi->data->data[num]=(void*)sv_dat;
9988                         SvREFCNT_inc_simple_void(sv_dat);
9989                     }
9990                     ret = reganode(pRExC_state,NGROUPP,num);
9991                     goto insert_if_check_paren;
9992                 }
9993                 else if (RExC_parse[0] == 'D' &&
9994                          RExC_parse[1] == 'E' &&
9995                          RExC_parse[2] == 'F' &&
9996                          RExC_parse[3] == 'I' &&
9997                          RExC_parse[4] == 'N' &&
9998                          RExC_parse[5] == 'E')
9999                 {
10000                     ret = reganode(pRExC_state,DEFINEP,0);
10001                     RExC_parse +=6 ;
10002                     is_define = 1;
10003                     goto insert_if_check_paren;
10004                 }
10005                 else if (RExC_parse[0] == 'R') {
10006                     RExC_parse++;
10007                     parno = 0;
10008                     if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
10009                         parno = grok_atou(RExC_parse, &endptr);
10010                         if (endptr)
10011                             RExC_parse = (char*)endptr;
10012                     } else if (RExC_parse[0] == '&') {
10013                         SV *sv_dat;
10014                         RExC_parse++;
10015                         sv_dat = reg_scan_name(pRExC_state,
10016                             SIZE_ONLY
10017                             ? REG_RSN_RETURN_NULL
10018                             : REG_RSN_RETURN_DATA);
10019                         parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
10020                     }
10021                     ret = reganode(pRExC_state,INSUBP,parno);
10022                     goto insert_if_check_paren;
10023                 }
10024                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
10025                     /* (?(1)...) */
10026                     char c;
10027                     char *tmp;
10028                     parno = grok_atou(RExC_parse, &endptr);
10029                     if (endptr)
10030                         RExC_parse = (char*)endptr;
10031                     ret = reganode(pRExC_state, GROUPP, parno);
10032
10033                  insert_if_check_paren:
10034                     if (*(tmp = nextchar(pRExC_state)) != ')') {
10035                         /* nextchar also skips comments, so undo its work
10036                          * and skip over the the next character.
10037                          */
10038                         RExC_parse = tmp;
10039                         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10040                         vFAIL("Switch condition not recognized");
10041                     }
10042                   insert_if:
10043                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
10044                     br = regbranch(pRExC_state, &flags, 1,depth+1);
10045                     if (br == NULL) {
10046                         if (flags & RESTART_UTF8) {
10047                             *flagp = RESTART_UTF8;
10048                             return NULL;
10049                         }
10050                         FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"",
10051                               (UV) flags);
10052                     } else
10053                         REGTAIL(pRExC_state, br, reganode(pRExC_state,
10054                                                           LONGJMP, 0));
10055                     c = *nextchar(pRExC_state);
10056                     if (flags&HASWIDTH)
10057                         *flagp |= HASWIDTH;
10058                     if (c == '|') {
10059                         if (is_define)
10060                             vFAIL("(?(DEFINE)....) does not allow branches");
10061
10062                         /* Fake one for optimizer.  */
10063                         lastbr = reganode(pRExC_state, IFTHEN, 0);
10064
10065                         if (!regbranch(pRExC_state, &flags, 1,depth+1)) {
10066                             if (flags & RESTART_UTF8) {
10067                                 *flagp = RESTART_UTF8;
10068                                 return NULL;
10069                             }
10070                             FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"",
10071                                   (UV) flags);
10072                         }
10073                         REGTAIL(pRExC_state, ret, lastbr);
10074                         if (flags&HASWIDTH)
10075                             *flagp |= HASWIDTH;
10076                         c = *nextchar(pRExC_state);
10077                     }
10078                     else
10079                         lastbr = NULL;
10080                     if (c != ')')
10081                         vFAIL("Switch (?(condition)... contains too many branches");
10082                     ender = reg_node(pRExC_state, TAIL);
10083                     REGTAIL(pRExC_state, br, ender);
10084                     if (lastbr) {
10085                         REGTAIL(pRExC_state, lastbr, ender);
10086                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
10087                     }
10088                     else
10089                         REGTAIL(pRExC_state, ret, ender);
10090                     RExC_size++; /* XXX WHY do we need this?!!
10091                                     For large programs it seems to be required
10092                                     but I can't figure out why. -- dmq*/
10093                     return ret;
10094                 }
10095                 else {
10096                     RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10097                     vFAIL("Unknown switch condition (?(...))");
10098                 }
10099             }
10100             case '[':           /* (?[ ... ]) */
10101                 return handle_regex_sets(pRExC_state, NULL, flagp, depth,
10102                                          oregcomp_parse);
10103             case 0:
10104                 RExC_parse--; /* for vFAIL to print correctly */
10105                 vFAIL("Sequence (? incomplete");
10106                 break;
10107             default: /* e.g., (?i) */
10108                 --RExC_parse;
10109               parse_flags:
10110                 parse_lparen_question_flags(pRExC_state);
10111                 if (UCHARAT(RExC_parse) != ':') {
10112                     nextchar(pRExC_state);
10113                     *flagp = TRYAGAIN;
10114                     return NULL;
10115                 }
10116                 paren = ':';
10117                 nextchar(pRExC_state);
10118                 ret = NULL;
10119                 goto parse_rest;
10120             } /* end switch */
10121         }
10122         else {                  /* (...) */
10123           capturing_parens:
10124             parno = RExC_npar;
10125             RExC_npar++;
10126
10127             ret = reganode(pRExC_state, OPEN, parno);
10128             if (!SIZE_ONLY ){
10129                 if (!RExC_nestroot)
10130                     RExC_nestroot = parno;
10131                 if (RExC_seen & REG_RECURSE_SEEN
10132                     && !RExC_open_parens[parno-1])
10133                 {
10134                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
10135                         "Setting open paren #%"IVdf" to %d\n",
10136                         (IV)parno, REG_NODE_NUM(ret)));
10137                     RExC_open_parens[parno-1]= ret;
10138                 }
10139             }
10140             Set_Node_Length(ret, 1); /* MJD */
10141             Set_Node_Offset(ret, RExC_parse); /* MJD */
10142             is_open = 1;
10143         }
10144     }
10145     else                        /* ! paren */
10146         ret = NULL;
10147
10148    parse_rest:
10149     /* Pick up the branches, linking them together. */
10150     parse_start = RExC_parse;   /* MJD */
10151     br = regbranch(pRExC_state, &flags, 1,depth+1);
10152
10153     /*     branch_len = (paren != 0); */
10154
10155     if (br == NULL) {
10156         if (flags & RESTART_UTF8) {
10157             *flagp = RESTART_UTF8;
10158             return NULL;
10159         }
10160         FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"", (UV) flags);
10161     }
10162     if (*RExC_parse == '|') {
10163         if (!SIZE_ONLY && RExC_extralen) {
10164             reginsert(pRExC_state, BRANCHJ, br, depth+1);
10165         }
10166         else {                  /* MJD */
10167             reginsert(pRExC_state, BRANCH, br, depth+1);
10168             Set_Node_Length(br, paren != 0);
10169             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
10170         }
10171         have_branch = 1;
10172         if (SIZE_ONLY)
10173             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
10174     }
10175     else if (paren == ':') {
10176         *flagp |= flags&SIMPLE;
10177     }
10178     if (is_open) {                              /* Starts with OPEN. */
10179         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
10180     }
10181     else if (paren != '?')              /* Not Conditional */
10182         ret = br;
10183     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
10184     lastbr = br;
10185     while (*RExC_parse == '|') {
10186         if (!SIZE_ONLY && RExC_extralen) {
10187             ender = reganode(pRExC_state, LONGJMP,0);
10188
10189             /* Append to the previous. */
10190             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
10191         }
10192         if (SIZE_ONLY)
10193             RExC_extralen += 2;         /* Account for LONGJMP. */
10194         nextchar(pRExC_state);
10195         if (freeze_paren) {
10196             if (RExC_npar > after_freeze)
10197                 after_freeze = RExC_npar;
10198             RExC_npar = freeze_paren;
10199         }
10200         br = regbranch(pRExC_state, &flags, 0, depth+1);
10201
10202         if (br == NULL) {
10203             if (flags & RESTART_UTF8) {
10204                 *flagp = RESTART_UTF8;
10205                 return NULL;
10206             }
10207             FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"", (UV) flags);
10208         }
10209         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
10210         lastbr = br;
10211         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
10212     }
10213
10214     if (have_branch || paren != ':') {
10215         /* Make a closing node, and hook it on the end. */
10216         switch (paren) {
10217         case ':':
10218             ender = reg_node(pRExC_state, TAIL);
10219             break;
10220         case 1: case 2:
10221             ender = reganode(pRExC_state, CLOSE, parno);
10222             if (!SIZE_ONLY && RExC_seen & REG_RECURSE_SEEN) {
10223                 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
10224                         "Setting close paren #%"IVdf" to %d\n",
10225                         (IV)parno, REG_NODE_NUM(ender)));
10226                 RExC_close_parens[parno-1]= ender;
10227                 if (RExC_nestroot == parno)
10228                     RExC_nestroot = 0;
10229             }
10230             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
10231             Set_Node_Length(ender,1); /* MJD */
10232             break;
10233         case '<':
10234         case ',':
10235         case '=':
10236         case '!':
10237             *flagp &= ~HASWIDTH;
10238             /* FALLTHROUGH */
10239         case '>':
10240             ender = reg_node(pRExC_state, SUCCEED);
10241             break;
10242         case 0:
10243             ender = reg_node(pRExC_state, END);
10244             if (!SIZE_ONLY) {
10245                 assert(!RExC_opend); /* there can only be one! */
10246                 RExC_opend = ender;
10247             }
10248             break;
10249         }
10250         DEBUG_PARSE_r(if (!SIZE_ONLY) {
10251             SV * const mysv_val1=sv_newmortal();
10252             SV * const mysv_val2=sv_newmortal();
10253             DEBUG_PARSE_MSG("lsbr");
10254             regprop(RExC_rx, mysv_val1, lastbr, NULL);
10255             regprop(RExC_rx, mysv_val2, ender, NULL);
10256             PerlIO_printf(Perl_debug_log, "~ tying lastbr %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
10257                           SvPV_nolen_const(mysv_val1),
10258                           (IV)REG_NODE_NUM(lastbr),
10259                           SvPV_nolen_const(mysv_val2),
10260                           (IV)REG_NODE_NUM(ender),
10261                           (IV)(ender - lastbr)
10262             );
10263         });
10264         REGTAIL(pRExC_state, lastbr, ender);
10265
10266         if (have_branch && !SIZE_ONLY) {
10267             char is_nothing= 1;
10268             if (depth==1)
10269                 RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
10270
10271             /* Hook the tails of the branches to the closing node. */
10272             for (br = ret; br; br = regnext(br)) {
10273                 const U8 op = PL_regkind[OP(br)];
10274                 if (op == BRANCH) {
10275                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
10276                     if ( OP(NEXTOPER(br)) != NOTHING
10277                          || regnext(NEXTOPER(br)) != ender)
10278                         is_nothing= 0;
10279                 }
10280                 else if (op == BRANCHJ) {
10281                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
10282                     /* for now we always disable this optimisation * /
10283                     if ( OP(NEXTOPER(NEXTOPER(br))) != NOTHING
10284                          || regnext(NEXTOPER(NEXTOPER(br))) != ender)
10285                     */
10286                         is_nothing= 0;
10287                 }
10288             }
10289             if (is_nothing) {
10290                 br= PL_regkind[OP(ret)] != BRANCH ? regnext(ret) : ret;
10291                 DEBUG_PARSE_r(if (!SIZE_ONLY) {
10292                     SV * const mysv_val1=sv_newmortal();
10293                     SV * const mysv_val2=sv_newmortal();
10294                     DEBUG_PARSE_MSG("NADA");
10295                     regprop(RExC_rx, mysv_val1, ret, NULL);
10296                     regprop(RExC_rx, mysv_val2, ender, NULL);
10297                     PerlIO_printf(Perl_debug_log, "~ converting ret %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
10298                                   SvPV_nolen_const(mysv_val1),
10299                                   (IV)REG_NODE_NUM(ret),
10300                                   SvPV_nolen_const(mysv_val2),
10301                                   (IV)REG_NODE_NUM(ender),
10302                                   (IV)(ender - ret)
10303                     );
10304                 });
10305                 OP(br)= NOTHING;
10306                 if (OP(ender) == TAIL) {
10307                     NEXT_OFF(br)= 0;
10308                     RExC_emit= br + 1;
10309                 } else {
10310                     regnode *opt;
10311                     for ( opt= br + 1; opt < ender ; opt++ )
10312                         OP(opt)= OPTIMIZED;
10313                     NEXT_OFF(br)= ender - br;
10314                 }
10315             }
10316         }
10317     }
10318
10319     {
10320         const char *p;
10321         static const char parens[] = "=!<,>";
10322
10323         if (paren && (p = strchr(parens, paren))) {
10324             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
10325             int flag = (p - parens) > 1;
10326
10327             if (paren == '>')
10328                 node = SUSPEND, flag = 0;
10329             reginsert(pRExC_state, node,ret, depth+1);
10330             Set_Node_Cur_Length(ret, parse_start);
10331             Set_Node_Offset(ret, parse_start + 1);
10332             ret->flags = flag;
10333             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
10334         }
10335     }
10336
10337     /* Check for proper termination. */
10338     if (paren) {
10339         /* restore original flags, but keep (?p) */
10340         RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY);
10341         if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
10342             RExC_parse = oregcomp_parse;
10343             vFAIL("Unmatched (");
10344         }
10345     }
10346     else if (!paren && RExC_parse < RExC_end) {
10347         if (*RExC_parse == ')') {
10348             RExC_parse++;
10349             vFAIL("Unmatched )");
10350         }
10351         else
10352             FAIL("Junk on end of regexp");      /* "Can't happen". */
10353         assert(0); /* NOTREACHED */
10354     }
10355
10356     if (RExC_in_lookbehind) {
10357         RExC_in_lookbehind--;
10358     }
10359     if (after_freeze > RExC_npar)
10360         RExC_npar = after_freeze;
10361     return(ret);
10362 }
10363
10364 /*
10365  - regbranch - one alternative of an | operator
10366  *
10367  * Implements the concatenation operator.
10368  *
10369  * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
10370  * restarted.
10371  */
10372 STATIC regnode *
10373 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
10374 {
10375     regnode *ret;
10376     regnode *chain = NULL;
10377     regnode *latest;
10378     I32 flags = 0, c = 0;
10379     GET_RE_DEBUG_FLAGS_DECL;
10380
10381     PERL_ARGS_ASSERT_REGBRANCH;
10382
10383     DEBUG_PARSE("brnc");
10384
10385     if (first)
10386         ret = NULL;
10387     else {
10388         if (!SIZE_ONLY && RExC_extralen)
10389             ret = reganode(pRExC_state, BRANCHJ,0);
10390         else {
10391             ret = reg_node(pRExC_state, BRANCH);
10392             Set_Node_Length(ret, 1);
10393         }
10394     }
10395
10396     if (!first && SIZE_ONLY)
10397         RExC_extralen += 1;                     /* BRANCHJ */
10398
10399     *flagp = WORST;                     /* Tentatively. */
10400
10401     RExC_parse--;
10402     nextchar(pRExC_state);
10403     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
10404         flags &= ~TRYAGAIN;
10405         latest = regpiece(pRExC_state, &flags,depth+1);
10406         if (latest == NULL) {
10407             if (flags & TRYAGAIN)
10408                 continue;
10409             if (flags & RESTART_UTF8) {
10410                 *flagp = RESTART_UTF8;
10411                 return NULL;
10412             }
10413             FAIL2("panic: regpiece returned NULL, flags=%#"UVxf"", (UV) flags);
10414         }
10415         else if (ret == NULL)
10416             ret = latest;
10417         *flagp |= flags&(HASWIDTH|POSTPONED);
10418         if (chain == NULL)      /* First piece. */
10419             *flagp |= flags&SPSTART;
10420         else {
10421             RExC_naughty++;
10422             REGTAIL(pRExC_state, chain, latest);
10423         }
10424         chain = latest;
10425         c++;
10426     }
10427     if (chain == NULL) {        /* Loop ran zero times. */
10428         chain = reg_node(pRExC_state, NOTHING);
10429         if (ret == NULL)
10430             ret = chain;
10431     }
10432     if (c == 1) {
10433         *flagp |= flags&SIMPLE;
10434     }
10435
10436     return ret;
10437 }
10438
10439 /*
10440  - regpiece - something followed by possible [*+?]
10441  *
10442  * Note that the branching code sequences used for ? and the general cases
10443  * of * and + are somewhat optimized:  they use the same NOTHING node as
10444  * both the endmarker for their branch list and the body of the last branch.
10445  * It might seem that this node could be dispensed with entirely, but the
10446  * endmarker role is not redundant.
10447  *
10448  * Returns NULL, setting *flagp to TRYAGAIN if regatom() returns NULL with
10449  * TRYAGAIN.
10450  * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
10451  * restarted.
10452  */
10453 STATIC regnode *
10454 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
10455 {
10456     regnode *ret;
10457     char op;
10458     char *next;
10459     I32 flags;
10460     const char * const origparse = RExC_parse;
10461     I32 min;
10462     I32 max = REG_INFTY;
10463 #ifdef RE_TRACK_PATTERN_OFFSETS
10464     char *parse_start;
10465 #endif
10466     const char *maxpos = NULL;
10467
10468     /* Save the original in case we change the emitted regop to a FAIL. */
10469     regnode * const orig_emit = RExC_emit;
10470
10471     GET_RE_DEBUG_FLAGS_DECL;
10472
10473     PERL_ARGS_ASSERT_REGPIECE;
10474
10475     DEBUG_PARSE("piec");
10476
10477     ret = regatom(pRExC_state, &flags,depth+1);
10478     if (ret == NULL) {
10479         if (flags & (TRYAGAIN|RESTART_UTF8))
10480             *flagp |= flags & (TRYAGAIN|RESTART_UTF8);
10481         else
10482             FAIL2("panic: regatom returned NULL, flags=%#"UVxf"", (UV) flags);
10483         return(NULL);
10484     }
10485
10486     op = *RExC_parse;
10487
10488     if (op == '{' && regcurly(RExC_parse)) {
10489         maxpos = NULL;
10490 #ifdef RE_TRACK_PATTERN_OFFSETS
10491         parse_start = RExC_parse; /* MJD */
10492 #endif
10493         next = RExC_parse + 1;
10494         while (isDIGIT(*next) || *next == ',') {
10495             if (*next == ',') {
10496                 if (maxpos)
10497                     break;
10498                 else
10499                     maxpos = next;
10500             }
10501             next++;
10502         }
10503         if (*next == '}') {             /* got one */
10504             const char* endptr;
10505             if (!maxpos)
10506                 maxpos = next;
10507             RExC_parse++;
10508             min = grok_atou(RExC_parse, &endptr);
10509             if (*maxpos == ',')
10510                 maxpos++;
10511             else
10512                 maxpos = RExC_parse;
10513             max = grok_atou(maxpos, &endptr);
10514             if (!max && *maxpos != '0')
10515                 max = REG_INFTY;                /* meaning "infinity" */
10516             else if (max >= REG_INFTY)
10517                 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
10518             RExC_parse = next;
10519             nextchar(pRExC_state);
10520             if (max < min) {    /* If can't match, warn and optimize to fail
10521                                    unconditionally */
10522                 if (SIZE_ONLY) {
10523                     ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
10524
10525                     /* We can't back off the size because we have to reserve
10526                      * enough space for all the things we are about to throw
10527                      * away, but we can shrink it by the ammount we are about
10528                      * to re-use here */
10529                     RExC_size = PREVOPER(RExC_size) - regarglen[(U8)OPFAIL];
10530                 }
10531                 else {
10532                     RExC_emit = orig_emit;
10533                 }
10534                 ret = reg_node(pRExC_state, OPFAIL);
10535                 return ret;
10536             }
10537             else if (min == max
10538                      && RExC_parse < RExC_end
10539                      && (*RExC_parse == '?' || *RExC_parse == '+'))
10540             {
10541                 if (SIZE_ONLY) {
10542                     ckWARN2reg(RExC_parse + 1,
10543                                "Useless use of greediness modifier '%c'",
10544                                *RExC_parse);
10545                 }
10546                 /* Absorb the modifier, so later code doesn't see nor use
10547                     * it */
10548                 nextchar(pRExC_state);
10549             }
10550
10551         do_curly:
10552             if ((flags&SIMPLE)) {
10553                 RExC_naughty += 2 + RExC_naughty / 2;
10554                 reginsert(pRExC_state, CURLY, ret, depth+1);
10555                 Set_Node_Offset(ret, parse_start+1); /* MJD */
10556                 Set_Node_Cur_Length(ret, parse_start);
10557             }
10558             else {
10559                 regnode * const w = reg_node(pRExC_state, WHILEM);
10560
10561                 w->flags = 0;
10562                 REGTAIL(pRExC_state, ret, w);
10563                 if (!SIZE_ONLY && RExC_extralen) {
10564                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
10565                     reginsert(pRExC_state, NOTHING,ret, depth+1);
10566                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
10567                 }
10568                 reginsert(pRExC_state, CURLYX,ret, depth+1);
10569                                 /* MJD hk */
10570                 Set_Node_Offset(ret, parse_start+1);
10571                 Set_Node_Length(ret,
10572                                 op == '{' ? (RExC_parse - parse_start) : 1);
10573
10574                 if (!SIZE_ONLY && RExC_extralen)
10575                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
10576                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
10577                 if (SIZE_ONLY)
10578                     RExC_whilem_seen++, RExC_extralen += 3;
10579                 RExC_naughty += 4 + RExC_naughty;       /* compound interest */
10580             }
10581             ret->flags = 0;
10582
10583             if (min > 0)
10584                 *flagp = WORST;
10585             if (max > 0)
10586                 *flagp |= HASWIDTH;
10587             if (!SIZE_ONLY) {
10588                 ARG1_SET(ret, (U16)min);
10589                 ARG2_SET(ret, (U16)max);
10590             }
10591             if (max == REG_INFTY)
10592                 RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
10593
10594             goto nest_check;
10595         }
10596     }
10597
10598     if (!ISMULT1(op)) {
10599         *flagp = flags;
10600         return(ret);
10601     }
10602
10603 #if 0                           /* Now runtime fix should be reliable. */
10604
10605     /* if this is reinstated, don't forget to put this back into perldiag:
10606
10607             =item Regexp *+ operand could be empty at {#} in regex m/%s/
10608
10609            (F) The part of the regexp subject to either the * or + quantifier
10610            could match an empty string. The {#} shows in the regular
10611            expression about where the problem was discovered.
10612
10613     */
10614
10615     if (!(flags&HASWIDTH) && op != '?')
10616       vFAIL("Regexp *+ operand could be empty");
10617 #endif
10618
10619 #ifdef RE_TRACK_PATTERN_OFFSETS
10620     parse_start = RExC_parse;
10621 #endif
10622     nextchar(pRExC_state);
10623
10624     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
10625
10626     if (op == '*' && (flags&SIMPLE)) {
10627         reginsert(pRExC_state, STAR, ret, depth+1);
10628         ret->flags = 0;
10629         RExC_naughty += 4;
10630         RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
10631     }
10632     else if (op == '*') {
10633         min = 0;
10634         goto do_curly;
10635     }
10636     else if (op == '+' && (flags&SIMPLE)) {
10637         reginsert(pRExC_state, PLUS, ret, depth+1);
10638         ret->flags = 0;
10639         RExC_naughty += 3;
10640         RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
10641     }
10642     else if (op == '+') {
10643         min = 1;
10644         goto do_curly;
10645     }
10646     else if (op == '?') {
10647         min = 0; max = 1;
10648         goto do_curly;
10649     }
10650   nest_check:
10651     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
10652         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
10653         ckWARN2reg(RExC_parse,
10654                    "%"UTF8f" matches null string many times",
10655                    UTF8fARG(UTF, (RExC_parse >= origparse
10656                                  ? RExC_parse - origparse
10657                                  : 0),
10658                    origparse));
10659         (void)ReREFCNT_inc(RExC_rx_sv);
10660     }
10661
10662     if (RExC_parse < RExC_end && *RExC_parse == '?') {
10663         nextchar(pRExC_state);
10664         reginsert(pRExC_state, MINMOD, ret, depth+1);
10665         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
10666     }
10667     else
10668     if (RExC_parse < RExC_end && *RExC_parse == '+') {
10669         regnode *ender;
10670         nextchar(pRExC_state);
10671         ender = reg_node(pRExC_state, SUCCEED);
10672         REGTAIL(pRExC_state, ret, ender);
10673         reginsert(pRExC_state, SUSPEND, ret, depth+1);
10674         ret->flags = 0;
10675         ender = reg_node(pRExC_state, TAIL);
10676         REGTAIL(pRExC_state, ret, ender);
10677     }
10678
10679     if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
10680         RExC_parse++;
10681         vFAIL("Nested quantifiers");
10682     }
10683
10684     return(ret);
10685 }
10686
10687 STATIC bool
10688 S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p,
10689                       UV *valuep, I32 *flagp, U32 depth, bool in_char_class,
10690                       const bool strict   /* Apply stricter parsing rules? */
10691     )
10692 {
10693
10694  /* This is expected to be called by a parser routine that has recognized '\N'
10695    and needs to handle the rest. RExC_parse is expected to point at the first
10696    char following the N at the time of the call.  On successful return,
10697    RExC_parse has been updated to point to just after the sequence identified
10698    by this routine, and <*flagp> has been updated.
10699
10700    The \N may be inside (indicated by the boolean <in_char_class>) or outside a
10701    character class.
10702
10703    \N may begin either a named sequence, or if outside a character class, mean
10704    to match a non-newline.  For non single-quoted regexes, the tokenizer has
10705    attempted to decide which, and in the case of a named sequence, converted it
10706    into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...},
10707    where c1... are the characters in the sequence.  For single-quoted regexes,
10708    the tokenizer passes the \N sequence through unchanged; this code will not
10709    attempt to determine this nor expand those, instead raising a syntax error.
10710    The net effect is that if the beginning of the passed-in pattern isn't '{U+'
10711    or there is no '}', it signals that this \N occurrence means to match a
10712    non-newline.
10713
10714    Only the \N{U+...} form should occur in a character class, for the same
10715    reason that '.' inside a character class means to just match a period: it
10716    just doesn't make sense.
10717
10718    The function raises an error (via vFAIL), and doesn't return for various
10719    syntax errors.  Otherwise it returns TRUE and sets <node_p> or <valuep> on
10720    success; it returns FALSE otherwise. Returns FALSE, setting *flagp to
10721    RESTART_UTF8 if the sizing scan needs to be restarted. Such a restart is
10722    only possible if node_p is non-NULL.
10723
10724
10725    If <valuep> is non-null, it means the caller can accept an input sequence
10726    consisting of a just a single code point; <*valuep> is set to that value
10727    if the input is such.
10728
10729    If <node_p> is non-null it signifies that the caller can accept any other
10730    legal sequence (i.e., one that isn't just a single code point).  <*node_p>
10731    is set as follows:
10732     1) \N means not-a-NL: points to a newly created REG_ANY node;
10733     2) \N{}:              points to a new NOTHING node;
10734     3) otherwise:         points to a new EXACT node containing the resolved
10735                           string.
10736    Note that FALSE is returned for single code point sequences if <valuep> is
10737    null.
10738  */
10739
10740     char * endbrace;    /* '}' following the name */
10741     char* p;
10742     char *endchar;      /* Points to '.' or '}' ending cur char in the input
10743                            stream */
10744     bool has_multiple_chars; /* true if the input stream contains a sequence of
10745                                 more than one character */
10746
10747     GET_RE_DEBUG_FLAGS_DECL;
10748
10749     PERL_ARGS_ASSERT_GROK_BSLASH_N;
10750
10751     GET_RE_DEBUG_FLAGS;
10752
10753     assert(cBOOL(node_p) ^ cBOOL(valuep));  /* Exactly one should be set */
10754
10755     /* The [^\n] meaning of \N ignores spaces and comments under the /x
10756      * modifier.  The other meaning does not, so use a temporary until we find
10757      * out which we are being called with */
10758     p = (RExC_flags & RXf_PMf_EXTENDED)
10759         ? regpatws(pRExC_state, RExC_parse,
10760                                 TRUE) /* means recognize comments */
10761         : RExC_parse;
10762
10763     /* Disambiguate between \N meaning a named character versus \N meaning
10764      * [^\n].  The former is assumed when it can't be the latter. */
10765     if (*p != '{' || regcurly(p)) {
10766         RExC_parse = p;
10767         if (! node_p) {
10768             /* no bare \N allowed in a charclass */
10769             if (in_char_class) {
10770                 vFAIL("\\N in a character class must be a named character: \\N{...}");
10771             }
10772             return FALSE;
10773         }
10774         RExC_parse--;   /* Need to back off so nextchar() doesn't skip the
10775                            current char */
10776         nextchar(pRExC_state);
10777         *node_p = reg_node(pRExC_state, REG_ANY);
10778         *flagp |= HASWIDTH|SIMPLE;
10779         RExC_naughty++;
10780         Set_Node_Length(*node_p, 1); /* MJD */
10781         return TRUE;
10782     }
10783
10784     /* Here, we have decided it should be a named character or sequence */
10785
10786     /* The test above made sure that the next real character is a '{', but
10787      * under the /x modifier, it could be separated by space (or a comment and
10788      * \n) and this is not allowed (for consistency with \x{...} and the
10789      * tokenizer handling of \N{NAME}). */
10790     if (*RExC_parse != '{') {
10791         vFAIL("Missing braces on \\N{}");
10792     }
10793
10794     RExC_parse++;       /* Skip past the '{' */
10795
10796     if (! (endbrace = strchr(RExC_parse, '}')) /* no trailing brace */
10797         || ! (endbrace == RExC_parse            /* nothing between the {} */
10798               || (endbrace - RExC_parse >= 2    /* U+ (bad hex is checked below
10799                                                  */
10800                   && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg)
10801                                                      */
10802     {
10803         if (endbrace) RExC_parse = endbrace;    /* position msg's '<--HERE' */
10804         vFAIL("\\N{NAME} must be resolved by the lexer");
10805     }
10806
10807     if (endbrace == RExC_parse) {   /* empty: \N{} */
10808         bool ret = TRUE;
10809         if (node_p) {
10810             *node_p = reg_node(pRExC_state,NOTHING);
10811         }
10812         else if (in_char_class) {
10813             if (SIZE_ONLY && in_char_class) {
10814                 if (strict) {
10815                     RExC_parse++;   /* Position after the "}" */
10816                     vFAIL("Zero length \\N{}");
10817                 }
10818                 else {
10819                     ckWARNreg(RExC_parse,
10820                               "Ignoring zero length \\N{} in character class");
10821                 }
10822             }
10823             ret = FALSE;
10824         }
10825         else {
10826             return FALSE;
10827         }
10828         nextchar(pRExC_state);
10829         return ret;
10830     }
10831
10832     RExC_uni_semantics = 1; /* Unicode named chars imply Unicode semantics */
10833     RExC_parse += 2;    /* Skip past the 'U+' */
10834
10835     endchar = RExC_parse + strcspn(RExC_parse, ".}");
10836
10837     /* Code points are separated by dots.  If none, there is only one code
10838      * point, and is terminated by the brace */
10839     has_multiple_chars = (endchar < endbrace);
10840
10841     if (valuep && (! has_multiple_chars || in_char_class)) {
10842         /* We only pay attention to the first char of
10843         multichar strings being returned in char classes. I kinda wonder
10844         if this makes sense as it does change the behaviour
10845         from earlier versions, OTOH that behaviour was broken
10846         as well. XXX Solution is to recharacterize as
10847         [rest-of-class]|multi1|multi2... */
10848
10849         STRLEN length_of_hex = (STRLEN)(endchar - RExC_parse);
10850         I32 grok_hex_flags = PERL_SCAN_ALLOW_UNDERSCORES
10851             | PERL_SCAN_DISALLOW_PREFIX
10852             | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
10853
10854         *valuep = grok_hex(RExC_parse, &length_of_hex, &grok_hex_flags, NULL);
10855
10856         /* The tokenizer should have guaranteed validity, but it's possible to
10857          * bypass it by using single quoting, so check */
10858         if (length_of_hex == 0
10859             || length_of_hex != (STRLEN)(endchar - RExC_parse) )
10860         {
10861             RExC_parse += length_of_hex;        /* Includes all the valid */
10862             RExC_parse += (RExC_orig_utf8)      /* point to after 1st invalid */
10863                             ? UTF8SKIP(RExC_parse)
10864                             : 1;
10865             /* Guard against malformed utf8 */
10866             if (RExC_parse >= endchar) {
10867                 RExC_parse = endchar;
10868             }
10869             vFAIL("Invalid hexadecimal number in \\N{U+...}");
10870         }
10871
10872         if (in_char_class && has_multiple_chars) {
10873             if (strict) {
10874                 RExC_parse = endbrace;
10875                 vFAIL("\\N{} in character class restricted to one character");
10876             }
10877             else {
10878                 ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
10879             }
10880         }
10881
10882         RExC_parse = endbrace + 1;
10883     }
10884     else if (! node_p || ! has_multiple_chars) {
10885
10886         /* Here, the input is legal, but not according to the caller's
10887          * options.  We fail without advancing the parse, so that the
10888          * caller can try again */
10889         RExC_parse = p;
10890         return FALSE;
10891     }
10892     else {
10893
10894         /* What is done here is to convert this to a sub-pattern of the form
10895          * (?:\x{char1}\x{char2}...)
10896          * and then call reg recursively.  That way, it retains its atomicness,
10897          * while not having to worry about special handling that some code
10898          * points may have.  toke.c has converted the original Unicode values
10899          * to native, so that we can just pass on the hex values unchanged.  We
10900          * do have to set a flag to keep recoding from happening in the
10901          * recursion */
10902
10903         SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP);
10904         STRLEN len;
10905         char *orig_end = RExC_end;
10906         I32 flags;
10907
10908         while (RExC_parse < endbrace) {
10909
10910             /* Convert to notation the rest of the code understands */
10911             sv_catpv(substitute_parse, "\\x{");
10912             sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
10913             sv_catpv(substitute_parse, "}");
10914
10915             /* Point to the beginning of the next character in the sequence. */
10916             RExC_parse = endchar + 1;
10917             endchar = RExC_parse + strcspn(RExC_parse, ".}");
10918         }
10919         sv_catpv(substitute_parse, ")");
10920
10921         RExC_parse = SvPV(substitute_parse, len);
10922
10923         /* Don't allow empty number */
10924         if (len < 8) {
10925             vFAIL("Invalid hexadecimal number in \\N{U+...}");
10926         }
10927         RExC_end = RExC_parse + len;
10928
10929         /* The values are Unicode, and therefore not subject to recoding */
10930         RExC_override_recoding = 1;
10931
10932         if (!(*node_p = reg(pRExC_state, 1, &flags, depth+1))) {
10933             if (flags & RESTART_UTF8) {
10934                 *flagp = RESTART_UTF8;
10935                 return FALSE;
10936             }
10937             FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#"UVxf"",
10938                   (UV) flags);
10939         }
10940         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
10941
10942         RExC_parse = endbrace;
10943         RExC_end = orig_end;
10944         RExC_override_recoding = 0;
10945
10946         nextchar(pRExC_state);
10947     }
10948
10949     return TRUE;
10950 }
10951
10952
10953 /*
10954  * reg_recode
10955  *
10956  * It returns the code point in utf8 for the value in *encp.
10957  *    value: a code value in the source encoding
10958  *    encp:  a pointer to an Encode object
10959  *
10960  * If the result from Encode is not a single character,
10961  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
10962  */
10963 STATIC UV
10964 S_reg_recode(pTHX_ const char value, SV **encp)
10965 {
10966     STRLEN numlen = 1;
10967     SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP);
10968     const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
10969     const STRLEN newlen = SvCUR(sv);
10970     UV uv = UNICODE_REPLACEMENT;
10971
10972     PERL_ARGS_ASSERT_REG_RECODE;
10973
10974     if (newlen)
10975         uv = SvUTF8(sv)
10976              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
10977              : *(U8*)s;
10978
10979     if (!newlen || numlen != newlen) {
10980         uv = UNICODE_REPLACEMENT;
10981         *encp = NULL;
10982     }
10983     return uv;
10984 }
10985
10986 PERL_STATIC_INLINE U8
10987 S_compute_EXACTish(RExC_state_t *pRExC_state)
10988 {
10989     U8 op;
10990
10991     PERL_ARGS_ASSERT_COMPUTE_EXACTISH;
10992
10993     if (! FOLD) {
10994         return EXACT;
10995     }
10996
10997     op = get_regex_charset(RExC_flags);
10998     if (op >= REGEX_ASCII_RESTRICTED_CHARSET) {
10999         op--; /* /a is same as /u, and map /aa's offset to what /a's would have
11000                  been, so there is no hole */
11001     }
11002
11003     return op + EXACTF;
11004 }
11005
11006 PERL_STATIC_INLINE void
11007 S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state,
11008                          regnode *node, I32* flagp, STRLEN len, UV code_point,
11009                          bool downgradable)
11010 {
11011     /* This knows the details about sizing an EXACTish node, setting flags for
11012      * it (by setting <*flagp>, and potentially populating it with a single
11013      * character.
11014      *
11015      * If <len> (the length in bytes) is non-zero, this function assumes that
11016      * the node has already been populated, and just does the sizing.  In this
11017      * case <code_point> should be the final code point that has already been
11018      * placed into the node.  This value will be ignored except that under some
11019      * circumstances <*flagp> is set based on it.
11020      *
11021      * If <len> is zero, the function assumes that the node is to contain only
11022      * the single character given by <code_point> and calculates what <len>
11023      * should be.  In pass 1, it sizes the node appropriately.  In pass 2, it
11024      * additionally will populate the node's STRING with <code_point> or its
11025      * fold if folding.
11026      *
11027      * In both cases <*flagp> is appropriately set
11028      *
11029      * It knows that under FOLD, the Latin Sharp S and UTF characters above
11030      * 255, must be folded (the former only when the rules indicate it can
11031      * match 'ss')
11032      *
11033      * When it does the populating, it looks at the flag 'downgradable'.  If
11034      * true with a node that folds, it checks if the single code point
11035      * participates in a fold, and if not downgrades the node to an EXACT.
11036      * This helps the optimizer */
11037
11038     bool len_passed_in = cBOOL(len != 0);
11039     U8 character[UTF8_MAXBYTES_CASE+1];
11040
11041     PERL_ARGS_ASSERT_ALLOC_MAYBE_POPULATE_EXACT;
11042
11043     /* Don't bother to check for downgrading in PASS1, as it doesn't make any
11044      * sizing difference, and is extra work that is thrown away */
11045     if (downgradable && ! PASS2) {
11046         downgradable = FALSE;
11047     }
11048
11049     if (! len_passed_in) {
11050         if (UTF) {
11051             if (UNI_IS_INVARIANT(code_point)) {
11052                 if (LOC || ! FOLD) {    /* /l defers folding until runtime */
11053                     *character = (U8) code_point;
11054                 }
11055                 else { /* Here is /i and not /l (toFOLD() is defined on just
11056                           ASCII, which isn't the same thing as INVARIANT on
11057                           EBCDIC, but it works there, as the extra invariants
11058                           fold to themselves) */
11059                     *character = toFOLD((U8) code_point);
11060                     if (downgradable
11061                         && *character == code_point
11062                         && ! HAS_NONLATIN1_FOLD_CLOSURE(code_point))
11063                     {
11064                         OP(node) = EXACT;
11065                     }
11066                 }
11067                 len = 1;
11068             }
11069             else if (FOLD && (! LOC
11070                               || ! is_PROBLEMATIC_LOCALE_FOLD_cp(code_point)))
11071             {   /* Folding, and ok to do so now */
11072                 UV folded = _to_uni_fold_flags(
11073                                    code_point,
11074                                    character,
11075                                    &len,
11076                                    FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
11077                                                       ? FOLD_FLAGS_NOMIX_ASCII
11078                                                       : 0));
11079                 if (downgradable
11080                     && folded == code_point
11081                     && ! _invlist_contains_cp(PL_utf8_foldable, code_point))
11082                 {
11083                     OP(node) = EXACT;
11084                 }
11085             }
11086             else if (code_point <= MAX_UTF8_TWO_BYTE) {
11087
11088                 /* Not folding this cp, and can output it directly */
11089                 *character = UTF8_TWO_BYTE_HI(code_point);
11090                 *(character + 1) = UTF8_TWO_BYTE_LO(code_point);
11091                 len = 2;
11092             }
11093             else {
11094                 uvchr_to_utf8( character, code_point);
11095                 len = UTF8SKIP(character);
11096             }
11097         } /* Else pattern isn't UTF8.  */
11098         else if (! FOLD) {
11099             *character = (U8) code_point;
11100             len = 1;
11101         } /* Else is folded non-UTF8 */
11102         else if (LIKELY(code_point != LATIN_SMALL_LETTER_SHARP_S)) {
11103
11104             /* We don't fold any non-UTF8 except possibly the Sharp s  (see
11105              * comments at join_exact()); */
11106             *character = (U8) code_point;
11107             len = 1;
11108
11109             /* Can turn into an EXACT node if we know the fold at compile time,
11110              * and it folds to itself and doesn't particpate in other folds */
11111             if (downgradable
11112                 && ! LOC
11113                 && PL_fold_latin1[code_point] == code_point
11114                 && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
11115                     || (isASCII(code_point) && ASCII_FOLD_RESTRICTED)))
11116             {
11117                 OP(node) = EXACT;
11118             }
11119         } /* else is Sharp s.  May need to fold it */
11120         else if (AT_LEAST_UNI_SEMANTICS && ! ASCII_FOLD_RESTRICTED) {
11121             *character = 's';
11122             *(character + 1) = 's';
11123             len = 2;
11124         }
11125         else {
11126             *character = LATIN_SMALL_LETTER_SHARP_S;
11127             len = 1;
11128         }
11129     }
11130
11131     if (SIZE_ONLY) {
11132         RExC_size += STR_SZ(len);
11133     }
11134     else {
11135         RExC_emit += STR_SZ(len);
11136         STR_LEN(node) = len;
11137         if (! len_passed_in) {
11138             Copy((char *) character, STRING(node), len, char);
11139         }
11140     }
11141
11142     *flagp |= HASWIDTH;
11143
11144     /* A single character node is SIMPLE, except for the special-cased SHARP S
11145      * under /di. */
11146     if ((len == 1 || (UTF && len == UNISKIP(code_point)))
11147         && (code_point != LATIN_SMALL_LETTER_SHARP_S
11148             || ! FOLD || ! DEPENDS_SEMANTICS))
11149     {
11150         *flagp |= SIMPLE;
11151     }
11152
11153     /* The OP may not be well defined in PASS1 */
11154     if (PASS2 && OP(node) == EXACTFL) {
11155         RExC_contains_locale = 1;
11156     }
11157 }
11158
11159
11160 /* Parse backref decimal value, unless it's too big to sensibly be a backref,
11161  * in which case return I32_MAX (rather than possibly 32-bit wrapping) */
11162
11163 static I32
11164 S_backref_value(char *p)
11165 {
11166     const char* endptr;
11167     Size_t val = grok_atou(p, &endptr);
11168     if (endptr == p || endptr == NULL || val > 999999999)
11169         return I32_MAX;
11170     return val;
11171 }
11172
11173
11174 /*
11175  - regatom - the lowest level
11176
11177    Try to identify anything special at the start of the pattern. If there
11178    is, then handle it as required. This may involve generating a single regop,
11179    such as for an assertion; or it may involve recursing, such as to
11180    handle a () structure.
11181
11182    If the string doesn't start with something special then we gobble up
11183    as much literal text as we can.
11184
11185    Once we have been able to handle whatever type of thing started the
11186    sequence, we return.
11187
11188    Note: we have to be careful with escapes, as they can be both literal
11189    and special, and in the case of \10 and friends, context determines which.
11190
11191    A summary of the code structure is:
11192
11193    switch (first_byte) {
11194         cases for each special:
11195             handle this special;
11196             break;
11197         case '\\':
11198             switch (2nd byte) {
11199                 cases for each unambiguous special:
11200                     handle this special;
11201                     break;
11202                 cases for each ambigous special/literal:
11203                     disambiguate;
11204                     if (special)  handle here
11205                     else goto defchar;
11206                 default: // unambiguously literal:
11207                     goto defchar;
11208             }
11209         default:  // is a literal char
11210             // FALL THROUGH
11211         defchar:
11212             create EXACTish node for literal;
11213             while (more input and node isn't full) {
11214                 switch (input_byte) {
11215                    cases for each special;
11216                        make sure parse pointer is set so that the next call to
11217                            regatom will see this special first
11218                        goto loopdone; // EXACTish node terminated by prev. char
11219                    default:
11220                        append char to EXACTISH node;
11221                 }
11222                 get next input byte;
11223             }
11224         loopdone:
11225    }
11226    return the generated node;
11227
11228    Specifically there are two separate switches for handling
11229    escape sequences, with the one for handling literal escapes requiring
11230    a dummy entry for all of the special escapes that are actually handled
11231    by the other.
11232
11233    Returns NULL, setting *flagp to TRYAGAIN if reg() returns NULL with
11234    TRYAGAIN.
11235    Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
11236    restarted.
11237    Otherwise does not return NULL.
11238 */
11239
11240 STATIC regnode *
11241 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
11242 {
11243     regnode *ret = NULL;
11244     I32 flags = 0;
11245     char *parse_start = RExC_parse;
11246     U8 op;
11247     int invert = 0;
11248     U8 arg;
11249
11250     GET_RE_DEBUG_FLAGS_DECL;
11251
11252     *flagp = WORST;             /* Tentatively. */
11253
11254     DEBUG_PARSE("atom");
11255
11256     PERL_ARGS_ASSERT_REGATOM;
11257
11258 tryagain:
11259     switch ((U8)*RExC_parse) {
11260     case '^':
11261         RExC_seen_zerolen++;
11262         nextchar(pRExC_state);
11263         if (RExC_flags & RXf_PMf_MULTILINE)
11264             ret = reg_node(pRExC_state, MBOL);
11265         else if (RExC_flags & RXf_PMf_SINGLELINE)
11266             ret = reg_node(pRExC_state, SBOL);
11267         else
11268             ret = reg_node(pRExC_state, BOL);
11269         Set_Node_Length(ret, 1); /* MJD */
11270         break;
11271     case '$':
11272         nextchar(pRExC_state);
11273         if (*RExC_parse)
11274             RExC_seen_zerolen++;
11275         if (RExC_flags & RXf_PMf_MULTILINE)
11276             ret = reg_node(pRExC_state, MEOL);
11277         else if (RExC_flags & RXf_PMf_SINGLELINE)
11278             ret = reg_node(pRExC_state, SEOL);
11279         else
11280             ret = reg_node(pRExC_state, EOL);
11281         Set_Node_Length(ret, 1); /* MJD */
11282         break;
11283     case '.':
11284         nextchar(pRExC_state);
11285         if (RExC_flags & RXf_PMf_SINGLELINE)
11286             ret = reg_node(pRExC_state, SANY);
11287         else
11288             ret = reg_node(pRExC_state, REG_ANY);
11289         *flagp |= HASWIDTH|SIMPLE;
11290         RExC_naughty++;
11291         Set_Node_Length(ret, 1); /* MJD */
11292         break;
11293     case '[':
11294     {
11295         char * const oregcomp_parse = ++RExC_parse;
11296         ret = regclass(pRExC_state, flagp,depth+1,
11297                        FALSE, /* means parse the whole char class */
11298                        TRUE, /* allow multi-char folds */
11299                        FALSE, /* don't silence non-portable warnings. */
11300                        NULL);
11301         if (*RExC_parse != ']') {
11302             RExC_parse = oregcomp_parse;
11303             vFAIL("Unmatched [");
11304         }
11305         if (ret == NULL) {
11306             if (*flagp & RESTART_UTF8)
11307                 return NULL;
11308             FAIL2("panic: regclass returned NULL to regatom, flags=%#"UVxf"",
11309                   (UV) *flagp);
11310         }
11311         nextchar(pRExC_state);
11312         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
11313         break;
11314     }
11315     case '(':
11316         nextchar(pRExC_state);
11317         ret = reg(pRExC_state, 2, &flags,depth+1);
11318         if (ret == NULL) {
11319                 if (flags & TRYAGAIN) {
11320                     if (RExC_parse == RExC_end) {
11321                          /* Make parent create an empty node if needed. */
11322                         *flagp |= TRYAGAIN;
11323                         return(NULL);
11324                     }
11325                     goto tryagain;
11326                 }
11327                 if (flags & RESTART_UTF8) {
11328                     *flagp = RESTART_UTF8;
11329                     return NULL;
11330                 }
11331                 FAIL2("panic: reg returned NULL to regatom, flags=%#"UVxf"",
11332                                                                  (UV) flags);
11333         }
11334         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
11335         break;
11336     case '|':
11337     case ')':
11338         if (flags & TRYAGAIN) {
11339             *flagp |= TRYAGAIN;
11340             return NULL;
11341         }
11342         vFAIL("Internal urp");
11343                                 /* Supposed to be caught earlier. */
11344         break;
11345     case '?':
11346     case '+':
11347     case '*':
11348         RExC_parse++;
11349         vFAIL("Quantifier follows nothing");
11350         break;
11351     case '\\':
11352         /* Special Escapes
11353
11354            This switch handles escape sequences that resolve to some kind
11355            of special regop and not to literal text. Escape sequnces that
11356            resolve to literal text are handled below in the switch marked
11357            "Literal Escapes".
11358
11359            Every entry in this switch *must* have a corresponding entry
11360            in the literal escape switch. However, the opposite is not
11361            required, as the default for this switch is to jump to the
11362            literal text handling code.
11363         */
11364         switch ((U8)*++RExC_parse) {
11365         /* Special Escapes */
11366         case 'A':
11367             RExC_seen_zerolen++;
11368             ret = reg_node(pRExC_state, SBOL);
11369             *flagp |= SIMPLE;
11370             goto finish_meta_pat;
11371         case 'G':
11372             ret = reg_node(pRExC_state, GPOS);
11373             RExC_seen |= REG_GPOS_SEEN;
11374             *flagp |= SIMPLE;
11375             goto finish_meta_pat;
11376         case 'K':
11377             RExC_seen_zerolen++;
11378             ret = reg_node(pRExC_state, KEEPS);
11379             *flagp |= SIMPLE;
11380             /* XXX:dmq : disabling in-place substitution seems to
11381              * be necessary here to avoid cases of memory corruption, as
11382              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
11383              */
11384             RExC_seen |= REG_LOOKBEHIND_SEEN;
11385             goto finish_meta_pat;
11386         case 'Z':
11387             ret = reg_node(pRExC_state, SEOL);
11388             *flagp |= SIMPLE;
11389             RExC_seen_zerolen++;                /* Do not optimize RE away */
11390             goto finish_meta_pat;
11391         case 'z':
11392             ret = reg_node(pRExC_state, EOS);
11393             *flagp |= SIMPLE;
11394             RExC_seen_zerolen++;                /* Do not optimize RE away */
11395             goto finish_meta_pat;
11396         case 'C':
11397             ret = reg_node(pRExC_state, CANY);
11398             RExC_seen |= REG_CANY_SEEN;
11399             *flagp |= HASWIDTH|SIMPLE;
11400             if (SIZE_ONLY) {
11401                 ckWARNdep(RExC_parse+1, "\\C is deprecated");
11402             }
11403             goto finish_meta_pat;
11404         case 'X':
11405             ret = reg_node(pRExC_state, CLUMP);
11406             *flagp |= HASWIDTH;
11407             goto finish_meta_pat;
11408
11409         case 'W':
11410             invert = 1;
11411             /* FALLTHROUGH */
11412         case 'w':
11413             arg = ANYOF_WORDCHAR;
11414             goto join_posix;
11415
11416         case 'b':
11417             RExC_seen_zerolen++;
11418             RExC_seen |= REG_LOOKBEHIND_SEEN;
11419             op = BOUND + get_regex_charset(RExC_flags);
11420             if (op > BOUNDA) {  /* /aa is same as /a */
11421                 op = BOUNDA;
11422             }
11423             else if (op == BOUNDL) {
11424                 RExC_contains_locale = 1;
11425             }
11426             ret = reg_node(pRExC_state, op);
11427             FLAGS(ret) = get_regex_charset(RExC_flags);
11428             *flagp |= SIMPLE;
11429             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
11430                 /* diag_listed_as: Use "%s" instead of "%s" */
11431                 vFAIL("Use \"\\b\\{\" instead of \"\\b{\"");
11432             }
11433             goto finish_meta_pat;
11434         case 'B':
11435             RExC_seen_zerolen++;
11436             RExC_seen |= REG_LOOKBEHIND_SEEN;
11437             op = NBOUND + get_regex_charset(RExC_flags);
11438             if (op > NBOUNDA) { /* /aa is same as /a */
11439                 op = NBOUNDA;
11440             }
11441             else if (op == NBOUNDL) {
11442                 RExC_contains_locale = 1;
11443             }
11444             ret = reg_node(pRExC_state, op);
11445             FLAGS(ret) = get_regex_charset(RExC_flags);
11446             *flagp |= SIMPLE;
11447             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
11448                 /* diag_listed_as: Use "%s" instead of "%s" */
11449                 vFAIL("Use \"\\B\\{\" instead of \"\\B{\"");
11450             }
11451             goto finish_meta_pat;
11452
11453         case 'D':
11454             invert = 1;
11455             /* FALLTHROUGH */
11456         case 'd':
11457             arg = ANYOF_DIGIT;
11458             goto join_posix;
11459
11460         case 'R':
11461             ret = reg_node(pRExC_state, LNBREAK);
11462             *flagp |= HASWIDTH|SIMPLE;
11463             goto finish_meta_pat;
11464
11465         case 'H':
11466             invert = 1;
11467             /* FALLTHROUGH */
11468         case 'h':
11469             arg = ANYOF_BLANK;
11470             op = POSIXU;
11471             goto join_posix_op_known;
11472
11473         case 'V':
11474             invert = 1;
11475             /* FALLTHROUGH */
11476         case 'v':
11477             arg = ANYOF_VERTWS;
11478             op = POSIXU;
11479             goto join_posix_op_known;
11480
11481         case 'S':
11482             invert = 1;
11483             /* FALLTHROUGH */
11484         case 's':
11485             arg = ANYOF_SPACE;
11486
11487         join_posix:
11488
11489             op = POSIXD + get_regex_charset(RExC_flags);
11490             if (op > POSIXA) {  /* /aa is same as /a */
11491                 op = POSIXA;
11492             }
11493             else if (op == POSIXL) {
11494                 RExC_contains_locale = 1;
11495             }
11496
11497         join_posix_op_known:
11498
11499             if (invert) {
11500                 op += NPOSIXD - POSIXD;
11501             }
11502
11503             ret = reg_node(pRExC_state, op);
11504             if (! SIZE_ONLY) {
11505                 FLAGS(ret) = namedclass_to_classnum(arg);
11506             }
11507
11508             *flagp |= HASWIDTH|SIMPLE;
11509             /* FALLTHROUGH */
11510
11511          finish_meta_pat:
11512             nextchar(pRExC_state);
11513             Set_Node_Length(ret, 2); /* MJD */
11514             break;
11515         case 'p':
11516         case 'P':
11517             {
11518 #ifdef DEBUGGING
11519                 char* parse_start = RExC_parse - 2;
11520 #endif
11521
11522                 RExC_parse--;
11523
11524                 ret = regclass(pRExC_state, flagp,depth+1,
11525                                TRUE, /* means just parse this element */
11526                                FALSE, /* don't allow multi-char folds */
11527                                FALSE, /* don't silence non-portable warnings.
11528                                          It would be a bug if these returned
11529                                          non-portables */
11530                                NULL);
11531                 /* regclass() can only return RESTART_UTF8 if multi-char folds
11532                    are allowed.  */
11533                 if (!ret)
11534                     FAIL2("panic: regclass returned NULL to regatom, flags=%#"UVxf"",
11535                           (UV) *flagp);
11536
11537                 RExC_parse--;
11538
11539                 Set_Node_Offset(ret, parse_start + 2);
11540                 Set_Node_Cur_Length(ret, parse_start);
11541                 nextchar(pRExC_state);
11542             }
11543             break;
11544         case 'N':
11545             /* Handle \N and \N{NAME} with multiple code points here and not
11546              * below because it can be multicharacter. join_exact() will join
11547              * them up later on.  Also this makes sure that things like
11548              * /\N{BLAH}+/ and \N{BLAH} being multi char Just Happen. dmq.
11549              * The options to the grok function call causes it to fail if the
11550              * sequence is just a single code point.  We then go treat it as
11551              * just another character in the current EXACT node, and hence it
11552              * gets uniform treatment with all the other characters.  The
11553              * special treatment for quantifiers is not needed for such single
11554              * character sequences */
11555             ++RExC_parse;
11556             if (! grok_bslash_N(pRExC_state, &ret, NULL, flagp, depth, FALSE,
11557                                 FALSE /* not strict */ )) {
11558                 if (*flagp & RESTART_UTF8)
11559                     return NULL;
11560                 RExC_parse--;
11561                 goto defchar;
11562             }
11563             break;
11564         case 'k':    /* Handle \k<NAME> and \k'NAME' */
11565         parse_named_seq:
11566         {
11567             char ch= RExC_parse[1];
11568             if (ch != '<' && ch != '\'' && ch != '{') {
11569                 RExC_parse++;
11570                 /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
11571                 vFAIL2("Sequence %.2s... not terminated",parse_start);
11572             } else {
11573                 /* this pretty much dupes the code for (?P=...) in reg(), if
11574                    you change this make sure you change that */
11575                 char* name_start = (RExC_parse += 2);
11576                 U32 num = 0;
11577                 SV *sv_dat = reg_scan_name(pRExC_state,
11578                     SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
11579                 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
11580                 if (RExC_parse == name_start || *RExC_parse != ch)
11581                     /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
11582                     vFAIL2("Sequence %.3s... not terminated",parse_start);
11583
11584                 if (!SIZE_ONLY) {
11585                     num = add_data( pRExC_state, STR_WITH_LEN("S"));
11586                     RExC_rxi->data->data[num]=(void*)sv_dat;
11587                     SvREFCNT_inc_simple_void(sv_dat);
11588                 }
11589
11590                 RExC_sawback = 1;
11591                 ret = reganode(pRExC_state,
11592                                ((! FOLD)
11593                                  ? NREF
11594                                  : (ASCII_FOLD_RESTRICTED)
11595                                    ? NREFFA
11596                                    : (AT_LEAST_UNI_SEMANTICS)
11597                                      ? NREFFU
11598                                      : (LOC)
11599                                        ? NREFFL
11600                                        : NREFF),
11601                                 num);
11602                 *flagp |= HASWIDTH;
11603
11604                 /* override incorrect value set in reganode MJD */
11605                 Set_Node_Offset(ret, parse_start+1);
11606                 Set_Node_Cur_Length(ret, parse_start);
11607                 nextchar(pRExC_state);
11608
11609             }
11610             break;
11611         }
11612         case 'g':
11613         case '1': case '2': case '3': case '4':
11614         case '5': case '6': case '7': case '8': case '9':
11615             {
11616                 I32 num;
11617                 bool hasbrace = 0;
11618
11619                 if (*RExC_parse == 'g') {
11620                     bool isrel = 0;
11621
11622                     RExC_parse++;
11623                     if (*RExC_parse == '{') {
11624                         RExC_parse++;
11625                         hasbrace = 1;
11626                     }
11627                     if (*RExC_parse == '-') {
11628                         RExC_parse++;
11629                         isrel = 1;
11630                     }
11631                     if (hasbrace && !isDIGIT(*RExC_parse)) {
11632                         if (isrel) RExC_parse--;
11633                         RExC_parse -= 2;
11634                         goto parse_named_seq;
11635                     }
11636
11637                     num = S_backref_value(RExC_parse);
11638                     if (num == 0)
11639                         vFAIL("Reference to invalid group 0");
11640                     else if (num == I32_MAX) {
11641                          if (isDIGIT(*RExC_parse))
11642                             vFAIL("Reference to nonexistent group");
11643                         else
11644                             vFAIL("Unterminated \\g... pattern");
11645                     }
11646
11647                     if (isrel) {
11648                         num = RExC_npar - num;
11649                         if (num < 1)
11650                             vFAIL("Reference to nonexistent or unclosed group");
11651                     }
11652                 }
11653                 else {
11654                     num = S_backref_value(RExC_parse);
11655                     /* bare \NNN might be backref or octal - if it is larger than or equal
11656                      * RExC_npar then it is assumed to be and octal escape.
11657                      * Note RExC_npar is +1 from the actual number of parens*/
11658                     if (num == I32_MAX || (num > 9 && num >= RExC_npar
11659                             && *RExC_parse != '8' && *RExC_parse != '9'))
11660                     {
11661                         /* Probably a character specified in octal, e.g. \35 */
11662                         goto defchar;
11663                     }
11664                 }
11665
11666                 /* at this point RExC_parse definitely points to a backref
11667                  * number */
11668                 {
11669 #ifdef RE_TRACK_PATTERN_OFFSETS
11670                     char * const parse_start = RExC_parse - 1; /* MJD */
11671 #endif
11672                     while (isDIGIT(*RExC_parse))
11673                         RExC_parse++;
11674                     if (hasbrace) {
11675                         if (*RExC_parse != '}')
11676                             vFAIL("Unterminated \\g{...} pattern");
11677                         RExC_parse++;
11678                     }
11679                     if (!SIZE_ONLY) {
11680                         if (num > (I32)RExC_rx->nparens)
11681                             vFAIL("Reference to nonexistent group");
11682                     }
11683                     RExC_sawback = 1;
11684                     ret = reganode(pRExC_state,
11685                                    ((! FOLD)
11686                                      ? REF
11687                                      : (ASCII_FOLD_RESTRICTED)
11688                                        ? REFFA
11689                                        : (AT_LEAST_UNI_SEMANTICS)
11690                                          ? REFFU
11691                                          : (LOC)
11692                                            ? REFFL
11693                                            : REFF),
11694                                     num);
11695                     *flagp |= HASWIDTH;
11696
11697                     /* override incorrect value set in reganode MJD */
11698                     Set_Node_Offset(ret, parse_start+1);
11699                     Set_Node_Cur_Length(ret, parse_start);
11700                     RExC_parse--;
11701                     nextchar(pRExC_state);
11702                 }
11703             }
11704             break;
11705         case '\0':
11706             if (RExC_parse >= RExC_end)
11707                 FAIL("Trailing \\");
11708             /* FALLTHROUGH */
11709         default:
11710             /* Do not generate "unrecognized" warnings here, we fall
11711                back into the quick-grab loop below */
11712             parse_start--;
11713             goto defchar;
11714         }
11715         break;
11716
11717     case '#':
11718         if (RExC_flags & RXf_PMf_EXTENDED) {
11719             RExC_parse = reg_skipcomment( pRExC_state, RExC_parse );
11720             if (RExC_parse < RExC_end)
11721                 goto tryagain;
11722         }
11723         /* FALLTHROUGH */
11724
11725     default:
11726
11727             parse_start = RExC_parse - 1;
11728
11729             RExC_parse++;
11730
11731         defchar: {
11732             STRLEN len = 0;
11733             UV ender = 0;
11734             char *p;
11735             char *s;
11736 #define MAX_NODE_STRING_SIZE 127
11737             char foldbuf[MAX_NODE_STRING_SIZE+UTF8_MAXBYTES_CASE];
11738             char *s0;
11739             U8 upper_parse = MAX_NODE_STRING_SIZE;
11740             U8 node_type = compute_EXACTish(pRExC_state);
11741             bool next_is_quantifier;
11742             char * oldp = NULL;
11743
11744             /* We can convert EXACTF nodes to EXACTFU if they contain only
11745              * characters that match identically regardless of the target
11746              * string's UTF8ness.  The reason to do this is that EXACTF is not
11747              * trie-able, EXACTFU is.
11748              *
11749              * Similarly, we can convert EXACTFL nodes to EXACTFU if they
11750              * contain only above-Latin1 characters (hence must be in UTF8),
11751              * which don't participate in folds with Latin1-range characters,
11752              * as the latter's folds aren't known until runtime.  (We don't
11753              * need to figure this out until pass 2) */
11754             bool maybe_exactfu = PASS2
11755                                && (node_type == EXACTF || node_type == EXACTFL);
11756
11757             /* If a folding node contains only code points that don't
11758              * participate in folds, it can be changed into an EXACT node,
11759              * which allows the optimizer more things to look for */
11760             bool maybe_exact;
11761
11762             ret = reg_node(pRExC_state, node_type);
11763
11764             /* In pass1, folded, we use a temporary buffer instead of the
11765              * actual node, as the node doesn't exist yet */
11766             s = (SIZE_ONLY && FOLD) ? foldbuf : STRING(ret);
11767
11768             s0 = s;
11769
11770         reparse:
11771
11772             /* We do the EXACTFish to EXACT node only if folding.  (And we
11773              * don't need to figure this out until pass 2) */
11774             maybe_exact = FOLD && PASS2;
11775
11776             /* XXX The node can hold up to 255 bytes, yet this only goes to
11777              * 127.  I (khw) do not know why.  Keeping it somewhat less than
11778              * 255 allows us to not have to worry about overflow due to
11779              * converting to utf8 and fold expansion, but that value is
11780              * 255-UTF8_MAXBYTES_CASE.  join_exact() may join adjacent nodes
11781              * split up by this limit into a single one using the real max of
11782              * 255.  Even at 127, this breaks under rare circumstances.  If
11783              * folding, we do not want to split a node at a character that is a
11784              * non-final in a multi-char fold, as an input string could just
11785              * happen to want to match across the node boundary.  The join
11786              * would solve that problem if the join actually happens.  But a
11787              * series of more than two nodes in a row each of 127 would cause
11788              * the first join to succeed to get to 254, but then there wouldn't
11789              * be room for the next one, which could at be one of those split
11790              * multi-char folds.  I don't know of any fool-proof solution.  One
11791              * could back off to end with only a code point that isn't such a
11792              * non-final, but it is possible for there not to be any in the
11793              * entire node. */
11794             for (p = RExC_parse - 1;
11795                  len < upper_parse && p < RExC_end;
11796                  len++)
11797             {
11798                 oldp = p;
11799
11800                 if (RExC_flags & RXf_PMf_EXTENDED)
11801                     p = regpatws(pRExC_state, p,
11802                                           TRUE); /* means recognize comments */
11803                 switch ((U8)*p) {
11804                 case '^':
11805                 case '$':
11806                 case '.':
11807                 case '[':
11808                 case '(':
11809                 case ')':
11810                 case '|':
11811                     goto loopdone;
11812                 case '\\':
11813                     /* Literal Escapes Switch
11814
11815                        This switch is meant to handle escape sequences that
11816                        resolve to a literal character.
11817
11818                        Every escape sequence that represents something
11819                        else, like an assertion or a char class, is handled
11820                        in the switch marked 'Special Escapes' above in this
11821                        routine, but also has an entry here as anything that
11822                        isn't explicitly mentioned here will be treated as
11823                        an unescaped equivalent literal.
11824                     */
11825
11826                     switch ((U8)*++p) {
11827                     /* These are all the special escapes. */
11828                     case 'A':             /* Start assertion */
11829                     case 'b': case 'B':   /* Word-boundary assertion*/
11830                     case 'C':             /* Single char !DANGEROUS! */
11831                     case 'd': case 'D':   /* digit class */
11832                     case 'g': case 'G':   /* generic-backref, pos assertion */
11833                     case 'h': case 'H':   /* HORIZWS */
11834                     case 'k': case 'K':   /* named backref, keep marker */
11835                     case 'p': case 'P':   /* Unicode property */
11836                               case 'R':   /* LNBREAK */
11837                     case 's': case 'S':   /* space class */
11838                     case 'v': case 'V':   /* VERTWS */
11839                     case 'w': case 'W':   /* word class */
11840                     case 'X':             /* eXtended Unicode "combining
11841                                              character sequence" */
11842                     case 'z': case 'Z':   /* End of line/string assertion */
11843                         --p;
11844                         goto loopdone;
11845
11846                     /* Anything after here is an escape that resolves to a
11847                        literal. (Except digits, which may or may not)
11848                      */
11849                     case 'n':
11850                         ender = '\n';
11851                         p++;
11852                         break;
11853                     case 'N': /* Handle a single-code point named character. */
11854                         /* The options cause it to fail if a multiple code
11855                          * point sequence.  Handle those in the switch() above
11856                          * */
11857                         RExC_parse = p + 1;
11858                         if (! grok_bslash_N(pRExC_state, NULL, &ender,
11859                                             flagp, depth, FALSE,
11860                                             FALSE /* not strict */ ))
11861                         {
11862                             if (*flagp & RESTART_UTF8)
11863                                 FAIL("panic: grok_bslash_N set RESTART_UTF8");
11864                             RExC_parse = p = oldp;
11865                             goto loopdone;
11866                         }
11867                         p = RExC_parse;
11868                         if (ender > 0xff) {
11869                             REQUIRE_UTF8;
11870                         }
11871                         break;
11872                     case 'r':
11873                         ender = '\r';
11874                         p++;
11875                         break;
11876                     case 't':
11877                         ender = '\t';
11878                         p++;
11879                         break;
11880                     case 'f':
11881                         ender = '\f';
11882                         p++;
11883                         break;
11884                     case 'e':
11885                           ender = ASCII_TO_NATIVE('\033');
11886                         p++;
11887                         break;
11888                     case 'a':
11889                           ender = '\a';
11890                         p++;
11891                         break;
11892                     case 'o':
11893                         {
11894                             UV result;
11895                             const char* error_msg;
11896
11897                             bool valid = grok_bslash_o(&p,
11898                                                        &result,
11899                                                        &error_msg,
11900                                                        TRUE, /* out warnings */
11901                                                        FALSE, /* not strict */
11902                                                        TRUE, /* Output warnings
11903                                                                 for non-
11904                                                                 portables */
11905                                                        UTF);
11906                             if (! valid) {
11907                                 RExC_parse = p; /* going to die anyway; point
11908                                                    to exact spot of failure */
11909                                 vFAIL(error_msg);
11910                             }
11911                             ender = result;
11912                             if (PL_encoding && ender < 0x100) {
11913                                 goto recode_encoding;
11914                             }
11915                             if (ender > 0xff) {
11916                                 REQUIRE_UTF8;
11917                             }
11918                             break;
11919                         }
11920                     case 'x':
11921                         {
11922                             UV result = UV_MAX; /* initialize to erroneous
11923                                                    value */
11924                             const char* error_msg;
11925
11926                             bool valid = grok_bslash_x(&p,
11927                                                        &result,
11928                                                        &error_msg,
11929                                                        TRUE, /* out warnings */
11930                                                        FALSE, /* not strict */
11931                                                        TRUE, /* Output warnings
11932                                                                 for non-
11933                                                                 portables */
11934                                                        UTF);
11935                             if (! valid) {
11936                                 RExC_parse = p; /* going to die anyway; point
11937                                                    to exact spot of failure */
11938                                 vFAIL(error_msg);
11939                             }
11940                             ender = result;
11941
11942                             if (PL_encoding && ender < 0x100) {
11943                                 goto recode_encoding;
11944                             }
11945                             if (ender > 0xff) {
11946                                 REQUIRE_UTF8;
11947                             }
11948                             break;
11949                         }
11950                     case 'c':
11951                         p++;
11952                         ender = grok_bslash_c(*p++, SIZE_ONLY);
11953                         break;
11954                     case '8': case '9': /* must be a backreference */
11955                         --p;
11956                         goto loopdone;
11957                     case '1': case '2': case '3':case '4':
11958                     case '5': case '6': case '7':
11959                         /* When we parse backslash escapes there is ambiguity
11960                          * between backreferences and octal escapes. Any escape
11961                          * from \1 - \9 is a backreference, any multi-digit
11962                          * escape which does not start with 0 and which when
11963                          * evaluated as decimal could refer to an already
11964                          * parsed capture buffer is a backslash. Anything else
11965                          * is octal.
11966                          *
11967                          * Note this implies that \118 could be interpreted as
11968                          * 118 OR as "\11" . "8" depending on whether there
11969                          * were 118 capture buffers defined already in the
11970                          * pattern.  */
11971
11972                         /* NOTE, RExC_npar is 1 more than the actual number of
11973                          * parens we have seen so far, hence the < RExC_npar below. */
11974
11975                         if ( !isDIGIT(p[1]) || S_backref_value(p) < RExC_npar)
11976                         {  /* Not to be treated as an octal constant, go
11977                                    find backref */
11978                             --p;
11979                             goto loopdone;
11980                         }
11981                         /* FALLTHROUGH */
11982                     case '0':
11983                         {
11984                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
11985                             STRLEN numlen = 3;
11986                             ender = grok_oct(p, &numlen, &flags, NULL);
11987                             if (ender > 0xff) {
11988                                 REQUIRE_UTF8;
11989                             }
11990                             p += numlen;
11991                             if (SIZE_ONLY   /* like \08, \178 */
11992                                 && numlen < 3
11993                                 && p < RExC_end
11994                                 && isDIGIT(*p) && ckWARN(WARN_REGEXP))
11995                             {
11996                                 reg_warn_non_literal_string(
11997                                          p + 1,
11998                                          form_short_octal_warning(p, numlen));
11999                             }
12000                         }
12001                         if (PL_encoding && ender < 0x100)
12002                             goto recode_encoding;
12003                         break;
12004                     recode_encoding:
12005                         if (! RExC_override_recoding) {
12006                             SV* enc = PL_encoding;
12007                             ender = reg_recode((const char)(U8)ender, &enc);
12008                             if (!enc && SIZE_ONLY)
12009                                 ckWARNreg(p, "Invalid escape in the specified encoding");
12010                             REQUIRE_UTF8;
12011                         }
12012                         break;
12013                     case '\0':
12014                         if (p >= RExC_end)
12015                             FAIL("Trailing \\");
12016                         /* FALLTHROUGH */
12017                     default:
12018                         if (!SIZE_ONLY&& isALPHANUMERIC(*p)) {
12019                             /* Include any { following the alpha to emphasize
12020                              * that it could be part of an escape at some point
12021                              * in the future */
12022                             int len = (isALPHA(*p) && *(p + 1) == '{') ? 2 : 1;
12023                             ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
12024                         }
12025                         goto normal_default;
12026                     } /* End of switch on '\' */
12027                     break;
12028                 case '{':
12029                     /* Currently we don't warn when the lbrace is at the start
12030                      * of a construct.  This catches it in the middle of a
12031                      * literal string, or when its the first thing after
12032                      * something like "\b" */
12033                     if (! SIZE_ONLY
12034                         && (len || (p > RExC_start && isALPHA_A(*(p -1)))))
12035                     {
12036                         ckWARNregdep(p + 1, "Unescaped left brace in regex is deprecated, passed through");
12037                     }
12038                     /*FALLTHROUGH*/
12039                 default:    /* A literal character */
12040                   normal_default:
12041                     if (UTF8_IS_START(*p) && UTF) {
12042                         STRLEN numlen;
12043                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
12044                                                &numlen, UTF8_ALLOW_DEFAULT);
12045                         p += numlen;
12046                     }
12047                     else
12048                         ender = (U8) *p++;
12049                     break;
12050                 } /* End of switch on the literal */
12051
12052                 /* Here, have looked at the literal character and <ender>
12053                  * contains its ordinal, <p> points to the character after it
12054                  */
12055
12056                 if ( RExC_flags & RXf_PMf_EXTENDED)
12057                     p = regpatws(pRExC_state, p,
12058                                           TRUE); /* means recognize comments */
12059
12060                 /* If the next thing is a quantifier, it applies to this
12061                  * character only, which means that this character has to be in
12062                  * its own node and can't just be appended to the string in an
12063                  * existing node, so if there are already other characters in
12064                  * the node, close the node with just them, and set up to do
12065                  * this character again next time through, when it will be the
12066                  * only thing in its new node */
12067                 if ((next_is_quantifier = (p < RExC_end && ISMULT2(p))) && len)
12068                 {
12069                     p = oldp;
12070                     goto loopdone;
12071                 }
12072
12073                 if (! FOLD   /* The simple case, just append the literal */
12074                     || (LOC  /* Also don't fold for tricky chars under /l */
12075                         && is_PROBLEMATIC_LOCALE_FOLD_cp(ender)))
12076                 {
12077                     if (UTF) {
12078                         const STRLEN unilen = reguni(pRExC_state, ender, s);
12079                         if (unilen > 0) {
12080                            s   += unilen;
12081                            len += unilen;
12082                         }
12083
12084                         /* The loop increments <len> each time, as all but this
12085                          * path (and one other) through it add a single byte to
12086                          * the EXACTish node.  But this one has changed len to
12087                          * be the correct final value, so subtract one to
12088                          * cancel out the increment that follows */
12089                         len--;
12090                     }
12091                     else {
12092                         REGC((char)ender, s++);
12093                     }
12094
12095                     /* Can get here if folding only if is one of the /l
12096                      * characters whose fold depends on the locale.  The
12097                      * occurrence of any of these indicate that we can't
12098                      * simplify things */
12099                     if (FOLD) {
12100                         maybe_exact = FALSE;
12101                         maybe_exactfu = FALSE;
12102                     }
12103                 }
12104                 else             /* FOLD */
12105                      if (! ( UTF
12106                         /* See comments for join_exact() as to why we fold this
12107                          * non-UTF at compile time */
12108                         || (node_type == EXACTFU
12109                             && ender == LATIN_SMALL_LETTER_SHARP_S)))
12110                 {
12111                     /* Here, are folding and are not UTF-8 encoded; therefore
12112                      * the character must be in the range 0-255, and is not /l
12113                      * (Not /l because we already handled these under /l in
12114                      * is_PROBLEMATIC_LOCALE_FOLD_cp */
12115                     if (IS_IN_SOME_FOLD_L1(ender)) {
12116                         maybe_exact = FALSE;
12117
12118                         /* See if the character's fold differs between /d and
12119                          * /u.  This includes the multi-char fold SHARP S to
12120                          * 'ss' */
12121                         if (maybe_exactfu
12122                             && (PL_fold[ender] != PL_fold_latin1[ender]
12123                                 || ender == LATIN_SMALL_LETTER_SHARP_S
12124                                 || (len > 0
12125                                    && isARG2_lower_or_UPPER_ARG1('s', ender)
12126                                    && isARG2_lower_or_UPPER_ARG1('s',
12127                                                                  *(s-1)))))
12128                         {
12129                             maybe_exactfu = FALSE;
12130                         }
12131                     }
12132
12133                     /* Even when folding, we store just the input character, as
12134                      * we have an array that finds its fold quickly */
12135                     *(s++) = (char) ender;
12136                 }
12137                 else {  /* FOLD and UTF */
12138                     /* Unlike the non-fold case, we do actually have to
12139                      * calculate the results here in pass 1.  This is for two
12140                      * reasons, the folded length may be longer than the
12141                      * unfolded, and we have to calculate how many EXACTish
12142                      * nodes it will take; and we may run out of room in a node
12143                      * in the middle of a potential multi-char fold, and have
12144                      * to back off accordingly.  (Hence we can't use REGC for
12145                      * the simple case just below.) */
12146
12147                     UV folded;
12148                     if (isASCII(ender)) {
12149                         folded = toFOLD(ender);
12150                         *(s)++ = (U8) folded;
12151                     }
12152                     else {
12153                         STRLEN foldlen;
12154
12155                         folded = _to_uni_fold_flags(
12156                                      ender,
12157                                      (U8 *) s,
12158                                      &foldlen,
12159                                      FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
12160                                                         ? FOLD_FLAGS_NOMIX_ASCII
12161                                                         : 0));
12162                         s += foldlen;
12163
12164                         /* The loop increments <len> each time, as all but this
12165                          * path (and one other) through it add a single byte to
12166                          * the EXACTish node.  But this one has changed len to
12167                          * be the correct final value, so subtract one to
12168                          * cancel out the increment that follows */
12169                         len += foldlen - 1;
12170                     }
12171                     /* If this node only contains non-folding code points so
12172                      * far, see if this new one is also non-folding */
12173                     if (maybe_exact) {
12174                         if (folded != ender) {
12175                             maybe_exact = FALSE;
12176                         }
12177                         else {
12178                             /* Here the fold is the original; we have to check
12179                              * further to see if anything folds to it */
12180                             if (_invlist_contains_cp(PL_utf8_foldable,
12181                                                         ender))
12182                             {
12183                                 maybe_exact = FALSE;
12184                             }
12185                         }
12186                     }
12187                     ender = folded;
12188                 }
12189
12190                 if (next_is_quantifier) {
12191
12192                     /* Here, the next input is a quantifier, and to get here,
12193                      * the current character is the only one in the node.
12194                      * Also, here <len> doesn't include the final byte for this
12195                      * character */
12196                     len++;
12197                     goto loopdone;
12198                 }
12199
12200             } /* End of loop through literal characters */
12201
12202             /* Here we have either exhausted the input or ran out of room in
12203              * the node.  (If we encountered a character that can't be in the
12204              * node, transfer is made directly to <loopdone>, and so we
12205              * wouldn't have fallen off the end of the loop.)  In the latter
12206              * case, we artificially have to split the node into two, because
12207              * we just don't have enough space to hold everything.  This
12208              * creates a problem if the final character participates in a
12209              * multi-character fold in the non-final position, as a match that
12210              * should have occurred won't, due to the way nodes are matched,
12211              * and our artificial boundary.  So back off until we find a non-
12212              * problematic character -- one that isn't at the beginning or
12213              * middle of such a fold.  (Either it doesn't participate in any
12214              * folds, or appears only in the final position of all the folds it
12215              * does participate in.)  A better solution with far fewer false
12216              * positives, and that would fill the nodes more completely, would
12217              * be to actually have available all the multi-character folds to
12218              * test against, and to back-off only far enough to be sure that
12219              * this node isn't ending with a partial one.  <upper_parse> is set
12220              * further below (if we need to reparse the node) to include just
12221              * up through that final non-problematic character that this code
12222              * identifies, so when it is set to less than the full node, we can
12223              * skip the rest of this */
12224             if (FOLD && p < RExC_end && upper_parse == MAX_NODE_STRING_SIZE) {
12225
12226                 const STRLEN full_len = len;
12227
12228                 assert(len >= MAX_NODE_STRING_SIZE);
12229
12230                 /* Here, <s> points to the final byte of the final character.
12231                  * Look backwards through the string until find a non-
12232                  * problematic character */
12233
12234                 if (! UTF) {
12235
12236                     /* This has no multi-char folds to non-UTF characters */
12237                     if (ASCII_FOLD_RESTRICTED) {
12238                         goto loopdone;
12239                     }
12240
12241                     while (--s >= s0 && IS_NON_FINAL_FOLD(*s)) { }
12242                     len = s - s0 + 1;
12243                 }
12244                 else {
12245                     if (!  PL_NonL1NonFinalFold) {
12246                         PL_NonL1NonFinalFold = _new_invlist_C_array(
12247                                         NonL1_Perl_Non_Final_Folds_invlist);
12248                     }
12249
12250                     /* Point to the first byte of the final character */
12251                     s = (char *) utf8_hop((U8 *) s, -1);
12252
12253                     while (s >= s0) {   /* Search backwards until find
12254                                            non-problematic char */
12255                         if (UTF8_IS_INVARIANT(*s)) {
12256
12257                             /* There are no ascii characters that participate
12258                              * in multi-char folds under /aa.  In EBCDIC, the
12259                              * non-ascii invariants are all control characters,
12260                              * so don't ever participate in any folds. */
12261                             if (ASCII_FOLD_RESTRICTED
12262                                 || ! IS_NON_FINAL_FOLD(*s))
12263                             {
12264                                 break;
12265                             }
12266                         }
12267                         else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
12268                             if (! IS_NON_FINAL_FOLD(TWO_BYTE_UTF8_TO_NATIVE(
12269                                                                   *s, *(s+1))))
12270                             {
12271                                 break;
12272                             }
12273                         }
12274                         else if (! _invlist_contains_cp(
12275                                         PL_NonL1NonFinalFold,
12276                                         valid_utf8_to_uvchr((U8 *) s, NULL)))
12277                         {
12278                             break;
12279                         }
12280
12281                         /* Here, the current character is problematic in that
12282                          * it does occur in the non-final position of some
12283                          * fold, so try the character before it, but have to
12284                          * special case the very first byte in the string, so
12285                          * we don't read outside the string */
12286                         s = (s == s0) ? s -1 : (char *) utf8_hop((U8 *) s, -1);
12287                     } /* End of loop backwards through the string */
12288
12289                     /* If there were only problematic characters in the string,
12290                      * <s> will point to before s0, in which case the length
12291                      * should be 0, otherwise include the length of the
12292                      * non-problematic character just found */
12293                     len = (s < s0) ? 0 : s - s0 + UTF8SKIP(s);
12294                 }
12295
12296                 /* Here, have found the final character, if any, that is
12297                  * non-problematic as far as ending the node without splitting
12298                  * it across a potential multi-char fold.  <len> contains the
12299                  * number of bytes in the node up-to and including that
12300                  * character, or is 0 if there is no such character, meaning
12301                  * the whole node contains only problematic characters.  In
12302                  * this case, give up and just take the node as-is.  We can't
12303                  * do any better */
12304                 if (len == 0) {
12305                     len = full_len;
12306
12307                     /* If the node ends in an 's' we make sure it stays EXACTF,
12308                      * as if it turns into an EXACTFU, it could later get
12309                      * joined with another 's' that would then wrongly match
12310                      * the sharp s */
12311                     if (maybe_exactfu && isARG2_lower_or_UPPER_ARG1('s', ender))
12312                     {
12313                         maybe_exactfu = FALSE;
12314                     }
12315                 } else {
12316
12317                     /* Here, the node does contain some characters that aren't
12318                      * problematic.  If one such is the final character in the
12319                      * node, we are done */
12320                     if (len == full_len) {
12321                         goto loopdone;
12322                     }
12323                     else if (len + ((UTF) ? UTF8SKIP(s) : 1) == full_len) {
12324
12325                         /* If the final character is problematic, but the
12326                          * penultimate is not, back-off that last character to
12327                          * later start a new node with it */
12328                         p = oldp;
12329                         goto loopdone;
12330                     }
12331
12332                     /* Here, the final non-problematic character is earlier
12333                      * in the input than the penultimate character.  What we do
12334                      * is reparse from the beginning, going up only as far as
12335                      * this final ok one, thus guaranteeing that the node ends
12336                      * in an acceptable character.  The reason we reparse is
12337                      * that we know how far in the character is, but we don't
12338                      * know how to correlate its position with the input parse.
12339                      * An alternate implementation would be to build that
12340                      * correlation as we go along during the original parse,
12341                      * but that would entail extra work for every node, whereas
12342                      * this code gets executed only when the string is too
12343                      * large for the node, and the final two characters are
12344                      * problematic, an infrequent occurrence.  Yet another
12345                      * possible strategy would be to save the tail of the
12346                      * string, and the next time regatom is called, initialize
12347                      * with that.  The problem with this is that unless you
12348                      * back off one more character, you won't be guaranteed
12349                      * regatom will get called again, unless regbranch,
12350                      * regpiece ... are also changed.  If you do back off that
12351                      * extra character, so that there is input guaranteed to
12352                      * force calling regatom, you can't handle the case where
12353                      * just the first character in the node is acceptable.  I
12354                      * (khw) decided to try this method which doesn't have that
12355                      * pitfall; if performance issues are found, we can do a
12356                      * combination of the current approach plus that one */
12357                     upper_parse = len;
12358                     len = 0;
12359                     s = s0;
12360                     goto reparse;
12361                 }
12362             }   /* End of verifying node ends with an appropriate char */
12363
12364         loopdone:   /* Jumped to when encounters something that shouldn't be in
12365                        the node */
12366
12367             /* I (khw) don't know if you can get here with zero length, but the
12368              * old code handled this situation by creating a zero-length EXACT
12369              * node.  Might as well be NOTHING instead */
12370             if (len == 0) {
12371                 OP(ret) = NOTHING;
12372             }
12373             else {
12374                 if (FOLD) {
12375                     /* If 'maybe_exact' is still set here, means there are no
12376                      * code points in the node that participate in folds;
12377                      * similarly for 'maybe_exactfu' and code points that match
12378                      * differently depending on UTF8ness of the target string
12379                      * (for /u), or depending on locale for /l */
12380                     if (maybe_exact) {
12381                         OP(ret) = EXACT;
12382                     }
12383                     else if (maybe_exactfu) {
12384                         OP(ret) = EXACTFU;
12385                     }
12386                 }
12387                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, len, ender,
12388                                            FALSE /* Don't look to see if could
12389                                                     be turned into an EXACT
12390                                                     node, as we have already
12391                                                     computed that */
12392                                           );
12393             }
12394
12395             RExC_parse = p - 1;
12396             Set_Node_Cur_Length(ret, parse_start);
12397             nextchar(pRExC_state);
12398             {
12399                 /* len is STRLEN which is unsigned, need to copy to signed */
12400                 IV iv = len;
12401                 if (iv < 0)
12402                     vFAIL("Internal disaster");
12403             }
12404
12405         } /* End of label 'defchar:' */
12406         break;
12407     } /* End of giant switch on input character */
12408
12409     return(ret);
12410 }
12411
12412 STATIC char *
12413 S_regpatws(RExC_state_t *pRExC_state, char *p , const bool recognize_comment )
12414 {
12415     /* Returns the next non-pattern-white space, non-comment character (the
12416      * latter only if 'recognize_comment is true) in the string p, which is
12417      * ended by RExC_end.  See also reg_skipcomment */
12418     const char *e = RExC_end;
12419
12420     PERL_ARGS_ASSERT_REGPATWS;
12421
12422     while (p < e) {
12423         STRLEN len;
12424         if ((len = is_PATWS_safe(p, e, UTF))) {
12425             p += len;
12426         }
12427         else if (recognize_comment && *p == '#') {
12428             p = reg_skipcomment(pRExC_state, p);
12429         }
12430         else
12431             break;
12432     }
12433     return p;
12434 }
12435
12436 STATIC void
12437 S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr)
12438 {
12439     /* Uses the inversion list '*invlist_ptr' to populate the ANYOF 'node'.  It
12440      * sets up the bitmap and any flags, removing those code points from the
12441      * inversion list, setting it to NULL should it become completely empty */
12442
12443     PERL_ARGS_ASSERT_POPULATE_ANYOF_FROM_INVLIST;
12444     assert(PL_regkind[OP(node)] == ANYOF);
12445
12446     ANYOF_BITMAP_ZERO(node);
12447     if (*invlist_ptr) {
12448
12449         /* This gets set if we actually need to modify things */
12450         bool change_invlist = FALSE;
12451
12452         UV start, end;
12453
12454         /* Start looking through *invlist_ptr */
12455         invlist_iterinit(*invlist_ptr);
12456         while (invlist_iternext(*invlist_ptr, &start, &end)) {
12457             UV high;
12458             int i;
12459
12460             if (end == UV_MAX && start <= 256) {
12461                 ANYOF_FLAGS(node) |= ANYOF_ABOVE_LATIN1_ALL;
12462             }
12463             else if (end >= 256) {
12464                 ANYOF_FLAGS(node) |= ANYOF_UTF8;
12465             }
12466
12467             /* Quit if are above what we should change */
12468             if (start > 255) {
12469                 break;
12470             }
12471
12472             change_invlist = TRUE;
12473
12474             /* Set all the bits in the range, up to the max that we are doing */
12475             high = (end < 255) ? end : 255;
12476             for (i = start; i <= (int) high; i++) {
12477                 if (! ANYOF_BITMAP_TEST(node, i)) {
12478                     ANYOF_BITMAP_SET(node, i);
12479                 }
12480             }
12481         }
12482         invlist_iterfinish(*invlist_ptr);
12483
12484         /* Done with loop; remove any code points that are in the bitmap from
12485          * *invlist_ptr; similarly for code points above latin1 if we have a
12486          * flag to match all of them anyways */
12487         if (change_invlist) {
12488             _invlist_subtract(*invlist_ptr, PL_Latin1, invlist_ptr);
12489         }
12490         if (ANYOF_FLAGS(node) & ANYOF_ABOVE_LATIN1_ALL) {
12491             _invlist_intersection(*invlist_ptr, PL_Latin1, invlist_ptr);
12492         }
12493
12494         /* If have completely emptied it, remove it completely */
12495         if (_invlist_len(*invlist_ptr) == 0) {
12496             SvREFCNT_dec_NN(*invlist_ptr);
12497             *invlist_ptr = NULL;
12498         }
12499     }
12500 }
12501
12502 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
12503    Character classes ([:foo:]) can also be negated ([:^foo:]).
12504    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
12505    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
12506    but trigger failures because they are currently unimplemented. */
12507
12508 #define POSIXCC_DONE(c)   ((c) == ':')
12509 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
12510 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
12511
12512 PERL_STATIC_INLINE I32
12513 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value, const bool strict)
12514 {
12515     I32 namedclass = OOB_NAMEDCLASS;
12516
12517     PERL_ARGS_ASSERT_REGPPOSIXCC;
12518
12519     if (value == '[' && RExC_parse + 1 < RExC_end &&
12520         /* I smell either [: or [= or [. -- POSIX has been here, right? */
12521         POSIXCC(UCHARAT(RExC_parse)))
12522     {
12523         const char c = UCHARAT(RExC_parse);
12524         char* const s = RExC_parse++;
12525
12526         while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
12527             RExC_parse++;
12528         if (RExC_parse == RExC_end) {
12529             if (strict) {
12530
12531                 /* Try to give a better location for the error (than the end of
12532                  * the string) by looking for the matching ']' */
12533                 RExC_parse = s;
12534                 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
12535                     RExC_parse++;
12536                 }
12537                 vFAIL2("Unmatched '%c' in POSIX class", c);
12538             }
12539             /* Grandfather lone [:, [=, [. */
12540             RExC_parse = s;
12541         }
12542         else {
12543             const char* const t = RExC_parse++; /* skip over the c */
12544             assert(*t == c);
12545
12546             if (UCHARAT(RExC_parse) == ']') {
12547                 const char *posixcc = s + 1;
12548                 RExC_parse++; /* skip over the ending ] */
12549
12550                 if (*s == ':') {
12551                     const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
12552                     const I32 skip = t - posixcc;
12553
12554                     /* Initially switch on the length of the name.  */
12555                     switch (skip) {
12556                     case 4:
12557                         if (memEQ(posixcc, "word", 4)) /* this is not POSIX,
12558                                                           this is the Perl \w
12559                                                         */
12560                             namedclass = ANYOF_WORDCHAR;
12561                         break;
12562                     case 5:
12563                         /* Names all of length 5.  */
12564                         /* alnum alpha ascii blank cntrl digit graph lower
12565                            print punct space upper  */
12566                         /* Offset 4 gives the best switch position.  */
12567                         switch (posixcc[4]) {
12568                         case 'a':
12569                             if (memEQ(posixcc, "alph", 4)) /* alpha */
12570                                 namedclass = ANYOF_ALPHA;
12571                             break;
12572                         case 'e':
12573                             if (memEQ(posixcc, "spac", 4)) /* space */
12574                                 namedclass = ANYOF_PSXSPC;
12575                             break;
12576                         case 'h':
12577                             if (memEQ(posixcc, "grap", 4)) /* graph */
12578                                 namedclass = ANYOF_GRAPH;
12579                             break;
12580                         case 'i':
12581                             if (memEQ(posixcc, "asci", 4)) /* ascii */
12582                                 namedclass = ANYOF_ASCII;
12583                             break;
12584                         case 'k':
12585                             if (memEQ(posixcc, "blan", 4)) /* blank */
12586                                 namedclass = ANYOF_BLANK;
12587                             break;
12588                         case 'l':
12589                             if (memEQ(posixcc, "cntr", 4)) /* cntrl */
12590                                 namedclass = ANYOF_CNTRL;
12591                             break;
12592                         case 'm':
12593                             if (memEQ(posixcc, "alnu", 4)) /* alnum */
12594                                 namedclass = ANYOF_ALPHANUMERIC;
12595                             break;
12596                         case 'r':
12597                             if (memEQ(posixcc, "lowe", 4)) /* lower */
12598                                 namedclass = (FOLD) ? ANYOF_CASED : ANYOF_LOWER;
12599                             else if (memEQ(posixcc, "uppe", 4)) /* upper */
12600                                 namedclass = (FOLD) ? ANYOF_CASED : ANYOF_UPPER;
12601                             break;
12602                         case 't':
12603                             if (memEQ(posixcc, "digi", 4)) /* digit */
12604                                 namedclass = ANYOF_DIGIT;
12605                             else if (memEQ(posixcc, "prin", 4)) /* print */
12606                                 namedclass = ANYOF_PRINT;
12607                             else if (memEQ(posixcc, "punc", 4)) /* punct */
12608                                 namedclass = ANYOF_PUNCT;
12609                             break;
12610                         }
12611                         break;
12612                     case 6:
12613                         if (memEQ(posixcc, "xdigit", 6))
12614                             namedclass = ANYOF_XDIGIT;
12615                         break;
12616                     }
12617
12618                     if (namedclass == OOB_NAMEDCLASS)
12619                         vFAIL2utf8f(
12620                             "POSIX class [:%"UTF8f":] unknown",
12621                             UTF8fARG(UTF, t - s - 1, s + 1));
12622
12623                     /* The #defines are structured so each complement is +1 to
12624                      * the normal one */
12625                     if (complement) {
12626                         namedclass++;
12627                     }
12628                     assert (posixcc[skip] == ':');
12629                     assert (posixcc[skip+1] == ']');
12630                 } else if (!SIZE_ONLY) {
12631                     /* [[=foo=]] and [[.foo.]] are still future. */
12632
12633                     /* adjust RExC_parse so the warning shows after
12634                        the class closes */
12635                     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
12636                         RExC_parse++;
12637                     vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
12638                 }
12639             } else {
12640                 /* Maternal grandfather:
12641                  * "[:" ending in ":" but not in ":]" */
12642                 if (strict) {
12643                     vFAIL("Unmatched '[' in POSIX class");
12644                 }
12645
12646                 /* Grandfather lone [:, [=, [. */
12647                 RExC_parse = s;
12648             }
12649         }
12650     }
12651
12652     return namedclass;
12653 }
12654
12655 STATIC bool
12656 S_could_it_be_a_POSIX_class(RExC_state_t *pRExC_state)
12657 {
12658     /* This applies some heuristics at the current parse position (which should
12659      * be at a '[') to see if what follows might be intended to be a [:posix:]
12660      * class.  It returns true if it really is a posix class, of course, but it
12661      * also can return true if it thinks that what was intended was a posix
12662      * class that didn't quite make it.
12663      *
12664      * It will return true for
12665      *      [:alphanumerics:
12666      *      [:alphanumerics]  (as long as the ] isn't followed immediately by a
12667      *                         ')' indicating the end of the (?[
12668      *      [:any garbage including %^&$ punctuation:]
12669      *
12670      * This is designed to be called only from S_handle_regex_sets; it could be
12671      * easily adapted to be called from the spot at the beginning of regclass()
12672      * that checks to see in a normal bracketed class if the surrounding []
12673      * have been omitted ([:word:] instead of [[:word:]]).  But doing so would
12674      * change long-standing behavior, so I (khw) didn't do that */
12675     char* p = RExC_parse + 1;
12676     char first_char = *p;
12677
12678     PERL_ARGS_ASSERT_COULD_IT_BE_A_POSIX_CLASS;
12679
12680     assert(*(p - 1) == '[');
12681
12682     if (! POSIXCC(first_char)) {
12683         return FALSE;
12684     }
12685
12686     p++;
12687     while (p < RExC_end && isWORDCHAR(*p)) p++;
12688
12689     if (p >= RExC_end) {
12690         return FALSE;
12691     }
12692
12693     if (p - RExC_parse > 2    /* Got at least 1 word character */
12694         && (*p == first_char
12695             || (*p == ']' && p + 1 < RExC_end && *(p + 1) != ')')))
12696     {
12697         return TRUE;
12698     }
12699
12700     p = (char *) memchr(RExC_parse, ']', RExC_end - RExC_parse);
12701
12702     return (p
12703             && p - RExC_parse > 2 /* [:] evaluates to colon;
12704                                       [::] is a bad posix class. */
12705             && first_char == *(p - 1));
12706 }
12707
12708 STATIC regnode *
12709 S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist,
12710                     I32 *flagp, U32 depth,
12711                     char * const oregcomp_parse)
12712 {
12713     /* Handle the (?[...]) construct to do set operations */
12714
12715     U8 curchar;
12716     UV start, end;      /* End points of code point ranges */
12717     SV* result_string;
12718     char *save_end, *save_parse;
12719     SV* final;
12720     STRLEN len;
12721     regnode* node;
12722     AV* stack;
12723     const bool save_fold = FOLD;
12724
12725     GET_RE_DEBUG_FLAGS_DECL;
12726
12727     PERL_ARGS_ASSERT_HANDLE_REGEX_SETS;
12728
12729     if (LOC) {
12730         vFAIL("(?[...]) not valid in locale");
12731     }
12732     RExC_uni_semantics = 1;
12733
12734     /* This will return only an ANYOF regnode, or (unlikely) something smaller
12735      * (such as EXACT).  Thus we can skip most everything if just sizing.  We
12736      * call regclass to handle '[]' so as to not have to reinvent its parsing
12737      * rules here (throwing away the size it computes each time).  And, we exit
12738      * upon an unescaped ']' that isn't one ending a regclass.  To do both
12739      * these things, we need to realize that something preceded by a backslash
12740      * is escaped, so we have to keep track of backslashes */
12741     if (SIZE_ONLY) {
12742         UV depth = 0; /* how many nested (?[...]) constructs */
12743
12744         Perl_ck_warner_d(aTHX_
12745             packWARN(WARN_EXPERIMENTAL__REGEX_SETS),
12746             "The regex_sets feature is experimental" REPORT_LOCATION,
12747                 UTF8fARG(UTF, (RExC_parse - RExC_precomp), RExC_precomp),
12748                 UTF8fARG(UTF,
12749                          RExC_end - RExC_start - (RExC_parse - RExC_precomp),
12750                          RExC_precomp + (RExC_parse - RExC_precomp)));
12751
12752         while (RExC_parse < RExC_end) {
12753             SV* current = NULL;
12754             RExC_parse = regpatws(pRExC_state, RExC_parse,
12755                                           TRUE); /* means recognize comments */
12756             switch (*RExC_parse) {
12757                 case '?':
12758                     if (RExC_parse[1] == '[') depth++, RExC_parse++;
12759                     /* FALLTHROUGH */
12760                 default:
12761                     break;
12762                 case '\\':
12763                     /* Skip the next byte (which could cause us to end up in
12764                      * the middle of a UTF-8 character, but since none of those
12765                      * are confusable with anything we currently handle in this
12766                      * switch (invariants all), it's safe.  We'll just hit the
12767                      * default: case next time and keep on incrementing until
12768                      * we find one of the invariants we do handle. */
12769                     RExC_parse++;
12770                     break;
12771                 case '[':
12772                 {
12773                     /* If this looks like it is a [:posix:] class, leave the
12774                      * parse pointer at the '[' to fool regclass() into
12775                      * thinking it is part of a '[[:posix:]]'.  That function
12776                      * will use strict checking to force a syntax error if it
12777                      * doesn't work out to a legitimate class */
12778                     bool is_posix_class
12779                                     = could_it_be_a_POSIX_class(pRExC_state);
12780                     if (! is_posix_class) {
12781                         RExC_parse++;
12782                     }
12783
12784                     /* regclass() can only return RESTART_UTF8 if multi-char
12785                        folds are allowed.  */
12786                     if (!regclass(pRExC_state, flagp,depth+1,
12787                                   is_posix_class, /* parse the whole char
12788                                                      class only if not a
12789                                                      posix class */
12790                                   FALSE, /* don't allow multi-char folds */
12791                                   TRUE, /* silence non-portable warnings. */
12792                                   &current))
12793                         FAIL2("panic: regclass returned NULL to handle_sets, flags=%#"UVxf"",
12794                               (UV) *flagp);
12795
12796                     /* function call leaves parse pointing to the ']', except
12797                      * if we faked it */
12798                     if (is_posix_class) {
12799                         RExC_parse--;
12800                     }
12801
12802                     SvREFCNT_dec(current);   /* In case it returned something */
12803                     break;
12804                 }
12805
12806                 case ']':
12807                     if (depth--) break;
12808                     RExC_parse++;
12809                     if (RExC_parse < RExC_end
12810                         && *RExC_parse == ')')
12811                     {
12812                         node = reganode(pRExC_state, ANYOF, 0);
12813                         RExC_size += ANYOF_SKIP;
12814                         nextchar(pRExC_state);
12815                         Set_Node_Length(node,
12816                                 RExC_parse - oregcomp_parse + 1); /* MJD */
12817                         return node;
12818                     }
12819                     goto no_close;
12820             }
12821             RExC_parse++;
12822         }
12823
12824         no_close:
12825         FAIL("Syntax error in (?[...])");
12826     }
12827
12828     /* Pass 2 only after this.  Everything in this construct is a
12829      * metacharacter.  Operands begin with either a '\' (for an escape
12830      * sequence), or a '[' for a bracketed character class.  Any other
12831      * character should be an operator, or parenthesis for grouping.  Both
12832      * types of operands are handled by calling regclass() to parse them.  It
12833      * is called with a parameter to indicate to return the computed inversion
12834      * list.  The parsing here is implemented via a stack.  Each entry on the
12835      * stack is a single character representing one of the operators, or the
12836      * '('; or else a pointer to an operand inversion list. */
12837
12838 #define IS_OPERAND(a)  (! SvIOK(a))
12839
12840     /* The stack starts empty.  It is a syntax error if the first thing parsed
12841      * is a binary operator; everything else is pushed on the stack.  When an
12842      * operand is parsed, the top of the stack is examined.  If it is a binary
12843      * operator, the item before it should be an operand, and both are replaced
12844      * by the result of doing that operation on the new operand and the one on
12845      * the stack.   Thus a sequence of binary operands is reduced to a single
12846      * one before the next one is parsed.
12847      *
12848      * A unary operator may immediately follow a binary in the input, for
12849      * example
12850      *      [a] + ! [b]
12851      * When an operand is parsed and the top of the stack is a unary operator,
12852      * the operation is performed, and then the stack is rechecked to see if
12853      * this new operand is part of a binary operation; if so, it is handled as
12854      * above.
12855      *
12856      * A '(' is simply pushed on the stack; it is valid only if the stack is
12857      * empty, or the top element of the stack is an operator or another '('
12858      * (for which the parenthesized expression will become an operand).  By the
12859      * time the corresponding ')' is parsed everything in between should have
12860      * been parsed and evaluated to a single operand (or else is a syntax
12861      * error), and is handled as a regular operand */
12862
12863     sv_2mortal((SV *)(stack = newAV()));
12864
12865     while (RExC_parse < RExC_end) {
12866         I32 top_index = av_tindex(stack);
12867         SV** top_ptr;
12868         SV* current = NULL;
12869
12870         /* Skip white space */
12871         RExC_parse = regpatws(pRExC_state, RExC_parse,
12872                                          TRUE /* means recognize comments */ );
12873         if (RExC_parse >= RExC_end) {
12874             Perl_croak(aTHX_ "panic: Read past end of '(?[ ])'");
12875         }
12876         if ((curchar = UCHARAT(RExC_parse)) == ']') {
12877             break;
12878         }
12879
12880         switch (curchar) {
12881
12882             case '?':
12883                 if (av_tindex(stack) >= 0   /* This makes sure that we can
12884                                                safely subtract 1 from
12885                                                RExC_parse in the next clause.
12886                                                If we have something on the
12887                                                stack, we have parsed something
12888                                              */
12889                     && UCHARAT(RExC_parse - 1) == '('
12890                     && RExC_parse < RExC_end)
12891                 {
12892                     /* If is a '(?', could be an embedded '(?flags:(?[...])'.
12893                      * This happens when we have some thing like
12894                      *
12895                      *   my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
12896                      *   ...
12897                      *   qr/(?[ \p{Digit} & $thai_or_lao ])/;
12898                      *
12899                      * Here we would be handling the interpolated
12900                      * '$thai_or_lao'.  We handle this by a recursive call to
12901                      * ourselves which returns the inversion list the
12902                      * interpolated expression evaluates to.  We use the flags
12903                      * from the interpolated pattern. */
12904                     U32 save_flags = RExC_flags;
12905                     const char * const save_parse = ++RExC_parse;
12906
12907                     parse_lparen_question_flags(pRExC_state);
12908
12909                     if (RExC_parse == save_parse  /* Makes sure there was at
12910                                                      least one flag (or this
12911                                                      embedding wasn't compiled)
12912                                                    */
12913                         || RExC_parse >= RExC_end - 4
12914                         || UCHARAT(RExC_parse) != ':'
12915                         || UCHARAT(++RExC_parse) != '('
12916                         || UCHARAT(++RExC_parse) != '?'
12917                         || UCHARAT(++RExC_parse) != '[')
12918                     {
12919
12920                         /* In combination with the above, this moves the
12921                          * pointer to the point just after the first erroneous
12922                          * character (or if there are no flags, to where they
12923                          * should have been) */
12924                         if (RExC_parse >= RExC_end - 4) {
12925                             RExC_parse = RExC_end;
12926                         }
12927                         else if (RExC_parse != save_parse) {
12928                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
12929                         }
12930                         vFAIL("Expecting '(?flags:(?[...'");
12931                     }
12932                     RExC_parse++;
12933                     (void) handle_regex_sets(pRExC_state, &current, flagp,
12934                                                     depth+1, oregcomp_parse);
12935
12936                     /* Here, 'current' contains the embedded expression's
12937                      * inversion list, and RExC_parse points to the trailing
12938                      * ']'; the next character should be the ')' which will be
12939                      * paired with the '(' that has been put on the stack, so
12940                      * the whole embedded expression reduces to '(operand)' */
12941                     RExC_parse++;
12942
12943                     RExC_flags = save_flags;
12944                     goto handle_operand;
12945                 }
12946                 /* FALLTHROUGH */
12947
12948             default:
12949                 RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
12950                 vFAIL("Unexpected character");
12951
12952             case '\\':
12953                 /* regclass() can only return RESTART_UTF8 if multi-char
12954                    folds are allowed.  */
12955                 if (!regclass(pRExC_state, flagp,depth+1,
12956                               TRUE, /* means parse just the next thing */
12957                               FALSE, /* don't allow multi-char folds */
12958                               FALSE, /* don't silence non-portable warnings.  */
12959                               &current))
12960                     FAIL2("panic: regclass returned NULL to handle_sets, flags=%#"UVxf"",
12961                           (UV) *flagp);
12962                 /* regclass() will return with parsing just the \ sequence,
12963                  * leaving the parse pointer at the next thing to parse */
12964                 RExC_parse--;
12965                 goto handle_operand;
12966
12967             case '[':   /* Is a bracketed character class */
12968             {
12969                 bool is_posix_class = could_it_be_a_POSIX_class(pRExC_state);
12970
12971                 if (! is_posix_class) {
12972                     RExC_parse++;
12973                 }
12974
12975                 /* regclass() can only return RESTART_UTF8 if multi-char
12976                    folds are allowed.  */
12977                 if(!regclass(pRExC_state, flagp,depth+1,
12978                              is_posix_class, /* parse the whole char class
12979                                                 only if not a posix class */
12980                              FALSE, /* don't allow multi-char folds */
12981                              FALSE, /* don't silence non-portable warnings.  */
12982                              &current))
12983                     FAIL2("panic: regclass returned NULL to handle_sets, flags=%#"UVxf"",
12984                           (UV) *flagp);
12985                 /* function call leaves parse pointing to the ']', except if we
12986                  * faked it */
12987                 if (is_posix_class) {
12988                     RExC_parse--;
12989                 }
12990
12991                 goto handle_operand;
12992             }
12993
12994             case '&':
12995             case '|':
12996             case '+':
12997             case '-':
12998             case '^':
12999                 if (top_index < 0
13000                     || ( ! (top_ptr = av_fetch(stack, top_index, FALSE)))
13001                     || ! IS_OPERAND(*top_ptr))
13002                 {
13003                     RExC_parse++;
13004                     vFAIL2("Unexpected binary operator '%c' with no preceding operand", curchar);
13005                 }
13006                 av_push(stack, newSVuv(curchar));
13007                 break;
13008
13009             case '!':
13010                 av_push(stack, newSVuv(curchar));
13011                 break;
13012
13013             case '(':
13014                 if (top_index >= 0) {
13015                     top_ptr = av_fetch(stack, top_index, FALSE);
13016                     assert(top_ptr);
13017                     if (IS_OPERAND(*top_ptr)) {
13018                         RExC_parse++;
13019                         vFAIL("Unexpected '(' with no preceding operator");
13020                     }
13021                 }
13022                 av_push(stack, newSVuv(curchar));
13023                 break;
13024
13025             case ')':
13026             {
13027                 SV* lparen;
13028                 if (top_index < 1
13029                     || ! (current = av_pop(stack))
13030                     || ! IS_OPERAND(current)
13031                     || ! (lparen = av_pop(stack))
13032                     || IS_OPERAND(lparen)
13033                     || SvUV(lparen) != '(')
13034                 {
13035                     SvREFCNT_dec(current);
13036                     RExC_parse++;
13037                     vFAIL("Unexpected ')'");
13038                 }
13039                 top_index -= 2;
13040                 SvREFCNT_dec_NN(lparen);
13041
13042                 /* FALLTHROUGH */
13043             }
13044
13045               handle_operand:
13046
13047                 /* Here, we have an operand to process, in 'current' */
13048
13049                 if (top_index < 0) {    /* Just push if stack is empty */
13050                     av_push(stack, current);
13051                 }
13052                 else {
13053                     SV* top = av_pop(stack);
13054                     SV *prev = NULL;
13055                     char current_operator;
13056
13057                     if (IS_OPERAND(top)) {
13058                         SvREFCNT_dec_NN(top);
13059                         SvREFCNT_dec_NN(current);
13060                         vFAIL("Operand with no preceding operator");
13061                     }
13062                     current_operator = (char) SvUV(top);
13063                     switch (current_operator) {
13064                         case '(':   /* Push the '(' back on followed by the new
13065                                        operand */
13066                             av_push(stack, top);
13067                             av_push(stack, current);
13068                             SvREFCNT_inc(top);  /* Counters the '_dec' done
13069                                                    just after the 'break', so
13070                                                    it doesn't get wrongly freed
13071                                                  */
13072                             break;
13073
13074                         case '!':
13075                             _invlist_invert(current);
13076
13077                             /* Unlike binary operators, the top of the stack,
13078                              * now that this unary one has been popped off, may
13079                              * legally be an operator, and we now have operand
13080                              * for it. */
13081                             top_index--;
13082                             SvREFCNT_dec_NN(top);
13083                             goto handle_operand;
13084
13085                         case '&':
13086                             prev = av_pop(stack);
13087                             _invlist_intersection(prev,
13088                                                    current,
13089                                                    &current);
13090                             av_push(stack, current);
13091                             break;
13092
13093                         case '|':
13094                         case '+':
13095                             prev = av_pop(stack);
13096                             _invlist_union(prev, current, &current);
13097                             av_push(stack, current);
13098                             break;
13099
13100                         case '-':
13101                             prev = av_pop(stack);;
13102                             _invlist_subtract(prev, current, &current);
13103                             av_push(stack, current);
13104                             break;
13105
13106                         case '^':   /* The union minus the intersection */
13107                         {
13108                             SV* i = NULL;
13109                             SV* u = NULL;
13110                             SV* element;
13111
13112                             prev = av_pop(stack);
13113                             _invlist_union(prev, current, &u);
13114                             _invlist_intersection(prev, current, &i);
13115                             /* _invlist_subtract will overwrite current
13116                                 without freeing what it already contains */
13117                             element = current;
13118                             _invlist_subtract(u, i, &current);
13119                             av_push(stack, current);
13120                             SvREFCNT_dec_NN(i);
13121                             SvREFCNT_dec_NN(u);
13122                             SvREFCNT_dec_NN(element);
13123                             break;
13124                         }
13125
13126                         default:
13127                             Perl_croak(aTHX_ "panic: Unexpected item on '(?[ ])' stack");
13128                 }
13129                 SvREFCNT_dec_NN(top);
13130                 SvREFCNT_dec(prev);
13131             }
13132         }
13133
13134         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
13135     }
13136
13137     if (av_tindex(stack) < 0   /* Was empty */
13138         || ((final = av_pop(stack)) == NULL)
13139         || ! IS_OPERAND(final)
13140         || av_tindex(stack) >= 0)  /* More left on stack */
13141     {
13142         vFAIL("Incomplete expression within '(?[ ])'");
13143     }
13144
13145     /* Here, 'final' is the resultant inversion list from evaluating the
13146      * expression.  Return it if so requested */
13147     if (return_invlist) {
13148         *return_invlist = final;
13149         return END;
13150     }
13151
13152     /* Otherwise generate a resultant node, based on 'final'.  regclass() is
13153      * expecting a string of ranges and individual code points */
13154     invlist_iterinit(final);
13155     result_string = newSVpvs("");
13156     while (invlist_iternext(final, &start, &end)) {
13157         if (start == end) {
13158             Perl_sv_catpvf(aTHX_ result_string, "\\x{%"UVXf"}", start);
13159         }
13160         else {
13161             Perl_sv_catpvf(aTHX_ result_string, "\\x{%"UVXf"}-\\x{%"UVXf"}",
13162                                                      start,          end);
13163         }
13164     }
13165
13166     save_parse = RExC_parse;
13167     RExC_parse = SvPV(result_string, len);
13168     save_end = RExC_end;
13169     RExC_end = RExC_parse + len;
13170
13171     /* We turn off folding around the call, as the class we have constructed
13172      * already has all folding taken into consideration, and we don't want
13173      * regclass() to add to that */
13174     RExC_flags &= ~RXf_PMf_FOLD;
13175     /* regclass() can only return RESTART_UTF8 if multi-char folds are allowed.
13176      */
13177     node = regclass(pRExC_state, flagp,depth+1,
13178                     FALSE, /* means parse the whole char class */
13179                     FALSE, /* don't allow multi-char folds */
13180                     TRUE, /* silence non-portable warnings.  The above may very
13181                              well have generated non-portable code points, but
13182                              they're valid on this machine */
13183                     NULL);
13184     if (!node)
13185         FAIL2("panic: regclass returned NULL to handle_sets, flags=%#"UVxf,
13186                     PTR2UV(flagp));
13187     if (save_fold) {
13188         RExC_flags |= RXf_PMf_FOLD;
13189     }
13190     RExC_parse = save_parse + 1;
13191     RExC_end = save_end;
13192     SvREFCNT_dec_NN(final);
13193     SvREFCNT_dec_NN(result_string);
13194
13195     nextchar(pRExC_state);
13196     Set_Node_Length(node, RExC_parse - oregcomp_parse + 1); /* MJD */
13197     return node;
13198 }
13199 #undef IS_OPERAND
13200
13201 STATIC void
13202 S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invlist)
13203 {
13204     /* This hard-codes the Latin1/above-Latin1 folding rules, so that an
13205      * innocent-looking character class, like /[ks]/i won't have to go out to
13206      * disk to find the possible matches.
13207      *
13208      * This should be called only for a Latin1-range code points, cp, which is
13209      * known to be involved in a simple fold with other code points above
13210      * Latin1.  It would give false results if /aa has been specified.
13211      * Multi-char folds are outside the scope of this, and must be handled
13212      * specially.
13213      *
13214      * XXX It would be better to generate these via regen, in case a new
13215      * version of the Unicode standard adds new mappings, though that is not
13216      * really likely, and may be caught by the default: case of the switch
13217      * below. */
13218
13219     PERL_ARGS_ASSERT_ADD_ABOVE_LATIN1_FOLDS;
13220
13221     assert(HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(cp));
13222
13223     switch (cp) {
13224         case 'k':
13225         case 'K':
13226           *invlist =
13227              add_cp_to_invlist(*invlist, KELVIN_SIGN);
13228             break;
13229         case 's':
13230         case 'S':
13231           *invlist = add_cp_to_invlist(*invlist, LATIN_SMALL_LETTER_LONG_S);
13232             break;
13233         case MICRO_SIGN:
13234           *invlist = add_cp_to_invlist(*invlist, GREEK_CAPITAL_LETTER_MU);
13235           *invlist = add_cp_to_invlist(*invlist, GREEK_SMALL_LETTER_MU);
13236             break;
13237         case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
13238         case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
13239           *invlist = add_cp_to_invlist(*invlist, ANGSTROM_SIGN);
13240             break;
13241         case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
13242           *invlist = add_cp_to_invlist(*invlist,
13243                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
13244             break;
13245         case LATIN_SMALL_LETTER_SHARP_S:
13246           *invlist = add_cp_to_invlist(*invlist, LATIN_CAPITAL_LETTER_SHARP_S);
13247             break;
13248         default:
13249             /* Use deprecated warning to increase the chances of this being
13250              * output */
13251             ckWARN2reg_d(RExC_parse, "Perl folding rules are not up-to-date for 0x%02X; please use the perlbug utility to report;", cp);
13252             break;
13253     }
13254 }
13255
13256 /* The names of properties whose definitions are not known at compile time are
13257  * stored in this SV, after a constant heading.  So if the length has been
13258  * changed since initialization, then there is a run-time definition. */
13259 #define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION                            \
13260                                         (SvCUR(listsv) != initial_listsv_len)
13261
13262 STATIC regnode *
13263 S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
13264                  const bool stop_at_1,  /* Just parse the next thing, don't
13265                                            look for a full character class */
13266                  bool allow_multi_folds,
13267                  const bool silence_non_portable,   /* Don't output warnings
13268                                                        about too large
13269                                                        characters */
13270                  SV** ret_invlist)  /* Return an inversion list, not a node */
13271 {
13272     /* parse a bracketed class specification.  Most of these will produce an
13273      * ANYOF node; but something like [a] will produce an EXACT node; [aA], an
13274      * EXACTFish node; [[:ascii:]], a POSIXA node; etc.  It is more complex
13275      * under /i with multi-character folds: it will be rewritten following the
13276      * paradigm of this example, where the <multi-fold>s are characters which
13277      * fold to multiple character sequences:
13278      *      /[abc\x{multi-fold1}def\x{multi-fold2}ghi]/i
13279      * gets effectively rewritten as:
13280      *      /(?:\x{multi-fold1}|\x{multi-fold2}|[abcdefghi]/i
13281      * reg() gets called (recursively) on the rewritten version, and this
13282      * function will return what it constructs.  (Actually the <multi-fold>s
13283      * aren't physically removed from the [abcdefghi], it's just that they are
13284      * ignored in the recursion by means of a flag:
13285      * <RExC_in_multi_char_class>.)
13286      *
13287      * ANYOF nodes contain a bit map for the first 256 characters, with the
13288      * corresponding bit set if that character is in the list.  For characters
13289      * above 255, a range list or swash is used.  There are extra bits for \w,
13290      * etc. in locale ANYOFs, as what these match is not determinable at
13291      * compile time
13292      *
13293      * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs
13294      * to be restarted.  This can only happen if ret_invlist is non-NULL.
13295      */
13296
13297     UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE;
13298     IV range = 0;
13299     UV value = OOB_UNICODE, save_value = OOB_UNICODE;
13300     regnode *ret;
13301     STRLEN numlen;
13302     IV namedclass = OOB_NAMEDCLASS;
13303     char *rangebegin = NULL;
13304     bool need_class = 0;
13305     SV *listsv = NULL;
13306     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
13307                                       than just initialized.  */
13308     SV* properties = NULL;    /* Code points that match \p{} \P{} */
13309     SV* posixes = NULL;     /* Code points that match classes like [:word:],
13310                                extended beyond the Latin1 range.  These have to
13311                                be kept separate from other code points for much
13312                                of this function because their handling  is
13313                                different under /i, and for most classes under
13314                                /d as well */
13315     SV* nposixes = NULL;    /* Similarly for [:^word:].  These are kept
13316                                separate for a while from the non-complemented
13317                                versions because of complications with /d
13318                                matching */
13319     UV element_count = 0;   /* Number of distinct elements in the class.
13320                                Optimizations may be possible if this is tiny */
13321     AV * multi_char_matches = NULL; /* Code points that fold to more than one
13322                                        character; used under /i */
13323     UV n;
13324     char * stop_ptr = RExC_end;    /* where to stop parsing */
13325     const bool skip_white = cBOOL(ret_invlist); /* ignore unescaped white
13326                                                    space? */
13327     const bool strict = cBOOL(ret_invlist); /* Apply strict parsing rules? */
13328
13329     /* Unicode properties are stored in a swash; this holds the current one
13330      * being parsed.  If this swash is the only above-latin1 component of the
13331      * character class, an optimization is to pass it directly on to the
13332      * execution engine.  Otherwise, it is set to NULL to indicate that there
13333      * are other things in the class that have to be dealt with at execution
13334      * time */
13335     SV* swash = NULL;           /* Code points that match \p{} \P{} */
13336
13337     /* Set if a component of this character class is user-defined; just passed
13338      * on to the engine */
13339     bool has_user_defined_property = FALSE;
13340
13341     /* inversion list of code points this node matches only when the target
13342      * string is in UTF-8.  (Because is under /d) */
13343     SV* depends_list = NULL;
13344
13345     /* Inversion list of code points this node matches regardless of things
13346      * like locale, folding, utf8ness of the target string */
13347     SV* cp_list = NULL;
13348
13349     /* Like cp_list, but code points on this list need to be checked for things
13350      * that fold to/from them under /i */
13351     SV* cp_foldable_list = NULL;
13352
13353     /* Like cp_list, but code points on this list are valid only when the
13354      * runtime locale is UTF-8 */
13355     SV* only_utf8_locale_list = NULL;
13356
13357 #ifdef EBCDIC
13358     /* In a range, counts how many 0-2 of the ends of it came from literals,
13359      * not escapes.  Thus we can tell if 'A' was input vs \x{C1} */
13360     UV literal_endpoint = 0;
13361 #endif
13362     bool invert = FALSE;    /* Is this class to be complemented */
13363
13364     bool warn_super = ALWAYS_WARN_SUPER;
13365
13366     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
13367         case we need to change the emitted regop to an EXACT. */
13368     const char * orig_parse = RExC_parse;
13369     const SSize_t orig_size = RExC_size;
13370     bool posixl_matches_all = FALSE; /* Does /l class have both e.g. \W,\w ? */
13371     GET_RE_DEBUG_FLAGS_DECL;
13372
13373     PERL_ARGS_ASSERT_REGCLASS;
13374 #ifndef DEBUGGING
13375     PERL_UNUSED_ARG(depth);
13376 #endif
13377
13378     DEBUG_PARSE("clas");
13379
13380     /* Assume we are going to generate an ANYOF node. */
13381     ret = reganode(pRExC_state, ANYOF, 0);
13382
13383     if (SIZE_ONLY) {
13384         RExC_size += ANYOF_SKIP;
13385         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
13386     }
13387     else {
13388         ANYOF_FLAGS(ret) = 0;
13389
13390         RExC_emit += ANYOF_SKIP;
13391         listsv = newSVpvs_flags("# comment\n", SVs_TEMP);
13392         initial_listsv_len = SvCUR(listsv);
13393         SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated.  */
13394     }
13395
13396     if (skip_white) {
13397         RExC_parse = regpatws(pRExC_state, RExC_parse,
13398                               FALSE /* means don't recognize comments */ );
13399     }
13400
13401     if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
13402         RExC_parse++;
13403         invert = TRUE;
13404         allow_multi_folds = FALSE;
13405         RExC_naughty++;
13406         if (skip_white) {
13407             RExC_parse = regpatws(pRExC_state, RExC_parse,
13408                                   FALSE /* means don't recognize comments */ );
13409         }
13410     }
13411
13412     /* Check that they didn't say [:posix:] instead of [[:posix:]] */
13413     if (!SIZE_ONLY && RExC_parse < RExC_end && POSIXCC(UCHARAT(RExC_parse))) {
13414         const char *s = RExC_parse;
13415         const char  c = *s++;
13416
13417         while (isWORDCHAR(*s))
13418             s++;
13419         if (*s && c == *s && s[1] == ']') {
13420             SAVEFREESV(RExC_rx_sv);
13421             ckWARN3reg(s+2,
13422                        "POSIX syntax [%c %c] belongs inside character classes",
13423                        c, c);
13424             (void)ReREFCNT_inc(RExC_rx_sv);
13425         }
13426     }
13427
13428     /* If the caller wants us to just parse a single element, accomplish this
13429      * by faking the loop ending condition */
13430     if (stop_at_1 && RExC_end > RExC_parse) {
13431         stop_ptr = RExC_parse + 1;
13432     }
13433
13434     /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */
13435     if (UCHARAT(RExC_parse) == ']')
13436         goto charclassloop;
13437
13438 parseit:
13439     while (1) {
13440         if  (RExC_parse >= stop_ptr) {
13441             break;
13442         }
13443
13444         if (skip_white) {
13445             RExC_parse = regpatws(pRExC_state, RExC_parse,
13446                                   FALSE /* means don't recognize comments */ );
13447         }
13448
13449         if  (UCHARAT(RExC_parse) == ']') {
13450             break;
13451         }
13452
13453     charclassloop:
13454
13455         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
13456         save_value = value;
13457         save_prevvalue = prevvalue;
13458
13459         if (!range) {
13460             rangebegin = RExC_parse;
13461             element_count++;
13462         }
13463         if (UTF) {
13464             value = utf8n_to_uvchr((U8*)RExC_parse,
13465                                    RExC_end - RExC_parse,
13466                                    &numlen, UTF8_ALLOW_DEFAULT);
13467             RExC_parse += numlen;
13468         }
13469         else
13470             value = UCHARAT(RExC_parse++);
13471
13472         if (value == '['
13473             && RExC_parse < RExC_end
13474             && POSIXCC(UCHARAT(RExC_parse)))
13475         {
13476             namedclass = regpposixcc(pRExC_state, value, strict);
13477         }
13478         else if (value == '\\') {
13479             if (UTF) {
13480                 value = utf8n_to_uvchr((U8*)RExC_parse,
13481                                    RExC_end - RExC_parse,
13482                                    &numlen, UTF8_ALLOW_DEFAULT);
13483                 RExC_parse += numlen;
13484             }
13485             else
13486                 value = UCHARAT(RExC_parse++);
13487
13488             /* Some compilers cannot handle switching on 64-bit integer
13489              * values, therefore value cannot be an UV.  Yes, this will
13490              * be a problem later if we want switch on Unicode.
13491              * A similar issue a little bit later when switching on
13492              * namedclass. --jhi */
13493
13494             /* If the \ is escaping white space when white space is being
13495              * skipped, it means that that white space is wanted literally, and
13496              * is already in 'value'.  Otherwise, need to translate the escape
13497              * into what it signifies. */
13498             if (! skip_white || ! is_PATWS_cp(value)) switch ((I32)value) {
13499
13500             case 'w':   namedclass = ANYOF_WORDCHAR;    break;
13501             case 'W':   namedclass = ANYOF_NWORDCHAR;   break;
13502             case 's':   namedclass = ANYOF_SPACE;       break;
13503             case 'S':   namedclass = ANYOF_NSPACE;      break;
13504             case 'd':   namedclass = ANYOF_DIGIT;       break;
13505             case 'D':   namedclass = ANYOF_NDIGIT;      break;
13506             case 'v':   namedclass = ANYOF_VERTWS;      break;
13507             case 'V':   namedclass = ANYOF_NVERTWS;     break;
13508             case 'h':   namedclass = ANYOF_HORIZWS;     break;
13509             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
13510             case 'N':  /* Handle \N{NAME} in class */
13511                 {
13512                     /* We only pay attention to the first char of
13513                     multichar strings being returned. I kinda wonder
13514                     if this makes sense as it does change the behaviour
13515                     from earlier versions, OTOH that behaviour was broken
13516                     as well. */
13517                     if (! grok_bslash_N(pRExC_state, NULL, &value, flagp, depth,
13518                                       TRUE, /* => charclass */
13519                                       strict))
13520                     {
13521                         if (*flagp & RESTART_UTF8)
13522                             FAIL("panic: grok_bslash_N set RESTART_UTF8");
13523                         goto parseit;
13524                     }
13525                 }
13526                 break;
13527             case 'p':
13528             case 'P':
13529                 {
13530                 char *e;
13531
13532                 /* We will handle any undefined properties ourselves */
13533                 U8 swash_init_flags = _CORE_SWASH_INIT_RETURN_IF_UNDEF
13534                                        /* And we actually would prefer to get
13535                                         * the straight inversion list of the
13536                                         * swash, since we will be accessing it
13537                                         * anyway, to save a little time */
13538                                       |_CORE_SWASH_INIT_ACCEPT_INVLIST;
13539
13540                 if (RExC_parse >= RExC_end)
13541                     vFAIL2("Empty \\%c{}", (U8)value);
13542                 if (*RExC_parse == '{') {
13543                     const U8 c = (U8)value;
13544                     e = strchr(RExC_parse++, '}');
13545                     if (!e)
13546                         vFAIL2("Missing right brace on \\%c{}", c);
13547                     while (isSPACE(*RExC_parse))
13548                         RExC_parse++;
13549                     if (e == RExC_parse)
13550                         vFAIL2("Empty \\%c{}", c);
13551                     n = e - RExC_parse;
13552                     while (isSPACE(*(RExC_parse + n - 1)))
13553                         n--;
13554                 }
13555                 else {
13556                     e = RExC_parse;
13557                     n = 1;
13558                 }
13559                 if (!SIZE_ONLY) {
13560                     SV* invlist;
13561                     char* name;
13562
13563                     if (UCHARAT(RExC_parse) == '^') {
13564                          RExC_parse++;
13565                          n--;
13566                          /* toggle.  (The rhs xor gets the single bit that
13567                           * differs between P and p; the other xor inverts just
13568                           * that bit) */
13569                          value ^= 'P' ^ 'p';
13570
13571                          while (isSPACE(*RExC_parse)) {
13572                               RExC_parse++;
13573                               n--;
13574                          }
13575                     }
13576                     /* Try to get the definition of the property into
13577                      * <invlist>.  If /i is in effect, the effective property
13578                      * will have its name be <__NAME_i>.  The design is
13579                      * discussed in commit
13580                      * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
13581                     name = savepv(Perl_form(aTHX_
13582                                           "%s%.*s%s\n",
13583                                           (FOLD) ? "__" : "",
13584                                           (int)n,
13585                                           RExC_parse,
13586                                           (FOLD) ? "_i" : ""
13587                                 ));
13588
13589                     /* Look up the property name, and get its swash and
13590                      * inversion list, if the property is found  */
13591                     if (swash) {
13592                         SvREFCNT_dec_NN(swash);
13593                     }
13594                     swash = _core_swash_init("utf8", name, &PL_sv_undef,
13595                                              1, /* binary */
13596                                              0, /* not tr/// */
13597                                              NULL, /* No inversion list */
13598                                              &swash_init_flags
13599                                             );
13600                     if (! swash || ! (invlist = _get_swash_invlist(swash))) {
13601                         HV* curpkg = (IN_PERL_COMPILETIME)
13602                                       ? PL_curstash
13603                                       : CopSTASH(PL_curcop);
13604                         if (swash) {
13605                             SvREFCNT_dec_NN(swash);
13606                             swash = NULL;
13607                         }
13608
13609                         /* Here didn't find it.  It could be a user-defined
13610                          * property that will be available at run-time.  If we
13611                          * accept only compile-time properties, is an error;
13612                          * otherwise add it to the list for run-time look up */
13613                         if (ret_invlist) {
13614                             RExC_parse = e + 1;
13615                             vFAIL2utf8f(
13616                                 "Property '%"UTF8f"' is unknown",
13617                                 UTF8fARG(UTF, n, name));
13618                         }
13619
13620                         /* If the property name doesn't already have a package
13621                          * name, add the current one to it so that it can be
13622                          * referred to outside it. [perl #121777] */
13623                         if (curpkg && ! instr(name, "::")) {
13624                             char* pkgname = HvNAME(curpkg);
13625                             if (strNE(pkgname, "main")) {
13626                                 char* full_name = Perl_form(aTHX_
13627                                                             "%s::%s",
13628                                                             pkgname,
13629                                                             name);
13630                                 n = strlen(full_name);
13631                                 Safefree(name);
13632                                 name = savepvn(full_name, n);
13633                             }
13634                         }
13635                         Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%"UTF8f"\n",
13636                                         (value == 'p' ? '+' : '!'),
13637                                         UTF8fARG(UTF, n, name));
13638                         has_user_defined_property = TRUE;
13639
13640                         /* We don't know yet, so have to assume that the
13641                          * property could match something in the Latin1 range,
13642                          * hence something that isn't utf8.  Note that this
13643                          * would cause things in <depends_list> to match
13644                          * inappropriately, except that any \p{}, including
13645                          * this one forces Unicode semantics, which means there
13646                          * is no <depends_list> */
13647                         ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
13648                     }
13649                     else {
13650
13651                         /* Here, did get the swash and its inversion list.  If
13652                          * the swash is from a user-defined property, then this
13653                          * whole character class should be regarded as such */
13654                         if (swash_init_flags
13655                             & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY)
13656                         {
13657                             has_user_defined_property = TRUE;
13658                         }
13659                         else if
13660                             /* We warn on matching an above-Unicode code point
13661                              * if the match would return true, except don't
13662                              * warn for \p{All}, which has exactly one element
13663                              * = 0 */
13664                             (_invlist_contains_cp(invlist, 0x110000)
13665                                 && (! (_invlist_len(invlist) == 1
13666                                        && *invlist_array(invlist) == 0)))
13667                         {
13668                             warn_super = TRUE;
13669                         }
13670
13671
13672                         /* Invert if asking for the complement */
13673                         if (value == 'P') {
13674                             _invlist_union_complement_2nd(properties,
13675                                                           invlist,
13676                                                           &properties);
13677
13678                             /* The swash can't be used as-is, because we've
13679                              * inverted things; delay removing it to here after
13680                              * have copied its invlist above */
13681                             SvREFCNT_dec_NN(swash);
13682                             swash = NULL;
13683                         }
13684                         else {
13685                             _invlist_union(properties, invlist, &properties);
13686                         }
13687                     }
13688                     Safefree(name);
13689                 }
13690                 RExC_parse = e + 1;
13691                 namedclass = ANYOF_UNIPROP;  /* no official name, but it's
13692                                                 named */
13693
13694                 /* \p means they want Unicode semantics */
13695                 RExC_uni_semantics = 1;
13696                 }
13697                 break;
13698             case 'n':   value = '\n';                   break;
13699             case 'r':   value = '\r';                   break;
13700             case 't':   value = '\t';                   break;
13701             case 'f':   value = '\f';                   break;
13702             case 'b':   value = '\b';                   break;
13703             case 'e':   value = ASCII_TO_NATIVE('\033');break;
13704             case 'a':   value = '\a';                   break;
13705             case 'o':
13706                 RExC_parse--;   /* function expects to be pointed at the 'o' */
13707                 {
13708                     const char* error_msg;
13709                     bool valid = grok_bslash_o(&RExC_parse,
13710                                                &value,
13711                                                &error_msg,
13712                                                SIZE_ONLY,   /* warnings in pass
13713                                                                1 only */
13714                                                strict,
13715                                                silence_non_portable,
13716                                                UTF);
13717                     if (! valid) {
13718                         vFAIL(error_msg);
13719                     }
13720                 }
13721                 if (PL_encoding && value < 0x100) {
13722                     goto recode_encoding;
13723                 }
13724                 break;
13725             case 'x':
13726                 RExC_parse--;   /* function expects to be pointed at the 'x' */
13727                 {
13728                     const char* error_msg;
13729                     bool valid = grok_bslash_x(&RExC_parse,
13730                                                &value,
13731                                                &error_msg,
13732                                                TRUE, /* Output warnings */
13733                                                strict,
13734                                                silence_non_portable,
13735                                                UTF);
13736                     if (! valid) {
13737                         vFAIL(error_msg);
13738                     }
13739                 }
13740                 if (PL_encoding && value < 0x100)
13741                     goto recode_encoding;
13742                 break;
13743             case 'c':
13744                 value = grok_bslash_c(*RExC_parse++, SIZE_ONLY);
13745                 break;
13746             case '0': case '1': case '2': case '3': case '4':
13747             case '5': case '6': case '7':
13748                 {
13749                     /* Take 1-3 octal digits */
13750                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
13751                     numlen = (strict) ? 4 : 3;
13752                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
13753                     RExC_parse += numlen;
13754                     if (numlen != 3) {
13755                         if (strict) {
13756                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
13757                             vFAIL("Need exactly 3 octal digits");
13758                         }
13759                         else if (! SIZE_ONLY /* like \08, \178 */
13760                                  && numlen < 3
13761                                  && RExC_parse < RExC_end
13762                                  && isDIGIT(*RExC_parse)
13763                                  && ckWARN(WARN_REGEXP))
13764                         {
13765                             SAVEFREESV(RExC_rx_sv);
13766                             reg_warn_non_literal_string(
13767                                  RExC_parse + 1,
13768                                  form_short_octal_warning(RExC_parse, numlen));
13769                             (void)ReREFCNT_inc(RExC_rx_sv);
13770                         }
13771                     }
13772                     if (PL_encoding && value < 0x100)
13773                         goto recode_encoding;
13774                     break;
13775                 }
13776             recode_encoding:
13777                 if (! RExC_override_recoding) {
13778                     SV* enc = PL_encoding;
13779                     value = reg_recode((const char)(U8)value, &enc);
13780                     if (!enc) {
13781                         if (strict) {
13782                             vFAIL("Invalid escape in the specified encoding");
13783                         }
13784                         else if (SIZE_ONLY) {
13785                             ckWARNreg(RExC_parse,
13786                                   "Invalid escape in the specified encoding");
13787                         }
13788                     }
13789                     break;
13790                 }
13791             default:
13792                 /* Allow \_ to not give an error */
13793                 if (!SIZE_ONLY && isWORDCHAR(value) && value != '_') {
13794                     if (strict) {
13795                         vFAIL2("Unrecognized escape \\%c in character class",
13796                                (int)value);
13797                     }
13798                     else {
13799                         SAVEFREESV(RExC_rx_sv);
13800                         ckWARN2reg(RExC_parse,
13801                             "Unrecognized escape \\%c in character class passed through",
13802                             (int)value);
13803                         (void)ReREFCNT_inc(RExC_rx_sv);
13804                     }
13805                 }
13806                 break;
13807             }   /* End of switch on char following backslash */
13808         } /* end of handling backslash escape sequences */
13809 #ifdef EBCDIC
13810         else
13811             literal_endpoint++;
13812 #endif
13813
13814         /* Here, we have the current token in 'value' */
13815
13816         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
13817             U8 classnum;
13818
13819             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
13820              * literal, as is the character that began the false range, i.e.
13821              * the 'a' in the examples */
13822             if (range) {
13823                 if (!SIZE_ONLY) {
13824                     const int w = (RExC_parse >= rangebegin)
13825                                   ? RExC_parse - rangebegin
13826                                   : 0;
13827                     if (strict) {
13828                         vFAIL2utf8f(
13829                             "False [] range \"%"UTF8f"\"",
13830                             UTF8fARG(UTF, w, rangebegin));
13831                     }
13832                     else {
13833                         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
13834                         ckWARN2reg(RExC_parse,
13835                             "False [] range \"%"UTF8f"\"",
13836                             UTF8fARG(UTF, w, rangebegin));
13837                         (void)ReREFCNT_inc(RExC_rx_sv);
13838                         cp_list = add_cp_to_invlist(cp_list, '-');
13839                         cp_foldable_list = add_cp_to_invlist(cp_foldable_list,
13840                                                              prevvalue);
13841                     }
13842                 }
13843
13844                 range = 0; /* this was not a true range */
13845                 element_count += 2; /* So counts for three values */
13846             }
13847
13848             classnum = namedclass_to_classnum(namedclass);
13849
13850             if (LOC && namedclass < ANYOF_POSIXL_MAX
13851 #ifndef HAS_ISASCII
13852                 && classnum != _CC_ASCII
13853 #endif
13854             ) {
13855                 /* What the Posix classes (like \w, [:space:]) match in locale
13856                  * isn't knowable under locale until actual match time.  Room
13857                  * must be reserved (one time per outer bracketed class) to
13858                  * store such classes.  The space will contain a bit for each
13859                  * named class that is to be matched against.  This isn't
13860                  * needed for \p{} and pseudo-classes, as they are not affected
13861                  * by locale, and hence are dealt with separately */
13862                 if (! need_class) {
13863                     need_class = 1;
13864                     if (SIZE_ONLY) {
13865                         RExC_size += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
13866                     }
13867                     else {
13868                         RExC_emit += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
13869                     }
13870                     ANYOF_FLAGS(ret) |= ANYOF_POSIXL;
13871                     ANYOF_POSIXL_ZERO(ret);
13872                 }
13873
13874                 /* Coverity thinks it is possible for this to be negative; both
13875                  * jhi and khw think it's not, but be safer */
13876                 assert(! (ANYOF_FLAGS(ret) & ANYOF_POSIXL)
13877                        || (namedclass + ((namedclass % 2) ? -1 : 1)) >= 0);
13878
13879                 /* See if it already matches the complement of this POSIX
13880                  * class */
13881                 if ((ANYOF_FLAGS(ret) & ANYOF_POSIXL)
13882                     && ANYOF_POSIXL_TEST(ret, namedclass + ((namedclass % 2)
13883                                                             ? -1
13884                                                             : 1)))
13885                 {
13886                     posixl_matches_all = TRUE;
13887                     break;  /* No need to continue.  Since it matches both
13888                                e.g., \w and \W, it matches everything, and the
13889                                bracketed class can be optimized into qr/./s */
13890                 }
13891
13892                 /* Add this class to those that should be checked at runtime */
13893                 ANYOF_POSIXL_SET(ret, namedclass);
13894
13895                 /* The above-Latin1 characters are not subject to locale rules.
13896                  * Just add them, in the second pass, to the
13897                  * unconditionally-matched list */
13898                 if (! SIZE_ONLY) {
13899                     SV* scratch_list = NULL;
13900
13901                     /* Get the list of the above-Latin1 code points this
13902                      * matches */
13903                     _invlist_intersection_maybe_complement_2nd(PL_AboveLatin1,
13904                                           PL_XPosix_ptrs[classnum],
13905
13906                                           /* Odd numbers are complements, like
13907                                            * NDIGIT, NASCII, ... */
13908                                           namedclass % 2 != 0,
13909                                           &scratch_list);
13910                     /* Checking if 'cp_list' is NULL first saves an extra
13911                      * clone.  Its reference count will be decremented at the
13912                      * next union, etc, or if this is the only instance, at the
13913                      * end of the routine */
13914                     if (! cp_list) {
13915                         cp_list = scratch_list;
13916                     }
13917                     else {
13918                         _invlist_union(cp_list, scratch_list, &cp_list);
13919                         SvREFCNT_dec_NN(scratch_list);
13920                     }
13921                     continue;   /* Go get next character */
13922                 }
13923             }
13924             else if (! SIZE_ONLY) {
13925
13926                 /* Here, not in pass1 (in that pass we skip calculating the
13927                  * contents of this class), and is /l, or is a POSIX class for
13928                  * which /l doesn't matter (or is a Unicode property, which is
13929                  * skipped here). */
13930                 if (namedclass >= ANYOF_POSIXL_MAX) {  /* If a special class */
13931                     if (namedclass != ANYOF_UNIPROP) { /* UNIPROP = \p and \P */
13932
13933                         /* Here, should be \h, \H, \v, or \V.  None of /d, /i
13934                          * nor /l make a difference in what these match,
13935                          * therefore we just add what they match to cp_list. */
13936                         if (classnum != _CC_VERTSPACE) {
13937                             assert(   namedclass == ANYOF_HORIZWS
13938                                    || namedclass == ANYOF_NHORIZWS);
13939
13940                             /* It turns out that \h is just a synonym for
13941                              * XPosixBlank */
13942                             classnum = _CC_BLANK;
13943                         }
13944
13945                         _invlist_union_maybe_complement_2nd(
13946                                 cp_list,
13947                                 PL_XPosix_ptrs[classnum],
13948                                 namedclass % 2 != 0,    /* Complement if odd
13949                                                           (NHORIZWS, NVERTWS)
13950                                                         */
13951                                 &cp_list);
13952                     }
13953                 }
13954                 else {  /* Garden variety class.  If is NASCII, NDIGIT, ...
13955                            complement and use nposixes */
13956                     SV** posixes_ptr = namedclass % 2 == 0
13957                                        ? &posixes
13958                                        : &nposixes;
13959                     SV** source_ptr = &PL_XPosix_ptrs[classnum];
13960                     _invlist_union_maybe_complement_2nd(
13961                                                      *posixes_ptr,
13962                                                      *source_ptr,
13963                                                      namedclass % 2 != 0,
13964                                                      posixes_ptr);
13965                 }
13966                 continue;   /* Go get next character */
13967             }
13968         } /* end of namedclass \blah */
13969
13970         /* Here, we have a single value.  If 'range' is set, it is the ending
13971          * of a range--check its validity.  Later, we will handle each
13972          * individual code point in the range.  If 'range' isn't set, this
13973          * could be the beginning of a range, so check for that by looking
13974          * ahead to see if the next real character to be processed is the range
13975          * indicator--the minus sign */
13976
13977         if (skip_white) {
13978             RExC_parse = regpatws(pRExC_state, RExC_parse,
13979                                 FALSE /* means don't recognize comments */ );
13980         }
13981
13982         if (range) {
13983             if (prevvalue > value) /* b-a */ {
13984                 const int w = RExC_parse - rangebegin;
13985                 vFAIL2utf8f(
13986                     "Invalid [] range \"%"UTF8f"\"",
13987                     UTF8fARG(UTF, w, rangebegin));
13988                 range = 0; /* not a valid range */
13989             }
13990         }
13991         else {
13992             prevvalue = value; /* save the beginning of the potential range */
13993             if (! stop_at_1     /* Can't be a range if parsing just one thing */
13994                 && *RExC_parse == '-')
13995             {
13996                 char* next_char_ptr = RExC_parse + 1;
13997                 if (skip_white) {   /* Get the next real char after the '-' */
13998                     next_char_ptr = regpatws(pRExC_state,
13999                                              RExC_parse + 1,
14000                                              FALSE); /* means don't recognize
14001                                                         comments */
14002                 }
14003
14004                 /* If the '-' is at the end of the class (just before the ']',
14005                  * it is a literal minus; otherwise it is a range */
14006                 if (next_char_ptr < RExC_end && *next_char_ptr != ']') {
14007                     RExC_parse = next_char_ptr;
14008
14009                     /* a bad range like \w-, [:word:]- ? */
14010                     if (namedclass > OOB_NAMEDCLASS) {
14011                         if (strict || ckWARN(WARN_REGEXP)) {
14012                             const int w =
14013                                 RExC_parse >= rangebegin ?
14014                                 RExC_parse - rangebegin : 0;
14015                             if (strict) {
14016                                 vFAIL4("False [] range \"%*.*s\"",
14017                                     w, w, rangebegin);
14018                             }
14019                             else {
14020                                 vWARN4(RExC_parse,
14021                                     "False [] range \"%*.*s\"",
14022                                     w, w, rangebegin);
14023                             }
14024                         }
14025                         if (!SIZE_ONLY) {
14026                             cp_list = add_cp_to_invlist(cp_list, '-');
14027                         }
14028                         element_count++;
14029                     } else
14030                         range = 1;      /* yeah, it's a range! */
14031                     continue;   /* but do it the next time */
14032                 }
14033             }
14034         }
14035
14036         /* Here, <prevvalue> is the beginning of the range, if any; or <value>
14037          * if not */
14038
14039         /* non-Latin1 code point implies unicode semantics.  Must be set in
14040          * pass1 so is there for the whole of pass 2 */
14041         if (value > 255) {
14042             RExC_uni_semantics = 1;
14043         }
14044
14045         /* Ready to process either the single value, or the completed range.
14046          * For single-valued non-inverted ranges, we consider the possibility
14047          * of multi-char folds.  (We made a conscious decision to not do this
14048          * for the other cases because it can often lead to non-intuitive
14049          * results.  For example, you have the peculiar case that:
14050          *  "s s" =~ /^[^\xDF]+$/i => Y
14051          *  "ss"  =~ /^[^\xDF]+$/i => N
14052          *
14053          * See [perl #89750] */
14054         if (FOLD && allow_multi_folds && value == prevvalue) {
14055             if (value == LATIN_SMALL_LETTER_SHARP_S
14056                 || (value > 255 && _invlist_contains_cp(PL_HasMultiCharFold,
14057                                                         value)))
14058             {
14059                 /* Here <value> is indeed a multi-char fold.  Get what it is */
14060
14061                 U8 foldbuf[UTF8_MAXBYTES_CASE];
14062                 STRLEN foldlen;
14063
14064                 UV folded = _to_uni_fold_flags(
14065                                 value,
14066                                 foldbuf,
14067                                 &foldlen,
14068                                 FOLD_FLAGS_FULL | (ASCII_FOLD_RESTRICTED
14069                                                    ? FOLD_FLAGS_NOMIX_ASCII
14070                                                    : 0)
14071                                 );
14072
14073                 /* Here, <folded> should be the first character of the
14074                  * multi-char fold of <value>, with <foldbuf> containing the
14075                  * whole thing.  But, if this fold is not allowed (because of
14076                  * the flags), <fold> will be the same as <value>, and should
14077                  * be processed like any other character, so skip the special
14078                  * handling */
14079                 if (folded != value) {
14080
14081                     /* Skip if we are recursed, currently parsing the class
14082                      * again.  Otherwise add this character to the list of
14083                      * multi-char folds. */
14084                     if (! RExC_in_multi_char_class) {
14085                         AV** this_array_ptr;
14086                         AV* this_array;
14087                         STRLEN cp_count = utf8_length(foldbuf,
14088                                                       foldbuf + foldlen);
14089                         SV* multi_fold = sv_2mortal(newSVpvs(""));
14090
14091                         Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%"UVXf"}", value);
14092
14093
14094                         if (! multi_char_matches) {
14095                             multi_char_matches = newAV();
14096                         }
14097
14098                         /* <multi_char_matches> is actually an array of arrays.
14099                          * There will be one or two top-level elements: [2],
14100                          * and/or [3].  The [2] element is an array, each
14101                          * element thereof is a character which folds to TWO
14102                          * characters; [3] is for folds to THREE characters.
14103                          * (Unicode guarantees a maximum of 3 characters in any
14104                          * fold.)  When we rewrite the character class below,
14105                          * we will do so such that the longest folds are
14106                          * written first, so that it prefers the longest
14107                          * matching strings first.  This is done even if it
14108                          * turns out that any quantifier is non-greedy, out of
14109                          * programmer laziness.  Tom Christiansen has agreed
14110                          * that this is ok.  This makes the test for the
14111                          * ligature 'ffi' come before the test for 'ff' */
14112                         if (av_exists(multi_char_matches, cp_count)) {
14113                             this_array_ptr = (AV**) av_fetch(multi_char_matches,
14114                                                              cp_count, FALSE);
14115                             this_array = *this_array_ptr;
14116                         }
14117                         else {
14118                             this_array = newAV();
14119                             av_store(multi_char_matches, cp_count,
14120                                      (SV*) this_array);
14121                         }
14122                         av_push(this_array, multi_fold);
14123                     }
14124
14125                     /* This element should not be processed further in this
14126                      * class */
14127                     element_count--;
14128                     value = save_value;
14129                     prevvalue = save_prevvalue;
14130                     continue;
14131                 }
14132             }
14133         }
14134
14135         /* Deal with this element of the class */
14136         if (! SIZE_ONLY) {
14137 #ifndef EBCDIC
14138             cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
14139                                                      prevvalue, value);
14140 #else
14141             SV* this_range = _new_invlist(1);
14142             _append_range_to_invlist(this_range, prevvalue, value);
14143
14144             /* In EBCDIC, the ranges 'A-Z' and 'a-z' are each not contiguous.
14145              * If this range was specified using something like 'i-j', we want
14146              * to include only the 'i' and the 'j', and not anything in
14147              * between, so exclude non-ASCII, non-alphabetics from it.
14148              * However, if the range was specified with something like
14149              * [\x89-\x91] or [\x89-j], all code points within it should be
14150              * included.  literal_endpoint==2 means both ends of the range used
14151              * a literal character, not \x{foo} */
14152             if (literal_endpoint == 2
14153                 && ((prevvalue >= 'a' && value <= 'z')
14154                     || (prevvalue >= 'A' && value <= 'Z')))
14155             {
14156                 _invlist_intersection(this_range, PL_XPosix_ptrs[_CC_ASCII],
14157                                       &this_range);
14158
14159                 /* Since this above only contains ascii, the intersection of it
14160                  * with anything will still yield only ascii */
14161                 _invlist_intersection(this_range, PL_XPosix_ptrs[_CC_ALPHA],
14162                                       &this_range);
14163             }
14164             _invlist_union(cp_foldable_list, this_range, &cp_foldable_list);
14165             literal_endpoint = 0;
14166 #endif
14167         }
14168
14169         range = 0; /* this range (if it was one) is done now */
14170     } /* End of loop through all the text within the brackets */
14171
14172     /* If anything in the class expands to more than one character, we have to
14173      * deal with them by building up a substitute parse string, and recursively
14174      * calling reg() on it, instead of proceeding */
14175     if (multi_char_matches) {
14176         SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
14177         I32 cp_count;
14178         STRLEN len;
14179         char *save_end = RExC_end;
14180         char *save_parse = RExC_parse;
14181         bool first_time = TRUE;     /* First multi-char occurrence doesn't get
14182                                        a "|" */
14183         I32 reg_flags;
14184
14185         assert(! invert);
14186 #if 0   /* Have decided not to deal with multi-char folds in inverted classes,
14187            because too confusing */
14188         if (invert) {
14189             sv_catpv(substitute_parse, "(?:");
14190         }
14191 #endif
14192
14193         /* Look at the longest folds first */
14194         for (cp_count = av_tindex(multi_char_matches); cp_count > 0; cp_count--) {
14195
14196             if (av_exists(multi_char_matches, cp_count)) {
14197                 AV** this_array_ptr;
14198                 SV* this_sequence;
14199
14200                 this_array_ptr = (AV**) av_fetch(multi_char_matches,
14201                                                  cp_count, FALSE);
14202                 while ((this_sequence = av_pop(*this_array_ptr)) !=
14203                                                                 &PL_sv_undef)
14204                 {
14205                     if (! first_time) {
14206                         sv_catpv(substitute_parse, "|");
14207                     }
14208                     first_time = FALSE;
14209
14210                     sv_catpv(substitute_parse, SvPVX(this_sequence));
14211                 }
14212             }
14213         }
14214
14215         /* If the character class contains anything else besides these
14216          * multi-character folds, have to include it in recursive parsing */
14217         if (element_count) {
14218             sv_catpv(substitute_parse, "|[");
14219             sv_catpvn(substitute_parse, orig_parse, RExC_parse - orig_parse);
14220             sv_catpv(substitute_parse, "]");
14221         }
14222
14223         sv_catpv(substitute_parse, ")");
14224 #if 0
14225         if (invert) {
14226             /* This is a way to get the parse to skip forward a whole named
14227              * sequence instead of matching the 2nd character when it fails the
14228              * first */
14229             sv_catpv(substitute_parse, "(*THEN)(*SKIP)(*FAIL)|.)");
14230         }
14231 #endif
14232
14233         RExC_parse = SvPV(substitute_parse, len);
14234         RExC_end = RExC_parse + len;
14235         RExC_in_multi_char_class = 1;
14236         RExC_emit = (regnode *)orig_emit;
14237
14238         ret = reg(pRExC_state, 1, &reg_flags, depth+1);
14239
14240         *flagp |= reg_flags&(HASWIDTH|SIMPLE|SPSTART|POSTPONED|RESTART_UTF8);
14241
14242         RExC_parse = save_parse;
14243         RExC_end = save_end;
14244         RExC_in_multi_char_class = 0;
14245         SvREFCNT_dec_NN(multi_char_matches);
14246         return ret;
14247     }
14248
14249     /* Here, we've gone through the entire class and dealt with multi-char
14250      * folds.  We are now in a position that we can do some checks to see if we
14251      * can optimize this ANYOF node into a simpler one, even in Pass 1.
14252      * Currently we only do two checks:
14253      * 1) is in the unlikely event that the user has specified both, eg. \w and
14254      *    \W under /l, then the class matches everything.  (This optimization
14255      *    is done only to make the optimizer code run later work.)
14256      * 2) if the character class contains only a single element (including a
14257      *    single range), we see if there is an equivalent node for it.
14258      * Other checks are possible */
14259     if (! ret_invlist   /* Can't optimize if returning the constructed
14260                            inversion list */
14261         && (UNLIKELY(posixl_matches_all) || element_count == 1))
14262     {
14263         U8 op = END;
14264         U8 arg = 0;
14265
14266         if (UNLIKELY(posixl_matches_all)) {
14267             op = SANY;
14268         }
14269         else if (namedclass > OOB_NAMEDCLASS) { /* this is a named class, like
14270                                                    \w or [:digit:] or \p{foo}
14271                                                  */
14272
14273             /* All named classes are mapped into POSIXish nodes, with its FLAG
14274              * argument giving which class it is */
14275             switch ((I32)namedclass) {
14276                 case ANYOF_UNIPROP:
14277                     break;
14278
14279                 /* These don't depend on the charset modifiers.  They always
14280                  * match under /u rules */
14281                 case ANYOF_NHORIZWS:
14282                 case ANYOF_HORIZWS:
14283                     namedclass = ANYOF_BLANK + namedclass - ANYOF_HORIZWS;
14284                     /* FALLTHROUGH */
14285
14286                 case ANYOF_NVERTWS:
14287                 case ANYOF_VERTWS:
14288                     op = POSIXU;
14289                     goto join_posix;
14290
14291                 /* The actual POSIXish node for all the rest depends on the
14292                  * charset modifier.  The ones in the first set depend only on
14293                  * ASCII or, if available on this platform, locale */
14294                 case ANYOF_ASCII:
14295                 case ANYOF_NASCII:
14296 #ifdef HAS_ISASCII
14297                     op = (LOC) ? POSIXL : POSIXA;
14298 #else
14299                     op = POSIXA;
14300 #endif
14301                     goto join_posix;
14302
14303                 case ANYOF_NCASED:
14304                 case ANYOF_LOWER:
14305                 case ANYOF_NLOWER:
14306                 case ANYOF_UPPER:
14307                 case ANYOF_NUPPER:
14308                     /* under /a could be alpha */
14309                     if (FOLD) {
14310                         if (ASCII_RESTRICTED) {
14311                             namedclass = ANYOF_ALPHA + (namedclass % 2);
14312                         }
14313                         else if (! LOC) {
14314                             break;
14315                         }
14316                     }
14317                     /* FALLTHROUGH */
14318
14319                 /* The rest have more possibilities depending on the charset.
14320                  * We take advantage of the enum ordering of the charset
14321                  * modifiers to get the exact node type, */
14322                 default:
14323                     op = POSIXD + get_regex_charset(RExC_flags);
14324                     if (op > POSIXA) { /* /aa is same as /a */
14325                         op = POSIXA;
14326                     }
14327
14328                 join_posix:
14329                     /* The odd numbered ones are the complements of the
14330                      * next-lower even number one */
14331                     if (namedclass % 2 == 1) {
14332                         invert = ! invert;
14333                         namedclass--;
14334                     }
14335                     arg = namedclass_to_classnum(namedclass);
14336                     break;
14337             }
14338         }
14339         else if (value == prevvalue) {
14340
14341             /* Here, the class consists of just a single code point */
14342
14343             if (invert) {
14344                 if (! LOC && value == '\n') {
14345                     op = REG_ANY; /* Optimize [^\n] */
14346                     *flagp |= HASWIDTH|SIMPLE;
14347                     RExC_naughty++;
14348                 }
14349             }
14350             else if (value < 256 || UTF) {
14351
14352                 /* Optimize a single value into an EXACTish node, but not if it
14353                  * would require converting the pattern to UTF-8. */
14354                 op = compute_EXACTish(pRExC_state);
14355             }
14356         } /* Otherwise is a range */
14357         else if (! LOC) {   /* locale could vary these */
14358             if (prevvalue == '0') {
14359                 if (value == '9') {
14360                     arg = _CC_DIGIT;
14361                     op = POSIXA;
14362                 }
14363             }
14364             else if (prevvalue == 'A') {
14365                 if (value == 'Z'
14366 #ifdef EBCDIC
14367                     && literal_endpoint == 2
14368 #endif
14369                 ) {
14370                     arg = (FOLD) ? _CC_ALPHA : _CC_UPPER;
14371                     op = POSIXA;
14372                 }
14373             }
14374             else if (prevvalue == 'a') {
14375                 if (value == 'z'
14376 #ifdef EBCDIC
14377                     && literal_endpoint == 2
14378 #endif
14379                 ) {
14380                     arg = (FOLD) ? _CC_ALPHA : _CC_LOWER;
14381                     op = POSIXA;
14382                 }
14383             }
14384         }
14385
14386         /* Here, we have changed <op> away from its initial value iff we found
14387          * an optimization */
14388         if (op != END) {
14389
14390             /* Throw away this ANYOF regnode, and emit the calculated one,
14391              * which should correspond to the beginning, not current, state of
14392              * the parse */
14393             const char * cur_parse = RExC_parse;
14394             RExC_parse = (char *)orig_parse;
14395             if ( SIZE_ONLY) {
14396                 if (! LOC) {
14397
14398                     /* To get locale nodes to not use the full ANYOF size would
14399                      * require moving the code above that writes the portions
14400                      * of it that aren't in other nodes to after this point.
14401                      * e.g.  ANYOF_POSIXL_SET */
14402                     RExC_size = orig_size;
14403                 }
14404             }
14405             else {
14406                 RExC_emit = (regnode *)orig_emit;
14407                 if (PL_regkind[op] == POSIXD) {
14408                     if (op == POSIXL) {
14409                         RExC_contains_locale = 1;
14410                     }
14411                     if (invert) {
14412                         op += NPOSIXD - POSIXD;
14413                     }
14414                 }
14415             }
14416
14417             ret = reg_node(pRExC_state, op);
14418
14419             if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
14420                 if (! SIZE_ONLY) {
14421                     FLAGS(ret) = arg;
14422                 }
14423                 *flagp |= HASWIDTH|SIMPLE;
14424             }
14425             else if (PL_regkind[op] == EXACT) {
14426                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
14427                                            TRUE /* downgradable to EXACT */
14428                                            );
14429             }
14430
14431             RExC_parse = (char *) cur_parse;
14432
14433             SvREFCNT_dec(posixes);
14434             SvREFCNT_dec(nposixes);
14435             SvREFCNT_dec(cp_list);
14436             SvREFCNT_dec(cp_foldable_list);
14437             return ret;
14438         }
14439     }
14440
14441     if (SIZE_ONLY)
14442         return ret;
14443     /****** !SIZE_ONLY (Pass 2) AFTER HERE *********/
14444
14445     /* If folding, we calculate all characters that could fold to or from the
14446      * ones already on the list */
14447     if (cp_foldable_list) {
14448         if (FOLD) {
14449             UV start, end;      /* End points of code point ranges */
14450
14451             SV* fold_intersection = NULL;
14452             SV** use_list;
14453
14454             /* Our calculated list will be for Unicode rules.  For locale
14455              * matching, we have to keep a separate list that is consulted at
14456              * runtime only when the locale indicates Unicode rules.  For
14457              * non-locale, we just use to the general list */
14458             if (LOC) {
14459                 use_list = &only_utf8_locale_list;
14460             }
14461             else {
14462                 use_list = &cp_list;
14463             }
14464
14465             /* Only the characters in this class that participate in folds need
14466              * be checked.  Get the intersection of this class and all the
14467              * possible characters that are foldable.  This can quickly narrow
14468              * down a large class */
14469             _invlist_intersection(PL_utf8_foldable, cp_foldable_list,
14470                                   &fold_intersection);
14471
14472             /* The folds for all the Latin1 characters are hard-coded into this
14473              * program, but we have to go out to disk to get the others. */
14474             if (invlist_highest(cp_foldable_list) >= 256) {
14475
14476                 /* This is a hash that for a particular fold gives all
14477                  * characters that are involved in it */
14478                 if (! PL_utf8_foldclosures) {
14479                     _load_PL_utf8_foldclosures();
14480                 }
14481             }
14482
14483             /* Now look at the foldable characters in this class individually */
14484             invlist_iterinit(fold_intersection);
14485             while (invlist_iternext(fold_intersection, &start, &end)) {
14486                 UV j;
14487
14488                 /* Look at every character in the range */
14489                 for (j = start; j <= end; j++) {
14490                     U8 foldbuf[UTF8_MAXBYTES_CASE+1];
14491                     STRLEN foldlen;
14492                     SV** listp;
14493
14494                     if (j < 256) {
14495
14496                         if (IS_IN_SOME_FOLD_L1(j)) {
14497
14498                             /* ASCII is always matched; non-ASCII is matched
14499                              * only under Unicode rules (which could happen
14500                              * under /l if the locale is a UTF-8 one */
14501                             if (isASCII(j) || ! DEPENDS_SEMANTICS) {
14502                                 *use_list = add_cp_to_invlist(*use_list,
14503                                                             PL_fold_latin1[j]);
14504                             }
14505                             else {
14506                                 depends_list =
14507                                  add_cp_to_invlist(depends_list,
14508                                                    PL_fold_latin1[j]);
14509                             }
14510                         }
14511
14512                         if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(j)
14513                             && (! isASCII(j) || ! ASCII_FOLD_RESTRICTED))
14514                         {
14515                             add_above_Latin1_folds(pRExC_state,
14516                                                    (U8) j,
14517                                                    use_list);
14518                         }
14519                         continue;
14520                     }
14521
14522                     /* Here is an above Latin1 character.  We don't have the
14523                      * rules hard-coded for it.  First, get its fold.  This is
14524                      * the simple fold, as the multi-character folds have been
14525                      * handled earlier and separated out */
14526                     _to_uni_fold_flags(j, foldbuf, &foldlen,
14527                                                         (ASCII_FOLD_RESTRICTED)
14528                                                         ? FOLD_FLAGS_NOMIX_ASCII
14529                                                         : 0);
14530
14531                     /* Single character fold of above Latin1.  Add everything in
14532                     * its fold closure to the list that this node should match.
14533                     * The fold closures data structure is a hash with the keys
14534                     * being the UTF-8 of every character that is folded to, like
14535                     * 'k', and the values each an array of all code points that
14536                     * fold to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ].
14537                     * Multi-character folds are not included */
14538                     if ((listp = hv_fetch(PL_utf8_foldclosures,
14539                                         (char *) foldbuf, foldlen, FALSE)))
14540                     {
14541                         AV* list = (AV*) *listp;
14542                         IV k;
14543                         for (k = 0; k <= av_tindex(list); k++) {
14544                             SV** c_p = av_fetch(list, k, FALSE);
14545                             UV c;
14546                             assert(c_p);
14547
14548                             c = SvUV(*c_p);
14549
14550                             /* /aa doesn't allow folds between ASCII and non- */
14551                             if ((ASCII_FOLD_RESTRICTED
14552                                 && (isASCII(c) != isASCII(j))))
14553                             {
14554                                 continue;
14555                             }
14556
14557                             /* Folds under /l which cross the 255/256 boundary
14558                              * are added to a separate list.  (These are valid
14559                              * only when the locale is UTF-8.) */
14560                             if (c < 256 && LOC) {
14561                                 *use_list = add_cp_to_invlist(*use_list, c);
14562                                 continue;
14563                             }
14564
14565                             if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS)
14566                             {
14567                                 cp_list = add_cp_to_invlist(cp_list, c);
14568                             }
14569                             else {
14570                                 /* Similarly folds involving non-ascii Latin1
14571                                 * characters under /d are added to their list */
14572                                 depends_list = add_cp_to_invlist(depends_list,
14573                                                                  c);
14574                             }
14575                         }
14576                     }
14577                 }
14578             }
14579             SvREFCNT_dec_NN(fold_intersection);
14580         }
14581
14582         /* Now that we have finished adding all the folds, there is no reason
14583          * to keep the foldable list separate */
14584         _invlist_union(cp_list, cp_foldable_list, &cp_list);
14585         SvREFCNT_dec_NN(cp_foldable_list);
14586     }
14587
14588     /* And combine the result (if any) with any inversion list from posix
14589      * classes.  The lists are kept separate up to now because we don't want to
14590      * fold the classes (folding of those is automatically handled by the swash
14591      * fetching code) */
14592     if (posixes || nposixes) {
14593         if (posixes && AT_LEAST_ASCII_RESTRICTED) {
14594             /* Under /a and /aa, nothing above ASCII matches these */
14595             _invlist_intersection(posixes,
14596                                   PL_XPosix_ptrs[_CC_ASCII],
14597                                   &posixes);
14598         }
14599         if (nposixes) {
14600             if (DEPENDS_SEMANTICS) {
14601                 /* Under /d, everything in the upper half of the Latin1 range
14602                  * matches these complements */
14603                 ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_NON_ASCII_ALL;
14604             }
14605             else if (AT_LEAST_ASCII_RESTRICTED) {
14606                 /* Under /a and /aa, everything above ASCII matches these
14607                  * complements */
14608                 _invlist_union_complement_2nd(nposixes,
14609                                               PL_XPosix_ptrs[_CC_ASCII],
14610                                               &nposixes);
14611             }
14612             if (posixes) {
14613                 _invlist_union(posixes, nposixes, &posixes);
14614                 SvREFCNT_dec_NN(nposixes);
14615             }
14616             else {
14617                 posixes = nposixes;
14618             }
14619         }
14620         if (! DEPENDS_SEMANTICS) {
14621             if (cp_list) {
14622                 _invlist_union(cp_list, posixes, &cp_list);
14623                 SvREFCNT_dec_NN(posixes);
14624             }
14625             else {
14626                 cp_list = posixes;
14627             }
14628         }
14629         else {
14630             /* Under /d, we put into a separate list the Latin1 things that
14631              * match only when the target string is utf8 */
14632             SV* nonascii_but_latin1_properties = NULL;
14633             _invlist_intersection(posixes, PL_UpperLatin1,
14634                                   &nonascii_but_latin1_properties);
14635             _invlist_subtract(posixes, nonascii_but_latin1_properties,
14636                               &posixes);
14637             if (cp_list) {
14638                 _invlist_union(cp_list, posixes, &cp_list);
14639                 SvREFCNT_dec_NN(posixes);
14640             }
14641             else {
14642                 cp_list = posixes;
14643             }
14644
14645             if (depends_list) {
14646                 _invlist_union(depends_list, nonascii_but_latin1_properties,
14647                                &depends_list);
14648                 SvREFCNT_dec_NN(nonascii_but_latin1_properties);
14649             }
14650             else {
14651                 depends_list = nonascii_but_latin1_properties;
14652             }
14653         }
14654     }
14655
14656     /* And combine the result (if any) with any inversion list from properties.
14657      * The lists are kept separate up to now so that we can distinguish the two
14658      * in regards to matching above-Unicode.  A run-time warning is generated
14659      * if a Unicode property is matched against a non-Unicode code point. But,
14660      * we allow user-defined properties to match anything, without any warning,
14661      * and we also suppress the warning if there is a portion of the character
14662      * class that isn't a Unicode property, and which matches above Unicode, \W
14663      * or [\x{110000}] for example.
14664      * (Note that in this case, unlike the Posix one above, there is no
14665      * <depends_list>, because having a Unicode property forces Unicode
14666      * semantics */
14667     if (properties) {
14668         if (cp_list) {
14669
14670             /* If it matters to the final outcome, see if a non-property
14671              * component of the class matches above Unicode.  If so, the
14672              * warning gets suppressed.  This is true even if just a single
14673              * such code point is specified, as though not strictly correct if
14674              * another such code point is matched against, the fact that they
14675              * are using above-Unicode code points indicates they should know
14676              * the issues involved */
14677             if (warn_super) {
14678                 warn_super = ! (invert
14679                                ^ (invlist_highest(cp_list) > PERL_UNICODE_MAX));
14680             }
14681
14682             _invlist_union(properties, cp_list, &cp_list);
14683             SvREFCNT_dec_NN(properties);
14684         }
14685         else {
14686             cp_list = properties;
14687         }
14688
14689         if (warn_super) {
14690             ANYOF_FLAGS(ret) |= ANYOF_WARN_SUPER;
14691         }
14692     }
14693
14694     /* Here, we have calculated what code points should be in the character
14695      * class.
14696      *
14697      * Now we can see about various optimizations.  Fold calculation (which we
14698      * did above) needs to take place before inversion.  Otherwise /[^k]/i
14699      * would invert to include K, which under /i would match k, which it
14700      * shouldn't.  Therefore we can't invert folded locale now, as it won't be
14701      * folded until runtime */
14702
14703     /* If we didn't do folding, it's because some information isn't available
14704      * until runtime; set the run-time fold flag for these.  (We don't have to
14705      * worry about properties folding, as that is taken care of by the swash
14706      * fetching).  We know to set the flag if we have a non-NULL list for UTF-8
14707      * locales, or the class matches at least one 0-255 range code point */
14708     if (LOC && FOLD) {
14709         if (only_utf8_locale_list) {
14710             ANYOF_FLAGS(ret) |= ANYOF_LOC_FOLD;
14711         }
14712         else if (cp_list) { /* Look to see if there a 0-255 code point is in
14713                                the list */
14714             UV start, end;
14715             invlist_iterinit(cp_list);
14716             if (invlist_iternext(cp_list, &start, &end) && start < 256) {
14717                 ANYOF_FLAGS(ret) |= ANYOF_LOC_FOLD;
14718             }
14719             invlist_iterfinish(cp_list);
14720         }
14721     }
14722
14723     /* Optimize inverted simple patterns (e.g. [^a-z]) when everything is known
14724      * at compile time.  Besides not inverting folded locale now, we can't
14725      * invert if there are things such as \w, which aren't known until runtime
14726      * */
14727     if (cp_list
14728         && invert
14729         && ! (ANYOF_FLAGS(ret) & (ANYOF_LOCALE_FLAGS))
14730         && ! depends_list
14731         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
14732     {
14733         _invlist_invert(cp_list);
14734
14735         /* Any swash can't be used as-is, because we've inverted things */
14736         if (swash) {
14737             SvREFCNT_dec_NN(swash);
14738             swash = NULL;
14739         }
14740
14741         /* Clear the invert flag since have just done it here */
14742         invert = FALSE;
14743     }
14744
14745     if (ret_invlist) {
14746         *ret_invlist = cp_list;
14747         SvREFCNT_dec(swash);
14748
14749         /* Discard the generated node */
14750         if (SIZE_ONLY) {
14751             RExC_size = orig_size;
14752         }
14753         else {
14754             RExC_emit = orig_emit;
14755         }
14756         return orig_emit;
14757     }
14758
14759     /* Some character classes are equivalent to other nodes.  Such nodes take
14760      * up less room and generally fewer operations to execute than ANYOF nodes.
14761      * Above, we checked for and optimized into some such equivalents for
14762      * certain common classes that are easy to test.  Getting to this point in
14763      * the code means that the class didn't get optimized there.  Since this
14764      * code is only executed in Pass 2, it is too late to save space--it has
14765      * been allocated in Pass 1, and currently isn't given back.  But turning
14766      * things into an EXACTish node can allow the optimizer to join it to any
14767      * adjacent such nodes.  And if the class is equivalent to things like /./,
14768      * expensive run-time swashes can be avoided.  Now that we have more
14769      * complete information, we can find things necessarily missed by the
14770      * earlier code.  I (khw) am not sure how much to look for here.  It would
14771      * be easy, but perhaps too slow, to check any candidates against all the
14772      * node types they could possibly match using _invlistEQ(). */
14773
14774     if (cp_list
14775         && ! invert
14776         && ! depends_list
14777         && ! (ANYOF_FLAGS(ret) & (ANYOF_LOCALE_FLAGS))
14778         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
14779
14780            /* We don't optimize if we are supposed to make sure all non-Unicode
14781             * code points raise a warning, as only ANYOF nodes have this check.
14782             * */
14783         && ! ((ANYOF_FLAGS(ret) & ANYOF_WARN_SUPER) && ALWAYS_WARN_SUPER))
14784     {
14785         UV start, end;
14786         U8 op = END;  /* The optimzation node-type */
14787         const char * cur_parse= RExC_parse;
14788
14789         invlist_iterinit(cp_list);
14790         if (! invlist_iternext(cp_list, &start, &end)) {
14791
14792             /* Here, the list is empty.  This happens, for example, when a
14793              * Unicode property is the only thing in the character class, and
14794              * it doesn't match anything.  (perluniprops.pod notes such
14795              * properties) */
14796             op = OPFAIL;
14797             *flagp |= HASWIDTH|SIMPLE;
14798         }
14799         else if (start == end) {    /* The range is a single code point */
14800             if (! invlist_iternext(cp_list, &start, &end)
14801
14802                     /* Don't do this optimization if it would require changing
14803                      * the pattern to UTF-8 */
14804                 && (start < 256 || UTF))
14805             {
14806                 /* Here, the list contains a single code point.  Can optimize
14807                  * into an EXACTish node */
14808
14809                 value = start;
14810
14811                 if (! FOLD) {
14812                     op = EXACT;
14813                 }
14814                 else if (LOC) {
14815
14816                     /* A locale node under folding with one code point can be
14817                      * an EXACTFL, as its fold won't be calculated until
14818                      * runtime */
14819                     op = EXACTFL;
14820                 }
14821                 else {
14822
14823                     /* Here, we are generally folding, but there is only one
14824                      * code point to match.  If we have to, we use an EXACT
14825                      * node, but it would be better for joining with adjacent
14826                      * nodes in the optimization pass if we used the same
14827                      * EXACTFish node that any such are likely to be.  We can
14828                      * do this iff the code point doesn't participate in any
14829                      * folds.  For example, an EXACTF of a colon is the same as
14830                      * an EXACT one, since nothing folds to or from a colon. */
14831                     if (value < 256) {
14832                         if (IS_IN_SOME_FOLD_L1(value)) {
14833                             op = EXACT;
14834                         }
14835                     }
14836                     else {
14837                         if (_invlist_contains_cp(PL_utf8_foldable, value)) {
14838                             op = EXACT;
14839                         }
14840                     }
14841
14842                     /* If we haven't found the node type, above, it means we
14843                      * can use the prevailing one */
14844                     if (op == END) {
14845                         op = compute_EXACTish(pRExC_state);
14846                     }
14847                 }
14848             }
14849         }
14850         else if (start == 0) {
14851             if (end == UV_MAX) {
14852                 op = SANY;
14853                 *flagp |= HASWIDTH|SIMPLE;
14854                 RExC_naughty++;
14855             }
14856             else if (end == '\n' - 1
14857                     && invlist_iternext(cp_list, &start, &end)
14858                     && start == '\n' + 1 && end == UV_MAX)
14859             {
14860                 op = REG_ANY;
14861                 *flagp |= HASWIDTH|SIMPLE;
14862                 RExC_naughty++;
14863             }
14864         }
14865         invlist_iterfinish(cp_list);
14866
14867         if (op != END) {
14868             RExC_parse = (char *)orig_parse;
14869             RExC_emit = (regnode *)orig_emit;
14870
14871             ret = reg_node(pRExC_state, op);
14872
14873             RExC_parse = (char *)cur_parse;
14874
14875             if (PL_regkind[op] == EXACT) {
14876                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
14877                                            TRUE /* downgradable to EXACT */
14878                                           );
14879             }
14880
14881             SvREFCNT_dec_NN(cp_list);
14882             return ret;
14883         }
14884     }
14885
14886     /* Here, <cp_list> contains all the code points we can determine at
14887      * compile time that match under all conditions.  Go through it, and
14888      * for things that belong in the bitmap, put them there, and delete from
14889      * <cp_list>.  While we are at it, see if everything above 255 is in the
14890      * list, and if so, set a flag to speed up execution */
14891
14892     populate_ANYOF_from_invlist(ret, &cp_list);
14893
14894     if (invert) {
14895         ANYOF_FLAGS(ret) |= ANYOF_INVERT;
14896     }
14897
14898     /* Here, the bitmap has been populated with all the Latin1 code points that
14899      * always match.  Can now add to the overall list those that match only
14900      * when the target string is UTF-8 (<depends_list>). */
14901     if (depends_list) {
14902         if (cp_list) {
14903             _invlist_union(cp_list, depends_list, &cp_list);
14904             SvREFCNT_dec_NN(depends_list);
14905         }
14906         else {
14907             cp_list = depends_list;
14908         }
14909         ANYOF_FLAGS(ret) |= ANYOF_UTF8;
14910     }
14911
14912     /* If there is a swash and more than one element, we can't use the swash in
14913      * the optimization below. */
14914     if (swash && element_count > 1) {
14915         SvREFCNT_dec_NN(swash);
14916         swash = NULL;
14917     }
14918
14919     set_ANYOF_arg(pRExC_state, ret, cp_list,
14920                   (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
14921                    ? listsv : NULL,
14922                   only_utf8_locale_list,
14923                   swash, has_user_defined_property);
14924
14925     *flagp |= HASWIDTH|SIMPLE;
14926
14927     if (ANYOF_FLAGS(ret) & ANYOF_LOCALE_FLAGS) {
14928         RExC_contains_locale = 1;
14929     }
14930
14931     return ret;
14932 }
14933
14934 #undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
14935
14936 STATIC void
14937 S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state,
14938                 regnode* const node,
14939                 SV* const cp_list,
14940                 SV* const runtime_defns,
14941                 SV* const only_utf8_locale_list,
14942                 SV* const swash,
14943                 const bool has_user_defined_property)
14944 {
14945     /* Sets the arg field of an ANYOF-type node 'node', using information about
14946      * the node passed-in.  If there is nothing outside the node's bitmap, the
14947      * arg is set to ANYOF_NONBITMAP_EMPTY.  Otherwise, it sets the argument to
14948      * the count returned by add_data(), having allocated and stored an array,
14949      * av, that that count references, as follows:
14950      *  av[0] stores the character class description in its textual form.
14951      *        This is used later (regexec.c:Perl_regclass_swash()) to
14952      *        initialize the appropriate swash, and is also useful for dumping
14953      *        the regnode.  This is set to &PL_sv_undef if the textual
14954      *        description is not needed at run-time (as happens if the other
14955      *        elements completely define the class)
14956      *  av[1] if &PL_sv_undef, is a placeholder to later contain the swash
14957      *        computed from av[0].  But if no further computation need be done,
14958      *        the swash is stored here now (and av[0] is &PL_sv_undef).
14959      *  av[2] stores the inversion list of code points that match only if the
14960      *        current locale is UTF-8
14961      *  av[3] stores the cp_list inversion list for use in addition or instead
14962      *        of av[0]; used only if cp_list exists and av[1] is &PL_sv_undef.
14963      *        (Otherwise everything needed is already in av[0] and av[1])
14964      *  av[4] is set if any component of the class is from a user-defined
14965      *        property; used only if av[3] exists */
14966
14967     UV n;
14968
14969     PERL_ARGS_ASSERT_SET_ANYOF_ARG;
14970
14971     if (! cp_list && ! runtime_defns && ! only_utf8_locale_list) {
14972         assert(! (ANYOF_FLAGS(node)
14973                     & (ANYOF_UTF8|ANYOF_NONBITMAP_NON_UTF8)));
14974         ARG_SET(node, ANYOF_NONBITMAP_EMPTY);
14975     }
14976     else {
14977         AV * const av = newAV();
14978         SV *rv;
14979
14980         assert(ANYOF_FLAGS(node)
14981                     & (ANYOF_UTF8|ANYOF_NONBITMAP_NON_UTF8|ANYOF_LOC_FOLD));
14982
14983         av_store(av, 0, (runtime_defns)
14984                         ? SvREFCNT_inc(runtime_defns) : &PL_sv_undef);
14985         if (swash) {
14986             assert(cp_list);
14987             av_store(av, 1, swash);
14988             SvREFCNT_dec_NN(cp_list);
14989         }
14990         else {
14991             av_store(av, 1, &PL_sv_undef);
14992             if (cp_list) {
14993                 av_store(av, 3, cp_list);
14994                 av_store(av, 4, newSVuv(has_user_defined_property));
14995             }
14996         }
14997
14998         if (only_utf8_locale_list) {
14999             av_store(av, 2, only_utf8_locale_list);
15000         }
15001         else {
15002             av_store(av, 2, &PL_sv_undef);
15003         }
15004
15005         rv = newRV_noinc(MUTABLE_SV(av));
15006         n = add_data(pRExC_state, STR_WITH_LEN("s"));
15007         RExC_rxi->data->data[n] = (void*)rv;
15008         ARG_SET(node, n);
15009     }
15010 }
15011
15012
15013 /* reg_skipcomment()
15014
15015    Absorbs an /x style # comment from the input stream,
15016    returning a pointer to the first character beyond the comment, or if the
15017    comment terminates the pattern without anything following it, this returns
15018    one past the final character of the pattern (in other words, RExC_end) and
15019    sets the REG_RUN_ON_COMMENT_SEEN flag.
15020
15021    Note it's the callers responsibility to ensure that we are
15022    actually in /x mode
15023
15024 */
15025
15026 PERL_STATIC_INLINE char*
15027 S_reg_skipcomment(RExC_state_t *pRExC_state, char* p)
15028 {
15029     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
15030
15031     assert(*p == '#');
15032
15033     while (p < RExC_end) {
15034         if (*(++p) == '\n') {
15035             return p+1;
15036         }
15037     }
15038
15039     /* we ran off the end of the pattern without ending the comment, so we have
15040      * to add an \n when wrapping */
15041     RExC_seen |= REG_RUN_ON_COMMENT_SEEN;
15042     return p;
15043 }
15044
15045 /* nextchar()
15046
15047    Advances the parse position, and optionally absorbs
15048    "whitespace" from the inputstream.
15049
15050    Without /x "whitespace" means (?#...) style comments only,
15051    with /x this means (?#...) and # comments and whitespace proper.
15052
15053    Returns the RExC_parse point from BEFORE the scan occurs.
15054
15055    This is the /x friendly way of saying RExC_parse++.
15056 */
15057
15058 STATIC char*
15059 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
15060 {
15061     char* const retval = RExC_parse++;
15062
15063     PERL_ARGS_ASSERT_NEXTCHAR;
15064
15065     for (;;) {
15066         if (RExC_end - RExC_parse >= 3
15067             && *RExC_parse == '('
15068             && RExC_parse[1] == '?'
15069             && RExC_parse[2] == '#')
15070         {
15071             while (*RExC_parse != ')') {
15072                 if (RExC_parse == RExC_end)
15073                     FAIL("Sequence (?#... not terminated");
15074                 RExC_parse++;
15075             }
15076             RExC_parse++;
15077             continue;
15078         }
15079         if (RExC_flags & RXf_PMf_EXTENDED) {
15080             char * p = regpatws(pRExC_state, RExC_parse,
15081                                           TRUE); /* means recognize comments */
15082             if (p != RExC_parse) {
15083                 RExC_parse = p;
15084                 continue;
15085             }
15086         }
15087         return retval;
15088     }
15089 }
15090
15091 /*
15092 - reg_node - emit a node
15093 */
15094 STATIC regnode *                        /* Location. */
15095 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
15096 {
15097     regnode *ptr;
15098     regnode * const ret = RExC_emit;
15099     GET_RE_DEBUG_FLAGS_DECL;
15100
15101     PERL_ARGS_ASSERT_REG_NODE;
15102
15103     if (SIZE_ONLY) {
15104         SIZE_ALIGN(RExC_size);
15105         RExC_size += 1;
15106         return(ret);
15107     }
15108     if (RExC_emit >= RExC_emit_bound)
15109         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
15110                    op, (void*)RExC_emit, (void*)RExC_emit_bound);
15111
15112     NODE_ALIGN_FILL(ret);
15113     ptr = ret;
15114     FILL_ADVANCE_NODE(ptr, op);
15115 #ifdef RE_TRACK_PATTERN_OFFSETS
15116     if (RExC_offsets) {         /* MJD */
15117         MJD_OFFSET_DEBUG(
15118               ("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n",
15119               "reg_node", __LINE__,
15120               PL_reg_name[op],
15121               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0]
15122                 ? "Overwriting end of array!\n" : "OK",
15123               (UV)(RExC_emit - RExC_emit_start),
15124               (UV)(RExC_parse - RExC_start),
15125               (UV)RExC_offsets[0]));
15126         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
15127     }
15128 #endif
15129     RExC_emit = ptr;
15130     return(ret);
15131 }
15132
15133 /*
15134 - reganode - emit a node with an argument
15135 */
15136 STATIC regnode *                        /* Location. */
15137 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
15138 {
15139     regnode *ptr;
15140     regnode * const ret = RExC_emit;
15141     GET_RE_DEBUG_FLAGS_DECL;
15142
15143     PERL_ARGS_ASSERT_REGANODE;
15144
15145     if (SIZE_ONLY) {
15146         SIZE_ALIGN(RExC_size);
15147         RExC_size += 2;
15148         /*
15149            We can't do this:
15150
15151            assert(2==regarglen[op]+1);
15152
15153            Anything larger than this has to allocate the extra amount.
15154            If we changed this to be:
15155
15156            RExC_size += (1 + regarglen[op]);
15157
15158            then it wouldn't matter. Its not clear what side effect
15159            might come from that so its not done so far.
15160            -- dmq
15161         */
15162         return(ret);
15163     }
15164     if (RExC_emit >= RExC_emit_bound)
15165         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
15166                    op, (void*)RExC_emit, (void*)RExC_emit_bound);
15167
15168     NODE_ALIGN_FILL(ret);
15169     ptr = ret;
15170     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
15171 #ifdef RE_TRACK_PATTERN_OFFSETS
15172     if (RExC_offsets) {         /* MJD */
15173         MJD_OFFSET_DEBUG(
15174               ("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
15175               "reganode",
15176               __LINE__,
15177               PL_reg_name[op],
15178               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ?
15179               "Overwriting end of array!\n" : "OK",
15180               (UV)(RExC_emit - RExC_emit_start),
15181               (UV)(RExC_parse - RExC_start),
15182               (UV)RExC_offsets[0]));
15183         Set_Cur_Node_Offset;
15184     }
15185 #endif
15186     RExC_emit = ptr;
15187     return(ret);
15188 }
15189
15190 /*
15191 - reguni - emit (if appropriate) a Unicode character
15192 */
15193 PERL_STATIC_INLINE STRLEN
15194 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
15195 {
15196     PERL_ARGS_ASSERT_REGUNI;
15197
15198     return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
15199 }
15200
15201 /*
15202 - reginsert - insert an operator in front of already-emitted operand
15203 *
15204 * Means relocating the operand.
15205 */
15206 STATIC void
15207 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
15208 {
15209     regnode *src;
15210     regnode *dst;
15211     regnode *place;
15212     const int offset = regarglen[(U8)op];
15213     const int size = NODE_STEP_REGNODE + offset;
15214     GET_RE_DEBUG_FLAGS_DECL;
15215
15216     PERL_ARGS_ASSERT_REGINSERT;
15217     PERL_UNUSED_CONTEXT;
15218     PERL_UNUSED_ARG(depth);
15219 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
15220     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
15221     if (SIZE_ONLY) {
15222         RExC_size += size;
15223         return;
15224     }
15225
15226     src = RExC_emit;
15227     RExC_emit += size;
15228     dst = RExC_emit;
15229     if (RExC_open_parens) {
15230         int paren;
15231         /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
15232         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
15233             if ( RExC_open_parens[paren] >= opnd ) {
15234                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
15235                 RExC_open_parens[paren] += size;
15236             } else {
15237                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
15238             }
15239             if ( RExC_close_parens[paren] >= opnd ) {
15240                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
15241                 RExC_close_parens[paren] += size;
15242             } else {
15243                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
15244             }
15245         }
15246     }
15247
15248     while (src > opnd) {
15249         StructCopy(--src, --dst, regnode);
15250 #ifdef RE_TRACK_PATTERN_OFFSETS
15251         if (RExC_offsets) {     /* MJD 20010112 */
15252             MJD_OFFSET_DEBUG(
15253                  ("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
15254                   "reg_insert",
15255                   __LINE__,
15256                   PL_reg_name[op],
15257                   (UV)(dst - RExC_emit_start) > RExC_offsets[0]
15258                     ? "Overwriting end of array!\n" : "OK",
15259                   (UV)(src - RExC_emit_start),
15260                   (UV)(dst - RExC_emit_start),
15261                   (UV)RExC_offsets[0]));
15262             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
15263             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
15264         }
15265 #endif
15266     }
15267
15268
15269     place = opnd;               /* Op node, where operand used to be. */
15270 #ifdef RE_TRACK_PATTERN_OFFSETS
15271     if (RExC_offsets) {         /* MJD */
15272         MJD_OFFSET_DEBUG(
15273               ("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
15274               "reginsert",
15275               __LINE__,
15276               PL_reg_name[op],
15277               (UV)(place - RExC_emit_start) > RExC_offsets[0]
15278               ? "Overwriting end of array!\n" : "OK",
15279               (UV)(place - RExC_emit_start),
15280               (UV)(RExC_parse - RExC_start),
15281               (UV)RExC_offsets[0]));
15282         Set_Node_Offset(place, RExC_parse);
15283         Set_Node_Length(place, 1);
15284     }
15285 #endif
15286     src = NEXTOPER(place);
15287     FILL_ADVANCE_NODE(place, op);
15288     Zero(src, offset, regnode);
15289 }
15290
15291 /*
15292 - regtail - set the next-pointer at the end of a node chain of p to val.
15293 - SEE ALSO: regtail_study
15294 */
15295 /* TODO: All three parms should be const */
15296 STATIC void
15297 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p,
15298                 const regnode *val,U32 depth)
15299 {
15300     regnode *scan;
15301     GET_RE_DEBUG_FLAGS_DECL;
15302
15303     PERL_ARGS_ASSERT_REGTAIL;
15304 #ifndef DEBUGGING
15305     PERL_UNUSED_ARG(depth);
15306 #endif
15307
15308     if (SIZE_ONLY)
15309         return;
15310
15311     /* Find last node. */
15312     scan = p;
15313     for (;;) {
15314         regnode * const temp = regnext(scan);
15315         DEBUG_PARSE_r({
15316             SV * const mysv=sv_newmortal();
15317             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
15318             regprop(RExC_rx, mysv, scan, NULL);
15319             PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
15320                 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
15321                     (temp == NULL ? "->" : ""),
15322                     (temp == NULL ? PL_reg_name[OP(val)] : "")
15323             );
15324         });
15325         if (temp == NULL)
15326             break;
15327         scan = temp;
15328     }
15329
15330     if (reg_off_by_arg[OP(scan)]) {
15331         ARG_SET(scan, val - scan);
15332     }
15333     else {
15334         NEXT_OFF(scan) = val - scan;
15335     }
15336 }
15337
15338 #ifdef DEBUGGING
15339 /*
15340 - regtail_study - set the next-pointer at the end of a node chain of p to val.
15341 - Look for optimizable sequences at the same time.
15342 - currently only looks for EXACT chains.
15343
15344 This is experimental code. The idea is to use this routine to perform
15345 in place optimizations on branches and groups as they are constructed,
15346 with the long term intention of removing optimization from study_chunk so
15347 that it is purely analytical.
15348
15349 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
15350 to control which is which.
15351
15352 */
15353 /* TODO: All four parms should be const */
15354
15355 STATIC U8
15356 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p,
15357                       const regnode *val,U32 depth)
15358 {
15359     dVAR;
15360     regnode *scan;
15361     U8 exact = PSEUDO;
15362 #ifdef EXPERIMENTAL_INPLACESCAN
15363     I32 min = 0;
15364 #endif
15365     GET_RE_DEBUG_FLAGS_DECL;
15366
15367     PERL_ARGS_ASSERT_REGTAIL_STUDY;
15368
15369
15370     if (SIZE_ONLY)
15371         return exact;
15372
15373     /* Find last node. */
15374
15375     scan = p;
15376     for (;;) {
15377         regnode * const temp = regnext(scan);
15378 #ifdef EXPERIMENTAL_INPLACESCAN
15379         if (PL_regkind[OP(scan)] == EXACT) {
15380             bool unfolded_multi_char;   /* Unexamined in this routine */
15381             if (join_exact(pRExC_state, scan, &min,
15382                            &unfolded_multi_char, 1, val, depth+1))
15383                 return EXACT;
15384         }
15385 #endif
15386         if ( exact ) {
15387             switch (OP(scan)) {
15388                 case EXACT:
15389                 case EXACTF:
15390                 case EXACTFA_NO_TRIE:
15391                 case EXACTFA:
15392                 case EXACTFU:
15393                 case EXACTFU_SS:
15394                 case EXACTFL:
15395                         if( exact == PSEUDO )
15396                             exact= OP(scan);
15397                         else if ( exact != OP(scan) )
15398                             exact= 0;
15399                 case NOTHING:
15400                     break;
15401                 default:
15402                     exact= 0;
15403             }
15404         }
15405         DEBUG_PARSE_r({
15406             SV * const mysv=sv_newmortal();
15407             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
15408             regprop(RExC_rx, mysv, scan, NULL);
15409             PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
15410                 SvPV_nolen_const(mysv),
15411                 REG_NODE_NUM(scan),
15412                 PL_reg_name[exact]);
15413         });
15414         if (temp == NULL)
15415             break;
15416         scan = temp;
15417     }
15418     DEBUG_PARSE_r({
15419         SV * const mysv_val=sv_newmortal();
15420         DEBUG_PARSE_MSG("");
15421         regprop(RExC_rx, mysv_val, val, NULL);
15422         PerlIO_printf(Perl_debug_log,
15423                       "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
15424                       SvPV_nolen_const(mysv_val),
15425                       (IV)REG_NODE_NUM(val),
15426                       (IV)(val - scan)
15427         );
15428     });
15429     if (reg_off_by_arg[OP(scan)]) {
15430         ARG_SET(scan, val - scan);
15431     }
15432     else {
15433         NEXT_OFF(scan) = val - scan;
15434     }
15435
15436     return exact;
15437 }
15438 #endif
15439
15440 /*
15441  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
15442  */
15443 #ifdef DEBUGGING
15444
15445 static void
15446 S_regdump_intflags(pTHX_ const char *lead, const U32 flags)
15447 {
15448     int bit;
15449     int set=0;
15450
15451     ASSUME(REG_INTFLAGS_NAME_SIZE <= sizeof(flags)*8);
15452
15453     for (bit=0; bit<REG_INTFLAGS_NAME_SIZE; bit++) {
15454         if (flags & (1<<bit)) {
15455             if (!set++ && lead)
15456                 PerlIO_printf(Perl_debug_log, "%s",lead);
15457             PerlIO_printf(Perl_debug_log, "%s ",PL_reg_intflags_name[bit]);
15458         }
15459     }
15460     if (lead)  {
15461         if (set)
15462             PerlIO_printf(Perl_debug_log, "\n");
15463         else
15464             PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
15465     }
15466 }
15467
15468 static void
15469 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
15470 {
15471     int bit;
15472     int set=0;
15473     regex_charset cs;
15474
15475     ASSUME(REG_EXTFLAGS_NAME_SIZE <= sizeof(flags)*8);
15476
15477     for (bit=0; bit<REG_EXTFLAGS_NAME_SIZE; bit++) {
15478         if (flags & (1<<bit)) {
15479             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
15480                 continue;
15481             }
15482             if (!set++ && lead)
15483                 PerlIO_printf(Perl_debug_log, "%s",lead);
15484             PerlIO_printf(Perl_debug_log, "%s ",PL_reg_extflags_name[bit]);
15485         }
15486     }
15487     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
15488             if (!set++ && lead) {
15489                 PerlIO_printf(Perl_debug_log, "%s",lead);
15490             }
15491             switch (cs) {
15492                 case REGEX_UNICODE_CHARSET:
15493                     PerlIO_printf(Perl_debug_log, "UNICODE");
15494                     break;
15495                 case REGEX_LOCALE_CHARSET:
15496                     PerlIO_printf(Perl_debug_log, "LOCALE");
15497                     break;
15498                 case REGEX_ASCII_RESTRICTED_CHARSET:
15499                     PerlIO_printf(Perl_debug_log, "ASCII-RESTRICTED");
15500                     break;
15501                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
15502                     PerlIO_printf(Perl_debug_log, "ASCII-MORE_RESTRICTED");
15503                     break;
15504                 default:
15505                     PerlIO_printf(Perl_debug_log, "UNKNOWN CHARACTER SET");
15506                     break;
15507             }
15508     }
15509     if (lead)  {
15510         if (set)
15511             PerlIO_printf(Perl_debug_log, "\n");
15512         else
15513             PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
15514     }
15515 }
15516 #endif
15517
15518 void
15519 Perl_regdump(pTHX_ const regexp *r)
15520 {
15521 #ifdef DEBUGGING
15522     dVAR;
15523     SV * const sv = sv_newmortal();
15524     SV *dsv= sv_newmortal();
15525     RXi_GET_DECL(r,ri);
15526     GET_RE_DEBUG_FLAGS_DECL;
15527
15528     PERL_ARGS_ASSERT_REGDUMP;
15529
15530     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
15531
15532     /* Header fields of interest. */
15533     if (r->anchored_substr) {
15534         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr),
15535             RE_SV_DUMPLEN(r->anchored_substr), 30);
15536         PerlIO_printf(Perl_debug_log,
15537                       "anchored %s%s at %"IVdf" ",
15538                       s, RE_SV_TAIL(r->anchored_substr),
15539                       (IV)r->anchored_offset);
15540     } else if (r->anchored_utf8) {
15541         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8),
15542             RE_SV_DUMPLEN(r->anchored_utf8), 30);
15543         PerlIO_printf(Perl_debug_log,
15544                       "anchored utf8 %s%s at %"IVdf" ",
15545                       s, RE_SV_TAIL(r->anchored_utf8),
15546                       (IV)r->anchored_offset);
15547     }
15548     if (r->float_substr) {
15549         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr),
15550             RE_SV_DUMPLEN(r->float_substr), 30);
15551         PerlIO_printf(Perl_debug_log,
15552                       "floating %s%s at %"IVdf"..%"UVuf" ",
15553                       s, RE_SV_TAIL(r->float_substr),
15554                       (IV)r->float_min_offset, (UV)r->float_max_offset);
15555     } else if (r->float_utf8) {
15556         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8),
15557             RE_SV_DUMPLEN(r->float_utf8), 30);
15558         PerlIO_printf(Perl_debug_log,
15559                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
15560                       s, RE_SV_TAIL(r->float_utf8),
15561                       (IV)r->float_min_offset, (UV)r->float_max_offset);
15562     }
15563     if (r->check_substr || r->check_utf8)
15564         PerlIO_printf(Perl_debug_log,
15565                       (const char *)
15566                       (r->check_substr == r->float_substr
15567                        && r->check_utf8 == r->float_utf8
15568                        ? "(checking floating" : "(checking anchored"));
15569     if (r->intflags & PREGf_NOSCAN)
15570         PerlIO_printf(Perl_debug_log, " noscan");
15571     if (r->extflags & RXf_CHECK_ALL)
15572         PerlIO_printf(Perl_debug_log, " isall");
15573     if (r->check_substr || r->check_utf8)
15574         PerlIO_printf(Perl_debug_log, ") ");
15575
15576     if (ri->regstclass) {
15577         regprop(r, sv, ri->regstclass, NULL);
15578         PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
15579     }
15580     if (r->intflags & PREGf_ANCH) {
15581         PerlIO_printf(Perl_debug_log, "anchored");
15582         if (r->intflags & PREGf_ANCH_BOL)
15583             PerlIO_printf(Perl_debug_log, "(BOL)");
15584         if (r->intflags & PREGf_ANCH_MBOL)
15585             PerlIO_printf(Perl_debug_log, "(MBOL)");
15586         if (r->intflags & PREGf_ANCH_SBOL)
15587             PerlIO_printf(Perl_debug_log, "(SBOL)");
15588         if (r->intflags & PREGf_ANCH_GPOS)
15589             PerlIO_printf(Perl_debug_log, "(GPOS)");
15590         PerlIO_putc(Perl_debug_log, ' ');
15591     }
15592     if (r->intflags & PREGf_GPOS_SEEN)
15593         PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
15594     if (r->intflags & PREGf_SKIP)
15595         PerlIO_printf(Perl_debug_log, "plus ");
15596     if (r->intflags & PREGf_IMPLICIT)
15597         PerlIO_printf(Perl_debug_log, "implicit ");
15598     PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
15599     if (r->extflags & RXf_EVAL_SEEN)
15600         PerlIO_printf(Perl_debug_log, "with eval ");
15601     PerlIO_printf(Perl_debug_log, "\n");
15602     DEBUG_FLAGS_r({
15603         regdump_extflags("r->extflags: ",r->extflags);
15604         regdump_intflags("r->intflags: ",r->intflags);
15605     });
15606 #else
15607     PERL_ARGS_ASSERT_REGDUMP;
15608     PERL_UNUSED_CONTEXT;
15609     PERL_UNUSED_ARG(r);
15610 #endif  /* DEBUGGING */
15611 }
15612
15613 /*
15614 - regprop - printable representation of opcode, with run time support
15615 */
15616
15617 void
15618 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_info *reginfo)
15619 {
15620 #ifdef DEBUGGING
15621     dVAR;
15622     int k;
15623
15624     /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
15625     static const char * const anyofs[] = {
15626 #if _CC_WORDCHAR != 0 || _CC_DIGIT != 1 || _CC_ALPHA != 2 || _CC_LOWER != 3 \
15627     || _CC_UPPER != 4 || _CC_PUNCT != 5 || _CC_PRINT != 6                   \
15628     || _CC_ALPHANUMERIC != 7 || _CC_GRAPH != 8 || _CC_CASED != 9            \
15629     || _CC_SPACE != 10 || _CC_BLANK != 11 || _CC_XDIGIT != 12               \
15630     || _CC_PSXSPC != 13 || _CC_CNTRL != 14 || _CC_ASCII != 15               \
15631     || _CC_VERTSPACE != 16
15632   #error Need to adjust order of anyofs[]
15633 #endif
15634         "\\w",
15635         "\\W",
15636         "\\d",
15637         "\\D",
15638         "[:alpha:]",
15639         "[:^alpha:]",
15640         "[:lower:]",
15641         "[:^lower:]",
15642         "[:upper:]",
15643         "[:^upper:]",
15644         "[:punct:]",
15645         "[:^punct:]",
15646         "[:print:]",
15647         "[:^print:]",
15648         "[:alnum:]",
15649         "[:^alnum:]",
15650         "[:graph:]",
15651         "[:^graph:]",
15652         "[:cased:]",
15653         "[:^cased:]",
15654         "\\s",
15655         "\\S",
15656         "[:blank:]",
15657         "[:^blank:]",
15658         "[:xdigit:]",
15659         "[:^xdigit:]",
15660         "[:space:]",
15661         "[:^space:]",
15662         "[:cntrl:]",
15663         "[:^cntrl:]",
15664         "[:ascii:]",
15665         "[:^ascii:]",
15666         "\\v",
15667         "\\V"
15668     };
15669     RXi_GET_DECL(prog,progi);
15670     GET_RE_DEBUG_FLAGS_DECL;
15671
15672     PERL_ARGS_ASSERT_REGPROP;
15673
15674     sv_setpvs(sv, "");
15675
15676     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
15677         /* It would be nice to FAIL() here, but this may be called from
15678            regexec.c, and it would be hard to supply pRExC_state. */
15679         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
15680                                               (int)OP(o), (int)REGNODE_MAX);
15681     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
15682
15683     k = PL_regkind[OP(o)];
15684
15685     if (k == EXACT) {
15686         sv_catpvs(sv, " ");
15687         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
15688          * is a crude hack but it may be the best for now since
15689          * we have no flag "this EXACTish node was UTF-8"
15690          * --jhi */
15691         pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
15692                   PERL_PV_ESCAPE_UNI_DETECT |
15693                   PERL_PV_ESCAPE_NONASCII   |
15694                   PERL_PV_PRETTY_ELLIPSES   |
15695                   PERL_PV_PRETTY_LTGT       |
15696                   PERL_PV_PRETTY_NOCLEAR
15697                   );
15698     } else if (k == TRIE) {
15699         /* print the details of the trie in dumpuntil instead, as
15700          * progi->data isn't available here */
15701         const char op = OP(o);
15702         const U32 n = ARG(o);
15703         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
15704                (reg_ac_data *)progi->data->data[n] :
15705                NULL;
15706         const reg_trie_data * const trie
15707             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
15708
15709         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
15710         DEBUG_TRIE_COMPILE_r(
15711           Perl_sv_catpvf(aTHX_ sv,
15712             "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
15713             (UV)trie->startstate,
15714             (IV)trie->statecount-1, /* -1 because of the unused 0 element */
15715             (UV)trie->wordcount,
15716             (UV)trie->minlen,
15717             (UV)trie->maxlen,
15718             (UV)TRIE_CHARCOUNT(trie),
15719             (UV)trie->uniquecharcount
15720           );
15721         );
15722         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
15723             sv_catpvs(sv, "[");
15724             (void) put_latin1_charclass_innards(sv, IS_ANYOF_TRIE(op)
15725                                                    ? ANYOF_BITMAP(o)
15726                                                    : TRIE_BITMAP(trie));
15727             sv_catpvs(sv, "]");
15728         }
15729
15730     } else if (k == CURLY) {
15731         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
15732             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
15733         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
15734     }
15735     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
15736         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
15737     else if (k == REF || k == OPEN || k == CLOSE
15738              || k == GROUPP || OP(o)==ACCEPT)
15739     {
15740         Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
15741         if ( RXp_PAREN_NAMES(prog) ) {
15742             if ( k != REF || (OP(o) < NREF)) {
15743                 AV *list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
15744                 SV **name= av_fetch(list, ARG(o), 0 );
15745                 if (name)
15746                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
15747             }
15748             else {
15749                 AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]);
15750                 SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]);
15751                 I32 *nums=(I32*)SvPVX(sv_dat);
15752                 SV **name= av_fetch(list, nums[0], 0 );
15753                 I32 n;
15754                 if (name) {
15755                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
15756                         Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
15757                                     (n ? "," : ""), (IV)nums[n]);
15758                     }
15759                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
15760                 }
15761             }
15762         }
15763         if ( k == REF && reginfo) {
15764             U32 n = ARG(o);  /* which paren pair */
15765             I32 ln = prog->offs[n].start;
15766             if (prog->lastparen < n || ln == -1)
15767                 Perl_sv_catpvf(aTHX_ sv, ": FAIL");
15768             else if (ln == prog->offs[n].end)
15769                 Perl_sv_catpvf(aTHX_ sv, ": ACCEPT - EMPTY STRING");
15770             else {
15771                 const char *s = reginfo->strbeg + ln;
15772                 Perl_sv_catpvf(aTHX_ sv, ": ");
15773                 Perl_pv_pretty( aTHX_ sv, s, prog->offs[n].end - prog->offs[n].start, 32, 0, 0,
15774                     PERL_PV_ESCAPE_UNI_DETECT|PERL_PV_PRETTY_NOCLEAR|PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE );
15775             }
15776         }
15777     } else if (k == GOSUB)
15778         /* Paren and offset */
15779         Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o));
15780     else if (k == VERB) {
15781         if (!o->flags)
15782             Perl_sv_catpvf(aTHX_ sv, ":%"SVf,
15783                            SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
15784     } else if (k == LOGICAL)
15785         /* 2: embedded, otherwise 1 */
15786         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);
15787     else if (k == ANYOF) {
15788         const U8 flags = ANYOF_FLAGS(o);
15789         int do_sep = 0;
15790
15791
15792         if (flags & ANYOF_LOCALE_FLAGS)
15793             sv_catpvs(sv, "{loc}");
15794         if (flags & ANYOF_LOC_FOLD)
15795             sv_catpvs(sv, "{i}");
15796         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
15797         if (flags & ANYOF_INVERT)
15798             sv_catpvs(sv, "^");
15799
15800         /* output what the standard cp 0-255 bitmap matches */
15801         do_sep = put_latin1_charclass_innards(sv, ANYOF_BITMAP(o));
15802
15803         /* output any special charclass tests (used entirely under use
15804          * locale) * */
15805         if (ANYOF_POSIXL_TEST_ANY_SET(o)) {
15806             int i;
15807             for (i = 0; i < ANYOF_POSIXL_MAX; i++) {
15808                 if (ANYOF_POSIXL_TEST(o,i)) {
15809                     sv_catpv(sv, anyofs[i]);
15810                     do_sep = 1;
15811                 }
15812             }
15813         }
15814
15815         if ((flags & (ANYOF_ABOVE_LATIN1_ALL
15816                       |ANYOF_UTF8
15817                       |ANYOF_NONBITMAP_NON_UTF8
15818                       |ANYOF_LOC_FOLD)))
15819         {
15820             if (do_sep) {
15821                 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]);
15822                 if (flags & ANYOF_INVERT)
15823                     /*make sure the invert info is in each */
15824                     sv_catpvs(sv, "^");
15825             }
15826
15827             if (flags & ANYOF_NON_UTF8_NON_ASCII_ALL) {
15828                 sv_catpvs(sv, "{non-utf8-latin1-all}");
15829             }
15830
15831             /* output information about the unicode matching */
15832             if (flags & ANYOF_ABOVE_LATIN1_ALL)
15833                 sv_catpvs(sv, "{unicode_all}");
15834             else if (ARG(o) != ANYOF_NONBITMAP_EMPTY) {
15835                 SV *lv; /* Set if there is something outside the bit map. */
15836                 bool byte_output = FALSE;   /* If something in the bitmap has
15837                                                been output */
15838                 SV *only_utf8_locale;
15839
15840                 /* Get the stuff that wasn't in the bitmap */
15841                 (void) _get_regclass_nonbitmap_data(prog, o, FALSE,
15842                                                     &lv, &only_utf8_locale);
15843                 if (lv && lv != &PL_sv_undef) {
15844                     char *s = savesvpv(lv);
15845                     char * const origs = s;
15846
15847                     while (*s && *s != '\n')
15848                         s++;
15849
15850                     if (*s == '\n') {
15851                         const char * const t = ++s;
15852
15853                         if (flags & ANYOF_NONBITMAP_NON_UTF8) {
15854                             sv_catpvs(sv, "{outside bitmap}");
15855                         }
15856                         else {
15857                             sv_catpvs(sv, "{utf8}");
15858                         }
15859
15860                         if (byte_output) {
15861                             sv_catpvs(sv, " ");
15862                         }
15863
15864                         while (*s) {
15865                             if (*s == '\n') {
15866
15867                                 /* Truncate very long output */
15868                                 if (s - origs > 256) {
15869                                     Perl_sv_catpvf(aTHX_ sv,
15870                                                 "%.*s...",
15871                                                 (int) (s - origs - 1),
15872                                                 t);
15873                                     goto out_dump;
15874                                 }
15875                                 *s = ' ';
15876                             }
15877                             else if (*s == '\t') {
15878                                 *s = '-';
15879                             }
15880                             s++;
15881                         }
15882                         if (s[-1] == ' ')
15883                             s[-1] = 0;
15884
15885                         sv_catpv(sv, t);
15886                     }
15887
15888                 out_dump:
15889
15890                     Safefree(origs);
15891                     SvREFCNT_dec_NN(lv);
15892                 }
15893
15894                 if ((flags & ANYOF_LOC_FOLD)
15895                      && only_utf8_locale
15896                      && only_utf8_locale != &PL_sv_undef)
15897                 {
15898                     UV start, end;
15899                     int max_entries = 256;
15900
15901                     sv_catpvs(sv, "{utf8 locale}");
15902                     invlist_iterinit(only_utf8_locale);
15903                     while (invlist_iternext(only_utf8_locale,
15904                                             &start, &end)) {
15905                         put_range(sv, start, end);
15906                         max_entries --;
15907                         if (max_entries < 0) {
15908                             sv_catpvs(sv, "...");
15909                             break;
15910                         }
15911                     }
15912                     invlist_iterfinish(only_utf8_locale);
15913                 }
15914             }
15915         }
15916
15917         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
15918     }
15919     else if (k == POSIXD || k == NPOSIXD) {
15920         U8 index = FLAGS(o) * 2;
15921         if (index < C_ARRAY_LENGTH(anyofs)) {
15922             if (*anyofs[index] != '[')  {
15923                 sv_catpv(sv, "[");
15924             }
15925             sv_catpv(sv, anyofs[index]);
15926             if (*anyofs[index] != '[')  {
15927                 sv_catpv(sv, "]");
15928             }
15929         }
15930         else {
15931             Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
15932         }
15933     }
15934     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
15935         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
15936 #else
15937     PERL_UNUSED_CONTEXT;
15938     PERL_UNUSED_ARG(sv);
15939     PERL_UNUSED_ARG(o);
15940     PERL_UNUSED_ARG(prog);
15941     PERL_UNUSED_ARG(reginfo);
15942 #endif  /* DEBUGGING */
15943 }
15944
15945
15946
15947 SV *
15948 Perl_re_intuit_string(pTHX_ REGEXP * const r)
15949 {                               /* Assume that RE_INTUIT is set */
15950     struct regexp *const prog = ReANY(r);
15951     GET_RE_DEBUG_FLAGS_DECL;
15952
15953     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
15954     PERL_UNUSED_CONTEXT;
15955
15956     DEBUG_COMPILE_r(
15957         {
15958             const char * const s = SvPV_nolen_const(prog->check_substr
15959                       ? prog->check_substr : prog->check_utf8);
15960
15961             if (!PL_colorset) reginitcolors();
15962             PerlIO_printf(Perl_debug_log,
15963                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
15964                       PL_colors[4],
15965                       prog->check_substr ? "" : "utf8 ",
15966                       PL_colors[5],PL_colors[0],
15967                       s,
15968                       PL_colors[1],
15969                       (strlen(s) > 60 ? "..." : ""));
15970         } );
15971
15972     return prog->check_substr ? prog->check_substr : prog->check_utf8;
15973 }
15974
15975 /*
15976    pregfree()
15977
15978    handles refcounting and freeing the perl core regexp structure. When
15979    it is necessary to actually free the structure the first thing it
15980    does is call the 'free' method of the regexp_engine associated to
15981    the regexp, allowing the handling of the void *pprivate; member
15982    first. (This routine is not overridable by extensions, which is why
15983    the extensions free is called first.)
15984
15985    See regdupe and regdupe_internal if you change anything here.
15986 */
15987 #ifndef PERL_IN_XSUB_RE
15988 void
15989 Perl_pregfree(pTHX_ REGEXP *r)
15990 {
15991     SvREFCNT_dec(r);
15992 }
15993
15994 void
15995 Perl_pregfree2(pTHX_ REGEXP *rx)
15996 {
15997     struct regexp *const r = ReANY(rx);
15998     GET_RE_DEBUG_FLAGS_DECL;
15999
16000     PERL_ARGS_ASSERT_PREGFREE2;
16001
16002     if (r->mother_re) {
16003         ReREFCNT_dec(r->mother_re);
16004     } else {
16005         CALLREGFREE_PVT(rx); /* free the private data */
16006         SvREFCNT_dec(RXp_PAREN_NAMES(r));
16007         Safefree(r->xpv_len_u.xpvlenu_pv);
16008     }
16009     if (r->substrs) {
16010         SvREFCNT_dec(r->anchored_substr);
16011         SvREFCNT_dec(r->anchored_utf8);
16012         SvREFCNT_dec(r->float_substr);
16013         SvREFCNT_dec(r->float_utf8);
16014         Safefree(r->substrs);
16015     }
16016     RX_MATCH_COPY_FREE(rx);
16017 #ifdef PERL_ANY_COW
16018     SvREFCNT_dec(r->saved_copy);
16019 #endif
16020     Safefree(r->offs);
16021     SvREFCNT_dec(r->qr_anoncv);
16022     rx->sv_u.svu_rx = 0;
16023 }
16024
16025 /*  reg_temp_copy()
16026
16027     This is a hacky workaround to the structural issue of match results
16028     being stored in the regexp structure which is in turn stored in
16029     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
16030     could be PL_curpm in multiple contexts, and could require multiple
16031     result sets being associated with the pattern simultaneously, such
16032     as when doing a recursive match with (??{$qr})
16033
16034     The solution is to make a lightweight copy of the regexp structure
16035     when a qr// is returned from the code executed by (??{$qr}) this
16036     lightweight copy doesn't actually own any of its data except for
16037     the starp/end and the actual regexp structure itself.
16038
16039 */
16040
16041
16042 REGEXP *
16043 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
16044 {
16045     struct regexp *ret;
16046     struct regexp *const r = ReANY(rx);
16047     const bool islv = ret_x && SvTYPE(ret_x) == SVt_PVLV;
16048
16049     PERL_ARGS_ASSERT_REG_TEMP_COPY;
16050
16051     if (!ret_x)
16052         ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
16053     else {
16054         SvOK_off((SV *)ret_x);
16055         if (islv) {
16056             /* For PVLVs, SvANY points to the xpvlv body while sv_u points
16057                to the regexp.  (For SVt_REGEXPs, sv_upgrade has already
16058                made both spots point to the same regexp body.) */
16059             REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
16060             assert(!SvPVX(ret_x));
16061             ret_x->sv_u.svu_rx = temp->sv_any;
16062             temp->sv_any = NULL;
16063             SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
16064             SvREFCNT_dec_NN(temp);
16065             /* SvCUR still resides in the xpvlv struct, so the regexp copy-
16066                ing below will not set it. */
16067             SvCUR_set(ret_x, SvCUR(rx));
16068         }
16069     }
16070     /* This ensures that SvTHINKFIRST(sv) is true, and hence that
16071        sv_force_normal(sv) is called.  */
16072     SvFAKE_on(ret_x);
16073     ret = ReANY(ret_x);
16074
16075     SvFLAGS(ret_x) |= SvUTF8(rx);
16076     /* We share the same string buffer as the original regexp, on which we
16077        hold a reference count, incremented when mother_re is set below.
16078        The string pointer is copied here, being part of the regexp struct.
16079      */
16080     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
16081            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
16082     if (r->offs) {
16083         const I32 npar = r->nparens+1;
16084         Newx(ret->offs, npar, regexp_paren_pair);
16085         Copy(r->offs, ret->offs, npar, regexp_paren_pair);
16086     }
16087     if (r->substrs) {
16088         Newx(ret->substrs, 1, struct reg_substr_data);
16089         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
16090
16091         SvREFCNT_inc_void(ret->anchored_substr);
16092         SvREFCNT_inc_void(ret->anchored_utf8);
16093         SvREFCNT_inc_void(ret->float_substr);
16094         SvREFCNT_inc_void(ret->float_utf8);
16095
16096         /* check_substr and check_utf8, if non-NULL, point to either their
16097            anchored or float namesakes, and don't hold a second reference.  */
16098     }
16099     RX_MATCH_COPIED_off(ret_x);
16100 #ifdef PERL_ANY_COW
16101     ret->saved_copy = NULL;
16102 #endif
16103     ret->mother_re = ReREFCNT_inc(r->mother_re ? r->mother_re : rx);
16104     SvREFCNT_inc_void(ret->qr_anoncv);
16105
16106     return ret_x;
16107 }
16108 #endif
16109
16110 /* regfree_internal()
16111
16112    Free the private data in a regexp. This is overloadable by
16113    extensions. Perl takes care of the regexp structure in pregfree(),
16114    this covers the *pprivate pointer which technically perl doesn't
16115    know about, however of course we have to handle the
16116    regexp_internal structure when no extension is in use.
16117
16118    Note this is called before freeing anything in the regexp
16119    structure.
16120  */
16121
16122 void
16123 Perl_regfree_internal(pTHX_ REGEXP * const rx)
16124 {
16125     struct regexp *const r = ReANY(rx);
16126     RXi_GET_DECL(r,ri);
16127     GET_RE_DEBUG_FLAGS_DECL;
16128
16129     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
16130
16131     DEBUG_COMPILE_r({
16132         if (!PL_colorset)
16133             reginitcolors();
16134         {
16135             SV *dsv= sv_newmortal();
16136             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
16137                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
16138             PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n",
16139                 PL_colors[4],PL_colors[5],s);
16140         }
16141     });
16142 #ifdef RE_TRACK_PATTERN_OFFSETS
16143     if (ri->u.offsets)
16144         Safefree(ri->u.offsets);             /* 20010421 MJD */
16145 #endif
16146     if (ri->code_blocks) {
16147         int n;
16148         for (n = 0; n < ri->num_code_blocks; n++)
16149             SvREFCNT_dec(ri->code_blocks[n].src_regex);
16150         Safefree(ri->code_blocks);
16151     }
16152
16153     if (ri->data) {
16154         int n = ri->data->count;
16155
16156         while (--n >= 0) {
16157           /* If you add a ->what type here, update the comment in regcomp.h */
16158             switch (ri->data->what[n]) {
16159             case 'a':
16160             case 'r':
16161             case 's':
16162             case 'S':
16163             case 'u':
16164                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
16165                 break;
16166             case 'f':
16167                 Safefree(ri->data->data[n]);
16168                 break;
16169             case 'l':
16170             case 'L':
16171                 break;
16172             case 'T':
16173                 { /* Aho Corasick add-on structure for a trie node.
16174                      Used in stclass optimization only */
16175                     U32 refcount;
16176                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
16177 #ifdef USE_ITHREADS
16178                     dVAR;
16179 #endif
16180                     OP_REFCNT_LOCK;
16181                     refcount = --aho->refcount;
16182                     OP_REFCNT_UNLOCK;
16183                     if ( !refcount ) {
16184                         PerlMemShared_free(aho->states);
16185                         PerlMemShared_free(aho->fail);
16186                          /* do this last!!!! */
16187                         PerlMemShared_free(ri->data->data[n]);
16188                         /* we should only ever get called once, so
16189                          * assert as much, and also guard the free
16190                          * which /might/ happen twice. At the least
16191                          * it will make code anlyzers happy and it
16192                          * doesn't cost much. - Yves */
16193                         assert(ri->regstclass);
16194                         if (ri->regstclass) {
16195                             PerlMemShared_free(ri->regstclass);
16196                             ri->regstclass = 0;
16197                         }
16198                     }
16199                 }
16200                 break;
16201             case 't':
16202                 {
16203                     /* trie structure. */
16204                     U32 refcount;
16205                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
16206 #ifdef USE_ITHREADS
16207                     dVAR;
16208 #endif
16209                     OP_REFCNT_LOCK;
16210                     refcount = --trie->refcount;
16211                     OP_REFCNT_UNLOCK;
16212                     if ( !refcount ) {
16213                         PerlMemShared_free(trie->charmap);
16214                         PerlMemShared_free(trie->states);
16215                         PerlMemShared_free(trie->trans);
16216                         if (trie->bitmap)
16217                             PerlMemShared_free(trie->bitmap);
16218                         if (trie->jump)
16219                             PerlMemShared_free(trie->jump);
16220                         PerlMemShared_free(trie->wordinfo);
16221                         /* do this last!!!! */
16222                         PerlMemShared_free(ri->data->data[n]);
16223                     }
16224                 }
16225                 break;
16226             default:
16227                 Perl_croak(aTHX_ "panic: regfree data code '%c'",
16228                                                     ri->data->what[n]);
16229             }
16230         }
16231         Safefree(ri->data->what);
16232         Safefree(ri->data);
16233     }
16234
16235     Safefree(ri);
16236 }
16237
16238 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
16239 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
16240 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
16241
16242 /*
16243    re_dup - duplicate a regexp.
16244
16245    This routine is expected to clone a given regexp structure. It is only
16246    compiled under USE_ITHREADS.
16247
16248    After all of the core data stored in struct regexp is duplicated
16249    the regexp_engine.dupe method is used to copy any private data
16250    stored in the *pprivate pointer. This allows extensions to handle
16251    any duplication it needs to do.
16252
16253    See pregfree() and regfree_internal() if you change anything here.
16254 */
16255 #if defined(USE_ITHREADS)
16256 #ifndef PERL_IN_XSUB_RE
16257 void
16258 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
16259 {
16260     dVAR;
16261     I32 npar;
16262     const struct regexp *r = ReANY(sstr);
16263     struct regexp *ret = ReANY(dstr);
16264
16265     PERL_ARGS_ASSERT_RE_DUP_GUTS;
16266
16267     npar = r->nparens+1;
16268     Newx(ret->offs, npar, regexp_paren_pair);
16269     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
16270
16271     if (ret->substrs) {
16272         /* Do it this way to avoid reading from *r after the StructCopy().
16273            That way, if any of the sv_dup_inc()s dislodge *r from the L1
16274            cache, it doesn't matter.  */
16275         const bool anchored = r->check_substr
16276             ? r->check_substr == r->anchored_substr
16277             : r->check_utf8 == r->anchored_utf8;
16278         Newx(ret->substrs, 1, struct reg_substr_data);
16279         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
16280
16281         ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
16282         ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
16283         ret->float_substr = sv_dup_inc(ret->float_substr, param);
16284         ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
16285
16286         /* check_substr and check_utf8, if non-NULL, point to either their
16287            anchored or float namesakes, and don't hold a second reference.  */
16288
16289         if (ret->check_substr) {
16290             if (anchored) {
16291                 assert(r->check_utf8 == r->anchored_utf8);
16292                 ret->check_substr = ret->anchored_substr;
16293                 ret->check_utf8 = ret->anchored_utf8;
16294             } else {
16295                 assert(r->check_substr == r->float_substr);
16296                 assert(r->check_utf8 == r->float_utf8);
16297                 ret->check_substr = ret->float_substr;
16298                 ret->check_utf8 = ret->float_utf8;
16299             }
16300         } else if (ret->check_utf8) {
16301             if (anchored) {
16302                 ret->check_utf8 = ret->anchored_utf8;
16303             } else {
16304                 ret->check_utf8 = ret->float_utf8;
16305             }
16306         }
16307     }
16308
16309     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
16310     ret->qr_anoncv = MUTABLE_CV(sv_dup_inc((const SV *)ret->qr_anoncv, param));
16311
16312     if (ret->pprivate)
16313         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
16314
16315     if (RX_MATCH_COPIED(dstr))
16316         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
16317     else
16318         ret->subbeg = NULL;
16319 #ifdef PERL_ANY_COW
16320     ret->saved_copy = NULL;
16321 #endif
16322
16323     /* Whether mother_re be set or no, we need to copy the string.  We
16324        cannot refrain from copying it when the storage points directly to
16325        our mother regexp, because that's
16326                1: a buffer in a different thread
16327                2: something we no longer hold a reference on
16328                so we need to copy it locally.  */
16329     RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED(sstr), SvCUR(sstr)+1);
16330     ret->mother_re   = NULL;
16331 }
16332 #endif /* PERL_IN_XSUB_RE */
16333
16334 /*
16335    regdupe_internal()
16336
16337    This is the internal complement to regdupe() which is used to copy
16338    the structure pointed to by the *pprivate pointer in the regexp.
16339    This is the core version of the extension overridable cloning hook.
16340    The regexp structure being duplicated will be copied by perl prior
16341    to this and will be provided as the regexp *r argument, however
16342    with the /old/ structures pprivate pointer value. Thus this routine
16343    may override any copying normally done by perl.
16344
16345    It returns a pointer to the new regexp_internal structure.
16346 */
16347
16348 void *
16349 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
16350 {
16351     dVAR;
16352     struct regexp *const r = ReANY(rx);
16353     regexp_internal *reti;
16354     int len;
16355     RXi_GET_DECL(r,ri);
16356
16357     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
16358
16359     len = ProgLen(ri);
16360
16361     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode),
16362           char, regexp_internal);
16363     Copy(ri->program, reti->program, len+1, regnode);
16364
16365     reti->num_code_blocks = ri->num_code_blocks;
16366     if (ri->code_blocks) {
16367         int n;
16368         Newxc(reti->code_blocks, ri->num_code_blocks, struct reg_code_block,
16369                 struct reg_code_block);
16370         Copy(ri->code_blocks, reti->code_blocks, ri->num_code_blocks,
16371                 struct reg_code_block);
16372         for (n = 0; n < ri->num_code_blocks; n++)
16373              reti->code_blocks[n].src_regex = (REGEXP*)
16374                     sv_dup_inc((SV*)(ri->code_blocks[n].src_regex), param);
16375     }
16376     else
16377         reti->code_blocks = NULL;
16378
16379     reti->regstclass = NULL;
16380
16381     if (ri->data) {
16382         struct reg_data *d;
16383         const int count = ri->data->count;
16384         int i;
16385
16386         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
16387                 char, struct reg_data);
16388         Newx(d->what, count, U8);
16389
16390         d->count = count;
16391         for (i = 0; i < count; i++) {
16392             d->what[i] = ri->data->what[i];
16393             switch (d->what[i]) {
16394                 /* see also regcomp.h and regfree_internal() */
16395             case 'a': /* actually an AV, but the dup function is identical.  */
16396             case 'r':
16397             case 's':
16398             case 'S':
16399             case 'u': /* actually an HV, but the dup function is identical.  */
16400                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
16401                 break;
16402             case 'f':
16403                 /* This is cheating. */
16404                 Newx(d->data[i], 1, regnode_ssc);
16405                 StructCopy(ri->data->data[i], d->data[i], regnode_ssc);
16406                 reti->regstclass = (regnode*)d->data[i];
16407                 break;
16408             case 'T':
16409                 /* Trie stclasses are readonly and can thus be shared
16410                  * without duplication. We free the stclass in pregfree
16411                  * when the corresponding reg_ac_data struct is freed.
16412                  */
16413                 reti->regstclass= ri->regstclass;
16414                 /* FALLTHROUGH */
16415             case 't':
16416                 OP_REFCNT_LOCK;
16417                 ((reg_trie_data*)ri->data->data[i])->refcount++;
16418                 OP_REFCNT_UNLOCK;
16419                 /* FALLTHROUGH */
16420             case 'l':
16421             case 'L':
16422                 d->data[i] = ri->data->data[i];
16423                 break;
16424             default:
16425                 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'",
16426                                                            ri->data->what[i]);
16427             }
16428         }
16429
16430         reti->data = d;
16431     }
16432     else
16433         reti->data = NULL;
16434
16435     reti->name_list_idx = ri->name_list_idx;
16436
16437 #ifdef RE_TRACK_PATTERN_OFFSETS
16438     if (ri->u.offsets) {
16439         Newx(reti->u.offsets, 2*len+1, U32);
16440         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
16441     }
16442 #else
16443     SetProgLen(reti,len);
16444 #endif
16445
16446     return (void*)reti;
16447 }
16448
16449 #endif    /* USE_ITHREADS */
16450
16451 #ifndef PERL_IN_XSUB_RE
16452
16453 /*
16454  - regnext - dig the "next" pointer out of a node
16455  */
16456 regnode *
16457 Perl_regnext(pTHX_ regnode *p)
16458 {
16459     I32 offset;
16460
16461     if (!p)
16462         return(NULL);
16463
16464     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
16465         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
16466                                                 (int)OP(p), (int)REGNODE_MAX);
16467     }
16468
16469     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
16470     if (offset == 0)
16471         return(NULL);
16472
16473     return(p+offset);
16474 }
16475 #endif
16476
16477 STATIC void
16478 S_re_croak2(pTHX_ bool utf8, const char* pat1,const char* pat2,...)
16479 {
16480     va_list args;
16481     STRLEN l1 = strlen(pat1);
16482     STRLEN l2 = strlen(pat2);
16483     char buf[512];
16484     SV *msv;
16485     const char *message;
16486
16487     PERL_ARGS_ASSERT_RE_CROAK2;
16488
16489     if (l1 > 510)
16490         l1 = 510;
16491     if (l1 + l2 > 510)
16492         l2 = 510 - l1;
16493     Copy(pat1, buf, l1 , char);
16494     Copy(pat2, buf + l1, l2 , char);
16495     buf[l1 + l2] = '\n';
16496     buf[l1 + l2 + 1] = '\0';
16497     va_start(args, pat2);
16498     msv = vmess(buf, &args);
16499     va_end(args);
16500     message = SvPV_const(msv,l1);
16501     if (l1 > 512)
16502         l1 = 512;
16503     Copy(message, buf, l1 , char);
16504     /* l1-1 to avoid \n */
16505     Perl_croak(aTHX_ "%"UTF8f, UTF8fARG(utf8, l1-1, buf));
16506 }
16507
16508 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
16509
16510 #ifndef PERL_IN_XSUB_RE
16511 void
16512 Perl_save_re_context(pTHX)
16513 {
16514     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
16515     if (PL_curpm) {
16516         const REGEXP * const rx = PM_GETRE(PL_curpm);
16517         if (rx) {
16518             U32 i;
16519             for (i = 1; i <= RX_NPARENS(rx); i++) {
16520                 char digits[TYPE_CHARS(long)];
16521                 const STRLEN len = my_snprintf(digits, sizeof(digits),
16522                                                "%lu", (long)i);
16523                 GV *const *const gvp
16524                     = (GV**)hv_fetch(PL_defstash, digits, len, 0);
16525
16526                 if (gvp) {
16527                     GV * const gv = *gvp;
16528                     if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
16529                         save_scalar(gv);
16530                 }
16531             }
16532         }
16533     }
16534 }
16535 #endif
16536
16537 #ifdef DEBUGGING
16538
16539 STATIC void
16540 S_put_byte(pTHX_ SV *sv, int c)
16541 {
16542     PERL_ARGS_ASSERT_PUT_BYTE;
16543
16544     if (!isPRINT(c)) {
16545         switch (c) {
16546             case '\r': Perl_sv_catpvf(aTHX_ sv, "\\r"); break;
16547             case '\n': Perl_sv_catpvf(aTHX_ sv, "\\n"); break;
16548             case '\t': Perl_sv_catpvf(aTHX_ sv, "\\t"); break;
16549             case '\f': Perl_sv_catpvf(aTHX_ sv, "\\f"); break;
16550             case '\a': Perl_sv_catpvf(aTHX_ sv, "\\a"); break;
16551
16552             default:
16553                 Perl_sv_catpvf(aTHX_ sv, "\\x{%x}", c);
16554                 break;
16555         }
16556     }
16557     else {
16558         const char string = c;
16559         if (c == '-' || c == ']' || c == '\\' || c == '^')
16560             sv_catpvs(sv, "\\");
16561         sv_catpvn(sv, &string, 1);
16562     }
16563 }
16564
16565 STATIC void
16566 S_put_range(pTHX_ SV *sv, UV start, UV end)
16567 {
16568
16569     /* Appends to 'sv' a displayable version of the range of code points from
16570      * 'start' to 'end'.  It assumes that only ASCII printables are displayable
16571      * as-is (though some of these will be escaped by put_byte()).  For the
16572      * time being, this subroutine only works for latin1 (< 256) code points */
16573
16574     assert(start <= end);
16575
16576     PERL_ARGS_ASSERT_PUT_RANGE;
16577
16578     while (start <= end) {
16579         if (end - start < 3) {  /* Individual chars in short ranges */
16580             for (; start <= end; start++) {
16581                 put_byte(sv, start);
16582             }
16583             break;
16584         }
16585
16586         /* For small ranges that include printable ASCII characters, it's more
16587          * legible to print those characters rather than hex values.  For
16588          * larger ranges that include more than printables, it's probably
16589          * clearer to just give the start and end points of the range in hex,
16590          * and that's all we can do if there aren't any printables within the
16591          * range
16592          *
16593          * On ASCII platforms the range of printables is contiguous.  If the
16594          * entire range is printable, we print each character as such.  If the
16595          * range is partially printable and partially not, it's less likely
16596          * that the individual printables are meaningful, especially if all or
16597          * almost all of them are in the range.  But we err on the side of the
16598          * individual printables being meaningful by using the hex only if the
16599          * range contains all but 2 of the printables.
16600          *
16601          * On EBCDIC platforms, the printables are scattered around so that the
16602          * maximum range length containing only them is about 10.  Anything
16603          * longer we treat as hex; otherwise we examine the range character by
16604          * character to see */
16605 #ifdef EBCDIC
16606         if (start < 256 && (((end < 255) ? end : 255) - start <= 10))
16607 #else
16608         if ((isPRINT_A(start) && isPRINT_A(end))
16609             || (end >= 0x7F && (isPRINT_A(start) && start > 0x21))
16610             || ((end < 0x7D && isPRINT_A(end)) && start < 0x20))
16611 #endif
16612         {
16613             /* If the range beginning isn't an ASCII printable, we find the
16614              * last such in the range, then split the output, so all the
16615              * non-printables are in one subrange; then process the remaining
16616              * portion as usual.  If the entire range isn't printables, we
16617              * don't split, but drop down to print as hex */
16618             if (! isPRINT_A(start)) {
16619                 UV temp_end = start + 1;
16620                 while (temp_end <= end && ! isPRINT_A(temp_end)) {
16621                     temp_end++;
16622                 }
16623                 if (temp_end <= end) {
16624                     put_range(sv, start, temp_end - 1);
16625                     start = temp_end;
16626                     continue;
16627                 }
16628             }
16629
16630             /* If the range beginning is a digit, output a subrange of just the
16631              * digits, then process the remaining portion as usual */
16632             if (isDIGIT_A(start)) {
16633                 put_byte(sv, start);
16634                 sv_catpvs(sv, "-");
16635                 while (start <= end && isDIGIT_A(start)) start++;
16636                 put_byte(sv, start - 1);
16637                 continue;
16638             }
16639
16640             /* Similarly for alphabetics.  Because in both ASCII and EBCDIC,
16641              * the code points for upper and lower A-Z and a-z aren't
16642              * intermixed, the resulting subrange will consist solely of either
16643              * upper- or lower- alphabetics */
16644             if (isALPHA_A(start)) {
16645                 put_byte(sv, start);
16646                 sv_catpvs(sv, "-");
16647                 while (start <= end && isALPHA_A(start)) start++;
16648                 put_byte(sv, start - 1);
16649                 continue;
16650             }
16651
16652             /* We output any remaining printables as individual characters */
16653             if (isPUNCT_A(start) || isSPACE_A(start)) {
16654                 while (start <= end && (isPUNCT_A(start) || isSPACE_A(start))) {
16655                     put_byte(sv, start);
16656                     start++;
16657                 }
16658                 continue;
16659             }
16660         }
16661
16662         /* Here is a control or non-ascii.  Output the range or subrange as
16663          * hex. */
16664         Perl_sv_catpvf(aTHX_ sv, "\\x{%02" UVXf "}-\\x{%02" UVXf "}",
16665                        start,
16666                        (end < 256) ? end : 255);
16667         break;
16668     }
16669 }
16670
16671 STATIC bool
16672 S_put_latin1_charclass_innards(pTHX_ SV *sv, char *bitmap)
16673 {
16674     /* Appends to 'sv' a displayable version of the innards of the bracketed
16675      * character class whose bitmap is 'bitmap';  Returns 'TRUE' if it actually
16676      * output anything */
16677
16678     int i;
16679     bool has_output_anything = FALSE;
16680
16681     PERL_ARGS_ASSERT_PUT_LATIN1_CHARCLASS_INNARDS;
16682
16683     for (i = 0; i < 256; i++) {
16684         if (i < 256 && BITMAP_TEST((U8 *) bitmap,i)) {
16685
16686             /* The character at index i should be output.  Find the next
16687              * character that should NOT be output */
16688             int j;
16689             for (j = i + 1; j <= 256; j++) {
16690                 if (! BITMAP_TEST((U8 *) bitmap, j)) {
16691                     break;
16692                 }
16693             }
16694
16695             /* Everything between them is a single range that should be output
16696              * */
16697             put_range(sv, i, j - 1);
16698             has_output_anything = TRUE;
16699             i = j;
16700         }
16701     }
16702
16703     return has_output_anything;
16704 }
16705
16706 #define CLEAR_OPTSTART \
16707     if (optstart) STMT_START {                                               \
16708         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,                       \
16709                               " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
16710         optstart=NULL;                                                       \
16711     } STMT_END
16712
16713 #define DUMPUNTIL(b,e)                                                       \
16714                     CLEAR_OPTSTART;                                          \
16715                     node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
16716
16717 STATIC const regnode *
16718 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
16719             const regnode *last, const regnode *plast,
16720             SV* sv, I32 indent, U32 depth)
16721 {
16722     dVAR;
16723     U8 op = PSEUDO;     /* Arbitrary non-END op. */
16724     const regnode *next;
16725     const regnode *optstart= NULL;
16726
16727     RXi_GET_DECL(r,ri);
16728     GET_RE_DEBUG_FLAGS_DECL;
16729
16730     PERL_ARGS_ASSERT_DUMPUNTIL;
16731
16732 #ifdef DEBUG_DUMPUNTIL
16733     PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
16734         last ? last-start : 0,plast ? plast-start : 0);
16735 #endif
16736
16737     if (plast && plast < last)
16738         last= plast;
16739
16740     while (PL_regkind[op] != END && (!last || node < last)) {
16741         assert(node);
16742         /* While that wasn't END last time... */
16743         NODE_ALIGN(node);
16744         op = OP(node);
16745         if (op == CLOSE || op == WHILEM)
16746             indent--;
16747         next = regnext((regnode *)node);
16748
16749         /* Where, what. */
16750         if (OP(node) == OPTIMIZED) {
16751             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
16752                 optstart = node;
16753             else
16754                 goto after_print;
16755         } else
16756             CLEAR_OPTSTART;
16757
16758         regprop(r, sv, node, NULL);
16759         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
16760                       (int)(2*indent + 1), "", SvPVX_const(sv));
16761
16762         if (OP(node) != OPTIMIZED) {
16763             if (next == NULL)           /* Next ptr. */
16764                 PerlIO_printf(Perl_debug_log, " (0)");
16765             else if (PL_regkind[(U8)op] == BRANCH
16766                      && PL_regkind[OP(next)] != BRANCH )
16767                 PerlIO_printf(Perl_debug_log, " (FAIL)");
16768             else
16769                 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
16770             (void)PerlIO_putc(Perl_debug_log, '\n');
16771         }
16772
16773       after_print:
16774         if (PL_regkind[(U8)op] == BRANCHJ) {
16775             assert(next);
16776             {
16777                 const regnode *nnode = (OP(next) == LONGJMP
16778                                        ? regnext((regnode *)next)
16779                                        : next);
16780                 if (last && nnode > last)
16781                     nnode = last;
16782                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
16783             }
16784         }
16785         else if (PL_regkind[(U8)op] == BRANCH) {
16786             assert(next);
16787             DUMPUNTIL(NEXTOPER(node), next);
16788         }
16789         else if ( PL_regkind[(U8)op]  == TRIE ) {
16790             const regnode *this_trie = node;
16791             const char op = OP(node);
16792             const U32 n = ARG(node);
16793             const reg_ac_data * const ac = op>=AHOCORASICK ?
16794                (reg_ac_data *)ri->data->data[n] :
16795                NULL;
16796             const reg_trie_data * const trie =
16797                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
16798 #ifdef DEBUGGING
16799             AV *const trie_words
16800                            = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
16801 #endif
16802             const regnode *nextbranch= NULL;
16803             I32 word_idx;
16804             sv_setpvs(sv, "");
16805             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
16806                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
16807
16808                 PerlIO_printf(Perl_debug_log, "%*s%s ",
16809                    (int)(2*(indent+3)), "",
16810                     elem_ptr
16811                     ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr),
16812                                 SvCUR(*elem_ptr), 60,
16813                                 PL_colors[0], PL_colors[1],
16814                                 (SvUTF8(*elem_ptr)
16815                                  ? PERL_PV_ESCAPE_UNI
16816                                  : 0)
16817                                 | PERL_PV_PRETTY_ELLIPSES
16818                                 | PERL_PV_PRETTY_LTGT
16819                             )
16820                     : "???"
16821                 );
16822                 if (trie->jump) {
16823                     U16 dist= trie->jump[word_idx+1];
16824                     PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
16825                                (UV)((dist ? this_trie + dist : next) - start));
16826                     if (dist) {
16827                         if (!nextbranch)
16828                             nextbranch= this_trie + trie->jump[0];
16829                         DUMPUNTIL(this_trie + dist, nextbranch);
16830                     }
16831                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
16832                         nextbranch= regnext((regnode *)nextbranch);
16833                 } else {
16834                     PerlIO_printf(Perl_debug_log, "\n");
16835                 }
16836             }
16837             if (last && next > last)
16838                 node= last;
16839             else
16840                 node= next;
16841         }
16842         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
16843             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
16844                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
16845         }
16846         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
16847             assert(next);
16848             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
16849         }
16850         else if ( op == PLUS || op == STAR) {
16851             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
16852         }
16853         else if (PL_regkind[(U8)op] == ANYOF) {
16854             /* arglen 1 + class block */
16855             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_POSIXL)
16856                           ? ANYOF_POSIXL_SKIP
16857                           : ANYOF_SKIP);
16858             node = NEXTOPER(node);
16859         }
16860         else if (PL_regkind[(U8)op] == EXACT) {
16861             /* Literal string, where present. */
16862             node += NODE_SZ_STR(node) - 1;
16863             node = NEXTOPER(node);
16864         }
16865         else {
16866             node = NEXTOPER(node);
16867             node += regarglen[(U8)op];
16868         }
16869         if (op == CURLYX || op == OPEN)
16870             indent++;
16871     }
16872     CLEAR_OPTSTART;
16873 #ifdef DEBUG_DUMPUNTIL
16874     PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
16875 #endif
16876     return node;
16877 }
16878
16879 #endif  /* DEBUGGING */
16880
16881 /*
16882  * Local variables:
16883  * c-indentation-style: bsd
16884  * c-basic-offset: 4
16885  * indent-tabs-mode: nil
16886  * End:
16887  *
16888  * ex: set ts=8 sts=4 sw=4 et:
16889  */