This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Blead is in sync with Data::Dumper 2.154
[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 /*
381  * Forward declarations for pregcomp()'s friends.
382  */
383
384 static const scan_data_t zero_scan_data =
385   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
386
387 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
388 #define SF_BEFORE_SEOL          0x0001
389 #define SF_BEFORE_MEOL          0x0002
390 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
391 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
392
393 #define SF_FIX_SHIFT_EOL        (+2)
394 #define SF_FL_SHIFT_EOL         (+4)
395
396 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
397 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
398
399 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
400 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
401 #define SF_IS_INF               0x0040
402 #define SF_HAS_PAR              0x0080
403 #define SF_IN_PAR               0x0100
404 #define SF_HAS_EVAL             0x0200
405 #define SCF_DO_SUBSTR           0x0400
406 #define SCF_DO_STCLASS_AND      0x0800
407 #define SCF_DO_STCLASS_OR       0x1000
408 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
409 #define SCF_WHILEM_VISITED_POS  0x2000
410
411 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
412 #define SCF_SEEN_ACCEPT         0x8000
413 #define SCF_TRIE_DOING_RESTUDY 0x10000
414
415 #define UTF cBOOL(RExC_utf8)
416
417 /* The enums for all these are ordered so things work out correctly */
418 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
419 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags)                    \
420                                                      == REGEX_DEPENDS_CHARSET)
421 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
422 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags)                \
423                                                      >= REGEX_UNICODE_CHARSET)
424 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags)                      \
425                                             == REGEX_ASCII_RESTRICTED_CHARSET)
426 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags)             \
427                                             >= REGEX_ASCII_RESTRICTED_CHARSET)
428 #define ASCII_FOLD_RESTRICTED (get_regex_charset(RExC_flags)                 \
429                                         == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
430
431 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
432
433 /* For programs that want to be strictly Unicode compatible by dying if any
434  * attempt is made to match a non-Unicode code point against a Unicode
435  * property.  */
436 #define ALWAYS_WARN_SUPER  ckDEAD(packWARN(WARN_NON_UNICODE))
437
438 #define OOB_NAMEDCLASS          -1
439
440 /* There is no code point that is out-of-bounds, so this is problematic.  But
441  * its only current use is to initialize a variable that is always set before
442  * looked at. */
443 #define OOB_UNICODE             0xDEADBEEF
444
445 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
446 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
447
448
449 /* length of regex to show in messages that don't mark a position within */
450 #define RegexLengthToShowInErrorMessages 127
451
452 /*
453  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
454  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
455  * op/pragma/warn/regcomp.
456  */
457 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
458 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
459
460 #define REPORT_LOCATION " in regex; marked by " MARKER1    \
461                         " in m/%"UTF8f MARKER2 "%"UTF8f"/"
462
463 #define REPORT_LOCATION_ARGS(offset)            \
464                 UTF8fARG(UTF, offset, RExC_precomp), \
465                 UTF8fARG(UTF, RExC_end - RExC_precomp - offset, RExC_precomp + offset)
466
467 /*
468  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
469  * arg. Show regex, up to a maximum length. If it's too long, chop and add
470  * "...".
471  */
472 #define _FAIL(code) STMT_START {                                        \
473     const char *ellipses = "";                                          \
474     IV len = RExC_end - RExC_precomp;                                   \
475                                                                         \
476     if (!SIZE_ONLY)                                                     \
477         SAVEFREESV(RExC_rx_sv);                                         \
478     if (len > RegexLengthToShowInErrorMessages) {                       \
479         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
480         len = RegexLengthToShowInErrorMessages - 10;                    \
481         ellipses = "...";                                               \
482     }                                                                   \
483     code;                                                               \
484 } STMT_END
485
486 #define FAIL(msg) _FAIL(                            \
487     Perl_croak(aTHX_ "%s in regex m/%"UTF8f"%s/",           \
488             msg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
489
490 #define FAIL2(msg,arg) _FAIL(                       \
491     Perl_croak(aTHX_ msg " in regex m/%"UTF8f"%s/",         \
492             arg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
493
494 /*
495  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
496  */
497 #define Simple_vFAIL(m) STMT_START {                                    \
498     const IV offset = RExC_parse - RExC_precomp;                        \
499     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
500             m, REPORT_LOCATION_ARGS(offset));   \
501 } STMT_END
502
503 /*
504  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
505  */
506 #define vFAIL(m) STMT_START {                           \
507     if (!SIZE_ONLY)                                     \
508         SAVEFREESV(RExC_rx_sv);                         \
509     Simple_vFAIL(m);                                    \
510 } STMT_END
511
512 /*
513  * Like Simple_vFAIL(), but accepts two arguments.
514  */
515 #define Simple_vFAIL2(m,a1) STMT_START {                        \
516     const IV offset = RExC_parse - RExC_precomp;                        \
517     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,                      \
518                       REPORT_LOCATION_ARGS(offset));    \
519 } STMT_END
520
521 /*
522  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
523  */
524 #define vFAIL2(m,a1) STMT_START {                       \
525     if (!SIZE_ONLY)                                     \
526         SAVEFREESV(RExC_rx_sv);                         \
527     Simple_vFAIL2(m, a1);                               \
528 } STMT_END
529
530
531 /*
532  * Like Simple_vFAIL(), but accepts three arguments.
533  */
534 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
535     const IV offset = RExC_parse - RExC_precomp;                \
536     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,          \
537             REPORT_LOCATION_ARGS(offset));      \
538 } STMT_END
539
540 /*
541  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
542  */
543 #define vFAIL3(m,a1,a2) STMT_START {                    \
544     if (!SIZE_ONLY)                                     \
545         SAVEFREESV(RExC_rx_sv);                         \
546     Simple_vFAIL3(m, a1, a2);                           \
547 } STMT_END
548
549 /*
550  * Like Simple_vFAIL(), but accepts four arguments.
551  */
552 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
553     const IV offset = RExC_parse - RExC_precomp;                \
554     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2, a3,              \
555             REPORT_LOCATION_ARGS(offset));      \
556 } STMT_END
557
558 #define vFAIL4(m,a1,a2,a3) STMT_START {                 \
559     if (!SIZE_ONLY)                                     \
560         SAVEFREESV(RExC_rx_sv);                         \
561     Simple_vFAIL4(m, a1, a2, a3);                       \
562 } STMT_END
563
564 /* A specialized version of vFAIL2 that works with UTF8f */
565 #define vFAIL2utf8f(m, a1) STMT_START { \
566     const IV offset = RExC_parse - RExC_precomp;   \
567     if (!SIZE_ONLY)                                \
568         SAVEFREESV(RExC_rx_sv);                    \
569     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, \
570             REPORT_LOCATION_ARGS(offset));         \
571 } STMT_END
572
573 /* These have asserts in them because of [perl #122671] Many warnings in
574  * regcomp.c can occur twice.  If they get output in pass1 and later in that
575  * pass, the pattern has to be converted to UTF-8 and the pass restarted, they
576  * would get output again.  So they should be output in pass2, and these
577  * asserts make sure new warnings follow that paradigm. */
578
579 /* m is not necessarily a "literal string", in this macro */
580 #define reg_warn_non_literal_string(loc, m) STMT_START {                \
581     const IV offset = loc - RExC_precomp;                               \
582     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s" REPORT_LOCATION,      \
583             m, REPORT_LOCATION_ARGS(offset));       \
584 } STMT_END
585
586 #define ckWARNreg(loc,m) STMT_START {                                   \
587     const IV offset = loc - RExC_precomp;                               \
588     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,     \
589             REPORT_LOCATION_ARGS(offset));              \
590 } STMT_END
591
592 #define vWARN_dep(loc, m) STMT_START {                                  \
593     const IV offset = loc - RExC_precomp;                               \
594     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), m REPORT_LOCATION,    \
595             REPORT_LOCATION_ARGS(offset));              \
596 } STMT_END
597
598 #define ckWARNdep(loc,m) STMT_START {                                   \
599     const IV offset = loc - RExC_precomp;                               \
600     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),                  \
601             m REPORT_LOCATION,                                          \
602             REPORT_LOCATION_ARGS(offset));              \
603 } STMT_END
604
605 #define ckWARNregdep(loc,m) STMT_START {                                \
606     const IV offset = loc - RExC_precomp;                               \
607     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),    \
608             m REPORT_LOCATION,                                          \
609             REPORT_LOCATION_ARGS(offset));              \
610 } STMT_END
611
612 #define ckWARN2reg_d(loc,m, a1) STMT_START {                            \
613     const IV offset = loc - RExC_precomp;                               \
614     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP),                      \
615             m REPORT_LOCATION,                                          \
616             a1, REPORT_LOCATION_ARGS(offset));  \
617 } STMT_END
618
619 #define ckWARN2reg(loc, m, a1) STMT_START {                             \
620     const IV offset = loc - RExC_precomp;                               \
621     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,     \
622             a1, REPORT_LOCATION_ARGS(offset));  \
623 } STMT_END
624
625 #define vWARN3(loc, m, a1, a2) STMT_START {                             \
626     const IV offset = loc - RExC_precomp;                               \
627     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,                \
628             a1, a2, REPORT_LOCATION_ARGS(offset));      \
629 } STMT_END
630
631 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                         \
632     const IV offset = loc - RExC_precomp;                               \
633     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,     \
634             a1, a2, REPORT_LOCATION_ARGS(offset));      \
635 } STMT_END
636
637 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
638     const IV offset = loc - RExC_precomp;                               \
639     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,                \
640             a1, a2, a3, REPORT_LOCATION_ARGS(offset)); \
641 } STMT_END
642
643 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
644     const IV offset = loc - RExC_precomp;                               \
645     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,     \
646             a1, a2, a3, REPORT_LOCATION_ARGS(offset)); \
647 } STMT_END
648
649 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
650     const IV offset = loc - RExC_precomp;                               \
651     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,                \
652             a1, a2, a3, a4, REPORT_LOCATION_ARGS(offset)); \
653 } STMT_END
654
655
656 /* Allow for side effects in s */
657 #define REGC(c,s) STMT_START {                  \
658     if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
659 } STMT_END
660
661 /* Macros for recording node offsets.   20001227 mjd@plover.com
662  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
663  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
664  * Element 0 holds the number n.
665  * Position is 1 indexed.
666  */
667 #ifndef RE_TRACK_PATTERN_OFFSETS
668 #define Set_Node_Offset_To_R(node,byte)
669 #define Set_Node_Offset(node,byte)
670 #define Set_Cur_Node_Offset
671 #define Set_Node_Length_To_R(node,len)
672 #define Set_Node_Length(node,len)
673 #define Set_Node_Cur_Length(node,start)
674 #define Node_Offset(n)
675 #define Node_Length(n)
676 #define Set_Node_Offset_Length(node,offset,len)
677 #define ProgLen(ri) ri->u.proglen
678 #define SetProgLen(ri,x) ri->u.proglen = x
679 #else
680 #define ProgLen(ri) ri->u.offsets[0]
681 #define SetProgLen(ri,x) ri->u.offsets[0] = x
682 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
683     if (! SIZE_ONLY) {                                                  \
684         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
685                     __LINE__, (int)(node), (int)(byte)));               \
686         if((node) < 0) {                                                \
687             Perl_croak(aTHX_ "value of node is %d in Offset macro",     \
688                                          (int)(node));                  \
689         } else {                                                        \
690             RExC_offsets[2*(node)-1] = (byte);                          \
691         }                                                               \
692     }                                                                   \
693 } STMT_END
694
695 #define Set_Node_Offset(node,byte) \
696     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
697 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
698
699 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
700     if (! SIZE_ONLY) {                                                  \
701         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
702                 __LINE__, (int)(node), (int)(len)));                    \
703         if((node) < 0) {                                                \
704             Perl_croak(aTHX_ "value of node is %d in Length macro",     \
705                                          (int)(node));                  \
706         } else {                                                        \
707             RExC_offsets[2*(node)] = (len);                             \
708         }                                                               \
709     }                                                                   \
710 } STMT_END
711
712 #define Set_Node_Length(node,len) \
713     Set_Node_Length_To_R((node)-RExC_emit_start, len)
714 #define Set_Node_Cur_Length(node, start)                \
715     Set_Node_Length(node, RExC_parse - start)
716
717 /* Get offsets and lengths */
718 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
719 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
720
721 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
722     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
723     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
724 } STMT_END
725 #endif
726
727 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
728 #define EXPERIMENTAL_INPLACESCAN
729 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
730
731 #define DEBUG_RExC_seen() \
732         DEBUG_OPTIMISE_MORE_r({                                             \
733             PerlIO_printf(Perl_debug_log,"RExC_seen: ");                    \
734                                                                             \
735             if (RExC_seen & REG_ZERO_LEN_SEEN)                              \
736                 PerlIO_printf(Perl_debug_log,"REG_ZERO_LEN_SEEN ");         \
737                                                                             \
738             if (RExC_seen & REG_LOOKBEHIND_SEEN)                            \
739                 PerlIO_printf(Perl_debug_log,"REG_LOOKBEHIND_SEEN ");       \
740                                                                             \
741             if (RExC_seen & REG_GPOS_SEEN)                                  \
742                 PerlIO_printf(Perl_debug_log,"REG_GPOS_SEEN ");             \
743                                                                             \
744             if (RExC_seen & REG_CANY_SEEN)                                  \
745                 PerlIO_printf(Perl_debug_log,"REG_CANY_SEEN ");             \
746                                                                             \
747             if (RExC_seen & REG_RECURSE_SEEN)                               \
748                 PerlIO_printf(Perl_debug_log,"REG_RECURSE_SEEN ");          \
749                                                                             \
750             if (RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)                         \
751                 PerlIO_printf(Perl_debug_log,"REG_TOP_LEVEL_BRANCHES_SEEN ");    \
752                                                                             \
753             if (RExC_seen & REG_VERBARG_SEEN)                               \
754                 PerlIO_printf(Perl_debug_log,"REG_VERBARG_SEEN ");          \
755                                                                             \
756             if (RExC_seen & REG_CUTGROUP_SEEN)                              \
757                 PerlIO_printf(Perl_debug_log,"REG_CUTGROUP_SEEN ");         \
758                                                                             \
759             if (RExC_seen & REG_RUN_ON_COMMENT_SEEN)                        \
760                 PerlIO_printf(Perl_debug_log,"REG_RUN_ON_COMMENT_SEEN ");   \
761                                                                             \
762             if (RExC_seen & REG_UNFOLDED_MULTI_SEEN)                        \
763                 PerlIO_printf(Perl_debug_log,"REG_UNFOLDED_MULTI_SEEN ");   \
764                                                                             \
765             if (RExC_seen & REG_GOSTART_SEEN)                               \
766                 PerlIO_printf(Perl_debug_log,"REG_GOSTART_SEEN ");          \
767                                                                             \
768             if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)                               \
769                 PerlIO_printf(Perl_debug_log,"REG_UNBOUNDED_QUANTIFIER_SEEN ");          \
770                                                                             \
771             PerlIO_printf(Perl_debug_log,"\n");                             \
772         });
773
774 #define DEBUG_STUDYDATA(str,data,depth)                              \
775 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
776     PerlIO_printf(Perl_debug_log,                                    \
777         "%*s" str "Pos:%"IVdf"/%"IVdf                                \
778         " Flags: 0x%"UVXf" Whilem_c: %"IVdf" Lcp: %"IVdf" %s",       \
779         (int)(depth)*2, "",                                          \
780         (IV)((data)->pos_min),                                       \
781         (IV)((data)->pos_delta),                                     \
782         (UV)((data)->flags),                                         \
783         (IV)((data)->whilem_c),                                      \
784         (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
785         is_inf ? "INF " : ""                                         \
786     );                                                               \
787     if ((data)->last_found)                                          \
788         PerlIO_printf(Perl_debug_log,                                \
789             "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
790             " %sFloat: '%s' @ %"IVdf"/%"IVdf"",                      \
791             SvPVX_const((data)->last_found),                         \
792             (IV)((data)->last_end),                                  \
793             (IV)((data)->last_start_min),                            \
794             (IV)((data)->last_start_max),                            \
795             ((data)->longest &&                                      \
796              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
797             SvPVX_const((data)->longest_fixed),                      \
798             (IV)((data)->offset_fixed),                              \
799             ((data)->longest &&                                      \
800              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
801             SvPVX_const((data)->longest_float),                      \
802             (IV)((data)->offset_float_min),                          \
803             (IV)((data)->offset_float_max)                           \
804         );                                                           \
805     PerlIO_printf(Perl_debug_log,"\n");                              \
806 });
807
808 #ifdef DEBUGGING
809
810 /* is c a control character for which we have a mnemonic? */
811 #define isMNEMONIC_CNTRL(c) _IS_MNEMONIC_CNTRL_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
812
813 STATIC const char *
814 S_cntrl_to_mnemonic(const U8 c)
815 {
816     /* Returns the mnemonic string that represents character 'c', if one
817      * exists; NULL otherwise.  The only ones that exist for the purposes of
818      * this routine are a few control characters */
819
820     switch (c) {
821         case '\a':       return "\\a";
822         case '\b':       return "\\b";
823         case ESC_NATIVE: return "\\e";
824         case '\f':       return "\\f";
825         case '\n':       return "\\n";
826         case '\r':       return "\\r";
827         case '\t':       return "\\t";
828     }
829
830     return NULL;
831 }
832
833 #endif
834
835 /* Mark that we cannot extend a found fixed substring at this point.
836    Update the longest found anchored substring and the longest found
837    floating substrings if needed. */
838
839 STATIC void
840 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data,
841                     SSize_t *minlenp, int is_inf)
842 {
843     const STRLEN l = CHR_SVLEN(data->last_found);
844     const STRLEN old_l = CHR_SVLEN(*data->longest);
845     GET_RE_DEBUG_FLAGS_DECL;
846
847     PERL_ARGS_ASSERT_SCAN_COMMIT;
848
849     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
850         SvSetMagicSV(*data->longest, data->last_found);
851         if (*data->longest == data->longest_fixed) {
852             data->offset_fixed = l ? data->last_start_min : data->pos_min;
853             if (data->flags & SF_BEFORE_EOL)
854                 data->flags
855                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
856             else
857                 data->flags &= ~SF_FIX_BEFORE_EOL;
858             data->minlen_fixed=minlenp;
859             data->lookbehind_fixed=0;
860         }
861         else { /* *data->longest == data->longest_float */
862             data->offset_float_min = l ? data->last_start_min : data->pos_min;
863             data->offset_float_max = (l
864                                       ? data->last_start_max
865                                       : (data->pos_delta == SSize_t_MAX
866                                          ? SSize_t_MAX
867                                          : data->pos_min + data->pos_delta));
868             if (is_inf
869                  || (STRLEN)data->offset_float_max > (STRLEN)SSize_t_MAX)
870                 data->offset_float_max = SSize_t_MAX;
871             if (data->flags & SF_BEFORE_EOL)
872                 data->flags
873                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
874             else
875                 data->flags &= ~SF_FL_BEFORE_EOL;
876             data->minlen_float=minlenp;
877             data->lookbehind_float=0;
878         }
879     }
880     SvCUR_set(data->last_found, 0);
881     {
882         SV * const sv = data->last_found;
883         if (SvUTF8(sv) && SvMAGICAL(sv)) {
884             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
885             if (mg)
886                 mg->mg_len = 0;
887         }
888     }
889     data->last_end = -1;
890     data->flags &= ~SF_BEFORE_EOL;
891     DEBUG_STUDYDATA("commit: ",data,0);
892 }
893
894 /* An SSC is just a regnode_charclass_posix with an extra field: the inversion
895  * list that describes which code points it matches */
896
897 STATIC void
898 S_ssc_anything(pTHX_ regnode_ssc *ssc)
899 {
900     /* Set the SSC 'ssc' to match an empty string or any code point */
901
902     PERL_ARGS_ASSERT_SSC_ANYTHING;
903
904     assert(is_ANYOF_SYNTHETIC(ssc));
905
906     ssc->invlist = sv_2mortal(_new_invlist(2)); /* mortalize so won't leak */
907     _append_range_to_invlist(ssc->invlist, 0, UV_MAX);
908     ANYOF_FLAGS(ssc) |= SSC_MATCHES_EMPTY_STRING;  /* Plus matches empty */
909 }
910
911 STATIC int
912 S_ssc_is_anything(const regnode_ssc *ssc)
913 {
914     /* Returns TRUE if the SSC 'ssc' can match the empty string and any code
915      * point; FALSE otherwise.  Thus, this is used to see if using 'ssc' buys
916      * us anything: if the function returns TRUE, 'ssc' hasn't been restricted
917      * in any way, so there's no point in using it */
918
919     UV start, end;
920     bool ret;
921
922     PERL_ARGS_ASSERT_SSC_IS_ANYTHING;
923
924     assert(is_ANYOF_SYNTHETIC(ssc));
925
926     if (! (ANYOF_FLAGS(ssc) & SSC_MATCHES_EMPTY_STRING)) {
927         return FALSE;
928     }
929
930     /* See if the list consists solely of the range 0 - Infinity */
931     invlist_iterinit(ssc->invlist);
932     ret = invlist_iternext(ssc->invlist, &start, &end)
933           && start == 0
934           && end == UV_MAX;
935
936     invlist_iterfinish(ssc->invlist);
937
938     if (ret) {
939         return TRUE;
940     }
941
942     /* If e.g., both \w and \W are set, matches everything */
943     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
944         int i;
945         for (i = 0; i < ANYOF_POSIXL_MAX; i += 2) {
946             if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i+1)) {
947                 return TRUE;
948             }
949         }
950     }
951
952     return FALSE;
953 }
954
955 STATIC void
956 S_ssc_init(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc)
957 {
958     /* Initializes the SSC 'ssc'.  This includes setting it to match an empty
959      * string, any code point, or any posix class under locale */
960
961     PERL_ARGS_ASSERT_SSC_INIT;
962
963     Zero(ssc, 1, regnode_ssc);
964     set_ANYOF_SYNTHETIC(ssc);
965     ARG_SET(ssc, ANYOF_ONLY_HAS_BITMAP);
966     ssc_anything(ssc);
967
968     /* If any portion of the regex is to operate under locale rules,
969      * initialization includes it.  The reason this isn't done for all regexes
970      * is that the optimizer was written under the assumption that locale was
971      * all-or-nothing.  Given the complexity and lack of documentation in the
972      * optimizer, and that there are inadequate test cases for locale, many
973      * parts of it may not work properly, it is safest to avoid locale unless
974      * necessary. */
975     if (RExC_contains_locale) {
976         ANYOF_POSIXL_SETALL(ssc);
977     }
978     else {
979         ANYOF_POSIXL_ZERO(ssc);
980     }
981 }
982
983 STATIC int
984 S_ssc_is_cp_posixl_init(const RExC_state_t *pRExC_state,
985                         const regnode_ssc *ssc)
986 {
987     /* Returns TRUE if the SSC 'ssc' is in its initial state with regard only
988      * to the list of code points matched, and locale posix classes; hence does
989      * not check its flags) */
990
991     UV start, end;
992     bool ret;
993
994     PERL_ARGS_ASSERT_SSC_IS_CP_POSIXL_INIT;
995
996     assert(is_ANYOF_SYNTHETIC(ssc));
997
998     invlist_iterinit(ssc->invlist);
999     ret = invlist_iternext(ssc->invlist, &start, &end)
1000           && start == 0
1001           && end == UV_MAX;
1002
1003     invlist_iterfinish(ssc->invlist);
1004
1005     if (! ret) {
1006         return FALSE;
1007     }
1008
1009     if (RExC_contains_locale && ! ANYOF_POSIXL_SSC_TEST_ALL_SET(ssc)) {
1010         return FALSE;
1011     }
1012
1013     return TRUE;
1014 }
1015
1016 STATIC SV*
1017 S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state,
1018                                const regnode_charclass* const node)
1019 {
1020     /* Returns a mortal inversion list defining which code points are matched
1021      * by 'node', which is of type ANYOF.  Handles complementing the result if
1022      * appropriate.  If some code points aren't knowable at this time, the
1023      * returned list must, and will, contain every code point that is a
1024      * possibility. */
1025
1026     SV* invlist = sv_2mortal(_new_invlist(0));
1027     SV* only_utf8_locale_invlist = NULL;
1028     unsigned int i;
1029     const U32 n = ARG(node);
1030     bool new_node_has_latin1 = FALSE;
1031
1032     PERL_ARGS_ASSERT_GET_ANYOF_CP_LIST_FOR_SSC;
1033
1034     /* Look at the data structure created by S_set_ANYOF_arg() */
1035     if (n != ANYOF_ONLY_HAS_BITMAP) {
1036         SV * const rv = MUTABLE_SV(RExC_rxi->data->data[n]);
1037         AV * const av = MUTABLE_AV(SvRV(rv));
1038         SV **const ary = AvARRAY(av);
1039         assert(RExC_rxi->data->what[n] == 's');
1040
1041         if (ary[1] && ary[1] != &PL_sv_undef) { /* Has compile-time swash */
1042             invlist = sv_2mortal(invlist_clone(_get_swash_invlist(ary[1])));
1043         }
1044         else if (ary[0] && ary[0] != &PL_sv_undef) {
1045
1046             /* Here, no compile-time swash, and there are things that won't be
1047              * known until runtime -- we have to assume it could be anything */
1048             return _add_range_to_invlist(invlist, 0, UV_MAX);
1049         }
1050         else if (ary[3] && ary[3] != &PL_sv_undef) {
1051
1052             /* Here no compile-time swash, and no run-time only data.  Use the
1053              * node's inversion list */
1054             invlist = sv_2mortal(invlist_clone(ary[3]));
1055         }
1056
1057         /* Get the code points valid only under UTF-8 locales */
1058         if ((ANYOF_FLAGS(node) & ANYOF_LOC_FOLD)
1059             && ary[2] && ary[2] != &PL_sv_undef)
1060         {
1061             only_utf8_locale_invlist = ary[2];
1062         }
1063     }
1064
1065     /* An ANYOF node contains a bitmap for the first NUM_ANYOF_CODE_POINTS
1066      * code points, and an inversion list for the others, but if there are code
1067      * points that should match only conditionally on the target string being
1068      * UTF-8, those are placed in the inversion list, and not the bitmap.
1069      * Since there are circumstances under which they could match, they are
1070      * included in the SSC.  But if the ANYOF node is to be inverted, we have
1071      * to exclude them here, so that when we invert below, the end result
1072      * actually does include them.  (Think about "\xe0" =~ /[^\xc0]/di;).  We
1073      * have to do this here before we add the unconditionally matched code
1074      * points */
1075     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1076         _invlist_intersection_complement_2nd(invlist,
1077                                              PL_UpperLatin1,
1078                                              &invlist);
1079     }
1080
1081     /* Add in the points from the bit map */
1082     for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
1083         if (ANYOF_BITMAP_TEST(node, i)) {
1084             invlist = add_cp_to_invlist(invlist, i);
1085             new_node_has_latin1 = TRUE;
1086         }
1087     }
1088
1089     /* If this can match all upper Latin1 code points, have to add them
1090      * as well */
1091     if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_NON_UTF8_NON_ASCII) {
1092         _invlist_union(invlist, PL_UpperLatin1, &invlist);
1093     }
1094
1095     /* Similarly for these */
1096     if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
1097         _invlist_union_complement_2nd(invlist, PL_InBitmap, &invlist);
1098     }
1099
1100     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1101         _invlist_invert(invlist);
1102     }
1103     else if (new_node_has_latin1 && ANYOF_FLAGS(node) & ANYOF_LOC_FOLD) {
1104
1105         /* Under /li, any 0-255 could fold to any other 0-255, depending on the
1106          * locale.  We can skip this if there are no 0-255 at all. */
1107         _invlist_union(invlist, PL_Latin1, &invlist);
1108     }
1109
1110     /* Similarly add the UTF-8 locale possible matches.  These have to be
1111      * deferred until after the non-UTF-8 locale ones are taken care of just
1112      * above, or it leads to wrong results under ANYOF_INVERT */
1113     if (only_utf8_locale_invlist) {
1114         _invlist_union_maybe_complement_2nd(invlist,
1115                                             only_utf8_locale_invlist,
1116                                             ANYOF_FLAGS(node) & ANYOF_INVERT,
1117                                             &invlist);
1118     }
1119
1120     return invlist;
1121 }
1122
1123 /* These two functions currently do the exact same thing */
1124 #define ssc_init_zero           ssc_init
1125
1126 #define ssc_add_cp(ssc, cp)   ssc_add_range((ssc), (cp), (cp))
1127 #define ssc_match_all_cp(ssc) ssc_add_range(ssc, 0, UV_MAX)
1128
1129 /* 'AND' a given class with another one.  Can create false positives.  'ssc'
1130  * should not be inverted.  'and_with->flags & ANYOF_MATCHES_POSIXL' should be
1131  * 0 if 'and_with' is a regnode_charclass instead of a regnode_ssc. */
1132
1133 STATIC void
1134 S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1135                 const regnode_charclass *and_with)
1136 {
1137     /* Accumulate into SSC 'ssc' its 'AND' with 'and_with', which is either
1138      * another SSC or a regular ANYOF class.  Can create false positives. */
1139
1140     SV* anded_cp_list;
1141     U8  anded_flags;
1142
1143     PERL_ARGS_ASSERT_SSC_AND;
1144
1145     assert(is_ANYOF_SYNTHETIC(ssc));
1146
1147     /* 'and_with' is used as-is if it too is an SSC; otherwise have to extract
1148      * the code point inversion list and just the relevant flags */
1149     if (is_ANYOF_SYNTHETIC(and_with)) {
1150         anded_cp_list = ((regnode_ssc *)and_with)->invlist;
1151         anded_flags = ANYOF_FLAGS(and_with);
1152
1153         /* XXX This is a kludge around what appears to be deficiencies in the
1154          * optimizer.  If we make S_ssc_anything() add in the WARN_SUPER flag,
1155          * there are paths through the optimizer where it doesn't get weeded
1156          * out when it should.  And if we don't make some extra provision for
1157          * it like the code just below, it doesn't get added when it should.
1158          * This solution is to add it only when AND'ing, which is here, and
1159          * only when what is being AND'ed is the pristine, original node
1160          * matching anything.  Thus it is like adding it to ssc_anything() but
1161          * only when the result is to be AND'ed.  Probably the same solution
1162          * could be adopted for the same problem we have with /l matching,
1163          * which is solved differently in S_ssc_init(), and that would lead to
1164          * fewer false positives than that solution has.  But if this solution
1165          * creates bugs, the consequences are only that a warning isn't raised
1166          * that should be; while the consequences for having /l bugs is
1167          * incorrect matches */
1168         if (ssc_is_anything((regnode_ssc *)and_with)) {
1169             anded_flags |= ANYOF_WARN_SUPER;
1170         }
1171     }
1172     else {
1173         anded_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, and_with);
1174         anded_flags = ANYOF_FLAGS(and_with) & ANYOF_COMMON_FLAGS;
1175     }
1176
1177     ANYOF_FLAGS(ssc) &= anded_flags;
1178
1179     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1180      * C2 is the list of code points in 'and-with'; P2, its posix classes.
1181      * 'and_with' may be inverted.  When not inverted, we have the situation of
1182      * computing:
1183      *  (C1 | P1) & (C2 | P2)
1184      *                     =  (C1 & (C2 | P2)) | (P1 & (C2 | P2))
1185      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1186      *                    <=  ((C1 & C2) |       P2)) | ( P1       | (P1 & P2))
1187      *                    <=  ((C1 & C2) | P1 | P2)
1188      * Alternatively, the last few steps could be:
1189      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1190      *                    <=  ((C1 & C2) |  C1      ) | (      C2  | (P1 & P2))
1191      *                    <=  (C1 | C2 | (P1 & P2))
1192      * We favor the second approach if either P1 or P2 is non-empty.  This is
1193      * because these components are a barrier to doing optimizations, as what
1194      * they match cannot be known until the moment of matching as they are
1195      * dependent on the current locale, 'AND"ing them likely will reduce or
1196      * eliminate them.
1197      * But we can do better if we know that C1,P1 are in their initial state (a
1198      * frequent occurrence), each matching everything:
1199      *  (<everything>) & (C2 | P2) =  C2 | P2
1200      * Similarly, if C2,P2 are in their initial state (again a frequent
1201      * occurrence), the result is a no-op
1202      *  (C1 | P1) & (<everything>) =  C1 | P1
1203      *
1204      * Inverted, we have
1205      *  (C1 | P1) & ~(C2 | P2)  =  (C1 | P1) & (~C2 & ~P2)
1206      *                          =  (C1 & (~C2 & ~P2)) | (P1 & (~C2 & ~P2))
1207      *                         <=  (C1 & ~C2) | (P1 & ~P2)
1208      * */
1209
1210     if ((ANYOF_FLAGS(and_with) & ANYOF_INVERT)
1211         && ! is_ANYOF_SYNTHETIC(and_with))
1212     {
1213         unsigned int i;
1214
1215         ssc_intersection(ssc,
1216                          anded_cp_list,
1217                          FALSE /* Has already been inverted */
1218                          );
1219
1220         /* If either P1 or P2 is empty, the intersection will be also; can skip
1221          * the loop */
1222         if (! (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL)) {
1223             ANYOF_POSIXL_ZERO(ssc);
1224         }
1225         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1226
1227             /* Note that the Posix class component P from 'and_with' actually
1228              * looks like:
1229              *      P = Pa | Pb | ... | Pn
1230              * where each component is one posix class, such as in [\w\s].
1231              * Thus
1232              *      ~P = ~(Pa | Pb | ... | Pn)
1233              *         = ~Pa & ~Pb & ... & ~Pn
1234              *        <= ~Pa | ~Pb | ... | ~Pn
1235              * The last is something we can easily calculate, but unfortunately
1236              * is likely to have many false positives.  We could do better
1237              * in some (but certainly not all) instances if two classes in
1238              * P have known relationships.  For example
1239              *      :lower: <= :alpha: <= :alnum: <= \w <= :graph: <= :print:
1240              * So
1241              *      :lower: & :print: = :lower:
1242              * And similarly for classes that must be disjoint.  For example,
1243              * since \s and \w can have no elements in common based on rules in
1244              * the POSIX standard,
1245              *      \w & ^\S = nothing
1246              * Unfortunately, some vendor locales do not meet the Posix
1247              * standard, in particular almost everything by Microsoft.
1248              * The loop below just changes e.g., \w into \W and vice versa */
1249
1250             regnode_charclass_posixl temp;
1251             int add = 1;    /* To calculate the index of the complement */
1252
1253             ANYOF_POSIXL_ZERO(&temp);
1254             for (i = 0; i < ANYOF_MAX; i++) {
1255                 assert(i % 2 != 0
1256                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)
1257                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i + 1));
1258
1259                 if (ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)) {
1260                     ANYOF_POSIXL_SET(&temp, i + add);
1261                 }
1262                 add = 0 - add; /* 1 goes to -1; -1 goes to 1 */
1263             }
1264             ANYOF_POSIXL_AND(&temp, ssc);
1265
1266         } /* else ssc already has no posixes */
1267     } /* else: Not inverted.  This routine is a no-op if 'and_with' is an SSC
1268          in its initial state */
1269     else if (! is_ANYOF_SYNTHETIC(and_with)
1270              || ! ssc_is_cp_posixl_init(pRExC_state, (regnode_ssc *)and_with))
1271     {
1272         /* But if 'ssc' is in its initial state, the result is just 'and_with';
1273          * copy it over 'ssc' */
1274         if (ssc_is_cp_posixl_init(pRExC_state, ssc)) {
1275             if (is_ANYOF_SYNTHETIC(and_with)) {
1276                 StructCopy(and_with, ssc, regnode_ssc);
1277             }
1278             else {
1279                 ssc->invlist = anded_cp_list;
1280                 ANYOF_POSIXL_ZERO(ssc);
1281                 if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1282                     ANYOF_POSIXL_OR((regnode_charclass_posixl*) and_with, ssc);
1283                 }
1284             }
1285         }
1286         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)
1287                  || (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL))
1288         {
1289             /* One or the other of P1, P2 is non-empty. */
1290             if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1291                 ANYOF_POSIXL_AND((regnode_charclass_posixl*) and_with, ssc);
1292             }
1293             ssc_union(ssc, anded_cp_list, FALSE);
1294         }
1295         else { /* P1 = P2 = empty */
1296             ssc_intersection(ssc, anded_cp_list, FALSE);
1297         }
1298     }
1299 }
1300
1301 STATIC void
1302 S_ssc_or(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1303                const regnode_charclass *or_with)
1304 {
1305     /* Accumulate into SSC 'ssc' its 'OR' with 'or_with', which is either
1306      * another SSC or a regular ANYOF class.  Can create false positives if
1307      * 'or_with' is to be inverted. */
1308
1309     SV* ored_cp_list;
1310     U8 ored_flags;
1311
1312     PERL_ARGS_ASSERT_SSC_OR;
1313
1314     assert(is_ANYOF_SYNTHETIC(ssc));
1315
1316     /* 'or_with' is used as-is if it too is an SSC; otherwise have to extract
1317      * the code point inversion list and just the relevant flags */
1318     if (is_ANYOF_SYNTHETIC(or_with)) {
1319         ored_cp_list = ((regnode_ssc*) or_with)->invlist;
1320         ored_flags = ANYOF_FLAGS(or_with);
1321     }
1322     else {
1323         ored_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, or_with);
1324         ored_flags = ANYOF_FLAGS(or_with) & ANYOF_COMMON_FLAGS;
1325     }
1326
1327     ANYOF_FLAGS(ssc) |= ored_flags;
1328
1329     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1330      * C2 is the list of code points in 'or-with'; P2, its posix classes.
1331      * 'or_with' may be inverted.  When not inverted, we have the simple
1332      * situation of computing:
1333      *  (C1 | P1) | (C2 | P2)  =  (C1 | C2) | (P1 | P2)
1334      * If P1|P2 yields a situation with both a class and its complement are
1335      * set, like having both \w and \W, this matches all code points, and we
1336      * can delete these from the P component of the ssc going forward.  XXX We
1337      * might be able to delete all the P components, but I (khw) am not certain
1338      * about this, and it is better to be safe.
1339      *
1340      * Inverted, we have
1341      *  (C1 | P1) | ~(C2 | P2)  =  (C1 | P1) | (~C2 & ~P2)
1342      *                         <=  (C1 | P1) | ~C2
1343      *                         <=  (C1 | ~C2) | P1
1344      * (which results in actually simpler code than the non-inverted case)
1345      * */
1346
1347     if ((ANYOF_FLAGS(or_with) & ANYOF_INVERT)
1348         && ! is_ANYOF_SYNTHETIC(or_with))
1349     {
1350         /* We ignore P2, leaving P1 going forward */
1351     }   /* else  Not inverted */
1352     else if (ANYOF_FLAGS(or_with) & ANYOF_MATCHES_POSIXL) {
1353         ANYOF_POSIXL_OR((regnode_charclass_posixl*)or_with, ssc);
1354         if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1355             unsigned int i;
1356             for (i = 0; i < ANYOF_MAX; i += 2) {
1357                 if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i + 1))
1358                 {
1359                     ssc_match_all_cp(ssc);
1360                     ANYOF_POSIXL_CLEAR(ssc, i);
1361                     ANYOF_POSIXL_CLEAR(ssc, i+1);
1362                 }
1363             }
1364         }
1365     }
1366
1367     ssc_union(ssc,
1368               ored_cp_list,
1369               FALSE /* Already has been inverted */
1370               );
1371 }
1372
1373 PERL_STATIC_INLINE void
1374 S_ssc_union(pTHX_ regnode_ssc *ssc, SV* const invlist, const bool invert2nd)
1375 {
1376     PERL_ARGS_ASSERT_SSC_UNION;
1377
1378     assert(is_ANYOF_SYNTHETIC(ssc));
1379
1380     _invlist_union_maybe_complement_2nd(ssc->invlist,
1381                                         invlist,
1382                                         invert2nd,
1383                                         &ssc->invlist);
1384 }
1385
1386 PERL_STATIC_INLINE void
1387 S_ssc_intersection(pTHX_ regnode_ssc *ssc,
1388                          SV* const invlist,
1389                          const bool invert2nd)
1390 {
1391     PERL_ARGS_ASSERT_SSC_INTERSECTION;
1392
1393     assert(is_ANYOF_SYNTHETIC(ssc));
1394
1395     _invlist_intersection_maybe_complement_2nd(ssc->invlist,
1396                                                invlist,
1397                                                invert2nd,
1398                                                &ssc->invlist);
1399 }
1400
1401 PERL_STATIC_INLINE void
1402 S_ssc_add_range(pTHX_ regnode_ssc *ssc, const UV start, const UV end)
1403 {
1404     PERL_ARGS_ASSERT_SSC_ADD_RANGE;
1405
1406     assert(is_ANYOF_SYNTHETIC(ssc));
1407
1408     ssc->invlist = _add_range_to_invlist(ssc->invlist, start, end);
1409 }
1410
1411 PERL_STATIC_INLINE void
1412 S_ssc_cp_and(pTHX_ regnode_ssc *ssc, const UV cp)
1413 {
1414     /* AND just the single code point 'cp' into the SSC 'ssc' */
1415
1416     SV* cp_list = _new_invlist(2);
1417
1418     PERL_ARGS_ASSERT_SSC_CP_AND;
1419
1420     assert(is_ANYOF_SYNTHETIC(ssc));
1421
1422     cp_list = add_cp_to_invlist(cp_list, cp);
1423     ssc_intersection(ssc, cp_list,
1424                      FALSE /* Not inverted */
1425                      );
1426     SvREFCNT_dec_NN(cp_list);
1427 }
1428
1429 PERL_STATIC_INLINE void
1430 S_ssc_clear_locale(regnode_ssc *ssc)
1431 {
1432     /* Set the SSC 'ssc' to not match any locale things */
1433     PERL_ARGS_ASSERT_SSC_CLEAR_LOCALE;
1434
1435     assert(is_ANYOF_SYNTHETIC(ssc));
1436
1437     ANYOF_POSIXL_ZERO(ssc);
1438     ANYOF_FLAGS(ssc) &= ~ANYOF_LOCALE_FLAGS;
1439 }
1440
1441 STATIC void
1442 S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc)
1443 {
1444     /* The inversion list in the SSC is marked mortal; now we need a more
1445      * permanent copy, which is stored the same way that is done in a regular
1446      * ANYOF node, with the first NUM_ANYOF_CODE_POINTS code points in a bit
1447      * map */
1448
1449     SV* invlist = invlist_clone(ssc->invlist);
1450
1451     PERL_ARGS_ASSERT_SSC_FINALIZE;
1452
1453     assert(is_ANYOF_SYNTHETIC(ssc));
1454
1455     /* The code in this file assumes that all but these flags aren't relevant
1456      * to the SSC, except SSC_MATCHES_EMPTY_STRING, which should be cleared
1457      * by the time we reach here */
1458     assert(! (ANYOF_FLAGS(ssc) & ~ANYOF_COMMON_FLAGS));
1459
1460     populate_ANYOF_from_invlist( (regnode *) ssc, &invlist);
1461
1462     set_ANYOF_arg(pRExC_state, (regnode *) ssc, invlist,
1463                                 NULL, NULL, NULL, FALSE);
1464
1465     /* Make sure is clone-safe */
1466     ssc->invlist = NULL;
1467
1468     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1469         ANYOF_FLAGS(ssc) |= ANYOF_MATCHES_POSIXL;
1470     }
1471
1472     assert(! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE_FLAGS) || RExC_contains_locale);
1473 }
1474
1475 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1476 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
1477 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1478 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list         \
1479                                ? (TRIE_LIST_CUR( idx ) - 1)           \
1480                                : 0 )
1481
1482
1483 #ifdef DEBUGGING
1484 /*
1485    dump_trie(trie,widecharmap,revcharmap)
1486    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1487    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1488
1489    These routines dump out a trie in a somewhat readable format.
1490    The _interim_ variants are used for debugging the interim
1491    tables that are used to generate the final compressed
1492    representation which is what dump_trie expects.
1493
1494    Part of the reason for their existence is to provide a form
1495    of documentation as to how the different representations function.
1496
1497 */
1498
1499 /*
1500   Dumps the final compressed table form of the trie to Perl_debug_log.
1501   Used for debugging make_trie().
1502 */
1503
1504 STATIC void
1505 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1506             AV *revcharmap, U32 depth)
1507 {
1508     U32 state;
1509     SV *sv=sv_newmortal();
1510     int colwidth= widecharmap ? 6 : 4;
1511     U16 word;
1512     GET_RE_DEBUG_FLAGS_DECL;
1513
1514     PERL_ARGS_ASSERT_DUMP_TRIE;
1515
1516     PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
1517         (int)depth * 2 + 2,"",
1518         "Match","Base","Ofs" );
1519
1520     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1521         SV ** const tmp = av_fetch( revcharmap, state, 0);
1522         if ( tmp ) {
1523             PerlIO_printf( Perl_debug_log, "%*s",
1524                 colwidth,
1525                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1526                             PL_colors[0], PL_colors[1],
1527                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1528                             PERL_PV_ESCAPE_FIRSTCHAR
1529                 )
1530             );
1531         }
1532     }
1533     PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
1534         (int)depth * 2 + 2,"");
1535
1536     for( state = 0 ; state < trie->uniquecharcount ; state++ )
1537         PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
1538     PerlIO_printf( Perl_debug_log, "\n");
1539
1540     for( state = 1 ; state < trie->statecount ; state++ ) {
1541         const U32 base = trie->states[ state ].trans.base;
1542
1543         PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|",
1544                                        (int)depth * 2 + 2,"", (UV)state);
1545
1546         if ( trie->states[ state ].wordnum ) {
1547             PerlIO_printf( Perl_debug_log, " W%4X",
1548                                            trie->states[ state ].wordnum );
1549         } else {
1550             PerlIO_printf( Perl_debug_log, "%6s", "" );
1551         }
1552
1553         PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
1554
1555         if ( base ) {
1556             U32 ofs = 0;
1557
1558             while( ( base + ofs  < trie->uniquecharcount ) ||
1559                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
1560                      && trie->trans[ base + ofs - trie->uniquecharcount ].check
1561                                                                     != state))
1562                     ofs++;
1563
1564             PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
1565
1566             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
1567                 if ( ( base + ofs >= trie->uniquecharcount )
1568                         && ( base + ofs - trie->uniquecharcount
1569                                                         < trie->lasttrans )
1570                         && trie->trans[ base + ofs
1571                                     - trie->uniquecharcount ].check == state )
1572                 {
1573                    PerlIO_printf( Perl_debug_log, "%*"UVXf,
1574                     colwidth,
1575                     (UV)trie->trans[ base + ofs
1576                                              - trie->uniquecharcount ].next );
1577                 } else {
1578                     PerlIO_printf( Perl_debug_log, "%*s",colwidth,"   ." );
1579                 }
1580             }
1581
1582             PerlIO_printf( Perl_debug_log, "]");
1583
1584         }
1585         PerlIO_printf( Perl_debug_log, "\n" );
1586     }
1587     PerlIO_printf(Perl_debug_log, "%*sword_info N:(prev,len)=",
1588                                 (int)depth*2, "");
1589     for (word=1; word <= trie->wordcount; word++) {
1590         PerlIO_printf(Perl_debug_log, " %d:(%d,%d)",
1591             (int)word, (int)(trie->wordinfo[word].prev),
1592             (int)(trie->wordinfo[word].len));
1593     }
1594     PerlIO_printf(Perl_debug_log, "\n" );
1595 }
1596 /*
1597   Dumps a fully constructed but uncompressed trie in list form.
1598   List tries normally only are used for construction when the number of
1599   possible chars (trie->uniquecharcount) is very high.
1600   Used for debugging make_trie().
1601 */
1602 STATIC void
1603 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
1604                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
1605                          U32 depth)
1606 {
1607     U32 state;
1608     SV *sv=sv_newmortal();
1609     int colwidth= widecharmap ? 6 : 4;
1610     GET_RE_DEBUG_FLAGS_DECL;
1611
1612     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
1613
1614     /* print out the table precompression.  */
1615     PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
1616         (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
1617         "------:-----+-----------------\n" );
1618
1619     for( state=1 ; state < next_alloc ; state ++ ) {
1620         U16 charid;
1621
1622         PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
1623             (int)depth * 2 + 2,"", (UV)state  );
1624         if ( ! trie->states[ state ].wordnum ) {
1625             PerlIO_printf( Perl_debug_log, "%5s| ","");
1626         } else {
1627             PerlIO_printf( Perl_debug_log, "W%4x| ",
1628                 trie->states[ state ].wordnum
1629             );
1630         }
1631         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
1632             SV ** const tmp = av_fetch( revcharmap,
1633                                         TRIE_LIST_ITEM(state,charid).forid, 0);
1634             if ( tmp ) {
1635                 PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
1636                     colwidth,
1637                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp),
1638                               colwidth,
1639                               PL_colors[0], PL_colors[1],
1640                               (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
1641                               | PERL_PV_ESCAPE_FIRSTCHAR
1642                     ) ,
1643                     TRIE_LIST_ITEM(state,charid).forid,
1644                     (UV)TRIE_LIST_ITEM(state,charid).newstate
1645                 );
1646                 if (!(charid % 10))
1647                     PerlIO_printf(Perl_debug_log, "\n%*s| ",
1648                         (int)((depth * 2) + 14), "");
1649             }
1650         }
1651         PerlIO_printf( Perl_debug_log, "\n");
1652     }
1653 }
1654
1655 /*
1656   Dumps a fully constructed but uncompressed trie in table form.
1657   This is the normal DFA style state transition table, with a few
1658   twists to facilitate compression later.
1659   Used for debugging make_trie().
1660 */
1661 STATIC void
1662 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
1663                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
1664                           U32 depth)
1665 {
1666     U32 state;
1667     U16 charid;
1668     SV *sv=sv_newmortal();
1669     int colwidth= widecharmap ? 6 : 4;
1670     GET_RE_DEBUG_FLAGS_DECL;
1671
1672     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
1673
1674     /*
1675        print out the table precompression so that we can do a visual check
1676        that they are identical.
1677      */
1678
1679     PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
1680
1681     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1682         SV ** const tmp = av_fetch( revcharmap, charid, 0);
1683         if ( tmp ) {
1684             PerlIO_printf( Perl_debug_log, "%*s",
1685                 colwidth,
1686                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1687                             PL_colors[0], PL_colors[1],
1688                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1689                             PERL_PV_ESCAPE_FIRSTCHAR
1690                 )
1691             );
1692         }
1693     }
1694
1695     PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
1696
1697     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
1698         PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
1699     }
1700
1701     PerlIO_printf( Perl_debug_log, "\n" );
1702
1703     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
1704
1705         PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ",
1706             (int)depth * 2 + 2,"",
1707             (UV)TRIE_NODENUM( state ) );
1708
1709         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1710             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
1711             if (v)
1712                 PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
1713             else
1714                 PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
1715         }
1716         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1717             PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n",
1718                                             (UV)trie->trans[ state ].check );
1719         } else {
1720             PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n",
1721                                             (UV)trie->trans[ state ].check,
1722             trie->states[ TRIE_NODENUM( state ) ].wordnum );
1723         }
1724     }
1725 }
1726
1727 #endif
1728
1729
1730 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
1731   startbranch: the first branch in the whole branch sequence
1732   first      : start branch of sequence of branch-exact nodes.
1733                May be the same as startbranch
1734   last       : Thing following the last branch.
1735                May be the same as tail.
1736   tail       : item following the branch sequence
1737   count      : words in the sequence
1738   flags      : currently the OP() type we will be building one of /EXACT(|F|FA|FU|FU_SS)/
1739   depth      : indent depth
1740
1741 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
1742
1743 A trie is an N'ary tree where the branches are determined by digital
1744 decomposition of the key. IE, at the root node you look up the 1st character and
1745 follow that branch repeat until you find the end of the branches. Nodes can be
1746 marked as "accepting" meaning they represent a complete word. Eg:
1747
1748   /he|she|his|hers/
1749
1750 would convert into the following structure. Numbers represent states, letters
1751 following numbers represent valid transitions on the letter from that state, if
1752 the number is in square brackets it represents an accepting state, otherwise it
1753 will be in parenthesis.
1754
1755       +-h->+-e->[3]-+-r->(8)-+-s->[9]
1756       |    |
1757       |   (2)
1758       |    |
1759      (1)   +-i->(6)-+-s->[7]
1760       |
1761       +-s->(3)-+-h->(4)-+-e->[5]
1762
1763       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
1764
1765 This shows that when matching against the string 'hers' we will begin at state 1
1766 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
1767 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
1768 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
1769 single traverse. We store a mapping from accepting to state to which word was
1770 matched, and then when we have multiple possibilities we try to complete the
1771 rest of the regex in the order in which they occured in the alternation.
1772
1773 The only prior NFA like behaviour that would be changed by the TRIE support is
1774 the silent ignoring of duplicate alternations which are of the form:
1775
1776  / (DUPE|DUPE) X? (?{ ... }) Y /x
1777
1778 Thus EVAL blocks following a trie may be called a different number of times with
1779 and without the optimisation. With the optimisations dupes will be silently
1780 ignored. This inconsistent behaviour of EVAL type nodes is well established as
1781 the following demonstrates:
1782
1783  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
1784
1785 which prints out 'word' three times, but
1786
1787  'words'=~/(word|word|word)(?{ print $1 })S/
1788
1789 which doesnt print it out at all. This is due to other optimisations kicking in.
1790
1791 Example of what happens on a structural level:
1792
1793 The regexp /(ac|ad|ab)+/ will produce the following debug output:
1794
1795    1: CURLYM[1] {1,32767}(18)
1796    5:   BRANCH(8)
1797    6:     EXACT <ac>(16)
1798    8:   BRANCH(11)
1799    9:     EXACT <ad>(16)
1800   11:   BRANCH(14)
1801   12:     EXACT <ab>(16)
1802   16:   SUCCEED(0)
1803   17:   NOTHING(18)
1804   18: END(0)
1805
1806 This would be optimizable with startbranch=5, first=5, last=16, tail=16
1807 and should turn into:
1808
1809    1: CURLYM[1] {1,32767}(18)
1810    5:   TRIE(16)
1811         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
1812           <ac>
1813           <ad>
1814           <ab>
1815   16:   SUCCEED(0)
1816   17:   NOTHING(18)
1817   18: END(0)
1818
1819 Cases where tail != last would be like /(?foo|bar)baz/:
1820
1821    1: BRANCH(4)
1822    2:   EXACT <foo>(8)
1823    4: BRANCH(7)
1824    5:   EXACT <bar>(8)
1825    7: TAIL(8)
1826    8: EXACT <baz>(10)
1827   10: END(0)
1828
1829 which would be optimizable with startbranch=1, first=1, last=7, tail=8
1830 and would end up looking like:
1831
1832     1: TRIE(8)
1833       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
1834         <foo>
1835         <bar>
1836    7: TAIL(8)
1837    8: EXACT <baz>(10)
1838   10: END(0)
1839
1840     d = uvchr_to_utf8_flags(d, uv, 0);
1841
1842 is the recommended Unicode-aware way of saying
1843
1844     *(d++) = uv;
1845 */
1846
1847 #define TRIE_STORE_REVCHAR(val)                                            \
1848     STMT_START {                                                           \
1849         if (UTF) {                                                         \
1850             SV *zlopp = newSV(7); /* XXX: optimize me */                   \
1851             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
1852             unsigned const char *const kapow = uvchr_to_utf8(flrbbbbb, val); \
1853             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
1854             SvPOK_on(zlopp);                                               \
1855             SvUTF8_on(zlopp);                                              \
1856             av_push(revcharmap, zlopp);                                    \
1857         } else {                                                           \
1858             char ooooff = (char)val;                                           \
1859             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
1860         }                                                                  \
1861         } STMT_END
1862
1863 /* This gets the next character from the input, folding it if not already
1864  * folded. */
1865 #define TRIE_READ_CHAR STMT_START {                                           \
1866     wordlen++;                                                                \
1867     if ( UTF ) {                                                              \
1868         /* if it is UTF then it is either already folded, or does not need    \
1869          * folding */                                                         \
1870         uvc = valid_utf8_to_uvchr( (const U8*) uc, &len);                     \
1871     }                                                                         \
1872     else if (folder == PL_fold_latin1) {                                      \
1873         /* This folder implies Unicode rules, which in the range expressible  \
1874          *  by not UTF is the lower case, with the two exceptions, one of     \
1875          *  which should have been taken care of before calling this */       \
1876         assert(*uc != LATIN_SMALL_LETTER_SHARP_S);                            \
1877         uvc = toLOWER_L1(*uc);                                                \
1878         if (UNLIKELY(uvc == MICRO_SIGN)) uvc = GREEK_SMALL_LETTER_MU;         \
1879         len = 1;                                                              \
1880     } else {                                                                  \
1881         /* raw data, will be folded later if needed */                        \
1882         uvc = (U32)*uc;                                                       \
1883         len = 1;                                                              \
1884     }                                                                         \
1885 } STMT_END
1886
1887
1888
1889 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
1890     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
1891         U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
1892         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
1893     }                                                           \
1894     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
1895     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
1896     TRIE_LIST_CUR( state )++;                                   \
1897 } STMT_END
1898
1899 #define TRIE_LIST_NEW(state) STMT_START {                       \
1900     Newxz( trie->states[ state ].trans.list,               \
1901         4, reg_trie_trans_le );                                 \
1902      TRIE_LIST_CUR( state ) = 1;                                \
1903      TRIE_LIST_LEN( state ) = 4;                                \
1904 } STMT_END
1905
1906 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
1907     U16 dupe= trie->states[ state ].wordnum;                    \
1908     regnode * const noper_next = regnext( noper );              \
1909                                                                 \
1910     DEBUG_r({                                                   \
1911         /* store the word for dumping */                        \
1912         SV* tmp;                                                \
1913         if (OP(noper) != NOTHING)                               \
1914             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
1915         else                                                    \
1916             tmp = newSVpvn_utf8( "", 0, UTF );                  \
1917         av_push( trie_words, tmp );                             \
1918     });                                                         \
1919                                                                 \
1920     curword++;                                                  \
1921     trie->wordinfo[curword].prev   = 0;                         \
1922     trie->wordinfo[curword].len    = wordlen;                   \
1923     trie->wordinfo[curword].accept = state;                     \
1924                                                                 \
1925     if ( noper_next < tail ) {                                  \
1926         if (!trie->jump)                                        \
1927             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, \
1928                                                  sizeof(U16) ); \
1929         trie->jump[curword] = (U16)(noper_next - convert);      \
1930         if (!jumper)                                            \
1931             jumper = noper_next;                                \
1932         if (!nextbranch)                                        \
1933             nextbranch= regnext(cur);                           \
1934     }                                                           \
1935                                                                 \
1936     if ( dupe ) {                                               \
1937         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
1938         /* chain, so that when the bits of chain are later    */\
1939         /* linked together, the dups appear in the chain      */\
1940         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
1941         trie->wordinfo[dupe].prev = curword;                    \
1942     } else {                                                    \
1943         /* we haven't inserted this word yet.                */ \
1944         trie->states[ state ].wordnum = curword;                \
1945     }                                                           \
1946 } STMT_END
1947
1948
1949 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
1950      ( ( base + charid >=  ucharcount                                   \
1951          && base + charid < ubound                                      \
1952          && state == trie->trans[ base - ucharcount + charid ].check    \
1953          && trie->trans[ base - ucharcount + charid ].next )            \
1954            ? trie->trans[ base - ucharcount + charid ].next             \
1955            : ( state==1 ? special : 0 )                                 \
1956       )
1957
1958 #define MADE_TRIE       1
1959 #define MADE_JUMP_TRIE  2
1960 #define MADE_EXACT_TRIE 4
1961
1962 STATIC I32
1963 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch,
1964                   regnode *first, regnode *last, regnode *tail,
1965                   U32 word_count, U32 flags, U32 depth)
1966 {
1967     /* first pass, loop through and scan words */
1968     reg_trie_data *trie;
1969     HV *widecharmap = NULL;
1970     AV *revcharmap = newAV();
1971     regnode *cur;
1972     STRLEN len = 0;
1973     UV uvc = 0;
1974     U16 curword = 0;
1975     U32 next_alloc = 0;
1976     regnode *jumper = NULL;
1977     regnode *nextbranch = NULL;
1978     regnode *convert = NULL;
1979     U32 *prev_states; /* temp array mapping each state to previous one */
1980     /* we just use folder as a flag in utf8 */
1981     const U8 * folder = NULL;
1982
1983 #ifdef DEBUGGING
1984     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tuuu"));
1985     AV *trie_words = NULL;
1986     /* along with revcharmap, this only used during construction but both are
1987      * useful during debugging so we store them in the struct when debugging.
1988      */
1989 #else
1990     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tu"));
1991     STRLEN trie_charcount=0;
1992 #endif
1993     SV *re_trie_maxbuff;
1994     GET_RE_DEBUG_FLAGS_DECL;
1995
1996     PERL_ARGS_ASSERT_MAKE_TRIE;
1997 #ifndef DEBUGGING
1998     PERL_UNUSED_ARG(depth);
1999 #endif
2000
2001     switch (flags) {
2002         case EXACT: break;
2003         case EXACTFA:
2004         case EXACTFU_SS:
2005         case EXACTFU: folder = PL_fold_latin1; break;
2006         case EXACTF:  folder = PL_fold; break;
2007         default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
2008     }
2009
2010     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
2011     trie->refcount = 1;
2012     trie->startstate = 1;
2013     trie->wordcount = word_count;
2014     RExC_rxi->data->data[ data_slot ] = (void*)trie;
2015     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
2016     if (flags == EXACT)
2017         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
2018     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
2019                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
2020
2021     DEBUG_r({
2022         trie_words = newAV();
2023     });
2024
2025     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2026     assert(re_trie_maxbuff);
2027     if (!SvIOK(re_trie_maxbuff)) {
2028         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2029     }
2030     DEBUG_TRIE_COMPILE_r({
2031         PerlIO_printf( Perl_debug_log,
2032           "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
2033           (int)depth * 2 + 2, "",
2034           REG_NODE_NUM(startbranch),REG_NODE_NUM(first),
2035           REG_NODE_NUM(last), REG_NODE_NUM(tail), (int)depth);
2036     });
2037
2038    /* Find the node we are going to overwrite */
2039     if ( first == startbranch && OP( last ) != BRANCH ) {
2040         /* whole branch chain */
2041         convert = first;
2042     } else {
2043         /* branch sub-chain */
2044         convert = NEXTOPER( first );
2045     }
2046
2047     /*  -- First loop and Setup --
2048
2049        We first traverse the branches and scan each word to determine if it
2050        contains widechars, and how many unique chars there are, this is
2051        important as we have to build a table with at least as many columns as we
2052        have unique chars.
2053
2054        We use an array of integers to represent the character codes 0..255
2055        (trie->charmap) and we use a an HV* to store Unicode characters. We use
2056        the native representation of the character value as the key and IV's for
2057        the coded index.
2058
2059        *TODO* If we keep track of how many times each character is used we can
2060        remap the columns so that the table compression later on is more
2061        efficient in terms of memory by ensuring the most common value is in the
2062        middle and the least common are on the outside.  IMO this would be better
2063        than a most to least common mapping as theres a decent chance the most
2064        common letter will share a node with the least common, meaning the node
2065        will not be compressible. With a middle is most common approach the worst
2066        case is when we have the least common nodes twice.
2067
2068      */
2069
2070     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2071         regnode *noper = NEXTOPER( cur );
2072         const U8 *uc = (U8*)STRING( noper );
2073         const U8 *e  = uc + STR_LEN( noper );
2074         int foldlen = 0;
2075         U32 wordlen      = 0;         /* required init */
2076         STRLEN minchars = 0;
2077         STRLEN maxchars = 0;
2078         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the
2079                                                bitmap?*/
2080
2081         if (OP(noper) == NOTHING) {
2082             regnode *noper_next= regnext(noper);
2083             if (noper_next != tail && OP(noper_next) == flags) {
2084                 noper = noper_next;
2085                 uc= (U8*)STRING(noper);
2086                 e= uc + STR_LEN(noper);
2087                 trie->minlen= STR_LEN(noper);
2088             } else {
2089                 trie->minlen= 0;
2090                 continue;
2091             }
2092         }
2093
2094         if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
2095             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
2096                                           regardless of encoding */
2097             if (OP( noper ) == EXACTFU_SS) {
2098                 /* false positives are ok, so just set this */
2099                 TRIE_BITMAP_SET(trie, LATIN_SMALL_LETTER_SHARP_S);
2100             }
2101         }
2102         for ( ; uc < e ; uc += len ) {  /* Look at each char in the current
2103                                            branch */
2104             TRIE_CHARCOUNT(trie)++;
2105             TRIE_READ_CHAR;
2106
2107             /* TRIE_READ_CHAR returns the current character, or its fold if /i
2108              * is in effect.  Under /i, this character can match itself, or
2109              * anything that folds to it.  If not under /i, it can match just
2110              * itself.  Most folds are 1-1, for example k, K, and KELVIN SIGN
2111              * all fold to k, and all are single characters.   But some folds
2112              * expand to more than one character, so for example LATIN SMALL
2113              * LIGATURE FFI folds to the three character sequence 'ffi'.  If
2114              * the string beginning at 'uc' is 'ffi', it could be matched by
2115              * three characters, or just by the one ligature character. (It
2116              * could also be matched by two characters: LATIN SMALL LIGATURE FF
2117              * followed by 'i', or by 'f' followed by LATIN SMALL LIGATURE FI).
2118              * (Of course 'I' and/or 'F' instead of 'i' and 'f' can also
2119              * match.)  The trie needs to know the minimum and maximum number
2120              * of characters that could match so that it can use size alone to
2121              * quickly reject many match attempts.  The max is simple: it is
2122              * the number of folded characters in this branch (since a fold is
2123              * never shorter than what folds to it. */
2124
2125             maxchars++;
2126
2127             /* And the min is equal to the max if not under /i (indicated by
2128              * 'folder' being NULL), or there are no multi-character folds.  If
2129              * there is a multi-character fold, the min is incremented just
2130              * once, for the character that folds to the sequence.  Each
2131              * character in the sequence needs to be added to the list below of
2132              * characters in the trie, but we count only the first towards the
2133              * min number of characters needed.  This is done through the
2134              * variable 'foldlen', which is returned by the macros that look
2135              * for these sequences as the number of bytes the sequence
2136              * occupies.  Each time through the loop, we decrement 'foldlen' by
2137              * how many bytes the current char occupies.  Only when it reaches
2138              * 0 do we increment 'minchars' or look for another multi-character
2139              * sequence. */
2140             if (folder == NULL) {
2141                 minchars++;
2142             }
2143             else if (foldlen > 0) {
2144                 foldlen -= (UTF) ? UTF8SKIP(uc) : 1;
2145             }
2146             else {
2147                 minchars++;
2148
2149                 /* See if *uc is the beginning of a multi-character fold.  If
2150                  * so, we decrement the length remaining to look at, to account
2151                  * for the current character this iteration.  (We can use 'uc'
2152                  * instead of the fold returned by TRIE_READ_CHAR because for
2153                  * non-UTF, the latin1_safe macro is smart enough to account
2154                  * for all the unfolded characters, and because for UTF, the
2155                  * string will already have been folded earlier in the
2156                  * compilation process */
2157                 if (UTF) {
2158                     if ((foldlen = is_MULTI_CHAR_FOLD_utf8_safe(uc, e))) {
2159                         foldlen -= UTF8SKIP(uc);
2160                     }
2161                 }
2162                 else if ((foldlen = is_MULTI_CHAR_FOLD_latin1_safe(uc, e))) {
2163                     foldlen--;
2164                 }
2165             }
2166
2167             /* The current character (and any potential folds) should be added
2168              * to the possible matching characters for this position in this
2169              * branch */
2170             if ( uvc < 256 ) {
2171                 if ( folder ) {
2172                     U8 folded= folder[ (U8) uvc ];
2173                     if ( !trie->charmap[ folded ] ) {
2174                         trie->charmap[ folded ]=( ++trie->uniquecharcount );
2175                         TRIE_STORE_REVCHAR( folded );
2176                     }
2177                 }
2178                 if ( !trie->charmap[ uvc ] ) {
2179                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
2180                     TRIE_STORE_REVCHAR( uvc );
2181                 }
2182                 if ( set_bit ) {
2183                     /* store the codepoint in the bitmap, and its folded
2184                      * equivalent. */
2185                     TRIE_BITMAP_SET(trie, uvc);
2186
2187                     /* store the folded codepoint */
2188                     if ( folder ) TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);
2189
2190                     if ( !UTF ) {
2191                         /* store first byte of utf8 representation of
2192                            variant codepoints */
2193                         if (! UVCHR_IS_INVARIANT(uvc)) {
2194                             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));
2195                         }
2196                     }
2197                     set_bit = 0; /* We've done our bit :-) */
2198                 }
2199             } else {
2200
2201                 /* XXX We could come up with the list of code points that fold
2202                  * to this using PL_utf8_foldclosures, except not for
2203                  * multi-char folds, as there may be multiple combinations
2204                  * there that could work, which needs to wait until runtime to
2205                  * resolve (The comment about LIGATURE FFI above is such an
2206                  * example */
2207
2208                 SV** svpp;
2209                 if ( !widecharmap )
2210                     widecharmap = newHV();
2211
2212                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
2213
2214                 if ( !svpp )
2215                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
2216
2217                 if ( !SvTRUE( *svpp ) ) {
2218                     sv_setiv( *svpp, ++trie->uniquecharcount );
2219                     TRIE_STORE_REVCHAR(uvc);
2220                 }
2221             }
2222         } /* end loop through characters in this branch of the trie */
2223
2224         /* We take the min and max for this branch and combine to find the min
2225          * and max for all branches processed so far */
2226         if( cur == first ) {
2227             trie->minlen = minchars;
2228             trie->maxlen = maxchars;
2229         } else if (minchars < trie->minlen) {
2230             trie->minlen = minchars;
2231         } else if (maxchars > trie->maxlen) {
2232             trie->maxlen = maxchars;
2233         }
2234     } /* end first pass */
2235     DEBUG_TRIE_COMPILE_r(
2236         PerlIO_printf( Perl_debug_log,
2237                 "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
2238                 (int)depth * 2 + 2,"",
2239                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
2240                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
2241                 (int)trie->minlen, (int)trie->maxlen )
2242     );
2243
2244     /*
2245         We now know what we are dealing with in terms of unique chars and
2246         string sizes so we can calculate how much memory a naive
2247         representation using a flat table  will take. If it's over a reasonable
2248         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
2249         conservative but potentially much slower representation using an array
2250         of lists.
2251
2252         At the end we convert both representations into the same compressed
2253         form that will be used in regexec.c for matching with. The latter
2254         is a form that cannot be used to construct with but has memory
2255         properties similar to the list form and access properties similar
2256         to the table form making it both suitable for fast searches and
2257         small enough that its feasable to store for the duration of a program.
2258
2259         See the comment in the code where the compressed table is produced
2260         inplace from the flat tabe representation for an explanation of how
2261         the compression works.
2262
2263     */
2264
2265
2266     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
2267     prev_states[1] = 0;
2268
2269     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1)
2270                                                     > SvIV(re_trie_maxbuff) )
2271     {
2272         /*
2273             Second Pass -- Array Of Lists Representation
2274
2275             Each state will be represented by a list of charid:state records
2276             (reg_trie_trans_le) the first such element holds the CUR and LEN
2277             points of the allocated array. (See defines above).
2278
2279             We build the initial structure using the lists, and then convert
2280             it into the compressed table form which allows faster lookups
2281             (but cant be modified once converted).
2282         */
2283
2284         STRLEN transcount = 1;
2285
2286         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
2287             "%*sCompiling trie using list compiler\n",
2288             (int)depth * 2 + 2, ""));
2289
2290         trie->states = (reg_trie_state *)
2291             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2292                                   sizeof(reg_trie_state) );
2293         TRIE_LIST_NEW(1);
2294         next_alloc = 2;
2295
2296         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2297
2298             regnode *noper   = NEXTOPER( cur );
2299             U8 *uc           = (U8*)STRING( noper );
2300             const U8 *e      = uc + STR_LEN( noper );
2301             U32 state        = 1;         /* required init */
2302             U16 charid       = 0;         /* sanity init */
2303             U32 wordlen      = 0;         /* required init */
2304
2305             if (OP(noper) == NOTHING) {
2306                 regnode *noper_next= regnext(noper);
2307                 if (noper_next != tail && OP(noper_next) == flags) {
2308                     noper = noper_next;
2309                     uc= (U8*)STRING(noper);
2310                     e= uc + STR_LEN(noper);
2311                 }
2312             }
2313
2314             if (OP(noper) != NOTHING) {
2315                 for ( ; uc < e ; uc += len ) {
2316
2317                     TRIE_READ_CHAR;
2318
2319                     if ( uvc < 256 ) {
2320                         charid = trie->charmap[ uvc ];
2321                     } else {
2322                         SV** const svpp = hv_fetch( widecharmap,
2323                                                     (char*)&uvc,
2324                                                     sizeof( UV ),
2325                                                     0);
2326                         if ( !svpp ) {
2327                             charid = 0;
2328                         } else {
2329                             charid=(U16)SvIV( *svpp );
2330                         }
2331                     }
2332                     /* charid is now 0 if we dont know the char read, or
2333                      * nonzero if we do */
2334                     if ( charid ) {
2335
2336                         U16 check;
2337                         U32 newstate = 0;
2338
2339                         charid--;
2340                         if ( !trie->states[ state ].trans.list ) {
2341                             TRIE_LIST_NEW( state );
2342                         }
2343                         for ( check = 1;
2344                               check <= TRIE_LIST_USED( state );
2345                               check++ )
2346                         {
2347                             if ( TRIE_LIST_ITEM( state, check ).forid
2348                                                                     == charid )
2349                             {
2350                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
2351                                 break;
2352                             }
2353                         }
2354                         if ( ! newstate ) {
2355                             newstate = next_alloc++;
2356                             prev_states[newstate] = state;
2357                             TRIE_LIST_PUSH( state, charid, newstate );
2358                             transcount++;
2359                         }
2360                         state = newstate;
2361                     } else {
2362                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
2363                     }
2364                 }
2365             }
2366             TRIE_HANDLE_WORD(state);
2367
2368         } /* end second pass */
2369
2370         /* next alloc is the NEXT state to be allocated */
2371         trie->statecount = next_alloc;
2372         trie->states = (reg_trie_state *)
2373             PerlMemShared_realloc( trie->states,
2374                                    next_alloc
2375                                    * sizeof(reg_trie_state) );
2376
2377         /* and now dump it out before we compress it */
2378         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
2379                                                          revcharmap, next_alloc,
2380                                                          depth+1)
2381         );
2382
2383         trie->trans = (reg_trie_trans *)
2384             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
2385         {
2386             U32 state;
2387             U32 tp = 0;
2388             U32 zp = 0;
2389
2390
2391             for( state=1 ; state < next_alloc ; state ++ ) {
2392                 U32 base=0;
2393
2394                 /*
2395                 DEBUG_TRIE_COMPILE_MORE_r(
2396                     PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
2397                 );
2398                 */
2399
2400                 if (trie->states[state].trans.list) {
2401                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
2402                     U16 maxid=minid;
2403                     U16 idx;
2404
2405                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2406                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
2407                         if ( forid < minid ) {
2408                             minid=forid;
2409                         } else if ( forid > maxid ) {
2410                             maxid=forid;
2411                         }
2412                     }
2413                     if ( transcount < tp + maxid - minid + 1) {
2414                         transcount *= 2;
2415                         trie->trans = (reg_trie_trans *)
2416                             PerlMemShared_realloc( trie->trans,
2417                                                      transcount
2418                                                      * sizeof(reg_trie_trans) );
2419                         Zero( trie->trans + (transcount / 2),
2420                               transcount / 2,
2421                               reg_trie_trans );
2422                     }
2423                     base = trie->uniquecharcount + tp - minid;
2424                     if ( maxid == minid ) {
2425                         U32 set = 0;
2426                         for ( ; zp < tp ; zp++ ) {
2427                             if ( ! trie->trans[ zp ].next ) {
2428                                 base = trie->uniquecharcount + zp - minid;
2429                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state,
2430                                                                    1).newstate;
2431                                 trie->trans[ zp ].check = state;
2432                                 set = 1;
2433                                 break;
2434                             }
2435                         }
2436                         if ( !set ) {
2437                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state,
2438                                                                    1).newstate;
2439                             trie->trans[ tp ].check = state;
2440                             tp++;
2441                             zp = tp;
2442                         }
2443                     } else {
2444                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2445                             const U32 tid = base
2446                                            - trie->uniquecharcount
2447                                            + TRIE_LIST_ITEM( state, idx ).forid;
2448                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state,
2449                                                                 idx ).newstate;
2450                             trie->trans[ tid ].check = state;
2451                         }
2452                         tp += ( maxid - minid + 1 );
2453                     }
2454                     Safefree(trie->states[ state ].trans.list);
2455                 }
2456                 /*
2457                 DEBUG_TRIE_COMPILE_MORE_r(
2458                     PerlIO_printf( Perl_debug_log, " base: %d\n",base);
2459                 );
2460                 */
2461                 trie->states[ state ].trans.base=base;
2462             }
2463             trie->lasttrans = tp + 1;
2464         }
2465     } else {
2466         /*
2467            Second Pass -- Flat Table Representation.
2468
2469            we dont use the 0 slot of either trans[] or states[] so we add 1 to
2470            each.  We know that we will need Charcount+1 trans at most to store
2471            the data (one row per char at worst case) So we preallocate both
2472            structures assuming worst case.
2473
2474            We then construct the trie using only the .next slots of the entry
2475            structs.
2476
2477            We use the .check field of the first entry of the node temporarily
2478            to make compression both faster and easier by keeping track of how
2479            many non zero fields are in the node.
2480
2481            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
2482            transition.
2483
2484            There are two terms at use here: state as a TRIE_NODEIDX() which is
2485            a number representing the first entry of the node, and state as a
2486            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1)
2487            and TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3)
2488            if there are 2 entrys per node. eg:
2489
2490              A B       A B
2491           1. 2 4    1. 3 7
2492           2. 0 3    3. 0 5
2493           3. 0 0    5. 0 0
2494           4. 0 0    7. 0 0
2495
2496            The table is internally in the right hand, idx form. However as we
2497            also have to deal with the states array which is indexed by nodenum
2498            we have to use TRIE_NODENUM() to convert.
2499
2500         */
2501         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
2502             "%*sCompiling trie using table compiler\n",
2503             (int)depth * 2 + 2, ""));
2504
2505         trie->trans = (reg_trie_trans *)
2506             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
2507                                   * trie->uniquecharcount + 1,
2508                                   sizeof(reg_trie_trans) );
2509         trie->states = (reg_trie_state *)
2510             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2511                                   sizeof(reg_trie_state) );
2512         next_alloc = trie->uniquecharcount + 1;
2513
2514
2515         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2516
2517             regnode *noper   = NEXTOPER( cur );
2518             const U8 *uc     = (U8*)STRING( noper );
2519             const U8 *e      = uc + STR_LEN( noper );
2520
2521             U32 state        = 1;         /* required init */
2522
2523             U16 charid       = 0;         /* sanity init */
2524             U32 accept_state = 0;         /* sanity init */
2525
2526             U32 wordlen      = 0;         /* required init */
2527
2528             if (OP(noper) == NOTHING) {
2529                 regnode *noper_next= regnext(noper);
2530                 if (noper_next != tail && OP(noper_next) == flags) {
2531                     noper = noper_next;
2532                     uc= (U8*)STRING(noper);
2533                     e= uc + STR_LEN(noper);
2534                 }
2535             }
2536
2537             if ( OP(noper) != NOTHING ) {
2538                 for ( ; uc < e ; uc += len ) {
2539
2540                     TRIE_READ_CHAR;
2541
2542                     if ( uvc < 256 ) {
2543                         charid = trie->charmap[ uvc ];
2544                     } else {
2545                         SV* const * const svpp = hv_fetch( widecharmap,
2546                                                            (char*)&uvc,
2547                                                            sizeof( UV ),
2548                                                            0);
2549                         charid = svpp ? (U16)SvIV(*svpp) : 0;
2550                     }
2551                     if ( charid ) {
2552                         charid--;
2553                         if ( !trie->trans[ state + charid ].next ) {
2554                             trie->trans[ state + charid ].next = next_alloc;
2555                             trie->trans[ state ].check++;
2556                             prev_states[TRIE_NODENUM(next_alloc)]
2557                                     = TRIE_NODENUM(state);
2558                             next_alloc += trie->uniquecharcount;
2559                         }
2560                         state = trie->trans[ state + charid ].next;
2561                     } else {
2562                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
2563                     }
2564                     /* charid is now 0 if we dont know the char read, or
2565                      * nonzero if we do */
2566                 }
2567             }
2568             accept_state = TRIE_NODENUM( state );
2569             TRIE_HANDLE_WORD(accept_state);
2570
2571         } /* end second pass */
2572
2573         /* and now dump it out before we compress it */
2574         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
2575                                                           revcharmap,
2576                                                           next_alloc, depth+1));
2577
2578         {
2579         /*
2580            * Inplace compress the table.*
2581
2582            For sparse data sets the table constructed by the trie algorithm will
2583            be mostly 0/FAIL transitions or to put it another way mostly empty.
2584            (Note that leaf nodes will not contain any transitions.)
2585
2586            This algorithm compresses the tables by eliminating most such
2587            transitions, at the cost of a modest bit of extra work during lookup:
2588
2589            - Each states[] entry contains a .base field which indicates the
2590            index in the state[] array wheres its transition data is stored.
2591
2592            - If .base is 0 there are no valid transitions from that node.
2593
2594            - If .base is nonzero then charid is added to it to find an entry in
2595            the trans array.
2596
2597            -If trans[states[state].base+charid].check!=state then the
2598            transition is taken to be a 0/Fail transition. Thus if there are fail
2599            transitions at the front of the node then the .base offset will point
2600            somewhere inside the previous nodes data (or maybe even into a node
2601            even earlier), but the .check field determines if the transition is
2602            valid.
2603
2604            XXX - wrong maybe?
2605            The following process inplace converts the table to the compressed
2606            table: We first do not compress the root node 1,and mark all its
2607            .check pointers as 1 and set its .base pointer as 1 as well. This
2608            allows us to do a DFA construction from the compressed table later,
2609            and ensures that any .base pointers we calculate later are greater
2610            than 0.
2611
2612            - We set 'pos' to indicate the first entry of the second node.
2613
2614            - We then iterate over the columns of the node, finding the first and
2615            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
2616            and set the .check pointers accordingly, and advance pos
2617            appropriately and repreat for the next node. Note that when we copy
2618            the next pointers we have to convert them from the original
2619            NODEIDX form to NODENUM form as the former is not valid post
2620            compression.
2621
2622            - If a node has no transitions used we mark its base as 0 and do not
2623            advance the pos pointer.
2624
2625            - If a node only has one transition we use a second pointer into the
2626            structure to fill in allocated fail transitions from other states.
2627            This pointer is independent of the main pointer and scans forward
2628            looking for null transitions that are allocated to a state. When it
2629            finds one it writes the single transition into the "hole".  If the
2630            pointer doesnt find one the single transition is appended as normal.
2631
2632            - Once compressed we can Renew/realloc the structures to release the
2633            excess space.
2634
2635            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
2636            specifically Fig 3.47 and the associated pseudocode.
2637
2638            demq
2639         */
2640         const U32 laststate = TRIE_NODENUM( next_alloc );
2641         U32 state, charid;
2642         U32 pos = 0, zp=0;
2643         trie->statecount = laststate;
2644
2645         for ( state = 1 ; state < laststate ; state++ ) {
2646             U8 flag = 0;
2647             const U32 stateidx = TRIE_NODEIDX( state );
2648             const U32 o_used = trie->trans[ stateidx ].check;
2649             U32 used = trie->trans[ stateidx ].check;
2650             trie->trans[ stateidx ].check = 0;
2651
2652             for ( charid = 0;
2653                   used && charid < trie->uniquecharcount;
2654                   charid++ )
2655             {
2656                 if ( flag || trie->trans[ stateidx + charid ].next ) {
2657                     if ( trie->trans[ stateidx + charid ].next ) {
2658                         if (o_used == 1) {
2659                             for ( ; zp < pos ; zp++ ) {
2660                                 if ( ! trie->trans[ zp ].next ) {
2661                                     break;
2662                                 }
2663                             }
2664                             trie->states[ state ].trans.base
2665                                                     = zp
2666                                                       + trie->uniquecharcount
2667                                                       - charid ;
2668                             trie->trans[ zp ].next
2669                                 = SAFE_TRIE_NODENUM( trie->trans[ stateidx
2670                                                              + charid ].next );
2671                             trie->trans[ zp ].check = state;
2672                             if ( ++zp > pos ) pos = zp;
2673                             break;
2674                         }
2675                         used--;
2676                     }
2677                     if ( !flag ) {
2678                         flag = 1;
2679                         trie->states[ state ].trans.base
2680                                        = pos + trie->uniquecharcount - charid ;
2681                     }
2682                     trie->trans[ pos ].next
2683                         = SAFE_TRIE_NODENUM(
2684                                        trie->trans[ stateidx + charid ].next );
2685                     trie->trans[ pos ].check = state;
2686                     pos++;
2687                 }
2688             }
2689         }
2690         trie->lasttrans = pos + 1;
2691         trie->states = (reg_trie_state *)
2692             PerlMemShared_realloc( trie->states, laststate
2693                                    * sizeof(reg_trie_state) );
2694         DEBUG_TRIE_COMPILE_MORE_r(
2695             PerlIO_printf( Perl_debug_log,
2696                 "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
2697                 (int)depth * 2 + 2,"",
2698                 (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount
2699                        + 1 ),
2700                 (IV)next_alloc,
2701                 (IV)pos,
2702                 ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
2703             );
2704
2705         } /* end table compress */
2706     }
2707     DEBUG_TRIE_COMPILE_MORE_r(
2708             PerlIO_printf(Perl_debug_log,
2709                 "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
2710                 (int)depth * 2 + 2, "",
2711                 (UV)trie->statecount,
2712                 (UV)trie->lasttrans)
2713     );
2714     /* resize the trans array to remove unused space */
2715     trie->trans = (reg_trie_trans *)
2716         PerlMemShared_realloc( trie->trans, trie->lasttrans
2717                                * sizeof(reg_trie_trans) );
2718
2719     {   /* Modify the program and insert the new TRIE node */
2720         U8 nodetype =(U8)(flags & 0xFF);
2721         char *str=NULL;
2722
2723 #ifdef DEBUGGING
2724         regnode *optimize = NULL;
2725 #ifdef RE_TRACK_PATTERN_OFFSETS
2726
2727         U32 mjd_offset = 0;
2728         U32 mjd_nodelen = 0;
2729 #endif /* RE_TRACK_PATTERN_OFFSETS */
2730 #endif /* DEBUGGING */
2731         /*
2732            This means we convert either the first branch or the first Exact,
2733            depending on whether the thing following (in 'last') is a branch
2734            or not and whther first is the startbranch (ie is it a sub part of
2735            the alternation or is it the whole thing.)
2736            Assuming its a sub part we convert the EXACT otherwise we convert
2737            the whole branch sequence, including the first.
2738          */
2739         /* Find the node we are going to overwrite */
2740         if ( first != startbranch || OP( last ) == BRANCH ) {
2741             /* branch sub-chain */
2742             NEXT_OFF( first ) = (U16)(last - first);
2743 #ifdef RE_TRACK_PATTERN_OFFSETS
2744             DEBUG_r({
2745                 mjd_offset= Node_Offset((convert));
2746                 mjd_nodelen= Node_Length((convert));
2747             });
2748 #endif
2749             /* whole branch chain */
2750         }
2751 #ifdef RE_TRACK_PATTERN_OFFSETS
2752         else {
2753             DEBUG_r({
2754                 const  regnode *nop = NEXTOPER( convert );
2755                 mjd_offset= Node_Offset((nop));
2756                 mjd_nodelen= Node_Length((nop));
2757             });
2758         }
2759         DEBUG_OPTIMISE_r(
2760             PerlIO_printf(Perl_debug_log,
2761                 "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
2762                 (int)depth * 2 + 2, "",
2763                 (UV)mjd_offset, (UV)mjd_nodelen)
2764         );
2765 #endif
2766         /* But first we check to see if there is a common prefix we can
2767            split out as an EXACT and put in front of the TRIE node.  */
2768         trie->startstate= 1;
2769         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
2770             U32 state;
2771             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
2772                 U32 ofs = 0;
2773                 I32 idx = -1;
2774                 U32 count = 0;
2775                 const U32 base = trie->states[ state ].trans.base;
2776
2777                 if ( trie->states[state].wordnum )
2778                         count = 1;
2779
2780                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2781                     if ( ( base + ofs >= trie->uniquecharcount ) &&
2782                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
2783                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
2784                     {
2785                         if ( ++count > 1 ) {
2786                             SV **tmp = av_fetch( revcharmap, ofs, 0);
2787                             const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
2788                             if ( state == 1 ) break;
2789                             if ( count == 2 ) {
2790                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
2791                                 DEBUG_OPTIMISE_r(
2792                                     PerlIO_printf(Perl_debug_log,
2793                                         "%*sNew Start State=%"UVuf" Class: [",
2794                                         (int)depth * 2 + 2, "",
2795                                         (UV)state));
2796                                 if (idx >= 0) {
2797                                     SV ** const tmp = av_fetch( revcharmap, idx, 0);
2798                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
2799
2800                                     TRIE_BITMAP_SET(trie,*ch);
2801                                     if ( folder )
2802                                         TRIE_BITMAP_SET(trie, folder[ *ch ]);
2803                                     DEBUG_OPTIMISE_r(
2804                                         PerlIO_printf(Perl_debug_log, "%s", (char*)ch)
2805                                     );
2806                                 }
2807                             }
2808                             TRIE_BITMAP_SET(trie,*ch);
2809                             if ( folder )
2810                                 TRIE_BITMAP_SET(trie,folder[ *ch ]);
2811                             DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
2812                         }
2813                         idx = ofs;
2814                     }
2815                 }
2816                 if ( count == 1 ) {
2817                     SV **tmp = av_fetch( revcharmap, idx, 0);
2818                     STRLEN len;
2819                     char *ch = SvPV( *tmp, len );
2820                     DEBUG_OPTIMISE_r({
2821                         SV *sv=sv_newmortal();
2822                         PerlIO_printf( Perl_debug_log,
2823                             "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
2824                             (int)depth * 2 + 2, "",
2825                             (UV)state, (UV)idx,
2826                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6,
2827                                 PL_colors[0], PL_colors[1],
2828                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2829                                 PERL_PV_ESCAPE_FIRSTCHAR
2830                             )
2831                         );
2832                     });
2833                     if ( state==1 ) {
2834                         OP( convert ) = nodetype;
2835                         str=STRING(convert);
2836                         STR_LEN(convert)=0;
2837                     }
2838                     STR_LEN(convert) += len;
2839                     while (len--)
2840                         *str++ = *ch++;
2841                 } else {
2842 #ifdef DEBUGGING
2843                     if (state>1)
2844                         DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
2845 #endif
2846                     break;
2847                 }
2848             }
2849             trie->prefixlen = (state-1);
2850             if (str) {
2851                 regnode *n = convert+NODE_SZ_STR(convert);
2852                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
2853                 trie->startstate = state;
2854                 trie->minlen -= (state - 1);
2855                 trie->maxlen -= (state - 1);
2856 #ifdef DEBUGGING
2857                /* At least the UNICOS C compiler choked on this
2858                 * being argument to DEBUG_r(), so let's just have
2859                 * it right here. */
2860                if (
2861 #ifdef PERL_EXT_RE_BUILD
2862                    1
2863 #else
2864                    DEBUG_r_TEST
2865 #endif
2866                    ) {
2867                    regnode *fix = convert;
2868                    U32 word = trie->wordcount;
2869                    mjd_nodelen++;
2870                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
2871                    while( ++fix < n ) {
2872                        Set_Node_Offset_Length(fix, 0, 0);
2873                    }
2874                    while (word--) {
2875                        SV ** const tmp = av_fetch( trie_words, word, 0 );
2876                        if (tmp) {
2877                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
2878                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
2879                            else
2880                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
2881                        }
2882                    }
2883                }
2884 #endif
2885                 if (trie->maxlen) {
2886                     convert = n;
2887                 } else {
2888                     NEXT_OFF(convert) = (U16)(tail - convert);
2889                     DEBUG_r(optimize= n);
2890                 }
2891             }
2892         }
2893         if (!jumper)
2894             jumper = last;
2895         if ( trie->maxlen ) {
2896             NEXT_OFF( convert ) = (U16)(tail - convert);
2897             ARG_SET( convert, data_slot );
2898             /* Store the offset to the first unabsorbed branch in
2899                jump[0], which is otherwise unused by the jump logic.
2900                We use this when dumping a trie and during optimisation. */
2901             if (trie->jump)
2902                 trie->jump[0] = (U16)(nextbranch - convert);
2903
2904             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
2905              *   and there is a bitmap
2906              *   and the first "jump target" node we found leaves enough room
2907              * then convert the TRIE node into a TRIEC node, with the bitmap
2908              * embedded inline in the opcode - this is hypothetically faster.
2909              */
2910             if ( !trie->states[trie->startstate].wordnum
2911                  && trie->bitmap
2912                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
2913             {
2914                 OP( convert ) = TRIEC;
2915                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
2916                 PerlMemShared_free(trie->bitmap);
2917                 trie->bitmap= NULL;
2918             } else
2919                 OP( convert ) = TRIE;
2920
2921             /* store the type in the flags */
2922             convert->flags = nodetype;
2923             DEBUG_r({
2924             optimize = convert
2925                       + NODE_STEP_REGNODE
2926                       + regarglen[ OP( convert ) ];
2927             });
2928             /* XXX We really should free up the resource in trie now,
2929                    as we won't use them - (which resources?) dmq */
2930         }
2931         /* needed for dumping*/
2932         DEBUG_r(if (optimize) {
2933             regnode *opt = convert;
2934
2935             while ( ++opt < optimize) {
2936                 Set_Node_Offset_Length(opt,0,0);
2937             }
2938             /*
2939                 Try to clean up some of the debris left after the
2940                 optimisation.
2941              */
2942             while( optimize < jumper ) {
2943                 mjd_nodelen += Node_Length((optimize));
2944                 OP( optimize ) = OPTIMIZED;
2945                 Set_Node_Offset_Length(optimize,0,0);
2946                 optimize++;
2947             }
2948             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
2949         });
2950     } /* end node insert */
2951
2952     /*  Finish populating the prev field of the wordinfo array.  Walk back
2953      *  from each accept state until we find another accept state, and if
2954      *  so, point the first word's .prev field at the second word. If the
2955      *  second already has a .prev field set, stop now. This will be the
2956      *  case either if we've already processed that word's accept state,
2957      *  or that state had multiple words, and the overspill words were
2958      *  already linked up earlier.
2959      */
2960     {
2961         U16 word;
2962         U32 state;
2963         U16 prev;
2964
2965         for (word=1; word <= trie->wordcount; word++) {
2966             prev = 0;
2967             if (trie->wordinfo[word].prev)
2968                 continue;
2969             state = trie->wordinfo[word].accept;
2970             while (state) {
2971                 state = prev_states[state];
2972                 if (!state)
2973                     break;
2974                 prev = trie->states[state].wordnum;
2975                 if (prev)
2976                     break;
2977             }
2978             trie->wordinfo[word].prev = prev;
2979         }
2980         Safefree(prev_states);
2981     }
2982
2983
2984     /* and now dump out the compressed format */
2985     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
2986
2987     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
2988 #ifdef DEBUGGING
2989     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
2990     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
2991 #else
2992     SvREFCNT_dec_NN(revcharmap);
2993 #endif
2994     return trie->jump
2995            ? MADE_JUMP_TRIE
2996            : trie->startstate>1
2997              ? MADE_EXACT_TRIE
2998              : MADE_TRIE;
2999 }
3000
3001 STATIC regnode *
3002 S_construct_ahocorasick_from_trie(pTHX_ RExC_state_t *pRExC_state, regnode *source, U32 depth)
3003 {
3004 /* The Trie is constructed and compressed now so we can build a fail array if
3005  * it's needed
3006
3007    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and
3008    3.32 in the
3009    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi,
3010    Ullman 1985/88
3011    ISBN 0-201-10088-6
3012
3013    We find the fail state for each state in the trie, this state is the longest
3014    proper suffix of the current state's 'word' that is also a proper prefix of
3015    another word in our trie. State 1 represents the word '' and is thus the
3016    default fail state. This allows the DFA not to have to restart after its
3017    tried and failed a word at a given point, it simply continues as though it
3018    had been matching the other word in the first place.
3019    Consider
3020       'abcdgu'=~/abcdefg|cdgu/
3021    When we get to 'd' we are still matching the first word, we would encounter
3022    'g' which would fail, which would bring us to the state representing 'd' in
3023    the second word where we would try 'g' and succeed, proceeding to match
3024    'cdgu'.
3025  */
3026  /* add a fail transition */
3027     const U32 trie_offset = ARG(source);
3028     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
3029     U32 *q;
3030     const U32 ucharcount = trie->uniquecharcount;
3031     const U32 numstates = trie->statecount;
3032     const U32 ubound = trie->lasttrans + ucharcount;
3033     U32 q_read = 0;
3034     U32 q_write = 0;
3035     U32 charid;
3036     U32 base = trie->states[ 1 ].trans.base;
3037     U32 *fail;
3038     reg_ac_data *aho;
3039     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("T"));
3040     regnode *stclass;
3041     GET_RE_DEBUG_FLAGS_DECL;
3042
3043     PERL_ARGS_ASSERT_CONSTRUCT_AHOCORASICK_FROM_TRIE;
3044     PERL_UNUSED_CONTEXT;
3045 #ifndef DEBUGGING
3046     PERL_UNUSED_ARG(depth);
3047 #endif
3048
3049     if ( OP(source) == TRIE ) {
3050         struct regnode_1 *op = (struct regnode_1 *)
3051             PerlMemShared_calloc(1, sizeof(struct regnode_1));
3052         StructCopy(source,op,struct regnode_1);
3053         stclass = (regnode *)op;
3054     } else {
3055         struct regnode_charclass *op = (struct regnode_charclass *)
3056             PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
3057         StructCopy(source,op,struct regnode_charclass);
3058         stclass = (regnode *)op;
3059     }
3060     OP(stclass)+=2; /* covert the TRIE type to its AHO-CORASICK equivalent */
3061
3062     ARG_SET( stclass, data_slot );
3063     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
3064     RExC_rxi->data->data[ data_slot ] = (void*)aho;
3065     aho->trie=trie_offset;
3066     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
3067     Copy( trie->states, aho->states, numstates, reg_trie_state );
3068     Newxz( q, numstates, U32);
3069     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
3070     aho->refcount = 1;
3071     fail = aho->fail;
3072     /* initialize fail[0..1] to be 1 so that we always have
3073        a valid final fail state */
3074     fail[ 0 ] = fail[ 1 ] = 1;
3075
3076     for ( charid = 0; charid < ucharcount ; charid++ ) {
3077         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
3078         if ( newstate ) {
3079             q[ q_write ] = newstate;
3080             /* set to point at the root */
3081             fail[ q[ q_write++ ] ]=1;
3082         }
3083     }
3084     while ( q_read < q_write) {
3085         const U32 cur = q[ q_read++ % numstates ];
3086         base = trie->states[ cur ].trans.base;
3087
3088         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
3089             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
3090             if (ch_state) {
3091                 U32 fail_state = cur;
3092                 U32 fail_base;
3093                 do {
3094                     fail_state = fail[ fail_state ];
3095                     fail_base = aho->states[ fail_state ].trans.base;
3096                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
3097
3098                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
3099                 fail[ ch_state ] = fail_state;
3100                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
3101                 {
3102                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
3103                 }
3104                 q[ q_write++ % numstates] = ch_state;
3105             }
3106         }
3107     }
3108     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
3109        when we fail in state 1, this allows us to use the
3110        charclass scan to find a valid start char. This is based on the principle
3111        that theres a good chance the string being searched contains lots of stuff
3112        that cant be a start char.
3113      */
3114     fail[ 0 ] = fail[ 1 ] = 0;
3115     DEBUG_TRIE_COMPILE_r({
3116         PerlIO_printf(Perl_debug_log,
3117                       "%*sStclass Failtable (%"UVuf" states): 0",
3118                       (int)(depth * 2), "", (UV)numstates
3119         );
3120         for( q_read=1; q_read<numstates; q_read++ ) {
3121             PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
3122         }
3123         PerlIO_printf(Perl_debug_log, "\n");
3124     });
3125     Safefree(q);
3126     /*RExC_seen |= REG_TRIEDFA_SEEN;*/
3127     return stclass;
3128 }
3129
3130
3131 #define DEBUG_PEEP(str,scan,depth) \
3132     DEBUG_OPTIMISE_r({if (scan){ \
3133        SV * const mysv=sv_newmortal(); \
3134        regnode *Next = regnext(scan); \
3135        regprop(RExC_rx, mysv, scan, NULL); \
3136        PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
3137        (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
3138        Next ? (REG_NODE_NUM(Next)) : 0 ); \
3139    }});
3140
3141
3142 /* The below joins as many adjacent EXACTish nodes as possible into a single
3143  * one.  The regop may be changed if the node(s) contain certain sequences that
3144  * require special handling.  The joining is only done if:
3145  * 1) there is room in the current conglomerated node to entirely contain the
3146  *    next one.
3147  * 2) they are the exact same node type
3148  *
3149  * The adjacent nodes actually may be separated by NOTHING-kind nodes, and
3150  * these get optimized out
3151  *
3152  * If a node is to match under /i (folded), the number of characters it matches
3153  * can be different than its character length if it contains a multi-character
3154  * fold.  *min_subtract is set to the total delta number of characters of the
3155  * input nodes.
3156  *
3157  * And *unfolded_multi_char is set to indicate whether or not the node contains
3158  * an unfolded multi-char fold.  This happens when whether the fold is valid or
3159  * not won't be known until runtime; namely for EXACTF nodes that contain LATIN
3160  * SMALL LETTER SHARP S, as only if the target string being matched against
3161  * turns out to be UTF-8 is that fold valid; and also for EXACTFL nodes whose
3162  * folding rules depend on the locale in force at runtime.  (Multi-char folds
3163  * whose components are all above the Latin1 range are not run-time locale
3164  * dependent, and have already been folded by the time this function is
3165  * called.)
3166  *
3167  * This is as good a place as any to discuss the design of handling these
3168  * multi-character fold sequences.  It's been wrong in Perl for a very long
3169  * time.  There are three code points in Unicode whose multi-character folds
3170  * were long ago discovered to mess things up.  The previous designs for
3171  * dealing with these involved assigning a special node for them.  This
3172  * approach doesn't always work, as evidenced by this example:
3173  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
3174  * Both sides fold to "sss", but if the pattern is parsed to create a node that
3175  * would match just the \xDF, it won't be able to handle the case where a
3176  * successful match would have to cross the node's boundary.  The new approach
3177  * that hopefully generally solves the problem generates an EXACTFU_SS node
3178  * that is "sss" in this case.
3179  *
3180  * It turns out that there are problems with all multi-character folds, and not
3181  * just these three.  Now the code is general, for all such cases.  The
3182  * approach taken is:
3183  * 1)   This routine examines each EXACTFish node that could contain multi-
3184  *      character folded sequences.  Since a single character can fold into
3185  *      such a sequence, the minimum match length for this node is less than
3186  *      the number of characters in the node.  This routine returns in
3187  *      *min_subtract how many characters to subtract from the the actual
3188  *      length of the string to get a real minimum match length; it is 0 if
3189  *      there are no multi-char foldeds.  This delta is used by the caller to
3190  *      adjust the min length of the match, and the delta between min and max,
3191  *      so that the optimizer doesn't reject these possibilities based on size
3192  *      constraints.
3193  * 2)   For the sequence involving the Sharp s (\xDF), the node type EXACTFU_SS
3194  *      is used for an EXACTFU node that contains at least one "ss" sequence in
3195  *      it.  For non-UTF-8 patterns and strings, this is the only case where
3196  *      there is a possible fold length change.  That means that a regular
3197  *      EXACTFU node without UTF-8 involvement doesn't have to concern itself
3198  *      with length changes, and so can be processed faster.  regexec.c takes
3199  *      advantage of this.  Generally, an EXACTFish node that is in UTF-8 is
3200  *      pre-folded by regcomp.c (except EXACTFL, some of whose folds aren't
3201  *      known until runtime).  This saves effort in regex matching.  However,
3202  *      the pre-folding isn't done for non-UTF8 patterns because the fold of
3203  *      the MICRO SIGN requires UTF-8, and we don't want to slow things down by
3204  *      forcing the pattern into UTF8 unless necessary.  Also what EXACTF (and,
3205  *      again, EXACTFL) nodes fold to isn't known until runtime.  The fold
3206  *      possibilities for the non-UTF8 patterns are quite simple, except for
3207  *      the sharp s.  All the ones that don't involve a UTF-8 target string are
3208  *      members of a fold-pair, and arrays are set up for all of them so that
3209  *      the other member of the pair can be found quickly.  Code elsewhere in
3210  *      this file makes sure that in EXACTFU nodes, the sharp s gets folded to
3211  *      'ss', even if the pattern isn't UTF-8.  This avoids the issues
3212  *      described in the next item.
3213  * 3)   A problem remains for unfolded multi-char folds. (These occur when the
3214  *      validity of the fold won't be known until runtime, and so must remain
3215  *      unfolded for now.  This happens for the sharp s in EXACTF and EXACTFA
3216  *      nodes when the pattern isn't in UTF-8.  (Note, BTW, that there cannot
3217  *      be an EXACTF node with a UTF-8 pattern.)  They also occur for various
3218  *      folds in EXACTFL nodes, regardless of the UTF-ness of the pattern.)
3219  *      The reason this is a problem is that the optimizer part of regexec.c
3220  *      (probably unwittingly, in Perl_regexec_flags()) makes an assumption
3221  *      that a character in the pattern corresponds to at most a single
3222  *      character in the target string.  (And I do mean character, and not byte
3223  *      here, unlike other parts of the documentation that have never been
3224  *      updated to account for multibyte Unicode.)  sharp s in EXACTF and
3225  *      EXACTFL nodes can match the two character string 'ss'; in EXACTFA nodes
3226  *      it can match "\x{17F}\x{17F}".  These, along with other ones in EXACTFL
3227  *      nodes, violate the assumption, and they are the only instances where it
3228  *      is violated.  I'm reluctant to try to change the assumption, as the
3229  *      code involved is impenetrable to me (khw), so instead the code here
3230  *      punts.  This routine examines EXACTFL nodes, and (when the pattern
3231  *      isn't UTF-8) EXACTF and EXACTFA for such unfolded folds, and returns a
3232  *      boolean indicating whether or not the node contains such a fold.  When
3233  *      it is true, the caller sets a flag that later causes the optimizer in
3234  *      this file to not set values for the floating and fixed string lengths,
3235  *      and thus avoids the optimizer code in regexec.c that makes the invalid
3236  *      assumption.  Thus, there is no optimization based on string lengths for
3237  *      EXACTFL nodes that contain these few folds, nor for non-UTF8-pattern
3238  *      EXACTF and EXACTFA nodes that contain the sharp s.  (The reason the
3239  *      assumption is wrong only in these cases is that all other non-UTF-8
3240  *      folds are 1-1; and, for UTF-8 patterns, we pre-fold all other folds to
3241  *      their expanded versions.  (Again, we can't prefold sharp s to 'ss' in
3242  *      EXACTF nodes because we don't know at compile time if it actually
3243  *      matches 'ss' or not.  For EXACTF nodes it will match iff the target
3244  *      string is in UTF-8.  This is in contrast to EXACTFU nodes, where it
3245  *      always matches; and EXACTFA where it never does.  In an EXACTFA node in
3246  *      a UTF-8 pattern, sharp s is folded to "\x{17F}\x{17F}, avoiding the
3247  *      problem; but in a non-UTF8 pattern, folding it to that above-Latin1
3248  *      string would require the pattern to be forced into UTF-8, the overhead
3249  *      of which we want to avoid.  Similarly the unfolded multi-char folds in
3250  *      EXACTFL nodes will match iff the locale at the time of match is a UTF-8
3251  *      locale.)
3252  *
3253  *      Similarly, the code that generates tries doesn't currently handle
3254  *      not-already-folded multi-char folds, and it looks like a pain to change
3255  *      that.  Therefore, trie generation of EXACTFA nodes with the sharp s
3256  *      doesn't work.  Instead, such an EXACTFA is turned into a new regnode,
3257  *      EXACTFA_NO_TRIE, which the trie code knows not to handle.  Most people
3258  *      using /iaa matching will be doing so almost entirely with ASCII
3259  *      strings, so this should rarely be encountered in practice */
3260
3261 #define JOIN_EXACT(scan,min_subtract,unfolded_multi_char, flags) \
3262     if (PL_regkind[OP(scan)] == EXACT) \
3263         join_exact(pRExC_state,(scan),(min_subtract),unfolded_multi_char, (flags),NULL,depth+1)
3264
3265 STATIC U32
3266 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan,
3267                    UV *min_subtract, bool *unfolded_multi_char,
3268                    U32 flags,regnode *val, U32 depth)
3269 {
3270     /* Merge several consecutive EXACTish nodes into one. */
3271     regnode *n = regnext(scan);
3272     U32 stringok = 1;
3273     regnode *next = scan + NODE_SZ_STR(scan);
3274     U32 merged = 0;
3275     U32 stopnow = 0;
3276 #ifdef DEBUGGING
3277     regnode *stop = scan;
3278     GET_RE_DEBUG_FLAGS_DECL;
3279 #else
3280     PERL_UNUSED_ARG(depth);
3281 #endif
3282
3283     PERL_ARGS_ASSERT_JOIN_EXACT;
3284 #ifndef EXPERIMENTAL_INPLACESCAN
3285     PERL_UNUSED_ARG(flags);
3286     PERL_UNUSED_ARG(val);
3287 #endif
3288     DEBUG_PEEP("join",scan,depth);
3289
3290     /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
3291      * EXACT ones that are mergeable to the current one. */
3292     while (n
3293            && (PL_regkind[OP(n)] == NOTHING
3294                || (stringok && OP(n) == OP(scan)))
3295            && NEXT_OFF(n)
3296            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
3297     {
3298
3299         if (OP(n) == TAIL || n > next)
3300             stringok = 0;
3301         if (PL_regkind[OP(n)] == NOTHING) {
3302             DEBUG_PEEP("skip:",n,depth);
3303             NEXT_OFF(scan) += NEXT_OFF(n);
3304             next = n + NODE_STEP_REGNODE;
3305 #ifdef DEBUGGING
3306             if (stringok)
3307                 stop = n;
3308 #endif
3309             n = regnext(n);
3310         }
3311         else if (stringok) {
3312             const unsigned int oldl = STR_LEN(scan);
3313             regnode * const nnext = regnext(n);
3314
3315             /* XXX I (khw) kind of doubt that this works on platforms (should
3316              * Perl ever run on one) where U8_MAX is above 255 because of lots
3317              * of other assumptions */
3318             /* Don't join if the sum can't fit into a single node */
3319             if (oldl + STR_LEN(n) > U8_MAX)
3320                 break;
3321
3322             DEBUG_PEEP("merg",n,depth);
3323             merged++;
3324
3325             NEXT_OFF(scan) += NEXT_OFF(n);
3326             STR_LEN(scan) += STR_LEN(n);
3327             next = n + NODE_SZ_STR(n);
3328             /* Now we can overwrite *n : */
3329             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
3330 #ifdef DEBUGGING
3331             stop = next - 1;
3332 #endif
3333             n = nnext;
3334             if (stopnow) break;
3335         }
3336
3337 #ifdef EXPERIMENTAL_INPLACESCAN
3338         if (flags && !NEXT_OFF(n)) {
3339             DEBUG_PEEP("atch", val, depth);
3340             if (reg_off_by_arg[OP(n)]) {
3341                 ARG_SET(n, val - n);
3342             }
3343             else {
3344                 NEXT_OFF(n) = val - n;
3345             }
3346             stopnow = 1;
3347         }
3348 #endif
3349     }
3350
3351     *min_subtract = 0;
3352     *unfolded_multi_char = FALSE;
3353
3354     /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
3355      * can now analyze for sequences of problematic code points.  (Prior to
3356      * this final joining, sequences could have been split over boundaries, and
3357      * hence missed).  The sequences only happen in folding, hence for any
3358      * non-EXACT EXACTish node */
3359     if (OP(scan) != EXACT) {
3360         U8* s0 = (U8*) STRING(scan);
3361         U8* s = s0;
3362         U8* s_end = s0 + STR_LEN(scan);
3363
3364         int total_count_delta = 0;  /* Total delta number of characters that
3365                                        multi-char folds expand to */
3366
3367         /* One pass is made over the node's string looking for all the
3368          * possibilities.  To avoid some tests in the loop, there are two main
3369          * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
3370          * non-UTF-8 */
3371         if (UTF) {
3372             U8* folded = NULL;
3373
3374             if (OP(scan) == EXACTFL) {
3375                 U8 *d;
3376
3377                 /* An EXACTFL node would already have been changed to another
3378                  * node type unless there is at least one character in it that
3379                  * is problematic; likely a character whose fold definition
3380                  * won't be known until runtime, and so has yet to be folded.
3381                  * For all but the UTF-8 locale, folds are 1-1 in length, but
3382                  * to handle the UTF-8 case, we need to create a temporary
3383                  * folded copy using UTF-8 locale rules in order to analyze it.
3384                  * This is because our macros that look to see if a sequence is
3385                  * a multi-char fold assume everything is folded (otherwise the
3386                  * tests in those macros would be too complicated and slow).
3387                  * Note that here, the non-problematic folds will have already
3388                  * been done, so we can just copy such characters.  We actually
3389                  * don't completely fold the EXACTFL string.  We skip the
3390                  * unfolded multi-char folds, as that would just create work
3391                  * below to figure out the size they already are */
3392
3393                 Newx(folded, UTF8_MAX_FOLD_CHAR_EXPAND * STR_LEN(scan) + 1, U8);
3394                 d = folded;
3395                 while (s < s_end) {
3396                     STRLEN s_len = UTF8SKIP(s);
3397                     if (! is_PROBLEMATIC_LOCALE_FOLD_utf8(s)) {
3398                         Copy(s, d, s_len, U8);
3399                         d += s_len;
3400                     }
3401                     else if (is_FOLDS_TO_MULTI_utf8(s)) {
3402                         *unfolded_multi_char = TRUE;
3403                         Copy(s, d, s_len, U8);
3404                         d += s_len;
3405                     }
3406                     else if (isASCII(*s)) {
3407                         *(d++) = toFOLD(*s);
3408                     }
3409                     else {
3410                         STRLEN len;
3411                         _to_utf8_fold_flags(s, d, &len, FOLD_FLAGS_FULL);
3412                         d += len;
3413                     }
3414                     s += s_len;
3415                 }
3416
3417                 /* Point the remainder of the routine to look at our temporary
3418                  * folded copy */
3419                 s = folded;
3420                 s_end = d;
3421             } /* End of creating folded copy of EXACTFL string */
3422
3423             /* Examine the string for a multi-character fold sequence.  UTF-8
3424              * patterns have all characters pre-folded by the time this code is
3425              * executed */
3426             while (s < s_end - 1) /* Can stop 1 before the end, as minimum
3427                                      length sequence we are looking for is 2 */
3428             {
3429                 int count = 0;  /* How many characters in a multi-char fold */
3430                 int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
3431                 if (! len) {    /* Not a multi-char fold: get next char */
3432                     s += UTF8SKIP(s);
3433                     continue;
3434                 }
3435
3436                 /* Nodes with 'ss' require special handling, except for
3437                  * EXACTFA-ish for which there is no multi-char fold to this */
3438                 if (len == 2 && *s == 's' && *(s+1) == 's'
3439                     && OP(scan) != EXACTFA
3440                     && OP(scan) != EXACTFA_NO_TRIE)
3441                 {
3442                     count = 2;
3443                     if (OP(scan) != EXACTFL) {
3444                         OP(scan) = EXACTFU_SS;
3445                     }
3446                     s += 2;
3447                 }
3448                 else { /* Here is a generic multi-char fold. */
3449                     U8* multi_end  = s + len;
3450
3451                     /* Count how many characters are in it.  In the case of
3452                      * /aa, no folds which contain ASCII code points are
3453                      * allowed, so check for those, and skip if found. */
3454                     if (OP(scan) != EXACTFA && OP(scan) != EXACTFA_NO_TRIE) {
3455                         count = utf8_length(s, multi_end);
3456                         s = multi_end;
3457                     }
3458                     else {
3459                         while (s < multi_end) {
3460                             if (isASCII(*s)) {
3461                                 s++;
3462                                 goto next_iteration;
3463                             }
3464                             else {
3465                                 s += UTF8SKIP(s);
3466                             }
3467                             count++;
3468                         }
3469                     }
3470                 }
3471
3472                 /* The delta is how long the sequence is minus 1 (1 is how long
3473                  * the character that folds to the sequence is) */
3474                 total_count_delta += count - 1;
3475               next_iteration: ;
3476             }
3477
3478             /* We created a temporary folded copy of the string in EXACTFL
3479              * nodes.  Therefore we need to be sure it doesn't go below zero,
3480              * as the real string could be shorter */
3481             if (OP(scan) == EXACTFL) {
3482                 int total_chars = utf8_length((U8*) STRING(scan),
3483                                            (U8*) STRING(scan) + STR_LEN(scan));
3484                 if (total_count_delta > total_chars) {
3485                     total_count_delta = total_chars;
3486                 }
3487             }
3488
3489             *min_subtract += total_count_delta;
3490             Safefree(folded);
3491         }
3492         else if (OP(scan) == EXACTFA) {
3493
3494             /* Non-UTF-8 pattern, EXACTFA node.  There can't be a multi-char
3495              * fold to the ASCII range (and there are no existing ones in the
3496              * upper latin1 range).  But, as outlined in the comments preceding
3497              * this function, we need to flag any occurrences of the sharp s.
3498              * This character forbids trie formation (because of added
3499              * complexity) */
3500             while (s < s_end) {
3501                 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3502                     OP(scan) = EXACTFA_NO_TRIE;
3503                     *unfolded_multi_char = TRUE;
3504                     break;
3505                 }
3506                 s++;
3507                 continue;
3508             }
3509         }
3510         else {
3511
3512             /* Non-UTF-8 pattern, not EXACTFA node.  Look for the multi-char
3513              * folds that are all Latin1.  As explained in the comments
3514              * preceding this function, we look also for the sharp s in EXACTF
3515              * and EXACTFL nodes; it can be in the final position.  Otherwise
3516              * we can stop looking 1 byte earlier because have to find at least
3517              * two characters for a multi-fold */
3518             const U8* upper = (OP(scan) == EXACTF || OP(scan) == EXACTFL)
3519                               ? s_end
3520                               : s_end -1;
3521
3522             while (s < upper) {
3523                 int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end);
3524                 if (! len) {    /* Not a multi-char fold. */
3525                     if (*s == LATIN_SMALL_LETTER_SHARP_S
3526                         && (OP(scan) == EXACTF || OP(scan) == EXACTFL))
3527                     {
3528                         *unfolded_multi_char = TRUE;
3529                     }
3530                     s++;
3531                     continue;
3532                 }
3533
3534                 if (len == 2
3535                     && isALPHA_FOLD_EQ(*s, 's')
3536                     && isALPHA_FOLD_EQ(*(s+1), 's'))
3537                 {
3538
3539                     /* EXACTF nodes need to know that the minimum length
3540                      * changed so that a sharp s in the string can match this
3541                      * ss in the pattern, but they remain EXACTF nodes, as they
3542                      * won't match this unless the target string is is UTF-8,
3543                      * which we don't know until runtime.  EXACTFL nodes can't
3544                      * transform into EXACTFU nodes */
3545                     if (OP(scan) != EXACTF && OP(scan) != EXACTFL) {
3546                         OP(scan) = EXACTFU_SS;
3547                     }
3548                 }
3549
3550                 *min_subtract += len - 1;
3551                 s += len;
3552             }
3553         }
3554     }
3555
3556 #ifdef DEBUGGING
3557     /* Allow dumping but overwriting the collection of skipped
3558      * ops and/or strings with fake optimized ops */
3559     n = scan + NODE_SZ_STR(scan);
3560     while (n <= stop) {
3561         OP(n) = OPTIMIZED;
3562         FLAGS(n) = 0;
3563         NEXT_OFF(n) = 0;
3564         n++;
3565     }
3566 #endif
3567     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
3568     return stopnow;
3569 }
3570
3571 /* REx optimizer.  Converts nodes into quicker variants "in place".
3572    Finds fixed substrings.  */
3573
3574 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
3575    to the position after last scanned or to NULL. */
3576
3577 #define INIT_AND_WITHP \
3578     assert(!and_withp); \
3579     Newx(and_withp,1, regnode_ssc); \
3580     SAVEFREEPV(and_withp)
3581
3582 /* this is a chain of data about sub patterns we are processing that
3583    need to be handled separately/specially in study_chunk. Its so
3584    we can simulate recursion without losing state.  */
3585 struct scan_frame;
3586 typedef struct scan_frame {
3587     regnode *last;  /* last node to process in this frame */
3588     regnode *next;  /* next node to process when last is reached */
3589     struct scan_frame *prev; /*previous frame*/
3590     U32 prev_recursed_depth;
3591     I32 stop; /* what stopparen do we use */
3592 } scan_frame;
3593
3594
3595 STATIC SSize_t
3596 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
3597                         SSize_t *minlenp, SSize_t *deltap,
3598                         regnode *last,
3599                         scan_data_t *data,
3600                         I32 stopparen,
3601                         U32 recursed_depth,
3602                         regnode_ssc *and_withp,
3603                         U32 flags, U32 depth)
3604                         /* scanp: Start here (read-write). */
3605                         /* deltap: Write maxlen-minlen here. */
3606                         /* last: Stop before this one. */
3607                         /* data: string data about the pattern */
3608                         /* stopparen: treat close N as END */
3609                         /* recursed: which subroutines have we recursed into */
3610                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
3611 {
3612     /* There must be at least this number of characters to match */
3613     SSize_t min = 0;
3614     I32 pars = 0, code;
3615     regnode *scan = *scanp, *next;
3616     SSize_t delta = 0;
3617     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
3618     int is_inf_internal = 0;            /* The studied chunk is infinite */
3619     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
3620     scan_data_t data_fake;
3621     SV *re_trie_maxbuff = NULL;
3622     regnode *first_non_open = scan;
3623     SSize_t stopmin = SSize_t_MAX;
3624     scan_frame *frame = NULL;
3625     GET_RE_DEBUG_FLAGS_DECL;
3626
3627     PERL_ARGS_ASSERT_STUDY_CHUNK;
3628
3629 #ifdef DEBUGGING
3630     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
3631 #endif
3632     if ( depth == 0 ) {
3633         while (first_non_open && OP(first_non_open) == OPEN)
3634             first_non_open=regnext(first_non_open);
3635     }
3636
3637
3638   fake_study_recurse:
3639     while ( scan && OP(scan) != END && scan < last ){
3640         UV min_subtract = 0;    /* How mmany chars to subtract from the minimum
3641                                    node length to get a real minimum (because
3642                                    the folded version may be shorter) */
3643         bool unfolded_multi_char = FALSE;
3644         /* Peephole optimizer: */
3645         DEBUG_OPTIMISE_MORE_r(
3646         {
3647             PerlIO_printf(Perl_debug_log,
3648                 "%*sstudy_chunk stopparen=%ld depth=%lu recursed_depth=%lu ",
3649                 ((int) depth*2), "", (long)stopparen,
3650                 (unsigned long)depth, (unsigned long)recursed_depth);
3651             if (recursed_depth) {
3652                 U32 i;
3653                 U32 j;
3654                 for ( j = 0 ; j < recursed_depth ; j++ ) {
3655                     PerlIO_printf(Perl_debug_log,"[");
3656                     for ( i = 0 ; i < (U32)RExC_npar ; i++ )
3657                         PerlIO_printf(Perl_debug_log,"%d",
3658                             PAREN_TEST(RExC_study_chunk_recursed +
3659                                        (j * RExC_study_chunk_recursed_bytes), i)
3660                             ? 1 : 0
3661                         );
3662                     PerlIO_printf(Perl_debug_log,"]");
3663                 }
3664             }
3665             PerlIO_printf(Perl_debug_log,"\n");
3666         }
3667         );
3668         DEBUG_STUDYDATA("Peep:", data, depth);
3669         DEBUG_PEEP("Peep", scan, depth);
3670
3671
3672         /* The reason we do this here we need to deal with things like /(?:f)(?:o)(?:o)/
3673          * which cant be dealt with by the normal EXACT parsing code, as each (?:..) is handled
3674          * by a different invocation of reg() -- Yves
3675          */
3676         JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
3677
3678         /* Follow the next-chain of the current node and optimize
3679            away all the NOTHINGs from it.  */
3680         if (OP(scan) != CURLYX) {
3681             const int max = (reg_off_by_arg[OP(scan)]
3682                        ? I32_MAX
3683                        /* I32 may be smaller than U16 on CRAYs! */
3684                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
3685             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
3686             int noff;
3687             regnode *n = scan;
3688
3689             /* Skip NOTHING and LONGJMP. */
3690             while ((n = regnext(n))
3691                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
3692                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
3693                    && off + noff < max)
3694                 off += noff;
3695             if (reg_off_by_arg[OP(scan)])
3696                 ARG(scan) = off;
3697             else
3698                 NEXT_OFF(scan) = off;
3699         }
3700
3701
3702
3703         /* The principal pseudo-switch.  Cannot be a switch, since we
3704            look into several different things.  */
3705         if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
3706                    || OP(scan) == IFTHEN) {
3707             next = regnext(scan);
3708             code = OP(scan);
3709             /* demq: the op(next)==code check is to see if we have
3710              * "branch-branch" AFAICT */
3711
3712             if (OP(next) == code || code == IFTHEN) {
3713                 /* NOTE - There is similar code to this block below for
3714                  * handling TRIE nodes on a re-study.  If you change stuff here
3715                  * check there too. */
3716                 SSize_t max1 = 0, min1 = SSize_t_MAX, num = 0;
3717                 regnode_ssc accum;
3718                 regnode * const startbranch=scan;
3719
3720                 if (flags & SCF_DO_SUBSTR) {
3721                     /* Cannot merge strings after this. */
3722                     scan_commit(pRExC_state, data, minlenp, is_inf);
3723                 }
3724
3725                 if (flags & SCF_DO_STCLASS)
3726                     ssc_init_zero(pRExC_state, &accum);
3727
3728                 while (OP(scan) == code) {
3729                     SSize_t deltanext, minnext, fake;
3730                     I32 f = 0;
3731                     regnode_ssc this_class;
3732
3733                     num++;
3734                     data_fake.flags = 0;
3735                     if (data) {
3736                         data_fake.whilem_c = data->whilem_c;
3737                         data_fake.last_closep = data->last_closep;
3738                     }
3739                     else
3740                         data_fake.last_closep = &fake;
3741
3742                     data_fake.pos_delta = delta;
3743                     next = regnext(scan);
3744                     scan = NEXTOPER(scan);
3745                     if (code != BRANCH)
3746                         scan = NEXTOPER(scan);
3747                     if (flags & SCF_DO_STCLASS) {
3748                         ssc_init(pRExC_state, &this_class);
3749                         data_fake.start_class = &this_class;
3750                         f = SCF_DO_STCLASS_AND;
3751                     }
3752                     if (flags & SCF_WHILEM_VISITED_POS)
3753                         f |= SCF_WHILEM_VISITED_POS;
3754
3755                     /* we suppose the run is continuous, last=next...*/
3756                     minnext = study_chunk(pRExC_state, &scan, minlenp,
3757                                       &deltanext, next, &data_fake, stopparen,
3758                                       recursed_depth, NULL, f,depth+1);
3759                     if (min1 > minnext)
3760                         min1 = minnext;
3761                     if (deltanext == SSize_t_MAX) {
3762                         is_inf = is_inf_internal = 1;
3763                         max1 = SSize_t_MAX;
3764                     } else if (max1 < minnext + deltanext)
3765                         max1 = minnext + deltanext;
3766                     scan = next;
3767                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3768                         pars++;
3769                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
3770                         if ( stopmin > minnext)
3771                             stopmin = min + min1;
3772                         flags &= ~SCF_DO_SUBSTR;
3773                         if (data)
3774                             data->flags |= SCF_SEEN_ACCEPT;
3775                     }
3776                     if (data) {
3777                         if (data_fake.flags & SF_HAS_EVAL)
3778                             data->flags |= SF_HAS_EVAL;
3779                         data->whilem_c = data_fake.whilem_c;
3780                     }
3781                     if (flags & SCF_DO_STCLASS)
3782                         ssc_or(pRExC_state, &accum, (regnode_charclass*)&this_class);
3783                 }
3784                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
3785                     min1 = 0;
3786                 if (flags & SCF_DO_SUBSTR) {
3787                     data->pos_min += min1;
3788                     if (data->pos_delta >= SSize_t_MAX - (max1 - min1))
3789                         data->pos_delta = SSize_t_MAX;
3790                     else
3791                         data->pos_delta += max1 - min1;
3792                     if (max1 != min1 || is_inf)
3793                         data->longest = &(data->longest_float);
3794                 }
3795                 min += min1;
3796                 if (delta == SSize_t_MAX
3797                  || SSize_t_MAX - delta - (max1 - min1) < 0)
3798                     delta = SSize_t_MAX;
3799                 else
3800                     delta += max1 - min1;
3801                 if (flags & SCF_DO_STCLASS_OR) {
3802                     ssc_or(pRExC_state, data->start_class, (regnode_charclass*) &accum);
3803                     if (min1) {
3804                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
3805                         flags &= ~SCF_DO_STCLASS;
3806                     }
3807                 }
3808                 else if (flags & SCF_DO_STCLASS_AND) {
3809                     if (min1) {
3810                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
3811                         flags &= ~SCF_DO_STCLASS;
3812                     }
3813                     else {
3814                         /* Switch to OR mode: cache the old value of
3815                          * data->start_class */
3816                         INIT_AND_WITHP;
3817                         StructCopy(data->start_class, and_withp, regnode_ssc);
3818                         flags &= ~SCF_DO_STCLASS_AND;
3819                         StructCopy(&accum, data->start_class, regnode_ssc);
3820                         flags |= SCF_DO_STCLASS_OR;
3821                     }
3822                 }
3823
3824                 if (PERL_ENABLE_TRIE_OPTIMISATION &&
3825                         OP( startbranch ) == BRANCH )
3826                 {
3827                 /* demq.
3828
3829                    Assuming this was/is a branch we are dealing with: 'scan'
3830                    now points at the item that follows the branch sequence,
3831                    whatever it is. We now start at the beginning of the
3832                    sequence and look for subsequences of
3833
3834                    BRANCH->EXACT=>x1
3835                    BRANCH->EXACT=>x2
3836                    tail
3837
3838                    which would be constructed from a pattern like
3839                    /A|LIST|OF|WORDS/
3840
3841                    If we can find such a subsequence we need to turn the first
3842                    element into a trie and then add the subsequent branch exact
3843                    strings to the trie.
3844
3845                    We have two cases
3846
3847                      1. patterns where the whole set of branches can be
3848                         converted.
3849
3850                      2. patterns where only a subset can be converted.
3851
3852                    In case 1 we can replace the whole set with a single regop
3853                    for the trie. In case 2 we need to keep the start and end
3854                    branches so
3855
3856                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
3857                      becomes BRANCH TRIE; BRANCH X;
3858
3859                   There is an additional case, that being where there is a
3860                   common prefix, which gets split out into an EXACT like node
3861                   preceding the TRIE node.
3862
3863                   If x(1..n)==tail then we can do a simple trie, if not we make
3864                   a "jump" trie, such that when we match the appropriate word
3865                   we "jump" to the appropriate tail node. Essentially we turn
3866                   a nested if into a case structure of sorts.
3867
3868                 */
3869
3870                     int made=0;
3871                     if (!re_trie_maxbuff) {
3872                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
3873                         if (!SvIOK(re_trie_maxbuff))
3874                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
3875                     }
3876                     if ( SvIV(re_trie_maxbuff)>=0  ) {
3877                         regnode *cur;
3878                         regnode *first = (regnode *)NULL;
3879                         regnode *last = (regnode *)NULL;
3880                         regnode *tail = scan;
3881                         U8 trietype = 0;
3882                         U32 count=0;
3883
3884 #ifdef DEBUGGING
3885                         SV * const mysv = sv_newmortal();   /* for dumping */
3886 #endif
3887                         /* var tail is used because there may be a TAIL
3888                            regop in the way. Ie, the exacts will point to the
3889                            thing following the TAIL, but the last branch will
3890                            point at the TAIL. So we advance tail. If we
3891                            have nested (?:) we may have to move through several
3892                            tails.
3893                          */
3894
3895                         while ( OP( tail ) == TAIL ) {
3896                             /* this is the TAIL generated by (?:) */
3897                             tail = regnext( tail );
3898                         }
3899
3900
3901                         DEBUG_TRIE_COMPILE_r({
3902                             regprop(RExC_rx, mysv, tail, NULL);
3903                             PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
3904                               (int)depth * 2 + 2, "",
3905                               "Looking for TRIE'able sequences. Tail node is: ",
3906                               SvPV_nolen_const( mysv )
3907                             );
3908                         });
3909
3910                         /*
3911
3912                             Step through the branches
3913                                 cur represents each branch,
3914                                 noper is the first thing to be matched as part
3915                                       of that branch
3916                                 noper_next is the regnext() of that node.
3917
3918                             We normally handle a case like this
3919                             /FOO[xyz]|BAR[pqr]/ via a "jump trie" but we also
3920                             support building with NOJUMPTRIE, which restricts
3921                             the trie logic to structures like /FOO|BAR/.
3922
3923                             If noper is a trieable nodetype then the branch is
3924                             a possible optimization target. If we are building
3925                             under NOJUMPTRIE then we require that noper_next is
3926                             the same as scan (our current position in the regex
3927                             program).
3928
3929                             Once we have two or more consecutive such branches
3930                             we can create a trie of the EXACT's contents and
3931                             stitch it in place into the program.
3932
3933                             If the sequence represents all of the branches in
3934                             the alternation we replace the entire thing with a
3935                             single TRIE node.
3936
3937                             Otherwise when it is a subsequence we need to
3938                             stitch it in place and replace only the relevant
3939                             branches. This means the first branch has to remain
3940                             as it is used by the alternation logic, and its
3941                             next pointer, and needs to be repointed at the item
3942                             on the branch chain following the last branch we
3943                             have optimized away.
3944
3945                             This could be either a BRANCH, in which case the
3946                             subsequence is internal, or it could be the item
3947                             following the branch sequence in which case the
3948                             subsequence is at the end (which does not
3949                             necessarily mean the first node is the start of the
3950                             alternation).
3951
3952                             TRIE_TYPE(X) is a define which maps the optype to a
3953                             trietype.
3954
3955                                 optype          |  trietype
3956                                 ----------------+-----------
3957                                 NOTHING         | NOTHING
3958                                 EXACT           | EXACT
3959                                 EXACTFU         | EXACTFU
3960                                 EXACTFU_SS      | EXACTFU
3961                                 EXACTFA         | EXACTFA
3962
3963
3964                         */
3965 #define TRIE_TYPE(X) ( ( NOTHING == (X) ) ? NOTHING :   \
3966                        ( EXACT == (X) )   ? EXACT :        \
3967                        ( EXACTFU == (X) || EXACTFU_SS == (X) ) ? EXACTFU :        \
3968                        ( EXACTFA == (X) ) ? EXACTFA :        \
3969                        0 )
3970
3971                         /* dont use tail as the end marker for this traverse */
3972                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
3973                             regnode * const noper = NEXTOPER( cur );
3974                             U8 noper_type = OP( noper );
3975                             U8 noper_trietype = TRIE_TYPE( noper_type );
3976 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
3977                             regnode * const noper_next = regnext( noper );
3978                             U8 noper_next_type = (noper_next && noper_next != tail) ? OP(noper_next) : 0;
3979                             U8 noper_next_trietype = (noper_next && noper_next != tail) ? TRIE_TYPE( noper_next_type ) :0;
3980 #endif
3981
3982                             DEBUG_TRIE_COMPILE_r({
3983                                 regprop(RExC_rx, mysv, cur, NULL);
3984                                 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
3985                                    (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
3986
3987                                 regprop(RExC_rx, mysv, noper, NULL);
3988                                 PerlIO_printf( Perl_debug_log, " -> %s",
3989                                     SvPV_nolen_const(mysv));
3990
3991                                 if ( noper_next ) {
3992                                   regprop(RExC_rx, mysv, noper_next, NULL);
3993                                   PerlIO_printf( Perl_debug_log,"\t=> %s\t",
3994                                     SvPV_nolen_const(mysv));
3995                                 }
3996                                 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d,tt==%s,nt==%s,nnt==%s)\n",
3997                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
3998                                    PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype]
3999                                 );
4000                             });
4001
4002                             /* Is noper a trieable nodetype that can be merged
4003                              * with the current trie (if there is one)? */
4004                             if ( noper_trietype
4005                                   &&
4006                                   (
4007                                         ( noper_trietype == NOTHING)
4008                                         || ( trietype == NOTHING )
4009                                         || ( trietype == noper_trietype )
4010                                   )
4011 #ifdef NOJUMPTRIE
4012                                   && noper_next == tail
4013 #endif
4014                                   && count < U16_MAX)
4015                             {
4016                                 /* Handle mergable triable node Either we are
4017                                  * the first node in a new trieable sequence,
4018                                  * in which case we do some bookkeeping,
4019                                  * otherwise we update the end pointer. */
4020                                 if ( !first ) {
4021                                     first = cur;
4022                                     if ( noper_trietype == NOTHING ) {
4023 #if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
4024                                         regnode * const noper_next = regnext( noper );
4025                                         U8 noper_next_type = (noper_next && noper_next!=tail) ? OP(noper_next) : 0;
4026                                         U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
4027 #endif
4028
4029                                         if ( noper_next_trietype ) {
4030                                             trietype = noper_next_trietype;
4031                                         } else if (noper_next_type)  {
4032                                             /* a NOTHING regop is 1 regop wide.
4033                                              * We need at least two for a trie
4034                                              * so we can't merge this in */
4035                                             first = NULL;
4036                                         }
4037                                     } else {
4038                                         trietype = noper_trietype;
4039                                     }
4040                                 } else {
4041                                     if ( trietype == NOTHING )
4042                                         trietype = noper_trietype;
4043                                     last = cur;
4044                                 }
4045                                 if (first)
4046                                     count++;
4047                             } /* end handle mergable triable node */
4048                             else {
4049                                 /* handle unmergable node -
4050                                  * noper may either be a triable node which can
4051                                  * not be tried together with the current trie,
4052                                  * or a non triable node */
4053                                 if ( last ) {
4054                                     /* If last is set and trietype is not
4055                                      * NOTHING then we have found at least two
4056                                      * triable branch sequences in a row of a
4057                                      * similar trietype so we can turn them
4058                                      * into a trie. If/when we allow NOTHING to
4059                                      * start a trie sequence this condition
4060                                      * will be required, and it isn't expensive
4061                                      * so we leave it in for now. */
4062                                     if ( trietype && trietype != NOTHING )
4063                                         make_trie( pRExC_state,
4064                                                 startbranch, first, cur, tail,
4065                                                 count, trietype, depth+1 );
4066                                     last = NULL; /* note: we clear/update
4067                                                     first, trietype etc below,
4068                                                     so we dont do it here */
4069                                 }
4070                                 if ( noper_trietype
4071 #ifdef NOJUMPTRIE
4072                                      && noper_next == tail
4073 #endif
4074                                 ){
4075                                     /* noper is triable, so we can start a new
4076                                      * trie sequence */
4077                                     count = 1;
4078                                     first = cur;
4079                                     trietype = noper_trietype;
4080                                 } else if (first) {
4081                                     /* if we already saw a first but the
4082                                      * current node is not triable then we have
4083                                      * to reset the first information. */
4084                                     count = 0;
4085                                     first = NULL;
4086                                     trietype = 0;
4087                                 }
4088                             } /* end handle unmergable node */
4089                         } /* loop over branches */
4090                         DEBUG_TRIE_COMPILE_r({
4091                             regprop(RExC_rx, mysv, cur, NULL);
4092                             PerlIO_printf( Perl_debug_log,
4093                               "%*s- %s (%d) <SCAN FINISHED>\n",
4094                               (int)depth * 2 + 2,
4095                               "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
4096
4097                         });
4098                         if ( last && trietype ) {
4099                             if ( trietype != NOTHING ) {
4100                                 /* the last branch of the sequence was part of
4101                                  * a trie, so we have to construct it here
4102                                  * outside of the loop */
4103                                 made= make_trie( pRExC_state, startbranch,
4104                                                  first, scan, tail, count,
4105                                                  trietype, depth+1 );
4106 #ifdef TRIE_STUDY_OPT
4107                                 if ( ((made == MADE_EXACT_TRIE &&
4108                                      startbranch == first)
4109                                      || ( first_non_open == first )) &&
4110                                      depth==0 ) {
4111                                     flags |= SCF_TRIE_RESTUDY;
4112                                     if ( startbranch == first
4113                                          && scan == tail )
4114                                     {
4115                                         RExC_seen &=~REG_TOP_LEVEL_BRANCHES_SEEN;
4116                                     }
4117                                 }
4118 #endif
4119                             } else {
4120                                 /* at this point we know whatever we have is a
4121                                  * NOTHING sequence/branch AND if 'startbranch'
4122                                  * is 'first' then we can turn the whole thing
4123                                  * into a NOTHING
4124                                  */
4125                                 if ( startbranch == first ) {
4126                                     regnode *opt;
4127                                     /* the entire thing is a NOTHING sequence,
4128                                      * something like this: (?:|) So we can
4129                                      * turn it into a plain NOTHING op. */
4130                                     DEBUG_TRIE_COMPILE_r({
4131                                         regprop(RExC_rx, mysv, cur, NULL);
4132                                         PerlIO_printf( Perl_debug_log,
4133                                           "%*s- %s (%d) <NOTHING BRANCH SEQUENCE>\n", (int)depth * 2 + 2,
4134                                           "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
4135
4136                                     });
4137                                     OP(startbranch)= NOTHING;
4138                                     NEXT_OFF(startbranch)= tail - startbranch;
4139                                     for ( opt= startbranch + 1; opt < tail ; opt++ )
4140                                         OP(opt)= OPTIMIZED;
4141                                 }
4142                             }
4143                         } /* end if ( last) */
4144                     } /* TRIE_MAXBUF is non zero */
4145
4146                 } /* do trie */
4147
4148             }
4149             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
4150                 scan = NEXTOPER(NEXTOPER(scan));
4151             } else                      /* single branch is optimized. */
4152                 scan = NEXTOPER(scan);
4153             continue;
4154         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
4155             scan_frame *newframe = NULL;
4156             I32 paren;
4157             regnode *start;
4158             regnode *end;
4159             U32 my_recursed_depth= recursed_depth;
4160
4161             if (OP(scan) != SUSPEND) {
4162                 /* set the pointer */
4163                 if (OP(scan) == GOSUB) {
4164                     paren = ARG(scan);
4165                     RExC_recurse[ARG2L(scan)] = scan;
4166                     start = RExC_open_parens[paren-1];
4167                     end   = RExC_close_parens[paren-1];
4168                 } else {
4169                     paren = 0;
4170                     start = RExC_rxi->program + 1;
4171                     end   = RExC_opend;
4172                 }
4173                 if (!recursed_depth
4174                     ||
4175                     !PAREN_TEST(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes), paren)
4176                 ) {
4177                     if (!recursed_depth) {
4178                         Zero(RExC_study_chunk_recursed, RExC_study_chunk_recursed_bytes, U8);
4179                     } else {
4180                         Copy(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes),
4181                              RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes),
4182                              RExC_study_chunk_recursed_bytes, U8);
4183                     }
4184                     /* we havent recursed into this paren yet, so recurse into it */
4185                     DEBUG_STUDYDATA("set:", data,depth);
4186                     PAREN_SET(RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes), paren);
4187                     my_recursed_depth= recursed_depth + 1;
4188                     Newx(newframe,1,scan_frame);
4189                 } else {
4190                     DEBUG_STUDYDATA("inf:", data,depth);
4191                     /* some form of infinite recursion, assume infinite length
4192                      * */
4193                     if (flags & SCF_DO_SUBSTR) {
4194                         scan_commit(pRExC_state, data, minlenp, is_inf);
4195                         data->longest = &(data->longest_float);
4196                     }
4197                     is_inf = is_inf_internal = 1;
4198                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4199                         ssc_anything(data->start_class);
4200                     flags &= ~SCF_DO_STCLASS;
4201                 }
4202             } else {
4203                 Newx(newframe,1,scan_frame);
4204                 paren = stopparen;
4205                 start = scan+2;
4206                 end = regnext(scan);
4207             }
4208             if (newframe) {
4209                 assert(start);
4210                 assert(end);
4211                 SAVEFREEPV(newframe);
4212                 newframe->next = regnext(scan);
4213                 newframe->last = last;
4214                 newframe->stop = stopparen;
4215                 newframe->prev = frame;
4216                 newframe->prev_recursed_depth = recursed_depth;
4217
4218                 DEBUG_STUDYDATA("frame-new:",data,depth);
4219                 DEBUG_PEEP("fnew", scan, depth);
4220
4221                 frame = newframe;
4222                 scan =  start;
4223                 stopparen = paren;
4224                 last = end;
4225                 depth = depth + 1;
4226                 recursed_depth= my_recursed_depth;
4227
4228                 continue;
4229             }
4230         }
4231         else if (OP(scan) == EXACT) {
4232             SSize_t l = STR_LEN(scan);
4233             UV uc;
4234             if (UTF) {
4235                 const U8 * const s = (U8*)STRING(scan);
4236                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
4237                 l = utf8_length(s, s + l);
4238             } else {
4239                 uc = *((U8*)STRING(scan));
4240             }
4241             min += l;
4242             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
4243                 /* The code below prefers earlier match for fixed
4244                    offset, later match for variable offset.  */
4245                 if (data->last_end == -1) { /* Update the start info. */
4246                     data->last_start_min = data->pos_min;
4247                     data->last_start_max = is_inf
4248                         ? SSize_t_MAX : data->pos_min + data->pos_delta;
4249                 }
4250                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
4251                 if (UTF)
4252                     SvUTF8_on(data->last_found);
4253                 {
4254                     SV * const sv = data->last_found;
4255                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4256                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
4257                     if (mg && mg->mg_len >= 0)
4258                         mg->mg_len += utf8_length((U8*)STRING(scan),
4259                                               (U8*)STRING(scan)+STR_LEN(scan));
4260                 }
4261                 data->last_end = data->pos_min + l;
4262                 data->pos_min += l; /* As in the first entry. */
4263                 data->flags &= ~SF_BEFORE_EOL;
4264             }
4265
4266             /* ANDing the code point leaves at most it, and not in locale, and
4267              * can't match null string */
4268             if (flags & SCF_DO_STCLASS_AND) {
4269                 ssc_cp_and(data->start_class, uc);
4270                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4271                 ssc_clear_locale(data->start_class);
4272             }
4273             else if (flags & SCF_DO_STCLASS_OR) {
4274                 ssc_add_cp(data->start_class, uc);
4275                 ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4276
4277                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
4278                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4279             }
4280             flags &= ~SCF_DO_STCLASS;
4281         }
4282         else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT!, so is
4283                                                      EXACTFish */
4284             SSize_t l = STR_LEN(scan);
4285             UV uc = *((U8*)STRING(scan));
4286             SV* EXACTF_invlist = _new_invlist(4); /* Start out big enough for 2
4287                                                      separate code points */
4288             const U8 * s = (U8*)STRING(scan);
4289
4290             /* Search for fixed substrings supports EXACT only. */
4291             if (flags & SCF_DO_SUBSTR) {
4292                 assert(data);
4293                 scan_commit(pRExC_state, data, minlenp, is_inf);
4294             }
4295             if (UTF) {
4296                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
4297                 l = utf8_length(s, s + l);
4298             }
4299             if (unfolded_multi_char) {
4300                 RExC_seen |= REG_UNFOLDED_MULTI_SEEN;
4301             }
4302             min += l - min_subtract;
4303             assert (min >= 0);
4304             delta += min_subtract;
4305             if (flags & SCF_DO_SUBSTR) {
4306                 data->pos_min += l - min_subtract;
4307                 if (data->pos_min < 0) {
4308                     data->pos_min = 0;
4309                 }
4310                 data->pos_delta += min_subtract;
4311                 if (min_subtract) {
4312                     data->longest = &(data->longest_float);
4313                 }
4314             }
4315
4316             if (OP(scan) != EXACTFL && flags & SCF_DO_STCLASS_AND) {
4317                 ssc_clear_locale(data->start_class);
4318             }
4319
4320             if (! UTF) {
4321
4322                 /* We punt and assume can match anything if the node begins
4323                  * with a multi-character fold.  Things are complicated.  For
4324                  * example, /ffi/i could match any of:
4325                  *  "\N{LATIN SMALL LIGATURE FFI}"
4326                  *  "\N{LATIN SMALL LIGATURE FF}I"
4327                  *  "F\N{LATIN SMALL LIGATURE FI}"
4328                  *  plus several other things; and making sure we have all the
4329                  *  possibilities is hard. */
4330                 if (is_MULTI_CHAR_FOLD_latin1_safe(s, s + STR_LEN(scan))) {
4331                     EXACTF_invlist =
4332                              _add_range_to_invlist(EXACTF_invlist, 0, UV_MAX);
4333                 }
4334                 else {
4335
4336                     /* Any Latin1 range character can potentially match any
4337                      * other depending on the locale */
4338                     if (OP(scan) == EXACTFL) {
4339                         _invlist_union(EXACTF_invlist, PL_Latin1,
4340                                                               &EXACTF_invlist);
4341                     }
4342                     else {
4343                         /* But otherwise, it matches at least itself.  We can
4344                          * quickly tell if it has a distinct fold, and if so,
4345                          * it matches that as well */
4346                         EXACTF_invlist = add_cp_to_invlist(EXACTF_invlist, uc);
4347                         if (IS_IN_SOME_FOLD_L1(uc)) {
4348                             EXACTF_invlist = add_cp_to_invlist(EXACTF_invlist,
4349                                                            PL_fold_latin1[uc]);
4350                         }
4351                     }
4352
4353                     /* Some characters match above-Latin1 ones under /i.  This
4354                      * is true of EXACTFL ones when the locale is UTF-8 */
4355                     if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(uc)
4356                         && (! isASCII(uc) || (OP(scan) != EXACTFA
4357                                             && OP(scan) != EXACTFA_NO_TRIE)))
4358                     {
4359                         add_above_Latin1_folds(pRExC_state,
4360                                                (U8) uc,
4361                                                &EXACTF_invlist);
4362                     }
4363                 }
4364             }
4365             else {  /* Pattern is UTF-8 */
4366                 U8 folded[UTF8_MAX_FOLD_CHAR_EXPAND * UTF8_MAXBYTES_CASE + 1] = { '\0' };
4367                 STRLEN foldlen = UTF8SKIP(s);
4368                 const U8* e = s + STR_LEN(scan);
4369                 SV** listp;
4370
4371                 /* The only code points that aren't folded in a UTF EXACTFish
4372                  * node are are the problematic ones in EXACTFL nodes */
4373                 if (OP(scan) == EXACTFL
4374                     && is_PROBLEMATIC_LOCALE_FOLDEDS_START_cp(uc))
4375                 {
4376                     /* We need to check for the possibility that this EXACTFL
4377                      * node begins with a multi-char fold.  Therefore we fold
4378                      * the first few characters of it so that we can make that
4379                      * check */
4380                     U8 *d = folded;
4381                     int i;
4382
4383                     for (i = 0; i < UTF8_MAX_FOLD_CHAR_EXPAND && s < e; i++) {
4384                         if (isASCII(*s)) {
4385                             *(d++) = (U8) toFOLD(*s);
4386                             s++;
4387                         }
4388                         else {
4389                             STRLEN len;
4390                             to_utf8_fold(s, d, &len);
4391                             d += len;
4392                             s += UTF8SKIP(s);
4393                         }
4394                     }
4395
4396                     /* And set up so the code below that looks in this folded
4397                      * buffer instead of the node's string */
4398                     e = d;
4399                     foldlen = UTF8SKIP(folded);
4400                     s = folded;
4401                 }
4402
4403                 /* When we reach here 's' points to the fold of the first
4404                  * character(s) of the node; and 'e' points to far enough along
4405                  * the folded string to be just past any possible multi-char
4406                  * fold. 'foldlen' is the length in bytes of the first
4407                  * character in 's'
4408                  *
4409                  * Unlike the non-UTF-8 case, the macro for determining if a
4410                  * string is a multi-char fold requires all the characters to
4411                  * already be folded.  This is because of all the complications
4412                  * if not.  Note that they are folded anyway, except in EXACTFL
4413                  * nodes.  Like the non-UTF case above, we punt if the node
4414                  * begins with a multi-char fold  */
4415
4416                 if (is_MULTI_CHAR_FOLD_utf8_safe(s, e)) {
4417                     EXACTF_invlist =
4418                              _add_range_to_invlist(EXACTF_invlist, 0, UV_MAX);
4419                 }
4420                 else {  /* Single char fold */
4421
4422                     /* It matches all the things that fold to it, which are
4423                      * found in PL_utf8_foldclosures (including itself) */
4424                     EXACTF_invlist = add_cp_to_invlist(EXACTF_invlist, uc);
4425                     if (! PL_utf8_foldclosures) {
4426                         _load_PL_utf8_foldclosures();
4427                     }
4428                     if ((listp = hv_fetch(PL_utf8_foldclosures,
4429                                         (char *) s, foldlen, FALSE)))
4430                     {
4431                         AV* list = (AV*) *listp;
4432                         IV k;
4433                         for (k = 0; k <= av_tindex(list); k++) {
4434                             SV** c_p = av_fetch(list, k, FALSE);
4435                             UV c;
4436                             assert(c_p);
4437
4438                             c = SvUV(*c_p);
4439
4440                             /* /aa doesn't allow folds between ASCII and non- */
4441                             if ((OP(scan) == EXACTFA || OP(scan) == EXACTFA_NO_TRIE)
4442                                 && isASCII(c) != isASCII(uc))
4443                             {
4444                                 continue;
4445                             }
4446
4447                             EXACTF_invlist = add_cp_to_invlist(EXACTF_invlist, c);
4448                         }
4449                     }
4450                 }
4451             }
4452             if (flags & SCF_DO_STCLASS_AND) {
4453                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4454                 ANYOF_POSIXL_ZERO(data->start_class);
4455                 ssc_intersection(data->start_class, EXACTF_invlist, FALSE);
4456             }
4457             else if (flags & SCF_DO_STCLASS_OR) {
4458                 ssc_union(data->start_class, EXACTF_invlist, FALSE);
4459                 ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4460
4461                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
4462                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4463             }
4464             flags &= ~SCF_DO_STCLASS;
4465             SvREFCNT_dec(EXACTF_invlist);
4466         }
4467         else if (REGNODE_VARIES(OP(scan))) {
4468             SSize_t mincount, maxcount, minnext, deltanext, pos_before = 0;
4469             I32 fl = 0, f = flags;
4470             regnode * const oscan = scan;
4471             regnode_ssc this_class;
4472             regnode_ssc *oclass = NULL;
4473             I32 next_is_eval = 0;
4474
4475             switch (PL_regkind[OP(scan)]) {
4476             case WHILEM:                /* End of (?:...)* . */
4477                 scan = NEXTOPER(scan);
4478                 goto finish;
4479             case PLUS:
4480                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
4481                     next = NEXTOPER(scan);
4482                     if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
4483                         mincount = 1;
4484                         maxcount = REG_INFTY;
4485                         next = regnext(scan);
4486                         scan = NEXTOPER(scan);
4487                         goto do_curly;
4488                     }
4489                 }
4490                 if (flags & SCF_DO_SUBSTR)
4491                     data->pos_min++;
4492                 min++;
4493                 /* FALLTHROUGH */
4494             case STAR:
4495                 if (flags & SCF_DO_STCLASS) {
4496                     mincount = 0;
4497                     maxcount = REG_INFTY;
4498                     next = regnext(scan);
4499                     scan = NEXTOPER(scan);
4500                     goto do_curly;
4501                 }
4502                 if (flags & SCF_DO_SUBSTR) {
4503                     scan_commit(pRExC_state, data, minlenp, is_inf);
4504                     /* Cannot extend fixed substrings */
4505                     data->longest = &(data->longest_float);
4506                 }
4507                 is_inf = is_inf_internal = 1;
4508                 scan = regnext(scan);
4509                 goto optimize_curly_tail;
4510             case CURLY:
4511                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
4512                     && (scan->flags == stopparen))
4513                 {
4514                     mincount = 1;
4515                     maxcount = 1;
4516                 } else {
4517                     mincount = ARG1(scan);
4518                     maxcount = ARG2(scan);
4519                 }
4520                 next = regnext(scan);
4521                 if (OP(scan) == CURLYX) {
4522                     I32 lp = (data ? *(data->last_closep) : 0);
4523                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
4524                 }
4525                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
4526                 next_is_eval = (OP(scan) == EVAL);
4527               do_curly:
4528                 if (flags & SCF_DO_SUBSTR) {
4529                     if (mincount == 0)
4530                         scan_commit(pRExC_state, data, minlenp, is_inf);
4531                     /* Cannot extend fixed substrings */
4532                     pos_before = data->pos_min;
4533                 }
4534                 if (data) {
4535                     fl = data->flags;
4536                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
4537                     if (is_inf)
4538                         data->flags |= SF_IS_INF;
4539                 }
4540                 if (flags & SCF_DO_STCLASS) {
4541                     ssc_init(pRExC_state, &this_class);
4542                     oclass = data->start_class;
4543                     data->start_class = &this_class;
4544                     f |= SCF_DO_STCLASS_AND;
4545                     f &= ~SCF_DO_STCLASS_OR;
4546                 }
4547                 /* Exclude from super-linear cache processing any {n,m}
4548                    regops for which the combination of input pos and regex
4549                    pos is not enough information to determine if a match
4550                    will be possible.
4551
4552                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
4553                    regex pos at the \s*, the prospects for a match depend not
4554                    only on the input position but also on how many (bar\s*)
4555                    repeats into the {4,8} we are. */
4556                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
4557                     f &= ~SCF_WHILEM_VISITED_POS;
4558
4559                 /* This will finish on WHILEM, setting scan, or on NULL: */
4560                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
4561                                   last, data, stopparen, recursed_depth, NULL,
4562                                   (mincount == 0
4563                                    ? (f & ~SCF_DO_SUBSTR)
4564                                    : f)
4565                                   ,depth+1);
4566
4567                 if (flags & SCF_DO_STCLASS)
4568                     data->start_class = oclass;
4569                 if (mincount == 0 || minnext == 0) {
4570                     if (flags & SCF_DO_STCLASS_OR) {
4571                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
4572                     }
4573                     else if (flags & SCF_DO_STCLASS_AND) {
4574                         /* Switch to OR mode: cache the old value of
4575                          * data->start_class */
4576                         INIT_AND_WITHP;
4577                         StructCopy(data->start_class, and_withp, regnode_ssc);
4578                         flags &= ~SCF_DO_STCLASS_AND;
4579                         StructCopy(&this_class, data->start_class, regnode_ssc);
4580                         flags |= SCF_DO_STCLASS_OR;
4581                         ANYOF_FLAGS(data->start_class)
4582                                                 |= SSC_MATCHES_EMPTY_STRING;
4583                     }
4584                 } else {                /* Non-zero len */
4585                     if (flags & SCF_DO_STCLASS_OR) {
4586                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
4587                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4588                     }
4589                     else if (flags & SCF_DO_STCLASS_AND)
4590                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
4591                     flags &= ~SCF_DO_STCLASS;
4592                 }
4593                 if (!scan)              /* It was not CURLYX, but CURLY. */
4594                     scan = next;
4595                 if (!(flags & SCF_TRIE_DOING_RESTUDY)
4596                     /* ? quantifier ok, except for (?{ ... }) */
4597                     && (next_is_eval || !(mincount == 0 && maxcount == 1))
4598                     && (minnext == 0) && (deltanext == 0)
4599                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
4600                     && maxcount <= REG_INFTY/3) /* Complement check for big
4601                                                    count */
4602                 {
4603                     /* Fatal warnings may leak the regexp without this: */
4604                     SAVEFREESV(RExC_rx_sv);
4605                     ckWARNreg(RExC_parse,
4606                             "Quantifier unexpected on zero-length expression");
4607                     (void)ReREFCNT_inc(RExC_rx_sv);
4608                 }
4609
4610                 min += minnext * mincount;
4611                 is_inf_internal |= deltanext == SSize_t_MAX
4612                          || (maxcount == REG_INFTY && minnext + deltanext > 0);
4613                 is_inf |= is_inf_internal;
4614                 if (is_inf) {
4615                     delta = SSize_t_MAX;
4616                 } else {
4617                     delta += (minnext + deltanext) * maxcount
4618                              - minnext * mincount;
4619                 }
4620                 /* Try powerful optimization CURLYX => CURLYN. */
4621                 if (  OP(oscan) == CURLYX && data
4622                       && data->flags & SF_IN_PAR
4623                       && !(data->flags & SF_HAS_EVAL)
4624                       && !deltanext && minnext == 1 ) {
4625                     /* Try to optimize to CURLYN.  */
4626                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
4627                     regnode * const nxt1 = nxt;
4628 #ifdef DEBUGGING
4629                     regnode *nxt2;
4630 #endif
4631
4632                     /* Skip open. */
4633                     nxt = regnext(nxt);
4634                     if (!REGNODE_SIMPLE(OP(nxt))
4635                         && !(PL_regkind[OP(nxt)] == EXACT
4636                              && STR_LEN(nxt) == 1))
4637                         goto nogo;
4638 #ifdef DEBUGGING
4639                     nxt2 = nxt;
4640 #endif
4641                     nxt = regnext(nxt);
4642                     if (OP(nxt) != CLOSE)
4643                         goto nogo;
4644                     if (RExC_open_parens) {
4645                         RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
4646                         RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
4647                     }
4648                     /* Now we know that nxt2 is the only contents: */
4649                     oscan->flags = (U8)ARG(nxt);
4650                     OP(oscan) = CURLYN;
4651                     OP(nxt1) = NOTHING; /* was OPEN. */
4652
4653 #ifdef DEBUGGING
4654                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
4655                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
4656                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
4657                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
4658                     OP(nxt + 1) = OPTIMIZED; /* was count. */
4659                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
4660 #endif
4661                 }
4662               nogo:
4663
4664                 /* Try optimization CURLYX => CURLYM. */
4665                 if (  OP(oscan) == CURLYX && data
4666                       && !(data->flags & SF_HAS_PAR)
4667                       && !(data->flags & SF_HAS_EVAL)
4668                       && !deltanext     /* atom is fixed width */
4669                       && minnext != 0   /* CURLYM can't handle zero width */
4670
4671                          /* Nor characters whose fold at run-time may be
4672                           * multi-character */
4673                       && ! (RExC_seen & REG_UNFOLDED_MULTI_SEEN)
4674                 ) {
4675                     /* XXXX How to optimize if data == 0? */
4676                     /* Optimize to a simpler form.  */
4677                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
4678                     regnode *nxt2;
4679
4680                     OP(oscan) = CURLYM;
4681                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
4682                             && (OP(nxt2) != WHILEM))
4683                         nxt = nxt2;
4684                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
4685                     /* Need to optimize away parenths. */
4686                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
4687                         /* Set the parenth number.  */
4688                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
4689
4690                         oscan->flags = (U8)ARG(nxt);
4691                         if (RExC_open_parens) {
4692                             RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
4693                             RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
4694                         }
4695                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
4696                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
4697
4698 #ifdef DEBUGGING
4699                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
4700                         OP(nxt + 1) = OPTIMIZED; /* was count. */
4701                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
4702                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
4703 #endif
4704 #if 0
4705                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
4706                             regnode *nnxt = regnext(nxt1);
4707                             if (nnxt == nxt) {
4708                                 if (reg_off_by_arg[OP(nxt1)])
4709                                     ARG_SET(nxt1, nxt2 - nxt1);
4710                                 else if (nxt2 - nxt1 < U16_MAX)
4711                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
4712                                 else
4713                                     OP(nxt) = NOTHING;  /* Cannot beautify */
4714                             }
4715                             nxt1 = nnxt;
4716                         }
4717 #endif
4718                         /* Optimize again: */
4719                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
4720                                     NULL, stopparen, recursed_depth, NULL, 0,depth+1);
4721                     }
4722                     else
4723                         oscan->flags = 0;
4724                 }
4725                 else if ((OP(oscan) == CURLYX)
4726                          && (flags & SCF_WHILEM_VISITED_POS)
4727                          /* See the comment on a similar expression above.
4728                             However, this time it's not a subexpression
4729                             we care about, but the expression itself. */
4730                          && (maxcount == REG_INFTY)
4731                          && data && ++data->whilem_c < 16) {
4732                     /* This stays as CURLYX, we can put the count/of pair. */
4733                     /* Find WHILEM (as in regexec.c) */
4734                     regnode *nxt = oscan + NEXT_OFF(oscan);
4735
4736                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
4737                         nxt += ARG(nxt);
4738                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
4739                         | (RExC_whilem_seen << 4)); /* On WHILEM */
4740                 }
4741                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
4742                     pars++;
4743                 if (flags & SCF_DO_SUBSTR) {
4744                     SV *last_str = NULL;
4745                     STRLEN last_chrs = 0;
4746                     int counted = mincount != 0;
4747
4748                     if (data->last_end > 0 && mincount != 0) { /* Ends with a
4749                                                                   string. */
4750                         SSize_t b = pos_before >= data->last_start_min
4751                             ? pos_before : data->last_start_min;
4752                         STRLEN l;
4753                         const char * const s = SvPV_const(data->last_found, l);
4754                         SSize_t old = b - data->last_start_min;
4755
4756                         if (UTF)
4757                             old = utf8_hop((U8*)s, old) - (U8*)s;
4758                         l -= old;
4759                         /* Get the added string: */
4760                         last_str = newSVpvn_utf8(s  + old, l, UTF);
4761                         last_chrs = UTF ? utf8_length((U8*)(s + old),
4762                                             (U8*)(s + old + l)) : l;
4763                         if (deltanext == 0 && pos_before == b) {
4764                             /* What was added is a constant string */
4765                             if (mincount > 1) {
4766
4767                                 SvGROW(last_str, (mincount * l) + 1);
4768                                 repeatcpy(SvPVX(last_str) + l,
4769                                           SvPVX_const(last_str), l,
4770                                           mincount - 1);
4771                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
4772                                 /* Add additional parts. */
4773                                 SvCUR_set(data->last_found,
4774                                           SvCUR(data->last_found) - l);
4775                                 sv_catsv(data->last_found, last_str);
4776                                 {
4777                                     SV * sv = data->last_found;
4778                                     MAGIC *mg =
4779                                         SvUTF8(sv) && SvMAGICAL(sv) ?
4780                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
4781                                     if (mg && mg->mg_len >= 0)
4782                                         mg->mg_len += last_chrs * (mincount-1);
4783                                 }
4784                                 last_chrs *= mincount;
4785                                 data->last_end += l * (mincount - 1);
4786                             }
4787                         } else {
4788                             /* start offset must point into the last copy */
4789                             data->last_start_min += minnext * (mincount - 1);
4790                             data->last_start_max += is_inf ? SSize_t_MAX
4791                                 : (maxcount - 1) * (minnext + data->pos_delta);
4792                         }
4793                     }
4794                     /* It is counted once already... */
4795                     data->pos_min += minnext * (mincount - counted);
4796 #if 0
4797 PerlIO_printf(Perl_debug_log, "counted=%"UVuf" deltanext=%"UVuf
4798                               " SSize_t_MAX=%"UVuf" minnext=%"UVuf
4799                               " maxcount=%"UVuf" mincount=%"UVuf"\n",
4800     (UV)counted, (UV)deltanext, (UV)SSize_t_MAX, (UV)minnext, (UV)maxcount,
4801     (UV)mincount);
4802 if (deltanext != SSize_t_MAX)
4803 PerlIO_printf(Perl_debug_log, "LHS=%"UVuf" RHS=%"UVuf"\n",
4804     (UV)(-counted * deltanext + (minnext + deltanext) * maxcount
4805           - minnext * mincount), (UV)(SSize_t_MAX - data->pos_delta));
4806 #endif
4807                     if (deltanext == SSize_t_MAX
4808                         || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= SSize_t_MAX - data->pos_delta)
4809                         data->pos_delta = SSize_t_MAX;
4810                     else
4811                         data->pos_delta += - counted * deltanext +
4812                         (minnext + deltanext) * maxcount - minnext * mincount;
4813                     if (mincount != maxcount) {
4814                          /* Cannot extend fixed substrings found inside
4815                             the group.  */
4816                         scan_commit(pRExC_state, data, minlenp, is_inf);
4817                         if (mincount && last_str) {
4818                             SV * const sv = data->last_found;
4819                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4820                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
4821
4822                             if (mg)
4823                                 mg->mg_len = -1;
4824                             sv_setsv(sv, last_str);
4825                             data->last_end = data->pos_min;
4826                             data->last_start_min = data->pos_min - last_chrs;
4827                             data->last_start_max = is_inf
4828                                 ? SSize_t_MAX
4829                                 : data->pos_min + data->pos_delta - last_chrs;
4830                         }
4831                         data->longest = &(data->longest_float);
4832                     }
4833                     SvREFCNT_dec(last_str);
4834                 }
4835                 if (data && (fl & SF_HAS_EVAL))
4836                     data->flags |= SF_HAS_EVAL;
4837               optimize_curly_tail:
4838                 if (OP(oscan) != CURLYX) {
4839                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
4840                            && NEXT_OFF(next))
4841                         NEXT_OFF(oscan) += NEXT_OFF(next);
4842                 }
4843                 continue;
4844
4845             default:
4846 #ifdef DEBUGGING
4847                 Perl_croak(aTHX_ "panic: unexpected varying REx opcode %d",
4848                                                                     OP(scan));
4849 #endif
4850             case REF:
4851             case CLUMP:
4852                 if (flags & SCF_DO_SUBSTR) {
4853                     /* Cannot expect anything... */
4854                     scan_commit(pRExC_state, data, minlenp, is_inf);
4855                     data->longest = &(data->longest_float);
4856                 }
4857                 is_inf = is_inf_internal = 1;
4858                 if (flags & SCF_DO_STCLASS_OR) {
4859                     if (OP(scan) == CLUMP) {
4860                         /* Actually is any start char, but very few code points
4861                          * aren't start characters */
4862                         ssc_match_all_cp(data->start_class);
4863                     }
4864                     else {
4865                         ssc_anything(data->start_class);
4866                     }
4867                 }
4868                 flags &= ~SCF_DO_STCLASS;
4869                 break;
4870             }
4871         }
4872         else if (OP(scan) == LNBREAK) {
4873             if (flags & SCF_DO_STCLASS) {
4874                 if (flags & SCF_DO_STCLASS_AND) {
4875                     ssc_intersection(data->start_class,
4876                                     PL_XPosix_ptrs[_CC_VERTSPACE], FALSE);
4877                     ssc_clear_locale(data->start_class);
4878                     ANYOF_FLAGS(data->start_class)
4879                                                 &= ~SSC_MATCHES_EMPTY_STRING;
4880                 }
4881                 else if (flags & SCF_DO_STCLASS_OR) {
4882                     ssc_union(data->start_class,
4883                               PL_XPosix_ptrs[_CC_VERTSPACE],
4884                               FALSE);
4885                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4886
4887                     /* See commit msg for
4888                      * 749e076fceedeb708a624933726e7989f2302f6a */
4889                     ANYOF_FLAGS(data->start_class)
4890                                                 &= ~SSC_MATCHES_EMPTY_STRING;
4891                 }
4892                 flags &= ~SCF_DO_STCLASS;
4893             }
4894             min++;
4895             delta++;    /* Because of the 2 char string cr-lf */
4896             if (flags & SCF_DO_SUBSTR) {
4897                 /* Cannot expect anything... */
4898                 scan_commit(pRExC_state, data, minlenp, is_inf);
4899                 data->pos_min += 1;
4900                 data->pos_delta += 1;
4901                 data->longest = &(data->longest_float);
4902             }
4903         }
4904         else if (REGNODE_SIMPLE(OP(scan))) {
4905
4906             if (flags & SCF_DO_SUBSTR) {
4907                 scan_commit(pRExC_state, data, minlenp, is_inf);
4908                 data->pos_min++;
4909             }
4910             min++;
4911             if (flags & SCF_DO_STCLASS) {
4912                 bool invert = 0;
4913                 SV* my_invlist = sv_2mortal(_new_invlist(0));
4914                 U8 namedclass;
4915
4916                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
4917                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4918
4919                 /* Some of the logic below assumes that switching
4920                    locale on will only add false positives. */
4921                 switch (OP(scan)) {
4922
4923                 default:
4924 #ifdef DEBUGGING
4925                    Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d",
4926                                                                      OP(scan));
4927 #endif
4928                 case CANY:
4929                 case SANY:
4930                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4931                         ssc_match_all_cp(data->start_class);
4932                     break;
4933
4934                 case REG_ANY:
4935                     {
4936                         SV* REG_ANY_invlist = _new_invlist(2);
4937                         REG_ANY_invlist = add_cp_to_invlist(REG_ANY_invlist,
4938                                                             '\n');
4939                         if (flags & SCF_DO_STCLASS_OR) {
4940                             ssc_union(data->start_class,
4941                                       REG_ANY_invlist,
4942                                       TRUE /* TRUE => invert, hence all but \n
4943                                             */
4944                                       );
4945                         }
4946                         else if (flags & SCF_DO_STCLASS_AND) {
4947                             ssc_intersection(data->start_class,
4948                                              REG_ANY_invlist,
4949                                              TRUE  /* TRUE => invert */
4950                                              );
4951                             ssc_clear_locale(data->start_class);
4952                         }
4953                         SvREFCNT_dec_NN(REG_ANY_invlist);
4954                     }
4955                     break;
4956
4957                 case ANYOF:
4958                     if (flags & SCF_DO_STCLASS_AND)
4959                         ssc_and(pRExC_state, data->start_class,
4960                                 (regnode_charclass *) scan);
4961                     else
4962                         ssc_or(pRExC_state, data->start_class,
4963                                                           (regnode_charclass *) scan);
4964                     break;
4965
4966                 case NPOSIXL:
4967                     invert = 1;
4968                     /* FALLTHROUGH */
4969
4970                 case POSIXL:
4971                     namedclass = classnum_to_namedclass(FLAGS(scan)) + invert;
4972                     if (flags & SCF_DO_STCLASS_AND) {
4973                         bool was_there = cBOOL(
4974                                           ANYOF_POSIXL_TEST(data->start_class,
4975                                                                  namedclass));
4976                         ANYOF_POSIXL_ZERO(data->start_class);
4977                         if (was_there) {    /* Do an AND */
4978                             ANYOF_POSIXL_SET(data->start_class, namedclass);
4979                         }
4980                         /* No individual code points can now match */
4981                         data->start_class->invlist
4982                                                 = sv_2mortal(_new_invlist(0));
4983                     }
4984                     else {
4985                         int complement = namedclass + ((invert) ? -1 : 1);
4986
4987                         assert(flags & SCF_DO_STCLASS_OR);
4988
4989                         /* If the complement of this class was already there,
4990                          * the result is that they match all code points,
4991                          * (\d + \D == everything).  Remove the classes from
4992                          * future consideration.  Locale is not relevant in
4993                          * this case */
4994                         if (ANYOF_POSIXL_TEST(data->start_class, complement)) {
4995                             ssc_match_all_cp(data->start_class);
4996                             ANYOF_POSIXL_CLEAR(data->start_class, namedclass);
4997                             ANYOF_POSIXL_CLEAR(data->start_class, complement);
4998                         }
4999                         else {  /* The usual case; just add this class to the
5000                                    existing set */
5001                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5002                         }
5003                     }
5004                     break;
5005
5006                 case NPOSIXA:   /* For these, we always know the exact set of
5007                                    what's matched */
5008                     invert = 1;
5009                     /* FALLTHROUGH */
5010                 case POSIXA:
5011                     if (FLAGS(scan) == _CC_ASCII) {
5012                         my_invlist = PL_XPosix_ptrs[_CC_ASCII];
5013                     }
5014                     else {
5015                         _invlist_intersection(PL_XPosix_ptrs[FLAGS(scan)],
5016                                               PL_XPosix_ptrs[_CC_ASCII],
5017                                               &my_invlist);
5018                     }
5019                     goto join_posix;
5020
5021                 case NPOSIXD:
5022                 case NPOSIXU:
5023                     invert = 1;
5024                     /* FALLTHROUGH */
5025                 case POSIXD:
5026                 case POSIXU:
5027                     my_invlist = invlist_clone(PL_XPosix_ptrs[FLAGS(scan)]);
5028
5029                     /* NPOSIXD matches all upper Latin1 code points unless the
5030                      * target string being matched is UTF-8, which is
5031                      * unknowable until match time.  Since we are going to
5032                      * invert, we want to get rid of all of them so that the
5033                      * inversion will match all */
5034                     if (OP(scan) == NPOSIXD) {
5035                         _invlist_subtract(my_invlist, PL_UpperLatin1,
5036                                           &my_invlist);
5037                     }
5038
5039                   join_posix:
5040
5041                     if (flags & SCF_DO_STCLASS_AND) {
5042                         ssc_intersection(data->start_class, my_invlist, invert);
5043                         ssc_clear_locale(data->start_class);
5044                     }
5045                     else {
5046                         assert(flags & SCF_DO_STCLASS_OR);
5047                         ssc_union(data->start_class, my_invlist, invert);
5048                     }
5049                 }
5050                 if (flags & SCF_DO_STCLASS_OR)
5051                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5052                 flags &= ~SCF_DO_STCLASS;
5053             }
5054         }
5055         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
5056             data->flags |= (OP(scan) == MEOL
5057                             ? SF_BEFORE_MEOL
5058                             : SF_BEFORE_SEOL);
5059             scan_commit(pRExC_state, data, minlenp, is_inf);
5060
5061         }
5062         else if (  PL_regkind[OP(scan)] == BRANCHJ
5063                  /* Lookbehind, or need to calculate parens/evals/stclass: */
5064                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
5065                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM))
5066         {
5067             if ( OP(scan) == UNLESSM &&
5068                  scan->flags == 0 &&
5069                  OP(NEXTOPER(NEXTOPER(scan))) == NOTHING &&
5070                  OP(regnext(NEXTOPER(NEXTOPER(scan)))) == SUCCEED
5071             ) {
5072                 regnode *opt;
5073                 regnode *upto= regnext(scan);
5074                 DEBUG_PARSE_r({
5075                     SV * const mysv_val=sv_newmortal();
5076                     DEBUG_STUDYDATA("OPFAIL",data,depth);
5077
5078                     /*DEBUG_PARSE_MSG("opfail");*/
5079                     regprop(RExC_rx, mysv_val, upto, NULL);
5080                     PerlIO_printf(Perl_debug_log,
5081                         "~ replace with OPFAIL pointed at %s (%"IVdf") offset %"IVdf"\n",
5082                         SvPV_nolen_const(mysv_val),
5083                         (IV)REG_NODE_NUM(upto),
5084                         (IV)(upto - scan)
5085                     );
5086                 });
5087                 OP(scan) = OPFAIL;
5088                 NEXT_OFF(scan) = upto - scan;
5089                 for (opt= scan + 1; opt < upto ; opt++)
5090                     OP(opt) = OPTIMIZED;
5091                 scan= upto;
5092                 continue;
5093             }
5094             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5095                 || OP(scan) == UNLESSM )
5096             {
5097                 /* Negative Lookahead/lookbehind
5098                    In this case we can't do fixed string optimisation.
5099                 */
5100
5101                 SSize_t deltanext, minnext, fake = 0;
5102                 regnode *nscan;
5103                 regnode_ssc intrnl;
5104                 int f = 0;
5105
5106                 data_fake.flags = 0;
5107                 if (data) {
5108                     data_fake.whilem_c = data->whilem_c;
5109                     data_fake.last_closep = data->last_closep;
5110                 }
5111                 else
5112                     data_fake.last_closep = &fake;
5113                 data_fake.pos_delta = delta;
5114                 if ( flags & SCF_DO_STCLASS && !scan->flags
5115                      && OP(scan) == IFMATCH ) { /* Lookahead */
5116                     ssc_init(pRExC_state, &intrnl);
5117                     data_fake.start_class = &intrnl;
5118                     f |= SCF_DO_STCLASS_AND;
5119                 }
5120                 if (flags & SCF_WHILEM_VISITED_POS)
5121                     f |= SCF_WHILEM_VISITED_POS;
5122                 next = regnext(scan);
5123                 nscan = NEXTOPER(NEXTOPER(scan));
5124                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
5125                                       last, &data_fake, stopparen,
5126                                       recursed_depth, NULL, f, depth+1);
5127                 if (scan->flags) {
5128                     if (deltanext) {
5129                         FAIL("Variable length lookbehind not implemented");
5130                     }
5131                     else if (minnext > (I32)U8_MAX) {
5132                         FAIL2("Lookbehind longer than %"UVuf" not implemented",
5133                               (UV)U8_MAX);
5134                     }
5135                     scan->flags = (U8)minnext;
5136                 }
5137                 if (data) {
5138                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5139                         pars++;
5140                     if (data_fake.flags & SF_HAS_EVAL)
5141                         data->flags |= SF_HAS_EVAL;
5142                     data->whilem_c = data_fake.whilem_c;
5143                 }
5144                 if (f & SCF_DO_STCLASS_AND) {
5145                     if (flags & SCF_DO_STCLASS_OR) {
5146                         /* OR before, AND after: ideally we would recurse with
5147                          * data_fake to get the AND applied by study of the
5148                          * remainder of the pattern, and then derecurse;
5149                          * *** HACK *** for now just treat as "no information".
5150                          * See [perl #56690].
5151                          */
5152                         ssc_init(pRExC_state, data->start_class);
5153                     }  else {
5154                         /* AND before and after: combine and continue.  These
5155                          * assertions are zero-length, so can match an EMPTY
5156                          * string */
5157                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5158                         ANYOF_FLAGS(data->start_class)
5159                                                    |= SSC_MATCHES_EMPTY_STRING;
5160                     }
5161                 }
5162             }
5163 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5164             else {
5165                 /* Positive Lookahead/lookbehind
5166                    In this case we can do fixed string optimisation,
5167                    but we must be careful about it. Note in the case of
5168                    lookbehind the positions will be offset by the minimum
5169                    length of the pattern, something we won't know about
5170                    until after the recurse.
5171                 */
5172                 SSize_t deltanext, fake = 0;
5173                 regnode *nscan;
5174                 regnode_ssc intrnl;
5175                 int f = 0;
5176                 /* We use SAVEFREEPV so that when the full compile
5177                     is finished perl will clean up the allocated
5178                     minlens when it's all done. This way we don't
5179                     have to worry about freeing them when we know
5180                     they wont be used, which would be a pain.
5181                  */
5182                 SSize_t *minnextp;
5183                 Newx( minnextp, 1, SSize_t );
5184                 SAVEFREEPV(minnextp);
5185
5186                 if (data) {
5187                     StructCopy(data, &data_fake, scan_data_t);
5188                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
5189                         f |= SCF_DO_SUBSTR;
5190                         if (scan->flags)
5191                             scan_commit(pRExC_state, &data_fake, minlenp, is_inf);
5192                         data_fake.last_found=newSVsv(data->last_found);
5193                     }
5194                 }
5195                 else
5196                     data_fake.last_closep = &fake;
5197                 data_fake.flags = 0;
5198                 data_fake.pos_delta = delta;
5199                 if (is_inf)
5200                     data_fake.flags |= SF_IS_INF;
5201                 if ( flags & SCF_DO_STCLASS && !scan->flags
5202                      && OP(scan) == IFMATCH ) { /* Lookahead */
5203                     ssc_init(pRExC_state, &intrnl);
5204                     data_fake.start_class = &intrnl;
5205                     f |= SCF_DO_STCLASS_AND;
5206                 }
5207                 if (flags & SCF_WHILEM_VISITED_POS)
5208                     f |= SCF_WHILEM_VISITED_POS;
5209                 next = regnext(scan);
5210                 nscan = NEXTOPER(NEXTOPER(scan));
5211
5212                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp,
5213                                         &deltanext, last, &data_fake,
5214                                         stopparen, recursed_depth, NULL,
5215                                         f,depth+1);
5216                 if (scan->flags) {
5217                     if (deltanext) {
5218                         FAIL("Variable length lookbehind not implemented");
5219                     }
5220                     else if (*minnextp > (I32)U8_MAX) {
5221                         FAIL2("Lookbehind longer than %"UVuf" not implemented",
5222                               (UV)U8_MAX);
5223                     }
5224                     scan->flags = (U8)*minnextp;
5225                 }
5226
5227                 *minnextp += min;
5228
5229                 if (f & SCF_DO_STCLASS_AND) {
5230                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5231                     ANYOF_FLAGS(data->start_class) |= SSC_MATCHES_EMPTY_STRING;
5232                 }
5233                 if (data) {
5234                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5235                         pars++;
5236                     if (data_fake.flags & SF_HAS_EVAL)
5237                         data->flags |= SF_HAS_EVAL;
5238                     data->whilem_c = data_fake.whilem_c;
5239                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
5240                         if (RExC_rx->minlen<*minnextp)
5241                             RExC_rx->minlen=*minnextp;
5242                         scan_commit(pRExC_state, &data_fake, minnextp, is_inf);
5243                         SvREFCNT_dec_NN(data_fake.last_found);
5244
5245                         if ( data_fake.minlen_fixed != minlenp )
5246                         {
5247                             data->offset_fixed= data_fake.offset_fixed;
5248                             data->minlen_fixed= data_fake.minlen_fixed;
5249                             data->lookbehind_fixed+= scan->flags;
5250                         }
5251                         if ( data_fake.minlen_float != minlenp )
5252                         {
5253                             data->minlen_float= data_fake.minlen_float;
5254                             data->offset_float_min=data_fake.offset_float_min;
5255                             data->offset_float_max=data_fake.offset_float_max;
5256                             data->lookbehind_float+= scan->flags;
5257                         }
5258                     }
5259                 }
5260             }
5261 #endif
5262         }
5263         else if (OP(scan) == OPEN) {
5264             if (stopparen != (I32)ARG(scan))
5265                 pars++;
5266         }
5267         else if (OP(scan) == CLOSE) {
5268             if (stopparen == (I32)ARG(scan)) {
5269                 break;
5270             }
5271             if ((I32)ARG(scan) == is_par) {
5272                 next = regnext(scan);
5273
5274                 if ( next && (OP(next) != WHILEM) && next < last)
5275                     is_par = 0;         /* Disable optimization */
5276             }
5277             if (data)
5278                 *(data->last_closep) = ARG(scan);
5279         }
5280         else if (OP(scan) == EVAL) {
5281                 if (data)
5282                     data->flags |= SF_HAS_EVAL;
5283         }
5284         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
5285             if (flags & SCF_DO_SUBSTR) {
5286                 scan_commit(pRExC_state, data, minlenp, is_inf);
5287                 flags &= ~SCF_DO_SUBSTR;
5288             }
5289             if (data && OP(scan)==ACCEPT) {
5290                 data->flags |= SCF_SEEN_ACCEPT;
5291                 if (stopmin > min)
5292                     stopmin = min;
5293             }
5294         }
5295         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
5296         {
5297                 if (flags & SCF_DO_SUBSTR) {
5298                     scan_commit(pRExC_state, data, minlenp, is_inf);
5299                     data->longest = &(data->longest_float);
5300                 }
5301                 is_inf = is_inf_internal = 1;
5302                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5303                     ssc_anything(data->start_class);
5304                 flags &= ~SCF_DO_STCLASS;
5305         }
5306         else if (OP(scan) == GPOS) {
5307             if (!(RExC_rx->intflags & PREGf_GPOS_FLOAT) &&
5308                 !(delta || is_inf || (data && data->pos_delta)))
5309             {
5310                 if (!(RExC_rx->intflags & PREGf_ANCH) && (flags & SCF_DO_SUBSTR))
5311                     RExC_rx->intflags |= PREGf_ANCH_GPOS;
5312                 if (RExC_rx->gofs < (STRLEN)min)
5313                     RExC_rx->gofs = min;
5314             } else {
5315                 RExC_rx->intflags |= PREGf_GPOS_FLOAT;
5316                 RExC_rx->gofs = 0;
5317             }
5318         }
5319 #ifdef TRIE_STUDY_OPT
5320 #ifdef FULL_TRIE_STUDY
5321         else if (PL_regkind[OP(scan)] == TRIE) {
5322             /* NOTE - There is similar code to this block above for handling
5323                BRANCH nodes on the initial study.  If you change stuff here
5324                check there too. */
5325             regnode *trie_node= scan;
5326             regnode *tail= regnext(scan);
5327             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
5328             SSize_t max1 = 0, min1 = SSize_t_MAX;
5329             regnode_ssc accum;
5330
5331             if (flags & SCF_DO_SUBSTR) { /* XXXX Add !SUSPEND? */
5332                 /* Cannot merge strings after this. */
5333                 scan_commit(pRExC_state, data, minlenp, is_inf);
5334             }
5335             if (flags & SCF_DO_STCLASS)
5336                 ssc_init_zero(pRExC_state, &accum);
5337
5338             if (!trie->jump) {
5339                 min1= trie->minlen;
5340                 max1= trie->maxlen;
5341             } else {
5342                 const regnode *nextbranch= NULL;
5343                 U32 word;
5344
5345                 for ( word=1 ; word <= trie->wordcount ; word++)
5346                 {
5347                     SSize_t deltanext=0, minnext=0, f = 0, fake;
5348                     regnode_ssc this_class;
5349
5350                     data_fake.flags = 0;
5351                     if (data) {
5352                         data_fake.whilem_c = data->whilem_c;
5353                         data_fake.last_closep = data->last_closep;
5354                     }
5355                     else
5356                         data_fake.last_closep = &fake;
5357                     data_fake.pos_delta = delta;
5358                     if (flags & SCF_DO_STCLASS) {
5359                         ssc_init(pRExC_state, &this_class);
5360                         data_fake.start_class = &this_class;
5361                         f = SCF_DO_STCLASS_AND;
5362                     }
5363                     if (flags & SCF_WHILEM_VISITED_POS)
5364                         f |= SCF_WHILEM_VISITED_POS;
5365
5366                     if (trie->jump[word]) {
5367                         if (!nextbranch)
5368                             nextbranch = trie_node + trie->jump[0];
5369                         scan= trie_node + trie->jump[word];
5370                         /* We go from the jump point to the branch that follows
5371                            it. Note this means we need the vestigal unused
5372                            branches even though they arent otherwise used. */
5373                         minnext = study_chunk(pRExC_state, &scan, minlenp,
5374                             &deltanext, (regnode *)nextbranch, &data_fake,
5375                             stopparen, recursed_depth, NULL, f,depth+1);
5376                     }
5377                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
5378                         nextbranch= regnext((regnode*)nextbranch);
5379
5380                     if (min1 > (SSize_t)(minnext + trie->minlen))
5381                         min1 = minnext + trie->minlen;
5382                     if (deltanext == SSize_t_MAX) {
5383                         is_inf = is_inf_internal = 1;
5384                         max1 = SSize_t_MAX;
5385                     } else if (max1 < (SSize_t)(minnext + deltanext + trie->maxlen))
5386                         max1 = minnext + deltanext + trie->maxlen;
5387
5388                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5389                         pars++;
5390                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
5391                         if ( stopmin > min + min1)
5392                             stopmin = min + min1;
5393                         flags &= ~SCF_DO_SUBSTR;
5394                         if (data)
5395                             data->flags |= SCF_SEEN_ACCEPT;
5396                     }
5397                     if (data) {
5398                         if (data_fake.flags & SF_HAS_EVAL)
5399                             data->flags |= SF_HAS_EVAL;
5400                         data->whilem_c = data_fake.whilem_c;
5401                     }
5402                     if (flags & SCF_DO_STCLASS)
5403                         ssc_or(pRExC_state, &accum, (regnode_charclass *) &this_class);
5404                 }
5405             }
5406             if (flags & SCF_DO_SUBSTR) {
5407                 data->pos_min += min1;
5408                 data->pos_delta += max1 - min1;
5409                 if (max1 != min1 || is_inf)
5410                     data->longest = &(data->longest_float);
5411             }
5412             min += min1;
5413             delta += max1 - min1;
5414             if (flags & SCF_DO_STCLASS_OR) {
5415                 ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &accum);
5416                 if (min1) {
5417                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5418                     flags &= ~SCF_DO_STCLASS;
5419                 }
5420             }
5421             else if (flags & SCF_DO_STCLASS_AND) {
5422                 if (min1) {
5423                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
5424                     flags &= ~SCF_DO_STCLASS;
5425                 }
5426                 else {
5427                     /* Switch to OR mode: cache the old value of
5428                      * data->start_class */
5429                     INIT_AND_WITHP;
5430                     StructCopy(data->start_class, and_withp, regnode_ssc);
5431                     flags &= ~SCF_DO_STCLASS_AND;
5432                     StructCopy(&accum, data->start_class, regnode_ssc);
5433                     flags |= SCF_DO_STCLASS_OR;
5434                 }
5435             }
5436             scan= tail;
5437             continue;
5438         }
5439 #else
5440         else if (PL_regkind[OP(scan)] == TRIE) {
5441             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
5442             U8*bang=NULL;
5443
5444             min += trie->minlen;
5445             delta += (trie->maxlen - trie->minlen);
5446             flags &= ~SCF_DO_STCLASS; /* xxx */
5447             if (flags & SCF_DO_SUBSTR) {
5448                 /* Cannot expect anything... */
5449                 scan_commit(pRExC_state, data, minlenp, is_inf);
5450                 data->pos_min += trie->minlen;
5451                 data->pos_delta += (trie->maxlen - trie->minlen);
5452                 if (trie->maxlen != trie->minlen)
5453                     data->longest = &(data->longest_float);
5454             }
5455             if (trie->jump) /* no more substrings -- for now /grr*/
5456                flags &= ~SCF_DO_SUBSTR;
5457         }
5458 #endif /* old or new */
5459 #endif /* TRIE_STUDY_OPT */
5460
5461         /* Else: zero-length, ignore. */
5462         scan = regnext(scan);
5463     }
5464     /* If we are exiting a recursion we can unset its recursed bit
5465      * and allow ourselves to enter it again - no danger of an
5466      * infinite loop there.
5467     if (stopparen > -1 && recursed) {
5468         DEBUG_STUDYDATA("unset:", data,depth);
5469         PAREN_UNSET( recursed, stopparen);
5470     }
5471     */
5472     if (frame) {
5473         DEBUG_STUDYDATA("frame-end:",data,depth);
5474         DEBUG_PEEP("fend", scan, depth);
5475         /* restore previous context */
5476         last = frame->last;
5477         scan = frame->next;
5478         stopparen = frame->stop;
5479         recursed_depth = frame->prev_recursed_depth;
5480         depth = depth - 1;
5481
5482         frame = frame->prev;
5483         goto fake_study_recurse;
5484     }
5485
5486   finish:
5487     assert(!frame);
5488     DEBUG_STUDYDATA("pre-fin:",data,depth);
5489
5490     *scanp = scan;
5491     *deltap = is_inf_internal ? SSize_t_MAX : delta;
5492
5493     if (flags & SCF_DO_SUBSTR && is_inf)
5494         data->pos_delta = SSize_t_MAX - data->pos_min;
5495     if (is_par > (I32)U8_MAX)
5496         is_par = 0;
5497     if (is_par && pars==1 && data) {
5498         data->flags |= SF_IN_PAR;
5499         data->flags &= ~SF_HAS_PAR;
5500     }
5501     else if (pars && data) {
5502         data->flags |= SF_HAS_PAR;
5503         data->flags &= ~SF_IN_PAR;
5504     }
5505     if (flags & SCF_DO_STCLASS_OR)
5506         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5507     if (flags & SCF_TRIE_RESTUDY)
5508         data->flags |=  SCF_TRIE_RESTUDY;
5509
5510     DEBUG_STUDYDATA("post-fin:",data,depth);
5511
5512     {
5513         SSize_t final_minlen= min < stopmin ? min : stopmin;
5514
5515         if (!(RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) && (RExC_maxlen < final_minlen + delta)) {
5516             RExC_maxlen = final_minlen + delta;
5517         }
5518         return final_minlen;
5519     }
5520     /* not-reached */
5521 }
5522
5523 STATIC U32
5524 S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n)
5525 {
5526     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
5527
5528     PERL_ARGS_ASSERT_ADD_DATA;
5529
5530     Renewc(RExC_rxi->data,
5531            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
5532            char, struct reg_data);
5533     if(count)
5534         Renew(RExC_rxi->data->what, count + n, U8);
5535     else
5536         Newx(RExC_rxi->data->what, n, U8);
5537     RExC_rxi->data->count = count + n;
5538     Copy(s, RExC_rxi->data->what + count, n, U8);
5539     return count;
5540 }
5541
5542 /*XXX: todo make this not included in a non debugging perl, but appears to be
5543  * used anyway there, in 'use re' */
5544 #ifndef PERL_IN_XSUB_RE
5545 void
5546 Perl_reginitcolors(pTHX)
5547 {
5548     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
5549     if (s) {
5550         char *t = savepv(s);
5551         int i = 0;
5552         PL_colors[0] = t;
5553         while (++i < 6) {
5554             t = strchr(t, '\t');
5555             if (t) {
5556                 *t = '\0';
5557                 PL_colors[i] = ++t;
5558             }
5559             else
5560                 PL_colors[i] = t = (char *)"";
5561         }
5562     } else {
5563         int i = 0;
5564         while (i < 6)
5565             PL_colors[i++] = (char *)"";
5566     }
5567     PL_colorset = 1;
5568 }
5569 #endif
5570
5571
5572 #ifdef TRIE_STUDY_OPT
5573 #define CHECK_RESTUDY_GOTO_butfirst(dOsomething)            \
5574     STMT_START {                                            \
5575         if (                                                \
5576               (data.flags & SCF_TRIE_RESTUDY)               \
5577               && ! restudied++                              \
5578         ) {                                                 \
5579             dOsomething;                                    \
5580             goto reStudy;                                   \
5581         }                                                   \
5582     } STMT_END
5583 #else
5584 #define CHECK_RESTUDY_GOTO_butfirst
5585 #endif
5586
5587 /*
5588  * pregcomp - compile a regular expression into internal code
5589  *
5590  * Decides which engine's compiler to call based on the hint currently in
5591  * scope
5592  */
5593
5594 #ifndef PERL_IN_XSUB_RE
5595
5596 /* return the currently in-scope regex engine (or the default if none)  */
5597
5598 regexp_engine const *
5599 Perl_current_re_engine(pTHX)
5600 {
5601     if (IN_PERL_COMPILETIME) {
5602         HV * const table = GvHV(PL_hintgv);
5603         SV **ptr;
5604
5605         if (!table || !(PL_hints & HINT_LOCALIZE_HH))
5606             return &PL_core_reg_engine;
5607         ptr = hv_fetchs(table, "regcomp", FALSE);
5608         if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
5609             return &PL_core_reg_engine;
5610         return INT2PTR(regexp_engine*,SvIV(*ptr));
5611     }
5612     else {
5613         SV *ptr;
5614         if (!PL_curcop->cop_hints_hash)
5615             return &PL_core_reg_engine;
5616         ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
5617         if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
5618             return &PL_core_reg_engine;
5619         return INT2PTR(regexp_engine*,SvIV(ptr));
5620     }
5621 }
5622
5623
5624 REGEXP *
5625 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
5626 {
5627     regexp_engine const *eng = current_re_engine();
5628     GET_RE_DEBUG_FLAGS_DECL;
5629
5630     PERL_ARGS_ASSERT_PREGCOMP;
5631
5632     /* Dispatch a request to compile a regexp to correct regexp engine. */
5633     DEBUG_COMPILE_r({
5634         PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
5635                         PTR2UV(eng));
5636     });
5637     return CALLREGCOMP_ENG(eng, pattern, flags);
5638 }
5639 #endif
5640
5641 /* public(ish) entry point for the perl core's own regex compiling code.
5642  * It's actually a wrapper for Perl_re_op_compile that only takes an SV
5643  * pattern rather than a list of OPs, and uses the internal engine rather
5644  * than the current one */
5645
5646 REGEXP *
5647 Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
5648 {
5649     SV *pat = pattern; /* defeat constness! */
5650     PERL_ARGS_ASSERT_RE_COMPILE;
5651     return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
5652 #ifdef PERL_IN_XSUB_RE
5653                                 &my_reg_engine,
5654 #else
5655                                 &PL_core_reg_engine,
5656 #endif
5657                                 NULL, NULL, rx_flags, 0);
5658 }
5659
5660
5661 /* upgrade pattern pat_p of length plen_p to UTF8, and if there are code
5662  * blocks, recalculate the indices. Update pat_p and plen_p in-place to
5663  * point to the realloced string and length.
5664  *
5665  * This is essentially a copy of Perl_bytes_to_utf8() with the code index
5666  * stuff added */
5667
5668 static void
5669 S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state,
5670                     char **pat_p, STRLEN *plen_p, int num_code_blocks)
5671 {
5672     U8 *const src = (U8*)*pat_p;
5673     U8 *dst, *d;
5674     int n=0;
5675     STRLEN s = 0;
5676     bool do_end = 0;
5677     GET_RE_DEBUG_FLAGS_DECL;
5678
5679     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
5680         "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
5681
5682     Newx(dst, *plen_p * 2 + 1, U8);
5683     d = dst;
5684
5685     while (s < *plen_p) {
5686         append_utf8_from_native_byte(src[s], &d);
5687         if (n < num_code_blocks) {
5688             if (!do_end && pRExC_state->code_blocks[n].start == s) {
5689                 pRExC_state->code_blocks[n].start = d - dst - 1;
5690                 assert(*(d - 1) == '(');
5691                 do_end = 1;
5692             }
5693             else if (do_end && pRExC_state->code_blocks[n].end == s) {
5694                 pRExC_state->code_blocks[n].end = d - dst - 1;
5695                 assert(*(d - 1) == ')');
5696                 do_end = 0;
5697                 n++;
5698             }
5699         }
5700         s++;
5701     }
5702     *d = '\0';
5703     *plen_p = d - dst;
5704     *pat_p = (char*) dst;
5705     SAVEFREEPV(*pat_p);
5706     RExC_orig_utf8 = RExC_utf8 = 1;
5707 }
5708
5709
5710
5711 /* S_concat_pat(): concatenate a list of args to the pattern string pat,
5712  * while recording any code block indices, and handling overloading,
5713  * nested qr// objects etc.  If pat is null, it will allocate a new
5714  * string, or just return the first arg, if there's only one.
5715  *
5716  * Returns the malloced/updated pat.
5717  * patternp and pat_count is the array of SVs to be concatted;
5718  * oplist is the optional list of ops that generated the SVs;
5719  * recompile_p is a pointer to a boolean that will be set if
5720  *   the regex will need to be recompiled.
5721  * delim, if non-null is an SV that will be inserted between each element
5722  */
5723
5724 static SV*
5725 S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
5726                 SV *pat, SV ** const patternp, int pat_count,
5727                 OP *oplist, bool *recompile_p, SV *delim)
5728 {
5729     SV **svp;
5730     int n = 0;
5731     bool use_delim = FALSE;
5732     bool alloced = FALSE;
5733
5734     /* if we know we have at least two args, create an empty string,
5735      * then concatenate args to that. For no args, return an empty string */
5736     if (!pat && pat_count != 1) {
5737         pat = newSVpvs("");
5738         SAVEFREESV(pat);
5739         alloced = TRUE;
5740     }
5741
5742     for (svp = patternp; svp < patternp + pat_count; svp++) {
5743         SV *sv;
5744         SV *rx  = NULL;
5745         STRLEN orig_patlen = 0;
5746         bool code = 0;
5747         SV *msv = use_delim ? delim : *svp;
5748         if (!msv) msv = &PL_sv_undef;
5749
5750         /* if we've got a delimiter, we go round the loop twice for each
5751          * svp slot (except the last), using the delimiter the second
5752          * time round */
5753         if (use_delim) {
5754             svp--;
5755             use_delim = FALSE;
5756         }
5757         else if (delim)
5758             use_delim = TRUE;
5759
5760         if (SvTYPE(msv) == SVt_PVAV) {
5761             /* we've encountered an interpolated array within
5762              * the pattern, e.g. /...@a..../. Expand the list of elements,
5763              * then recursively append elements.
5764              * The code in this block is based on S_pushav() */
5765
5766             AV *const av = (AV*)msv;
5767             const SSize_t maxarg = AvFILL(av) + 1;
5768             SV **array;
5769
5770             if (oplist) {
5771                 assert(oplist->op_type == OP_PADAV
5772                     || oplist->op_type == OP_RV2AV);
5773                 oplist = OP_SIBLING(oplist);
5774             }
5775
5776             if (SvRMAGICAL(av)) {
5777                 SSize_t i;
5778
5779                 Newx(array, maxarg, SV*);
5780                 SAVEFREEPV(array);
5781                 for (i=0; i < maxarg; i++) {
5782                     SV ** const svp = av_fetch(av, i, FALSE);
5783                     array[i] = svp ? *svp : &PL_sv_undef;
5784                 }
5785             }
5786             else
5787                 array = AvARRAY(av);
5788
5789             pat = S_concat_pat(aTHX_ pRExC_state, pat,
5790                                 array, maxarg, NULL, recompile_p,
5791                                 /* $" */
5792                                 GvSV((gv_fetchpvs("\"", GV_ADDMULTI, SVt_PV))));
5793
5794             continue;
5795         }
5796
5797
5798         /* we make the assumption here that each op in the list of
5799          * op_siblings maps to one SV pushed onto the stack,
5800          * except for code blocks, with have both an OP_NULL and
5801          * and OP_CONST.
5802          * This allows us to match up the list of SVs against the
5803          * list of OPs to find the next code block.
5804          *
5805          * Note that       PUSHMARK PADSV PADSV ..
5806          * is optimised to
5807          *                 PADRANGE PADSV  PADSV  ..
5808          * so the alignment still works. */
5809
5810         if (oplist) {
5811             if (oplist->op_type == OP_NULL
5812                 && (oplist->op_flags & OPf_SPECIAL))
5813             {
5814                 assert(n < pRExC_state->num_code_blocks);
5815                 pRExC_state->code_blocks[n].start = pat ? SvCUR(pat) : 0;
5816                 pRExC_state->code_blocks[n].block = oplist;
5817                 pRExC_state->code_blocks[n].src_regex = NULL;
5818                 n++;
5819                 code = 1;
5820                 oplist = OP_SIBLING(oplist); /* skip CONST */
5821                 assert(oplist);
5822             }
5823             oplist = OP_SIBLING(oplist);;
5824         }
5825
5826         /* apply magic and QR overloading to arg */
5827
5828         SvGETMAGIC(msv);
5829         if (SvROK(msv) && SvAMAGIC(msv)) {
5830             SV *sv = AMG_CALLunary(msv, regexp_amg);
5831             if (sv) {
5832                 if (SvROK(sv))
5833                     sv = SvRV(sv);
5834                 if (SvTYPE(sv) != SVt_REGEXP)
5835                     Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
5836                 msv = sv;
5837             }
5838         }
5839
5840         /* try concatenation overload ... */
5841         if (pat && (SvAMAGIC(pat) || SvAMAGIC(msv)) &&
5842                 (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
5843         {
5844             sv_setsv(pat, sv);
5845             /* overloading involved: all bets are off over literal
5846              * code. Pretend we haven't seen it */
5847             pRExC_state->num_code_blocks -= n;
5848             n = 0;
5849         }
5850         else  {
5851             /* ... or failing that, try "" overload */
5852             while (SvAMAGIC(msv)
5853                     && (sv = AMG_CALLunary(msv, string_amg))
5854                     && sv != msv
5855                     &&  !(   SvROK(msv)
5856                           && SvROK(sv)
5857                           && SvRV(msv) == SvRV(sv))
5858             ) {
5859                 msv = sv;
5860                 SvGETMAGIC(msv);
5861             }
5862             if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
5863                 msv = SvRV(msv);
5864
5865             if (pat) {
5866                 /* this is a partially unrolled
5867                  *     sv_catsv_nomg(pat, msv);
5868                  * that allows us to adjust code block indices if
5869                  * needed */
5870                 STRLEN dlen;
5871                 char *dst = SvPV_force_nomg(pat, dlen);
5872                 orig_patlen = dlen;
5873                 if (SvUTF8(msv) && !SvUTF8(pat)) {
5874                     S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &dst, &dlen, n);
5875                     sv_setpvn(pat, dst, dlen);
5876                     SvUTF8_on(pat);
5877                 }
5878                 sv_catsv_nomg(pat, msv);
5879                 rx = msv;
5880             }
5881             else
5882                 pat = msv;
5883
5884             if (code)
5885                 pRExC_state->code_blocks[n-1].end = SvCUR(pat)-1;
5886         }
5887
5888         /* extract any code blocks within any embedded qr//'s */
5889         if (rx && SvTYPE(rx) == SVt_REGEXP
5890             && RX_ENGINE((REGEXP*)rx)->op_comp)
5891         {
5892
5893             RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
5894             if (ri->num_code_blocks) {
5895                 int i;
5896                 /* the presence of an embedded qr// with code means
5897                  * we should always recompile: the text of the
5898                  * qr// may not have changed, but it may be a
5899                  * different closure than last time */
5900                 *recompile_p = 1;
5901                 Renew(pRExC_state->code_blocks,
5902                     pRExC_state->num_code_blocks + ri->num_code_blocks,
5903                     struct reg_code_block);
5904                 pRExC_state->num_code_blocks += ri->num_code_blocks;
5905
5906                 for (i=0; i < ri->num_code_blocks; i++) {
5907                     struct reg_code_block *src, *dst;
5908                     STRLEN offset =  orig_patlen
5909                         + ReANY((REGEXP *)rx)->pre_prefix;
5910                     assert(n < pRExC_state->num_code_blocks);
5911                     src = &ri->code_blocks[i];
5912                     dst = &pRExC_state->code_blocks[n];
5913                     dst->start      = src->start + offset;
5914                     dst->end        = src->end   + offset;
5915                     dst->block      = src->block;
5916                     dst->src_regex  = (REGEXP*) SvREFCNT_inc( (SV*)
5917                                             src->src_regex
5918                                                 ? src->src_regex
5919                                                 : (REGEXP*)rx);
5920                     n++;
5921                 }
5922             }
5923         }
5924     }
5925     /* avoid calling magic multiple times on a single element e.g. =~ $qr */
5926     if (alloced)
5927         SvSETMAGIC(pat);
5928
5929     return pat;
5930 }
5931
5932
5933
5934 /* see if there are any run-time code blocks in the pattern.
5935  * False positives are allowed */
5936
5937 static bool
5938 S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
5939                     char *pat, STRLEN plen)
5940 {
5941     int n = 0;
5942     STRLEN s;
5943     
5944     PERL_UNUSED_CONTEXT;
5945
5946     for (s = 0; s < plen; s++) {
5947         if (n < pRExC_state->num_code_blocks
5948             && s == pRExC_state->code_blocks[n].start)
5949         {
5950             s = pRExC_state->code_blocks[n].end;
5951             n++;
5952             continue;
5953         }
5954         /* TODO ideally should handle [..], (#..), /#.../x to reduce false
5955          * positives here */
5956         if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' &&
5957             (pat[s+2] == '{'
5958                 || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{'))
5959         )
5960             return 1;
5961     }
5962     return 0;
5963 }
5964
5965 /* Handle run-time code blocks. We will already have compiled any direct
5966  * or indirect literal code blocks. Now, take the pattern 'pat' and make a
5967  * copy of it, but with any literal code blocks blanked out and
5968  * appropriate chars escaped; then feed it into
5969  *
5970  *    eval "qr'modified_pattern'"
5971  *
5972  * For example,
5973  *
5974  *       a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
5975  *
5976  * becomes
5977  *
5978  *    qr'a\\bc_______________________def\'ghi\\\\jkl(?{"this is runtime"})mno'
5979  *
5980  * After eval_sv()-ing that, grab any new code blocks from the returned qr
5981  * and merge them with any code blocks of the original regexp.
5982  *
5983  * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
5984  * instead, just save the qr and return FALSE; this tells our caller that
5985  * the original pattern needs upgrading to utf8.
5986  */
5987
5988 static bool
5989 S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
5990     char *pat, STRLEN plen)
5991 {
5992     SV *qr;
5993
5994     GET_RE_DEBUG_FLAGS_DECL;
5995
5996     if (pRExC_state->runtime_code_qr) {
5997         /* this is the second time we've been called; this should
5998          * only happen if the main pattern got upgraded to utf8
5999          * during compilation; re-use the qr we compiled first time
6000          * round (which should be utf8 too)
6001          */
6002         qr = pRExC_state->runtime_code_qr;
6003         pRExC_state->runtime_code_qr = NULL;
6004         assert(RExC_utf8 && SvUTF8(qr));
6005     }
6006     else {
6007         int n = 0;
6008         STRLEN s;
6009         char *p, *newpat;
6010         int newlen = plen + 6; /* allow for "qr''x\0" extra chars */
6011         SV *sv, *qr_ref;
6012         dSP;
6013
6014         /* determine how many extra chars we need for ' and \ escaping */
6015         for (s = 0; s < plen; s++) {
6016             if (pat[s] == '\'' || pat[s] == '\\')
6017                 newlen++;
6018         }
6019
6020         Newx(newpat, newlen, char);
6021         p = newpat;
6022         *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
6023
6024         for (s = 0; s < plen; s++) {
6025             if (n < pRExC_state->num_code_blocks
6026                 && s == pRExC_state->code_blocks[n].start)
6027             {
6028                 /* blank out literal code block */
6029                 assert(pat[s] == '(');
6030                 while (s <= pRExC_state->code_blocks[n].end) {
6031                     *p++ = '_';
6032                     s++;
6033                 }
6034                 s--;
6035                 n++;
6036                 continue;
6037             }
6038             if (pat[s] == '\'' || pat[s] == '\\')
6039                 *p++ = '\\';
6040             *p++ = pat[s];
6041         }
6042         *p++ = '\'';
6043         if (pRExC_state->pm_flags & RXf_PMf_EXTENDED)
6044             *p++ = 'x';
6045         *p++ = '\0';
6046         DEBUG_COMPILE_r({
6047             PerlIO_printf(Perl_debug_log,
6048                 "%sre-parsing pattern for runtime code:%s %s\n",
6049                 PL_colors[4],PL_colors[5],newpat);
6050         });
6051
6052         sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
6053         Safefree(newpat);
6054
6055         ENTER;
6056         SAVETMPS;
6057         PUSHSTACKi(PERLSI_REQUIRE);
6058         /* G_RE_REPARSING causes the toker to collapse \\ into \ when
6059          * parsing qr''; normally only q'' does this. It also alters
6060          * hints handling */
6061         eval_sv(sv, G_SCALAR|G_RE_REPARSING);
6062         SvREFCNT_dec_NN(sv);
6063         SPAGAIN;
6064         qr_ref = POPs;
6065         PUTBACK;
6066         {
6067             SV * const errsv = ERRSV;
6068             if (SvTRUE_NN(errsv))
6069             {
6070                 Safefree(pRExC_state->code_blocks);
6071                 /* use croak_sv ? */
6072                 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
6073             }
6074         }
6075         assert(SvROK(qr_ref));
6076         qr = SvRV(qr_ref);
6077         assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
6078         /* the leaving below frees the tmp qr_ref.
6079          * Give qr a life of its own */
6080         SvREFCNT_inc(qr);
6081         POPSTACK;
6082         FREETMPS;
6083         LEAVE;
6084
6085     }
6086
6087     if (!RExC_utf8 && SvUTF8(qr)) {
6088         /* first time through; the pattern got upgraded; save the
6089          * qr for the next time through */
6090         assert(!pRExC_state->runtime_code_qr);
6091         pRExC_state->runtime_code_qr = qr;
6092         return 0;
6093     }
6094
6095
6096     /* extract any code blocks within the returned qr//  */
6097
6098
6099     /* merge the main (r1) and run-time (r2) code blocks into one */
6100     {
6101         RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
6102         struct reg_code_block *new_block, *dst;
6103         RExC_state_t * const r1 = pRExC_state; /* convenient alias */
6104         int i1 = 0, i2 = 0;
6105
6106         if (!r2->num_code_blocks) /* we guessed wrong */
6107         {
6108             SvREFCNT_dec_NN(qr);
6109             return 1;
6110         }
6111
6112         Newx(new_block,
6113             r1->num_code_blocks + r2->num_code_blocks,
6114             struct reg_code_block);
6115         dst = new_block;
6116
6117         while (    i1 < r1->num_code_blocks
6118                 || i2 < r2->num_code_blocks)
6119         {
6120             struct reg_code_block *src;
6121             bool is_qr = 0;
6122
6123             if (i1 == r1->num_code_blocks) {
6124                 src = &r2->code_blocks[i2++];
6125                 is_qr = 1;
6126             }
6127             else if (i2 == r2->num_code_blocks)
6128                 src = &r1->code_blocks[i1++];
6129             else if (  r1->code_blocks[i1].start
6130                      < r2->code_blocks[i2].start)
6131             {
6132                 src = &r1->code_blocks[i1++];
6133                 assert(src->end < r2->code_blocks[i2].start);
6134             }
6135             else {
6136                 assert(  r1->code_blocks[i1].start
6137                        > r2->code_blocks[i2].start);
6138                 src = &r2->code_blocks[i2++];
6139                 is_qr = 1;
6140                 assert(src->end < r1->code_blocks[i1].start);
6141             }
6142
6143             assert(pat[src->start] == '(');
6144             assert(pat[src->end]   == ')');
6145             dst->start      = src->start;
6146             dst->end        = src->end;
6147             dst->block      = src->block;
6148             dst->src_regex  = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
6149                                     : src->src_regex;
6150             dst++;
6151         }
6152         r1->num_code_blocks += r2->num_code_blocks;
6153         Safefree(r1->code_blocks);
6154         r1->code_blocks = new_block;
6155     }
6156
6157     SvREFCNT_dec_NN(qr);
6158     return 1;
6159 }
6160
6161
6162 STATIC bool
6163 S_setup_longest(pTHX_ RExC_state_t *pRExC_state, SV* sv_longest,
6164                       SV** rx_utf8, SV** rx_substr, SSize_t* rx_end_shift,
6165                       SSize_t lookbehind, SSize_t offset, SSize_t *minlen,
6166                       STRLEN longest_length, bool eol, bool meol)
6167 {
6168     /* This is the common code for setting up the floating and fixed length
6169      * string data extracted from Perl_re_op_compile() below.  Returns a boolean
6170      * as to whether succeeded or not */
6171
6172     I32 t;
6173     SSize_t ml;
6174
6175     if (! (longest_length
6176            || (eol /* Can't have SEOL and MULTI */
6177                && (! meol || (RExC_flags & RXf_PMf_MULTILINE)))
6178           )
6179             /* See comments for join_exact for why REG_UNFOLDED_MULTI_SEEN */
6180         || (RExC_seen & REG_UNFOLDED_MULTI_SEEN))
6181     {
6182         return FALSE;
6183     }
6184
6185     /* copy the information about the longest from the reg_scan_data
6186         over to the program. */
6187     if (SvUTF8(sv_longest)) {
6188         *rx_utf8 = sv_longest;
6189         *rx_substr = NULL;
6190     } else {
6191         *rx_substr = sv_longest;
6192         *rx_utf8 = NULL;
6193     }
6194     /* end_shift is how many chars that must be matched that
6195         follow this item. We calculate it ahead of time as once the
6196         lookbehind offset is added in we lose the ability to correctly
6197         calculate it.*/
6198     ml = minlen ? *(minlen) : (SSize_t)longest_length;
6199     *rx_end_shift = ml - offset
6200         - longest_length + (SvTAIL(sv_longest) != 0)
6201         + lookbehind;
6202
6203     t = (eol/* Can't have SEOL and MULTI */
6204          && (! meol || (RExC_flags & RXf_PMf_MULTILINE)));
6205     fbm_compile(sv_longest, t ? FBMcf_TAIL : 0);
6206
6207     return TRUE;
6208 }
6209
6210 /*
6211  * Perl_re_op_compile - the perl internal RE engine's function to compile a
6212  * regular expression into internal code.
6213  * The pattern may be passed either as:
6214  *    a list of SVs (patternp plus pat_count)
6215  *    a list of OPs (expr)
6216  * If both are passed, the SV list is used, but the OP list indicates
6217  * which SVs are actually pre-compiled code blocks
6218  *
6219  * The SVs in the list have magic and qr overloading applied to them (and
6220  * the list may be modified in-place with replacement SVs in the latter
6221  * case).
6222  *
6223  * If the pattern hasn't changed from old_re, then old_re will be
6224  * returned.
6225  *
6226  * eng is the current engine. If that engine has an op_comp method, then
6227  * handle directly (i.e. we assume that op_comp was us); otherwise, just
6228  * do the initial concatenation of arguments and pass on to the external
6229  * engine.
6230  *
6231  * If is_bare_re is not null, set it to a boolean indicating whether the
6232  * arg list reduced (after overloading) to a single bare regex which has
6233  * been returned (i.e. /$qr/).
6234  *
6235  * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
6236  *
6237  * pm_flags contains the PMf_* flags, typically based on those from the
6238  * pm_flags field of the related PMOP. Currently we're only interested in
6239  * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL.
6240  *
6241  * We can't allocate space until we know how big the compiled form will be,
6242  * but we can't compile it (and thus know how big it is) until we've got a
6243  * place to put the code.  So we cheat:  we compile it twice, once with code
6244  * generation turned off and size counting turned on, and once "for real".
6245  * This also means that we don't allocate space until we are sure that the
6246  * thing really will compile successfully, and we never have to move the
6247  * code and thus invalidate pointers into it.  (Note that it has to be in
6248  * one piece because free() must be able to free it all.) [NB: not true in perl]
6249  *
6250  * Beware that the optimization-preparation code in here knows about some
6251  * of the structure of the compiled regexp.  [I'll say.]
6252  */
6253
6254 REGEXP *
6255 Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
6256                     OP *expr, const regexp_engine* eng, REGEXP *old_re,
6257                      bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags)
6258 {
6259     REGEXP *rx;
6260     struct regexp *r;
6261     regexp_internal *ri;
6262     STRLEN plen;
6263     char *exp;
6264     regnode *scan;
6265     I32 flags;
6266     SSize_t minlen = 0;
6267     U32 rx_flags;
6268     SV *pat;
6269     SV *code_blocksv = NULL;
6270     SV** new_patternp = patternp;
6271
6272     /* these are all flags - maybe they should be turned
6273      * into a single int with different bit masks */
6274     I32 sawlookahead = 0;
6275     I32 sawplus = 0;
6276     I32 sawopen = 0;
6277     I32 sawminmod = 0;
6278
6279     regex_charset initial_charset = get_regex_charset(orig_rx_flags);
6280     bool recompile = 0;
6281     bool runtime_code = 0;
6282     scan_data_t data;
6283     RExC_state_t RExC_state;
6284     RExC_state_t * const pRExC_state = &RExC_state;
6285 #ifdef TRIE_STUDY_OPT
6286     int restudied = 0;
6287     RExC_state_t copyRExC_state;
6288 #endif
6289     GET_RE_DEBUG_FLAGS_DECL;
6290
6291     PERL_ARGS_ASSERT_RE_OP_COMPILE;
6292
6293     DEBUG_r(if (!PL_colorset) reginitcolors());
6294
6295 #ifndef PERL_IN_XSUB_RE
6296     /* Initialize these here instead of as-needed, as is quick and avoids
6297      * having to test them each time otherwise */
6298     if (! PL_AboveLatin1) {
6299         PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
6300         PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
6301         PL_UpperLatin1 = _new_invlist_C_array(UpperLatin1_invlist);
6302         PL_utf8_foldable = _new_invlist_C_array(_Perl_Any_Folds_invlist);
6303         PL_HasMultiCharFold =
6304                        _new_invlist_C_array(_Perl_Folds_To_Multi_Char_invlist);
6305
6306         /* This is calculated here, because the Perl program that generates the
6307          * static global ones doesn't currently have access to
6308          * NUM_ANYOF_CODE_POINTS */
6309         PL_InBitmap = _new_invlist(2);
6310         PL_InBitmap = _add_range_to_invlist(PL_InBitmap, 0,
6311                                                     NUM_ANYOF_CODE_POINTS - 1);
6312     }
6313 #endif
6314
6315     pRExC_state->code_blocks = NULL;
6316     pRExC_state->num_code_blocks = 0;
6317
6318     if (is_bare_re)
6319         *is_bare_re = FALSE;
6320
6321     if (expr && (expr->op_type == OP_LIST ||
6322                 (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
6323         /* allocate code_blocks if needed */
6324         OP *o;
6325         int ncode = 0;
6326
6327         for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o))
6328             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
6329                 ncode++; /* count of DO blocks */
6330         if (ncode) {
6331             pRExC_state->num_code_blocks = ncode;
6332             Newx(pRExC_state->code_blocks, ncode, struct reg_code_block);
6333         }
6334     }
6335
6336     if (!pat_count) {
6337         /* compile-time pattern with just OP_CONSTs and DO blocks */
6338
6339         int n;
6340         OP *o;
6341
6342         /* find how many CONSTs there are */
6343         assert(expr);
6344         n = 0;
6345         if (expr->op_type == OP_CONST)
6346             n = 1;
6347         else
6348             for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
6349                 if (o->op_type == OP_CONST)
6350                     n++;
6351             }
6352
6353         /* fake up an SV array */
6354
6355         assert(!new_patternp);
6356         Newx(new_patternp, n, SV*);
6357         SAVEFREEPV(new_patternp);
6358         pat_count = n;
6359
6360         n = 0;
6361         if (expr->op_type == OP_CONST)
6362             new_patternp[n] = cSVOPx_sv(expr);
6363         else
6364             for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
6365                 if (o->op_type == OP_CONST)
6366                     new_patternp[n++] = cSVOPo_sv;
6367             }
6368
6369     }
6370
6371     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
6372         "Assembling pattern from %d elements%s\n", pat_count,
6373             orig_rx_flags & RXf_SPLIT ? " for split" : ""));
6374
6375     /* set expr to the first arg op */
6376
6377     if (pRExC_state->num_code_blocks
6378          && expr->op_type != OP_CONST)
6379     {
6380             expr = cLISTOPx(expr)->op_first;
6381             assert(   expr->op_type == OP_PUSHMARK
6382                    || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK)
6383                    || expr->op_type == OP_PADRANGE);
6384             expr = OP_SIBLING(expr);
6385     }
6386
6387     pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count,
6388                         expr, &recompile, NULL);
6389
6390     /* handle bare (possibly after overloading) regex: foo =~ $re */
6391     {
6392         SV *re = pat;
6393         if (SvROK(re))
6394             re = SvRV(re);
6395         if (SvTYPE(re) == SVt_REGEXP) {
6396             if (is_bare_re)
6397                 *is_bare_re = TRUE;
6398             SvREFCNT_inc(re);
6399             Safefree(pRExC_state->code_blocks);
6400             DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
6401                 "Precompiled pattern%s\n",
6402                     orig_rx_flags & RXf_SPLIT ? " for split" : ""));
6403
6404             return (REGEXP*)re;
6405         }
6406     }
6407
6408     exp = SvPV_nomg(pat, plen);
6409
6410     if (!eng->op_comp) {
6411         if ((SvUTF8(pat) && IN_BYTES)
6412                 || SvGMAGICAL(pat) || SvAMAGIC(pat))
6413         {
6414             /* make a temporary copy; either to convert to bytes,
6415              * or to avoid repeating get-magic / overloaded stringify */
6416             pat = newSVpvn_flags(exp, plen, SVs_TEMP |
6417                                         (IN_BYTES ? 0 : SvUTF8(pat)));
6418         }
6419         Safefree(pRExC_state->code_blocks);
6420         return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
6421     }
6422
6423     /* ignore the utf8ness if the pattern is 0 length */
6424     RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
6425     RExC_uni_semantics = 0;
6426     RExC_contains_locale = 0;
6427     RExC_contains_i = 0;
6428     pRExC_state->runtime_code_qr = NULL;
6429
6430     DEBUG_COMPILE_r({
6431             SV *dsv= sv_newmortal();
6432             RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, 60);
6433             PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
6434                           PL_colors[4],PL_colors[5],s);
6435         });
6436
6437   redo_first_pass:
6438     /* we jump here if we upgrade the pattern to utf8 and have to
6439      * recompile */
6440
6441     if ((pm_flags & PMf_USE_RE_EVAL)
6442                 /* this second condition covers the non-regex literal case,
6443                  * i.e.  $foo =~ '(?{})'. */
6444                 || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
6445     )
6446         runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen);
6447
6448     /* return old regex if pattern hasn't changed */
6449     /* XXX: note in the below we have to check the flags as well as the
6450      * pattern.
6451      *
6452      * Things get a touch tricky as we have to compare the utf8 flag
6453      * independently from the compile flags.  */
6454
6455     if (   old_re
6456         && !recompile
6457         && !!RX_UTF8(old_re) == !!RExC_utf8
6458         && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) )
6459         && RX_PRECOMP(old_re)
6460         && RX_PRELEN(old_re) == plen
6461         && memEQ(RX_PRECOMP(old_re), exp, plen)
6462         && !runtime_code /* with runtime code, always recompile */ )
6463     {
6464         Safefree(pRExC_state->code_blocks);
6465         return old_re;
6466     }
6467
6468     rx_flags = orig_rx_flags;
6469
6470     if (rx_flags & PMf_FOLD) {
6471         RExC_contains_i = 1;
6472     }
6473     if (RExC_utf8 && initial_charset == REGEX_DEPENDS_CHARSET) {
6474
6475         /* Set to use unicode semantics if the pattern is in utf8 and has the
6476          * 'depends' charset specified, as it means unicode when utf8  */
6477         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
6478     }
6479
6480     RExC_precomp = exp;
6481     RExC_flags = rx_flags;
6482     RExC_pm_flags = pm_flags;
6483
6484     if (runtime_code) {
6485         if (TAINTING_get && TAINT_get)
6486             Perl_croak(aTHX_ "Eval-group in insecure regular expression");
6487
6488         if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
6489             /* whoops, we have a non-utf8 pattern, whilst run-time code
6490              * got compiled as utf8. Try again with a utf8 pattern */
6491             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
6492                                     pRExC_state->num_code_blocks);
6493             goto redo_first_pass;
6494         }
6495     }
6496     assert(!pRExC_state->runtime_code_qr);
6497
6498     RExC_sawback = 0;
6499
6500     RExC_seen = 0;
6501     RExC_maxlen = 0;
6502     RExC_in_lookbehind = 0;
6503     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
6504     RExC_extralen = 0;
6505     RExC_override_recoding = 0;
6506     RExC_in_multi_char_class = 0;
6507
6508     /* First pass: determine size, legality. */
6509     RExC_parse = exp;
6510     RExC_start = exp;
6511     RExC_end = exp + plen;
6512     RExC_naughty = 0;
6513     RExC_npar = 1;
6514     RExC_nestroot = 0;
6515     RExC_size = 0L;
6516     RExC_emit = (regnode *) &RExC_emit_dummy;
6517     RExC_whilem_seen = 0;
6518     RExC_open_parens = NULL;
6519     RExC_close_parens = NULL;
6520     RExC_opend = NULL;
6521     RExC_paren_names = NULL;
6522 #ifdef DEBUGGING
6523     RExC_paren_name_list = NULL;
6524 #endif
6525     RExC_recurse = NULL;
6526     RExC_study_chunk_recursed = NULL;
6527     RExC_study_chunk_recursed_bytes= 0;
6528     RExC_recurse_count = 0;
6529     pRExC_state->code_index = 0;
6530
6531 #if 0 /* REGC() is (currently) a NOP at the first pass.
6532        * Clever compilers notice this and complain. --jhi */
6533     REGC((U8)REG_MAGIC, (char*)RExC_emit);
6534 #endif
6535     DEBUG_PARSE_r(
6536         PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n");
6537         RExC_lastnum=0;
6538         RExC_lastparse=NULL;
6539     );
6540     /* reg may croak on us, not giving us a chance to free
6541        pRExC_state->code_blocks.  We cannot SAVEFREEPV it now, as we may
6542        need it to survive as long as the regexp (qr/(?{})/).
6543        We must check that code_blocksv is not already set, because we may
6544        have jumped back to restart the sizing pass. */
6545     if (pRExC_state->code_blocks && !code_blocksv) {
6546         code_blocksv = newSV_type(SVt_PV);
6547         SAVEFREESV(code_blocksv);
6548         SvPV_set(code_blocksv, (char *)pRExC_state->code_blocks);
6549         SvLEN_set(code_blocksv, 1); /*sufficient to make sv_clear free it*/
6550     }
6551     if (reg(pRExC_state, 0, &flags,1) == NULL) {
6552         /* It's possible to write a regexp in ascii that represents Unicode
6553         codepoints outside of the byte range, such as via \x{100}. If we
6554         detect such a sequence we have to convert the entire pattern to utf8
6555         and then recompile, as our sizing calculation will have been based
6556         on 1 byte == 1 character, but we will need to use utf8 to encode
6557         at least some part of the pattern, and therefore must convert the whole
6558         thing.
6559         -- dmq */
6560         if (flags & RESTART_UTF8) {
6561             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
6562                                     pRExC_state->num_code_blocks);
6563             goto redo_first_pass;
6564         }
6565         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for sizing pass, flags=%#"UVxf"", (UV) flags);
6566     }
6567     if (code_blocksv)
6568         SvLEN_set(code_blocksv,0); /* no you can't have it, sv_clear */
6569
6570     DEBUG_PARSE_r({
6571         PerlIO_printf(Perl_debug_log,
6572             "Required size %"IVdf" nodes\n"
6573             "Starting second pass (creation)\n",
6574             (IV)RExC_size);
6575         RExC_lastnum=0;
6576         RExC_lastparse=NULL;
6577     });
6578
6579     /* The first pass could have found things that force Unicode semantics */
6580     if ((RExC_utf8 || RExC_uni_semantics)
6581          && get_regex_charset(rx_flags) == REGEX_DEPENDS_CHARSET)
6582     {
6583         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
6584     }
6585
6586     /* Small enough for pointer-storage convention?
6587        If extralen==0, this means that we will not need long jumps. */
6588     if (RExC_size >= 0x10000L && RExC_extralen)
6589         RExC_size += RExC_extralen;
6590     else
6591         RExC_extralen = 0;
6592     if (RExC_whilem_seen > 15)
6593         RExC_whilem_seen = 15;
6594
6595     /* Allocate space and zero-initialize. Note, the two step process
6596        of zeroing when in debug mode, thus anything assigned has to
6597        happen after that */
6598     rx = (REGEXP*) newSV_type(SVt_REGEXP);
6599     r = ReANY(rx);
6600     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
6601          char, regexp_internal);
6602     if ( r == NULL || ri == NULL )
6603         FAIL("Regexp out of space");
6604 #ifdef DEBUGGING
6605     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
6606     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
6607          char);
6608 #else
6609     /* bulk initialize base fields with 0. */
6610     Zero(ri, sizeof(regexp_internal), char);
6611 #endif
6612
6613     /* non-zero initialization begins here */
6614     RXi_SET( r, ri );
6615     r->engine= eng;
6616     r->extflags = rx_flags;
6617     RXp_COMPFLAGS(r) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK;
6618
6619     if (pm_flags & PMf_IS_QR) {
6620         ri->code_blocks = pRExC_state->code_blocks;
6621         ri->num_code_blocks = pRExC_state->num_code_blocks;
6622     }
6623     else
6624     {
6625         int n;
6626         for (n = 0; n < pRExC_state->num_code_blocks; n++)
6627             if (pRExC_state->code_blocks[n].src_regex)
6628                 SAVEFREESV(pRExC_state->code_blocks[n].src_regex);
6629         SAVEFREEPV(pRExC_state->code_blocks);
6630     }
6631
6632     {
6633         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
6634         bool has_charset = (get_regex_charset(r->extflags)
6635                                                     != REGEX_DEPENDS_CHARSET);
6636
6637         /* The caret is output if there are any defaults: if not all the STD
6638          * flags are set, or if no character set specifier is needed */
6639         bool has_default =
6640                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
6641                     || ! has_charset);
6642         bool has_runon = ((RExC_seen & REG_RUN_ON_COMMENT_SEEN)
6643                                                    == REG_RUN_ON_COMMENT_SEEN);
6644         U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD)
6645                             >> RXf_PMf_STD_PMMOD_SHIFT);
6646         const char *fptr = STD_PAT_MODS;        /*"msix"*/
6647         char *p;
6648         /* Allocate for the worst case, which is all the std flags are turned
6649          * on.  If more precision is desired, we could do a population count of
6650          * the flags set.  This could be done with a small lookup table, or by
6651          * shifting, masking and adding, or even, when available, assembly
6652          * language for a machine-language population count.
6653          * We never output a minus, as all those are defaults, so are
6654          * covered by the caret */
6655         const STRLEN wraplen = plen + has_p + has_runon
6656             + has_default       /* If needs a caret */
6657
6658                 /* If needs a character set specifier */
6659             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
6660             + (sizeof(STD_PAT_MODS) - 1)
6661             + (sizeof("(?:)") - 1);
6662
6663         Newx(p, wraplen + 1, char); /* +1 for the ending NUL */
6664         r->xpv_len_u.xpvlenu_pv = p;
6665         if (RExC_utf8)
6666             SvFLAGS(rx) |= SVf_UTF8;
6667         *p++='('; *p++='?';
6668
6669         /* If a default, cover it using the caret */
6670         if (has_default) {
6671             *p++= DEFAULT_PAT_MOD;
6672         }
6673         if (has_charset) {
6674             STRLEN len;
6675             const char* const name = get_regex_charset_name(r->extflags, &len);
6676             Copy(name, p, len, char);
6677             p += len;
6678         }
6679         if (has_p)
6680             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
6681         {
6682             char ch;
6683             while((ch = *fptr++)) {
6684                 if(reganch & 1)
6685                     *p++ = ch;
6686                 reganch >>= 1;
6687             }
6688         }
6689
6690         *p++ = ':';
6691         Copy(RExC_precomp, p, plen, char);
6692         assert ((RX_WRAPPED(rx) - p) < 16);
6693         r->pre_prefix = p - RX_WRAPPED(rx);
6694         p += plen;
6695         if (has_runon)
6696             *p++ = '\n';
6697         *p++ = ')';
6698         *p = 0;
6699         SvCUR_set(rx, p - RX_WRAPPED(rx));
6700     }
6701
6702     r->intflags = 0;
6703     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
6704
6705     /* setup various meta data about recursion, this all requires
6706      * RExC_npar to be correctly set, and a bit later on we clear it */
6707     if (RExC_seen & REG_RECURSE_SEEN) {
6708         Newxz(RExC_open_parens, RExC_npar,regnode *);
6709         SAVEFREEPV(RExC_open_parens);
6710         Newxz(RExC_close_parens,RExC_npar,regnode *);
6711         SAVEFREEPV(RExC_close_parens);
6712     }
6713     if (RExC_seen & (REG_RECURSE_SEEN | REG_GOSTART_SEEN)) {
6714         /* Note, RExC_npar is 1 + the number of parens in a pattern.
6715          * So its 1 if there are no parens. */
6716         RExC_study_chunk_recursed_bytes= (RExC_npar >> 3) +
6717                                          ((RExC_npar & 0x07) != 0);
6718         Newx(RExC_study_chunk_recursed,
6719              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
6720         SAVEFREEPV(RExC_study_chunk_recursed);
6721     }
6722
6723     /* Useful during FAIL. */
6724 #ifdef RE_TRACK_PATTERN_OFFSETS
6725     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
6726     DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
6727                           "%s %"UVuf" bytes for offset annotations.\n",
6728                           ri->u.offsets ? "Got" : "Couldn't get",
6729                           (UV)((2*RExC_size+1) * sizeof(U32))));
6730 #endif
6731     SetProgLen(ri,RExC_size);
6732     RExC_rx_sv = rx;
6733     RExC_rx = r;
6734     RExC_rxi = ri;
6735
6736     /* Second pass: emit code. */
6737     RExC_flags = rx_flags;      /* don't let top level (?i) bleed */
6738     RExC_pm_flags = pm_flags;
6739     RExC_parse = exp;
6740     RExC_end = exp + plen;
6741     RExC_naughty = 0;
6742     RExC_npar = 1;
6743     RExC_emit_start = ri->program;
6744     RExC_emit = ri->program;
6745     RExC_emit_bound = ri->program + RExC_size + 1;
6746     pRExC_state->code_index = 0;
6747
6748     REGC((U8)REG_MAGIC, (char*) RExC_emit++);
6749     if (reg(pRExC_state, 0, &flags,1) == NULL) {
6750         ReREFCNT_dec(rx);
6751         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for generation pass, flags=%#"UVxf"", (UV) flags);
6752     }
6753     /* XXXX To minimize changes to RE engine we always allocate
6754        3-units-long substrs field. */
6755     Newx(r->substrs, 1, struct reg_substr_data);
6756     if (RExC_recurse_count) {
6757         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
6758         SAVEFREEPV(RExC_recurse);
6759     }
6760
6761 reStudy:
6762     r->minlen = minlen = sawlookahead = sawplus = sawopen = sawminmod = 0;
6763     Zero(r->substrs, 1, struct reg_substr_data);
6764     if (RExC_study_chunk_recursed)
6765         Zero(RExC_study_chunk_recursed,
6766              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
6767
6768 #ifdef TRIE_STUDY_OPT
6769     if (!restudied) {
6770         StructCopy(&zero_scan_data, &data, scan_data_t);
6771         copyRExC_state = RExC_state;
6772     } else {
6773         U32 seen=RExC_seen;
6774         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
6775
6776         RExC_state = copyRExC_state;
6777         if (seen & REG_TOP_LEVEL_BRANCHES_SEEN)
6778             RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
6779         else
6780             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES_SEEN;
6781         StructCopy(&zero_scan_data, &data, scan_data_t);
6782     }
6783 #else
6784     StructCopy(&zero_scan_data, &data, scan_data_t);
6785 #endif
6786
6787     /* Dig out information for optimizations. */
6788     r->extflags = RExC_flags; /* was pm_op */
6789     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
6790
6791     if (UTF)
6792         SvUTF8_on(rx);  /* Unicode in it? */
6793     ri->regstclass = NULL;
6794     if (RExC_naughty >= 10)     /* Probably an expensive pattern. */
6795         r->intflags |= PREGf_NAUGHTY;
6796     scan = ri->program + 1;             /* First BRANCH. */
6797
6798     /* testing for BRANCH here tells us whether there is "must appear"
6799        data in the pattern. If there is then we can use it for optimisations */
6800     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)) { /*  Only one top-level choice.
6801                                                   */
6802         SSize_t fake;
6803         STRLEN longest_float_length, longest_fixed_length;
6804         regnode_ssc ch_class; /* pointed to by data */
6805         int stclass_flag;
6806         SSize_t last_close = 0; /* pointed to by data */
6807         regnode *first= scan;
6808         regnode *first_next= regnext(first);
6809         /*
6810          * Skip introductions and multiplicators >= 1
6811          * so that we can extract the 'meat' of the pattern that must
6812          * match in the large if() sequence following.
6813          * NOTE that EXACT is NOT covered here, as it is normally
6814          * picked up by the optimiser separately.
6815          *
6816          * This is unfortunate as the optimiser isnt handling lookahead
6817          * properly currently.
6818          *
6819          */
6820         while ((OP(first) == OPEN && (sawopen = 1)) ||
6821                /* An OR of *one* alternative - should not happen now. */
6822             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
6823             /* for now we can't handle lookbehind IFMATCH*/
6824             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
6825             (OP(first) == PLUS) ||
6826             (OP(first) == MINMOD) ||
6827                /* An {n,m} with n>0 */
6828             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
6829             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
6830         {
6831                 /*
6832                  * the only op that could be a regnode is PLUS, all the rest
6833                  * will be regnode_1 or regnode_2.
6834                  *
6835                  * (yves doesn't think this is true)
6836                  */
6837                 if (OP(first) == PLUS)
6838                     sawplus = 1;
6839                 else {
6840                     if (OP(first) == MINMOD)
6841                         sawminmod = 1;
6842                     first += regarglen[OP(first)];
6843                 }
6844                 first = NEXTOPER(first);
6845                 first_next= regnext(first);
6846         }
6847
6848         /* Starting-point info. */
6849       again:
6850         DEBUG_PEEP("first:",first,0);
6851         /* Ignore EXACT as we deal with it later. */
6852         if (PL_regkind[OP(first)] == EXACT) {
6853             if (OP(first) == EXACT)
6854                 NOOP;   /* Empty, get anchored substr later. */
6855             else
6856                 ri->regstclass = first;
6857         }
6858 #ifdef TRIE_STCLASS
6859         else if (PL_regkind[OP(first)] == TRIE &&
6860                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0)
6861         {
6862             /* this can happen only on restudy */
6863             ri->regstclass = construct_ahocorasick_from_trie(pRExC_state, (regnode *)first, 0);
6864         }
6865 #endif
6866         else if (REGNODE_SIMPLE(OP(first)))
6867             ri->regstclass = first;
6868         else if (PL_regkind[OP(first)] == BOUND ||
6869                  PL_regkind[OP(first)] == NBOUND)
6870             ri->regstclass = first;
6871         else if (PL_regkind[OP(first)] == BOL) {
6872             r->intflags |= (OP(first) == MBOL
6873                            ? PREGf_ANCH_MBOL
6874                            : PREGf_ANCH_SBOL);
6875             first = NEXTOPER(first);
6876             goto again;
6877         }
6878         else if (OP(first) == GPOS) {
6879             r->intflags |= PREGf_ANCH_GPOS;
6880             first = NEXTOPER(first);
6881             goto again;
6882         }
6883         else if ((!sawopen || !RExC_sawback) &&
6884             !sawlookahead &&
6885             (OP(first) == STAR &&
6886             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
6887             !(r->intflags & PREGf_ANCH) && !pRExC_state->num_code_blocks)
6888         {
6889             /* turn .* into ^.* with an implied $*=1 */
6890             const int type =
6891                 (OP(NEXTOPER(first)) == REG_ANY)
6892                     ? PREGf_ANCH_MBOL
6893                     : PREGf_ANCH_SBOL;
6894             r->intflags |= (type | PREGf_IMPLICIT);
6895             first = NEXTOPER(first);
6896             goto again;
6897         }
6898         if (sawplus && !sawminmod && !sawlookahead
6899             && (!sawopen || !RExC_sawback)
6900             && !pRExC_state->num_code_blocks) /* May examine pos and $& */
6901             /* x+ must match at the 1st pos of run of x's */
6902             r->intflags |= PREGf_SKIP;
6903
6904         /* Scan is after the zeroth branch, first is atomic matcher. */
6905 #ifdef TRIE_STUDY_OPT
6906         DEBUG_PARSE_r(
6907             if (!restudied)
6908                 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
6909                               (IV)(first - scan + 1))
6910         );
6911 #else
6912         DEBUG_PARSE_r(
6913             PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
6914                 (IV)(first - scan + 1))
6915         );
6916 #endif
6917
6918
6919         /*
6920         * If there's something expensive in the r.e., find the
6921         * longest literal string that must appear and make it the
6922         * regmust.  Resolve ties in favor of later strings, since
6923         * the regstart check works with the beginning of the r.e.
6924         * and avoiding duplication strengthens checking.  Not a
6925         * strong reason, but sufficient in the absence of others.
6926         * [Now we resolve ties in favor of the earlier string if
6927         * it happens that c_offset_min has been invalidated, since the
6928         * earlier string may buy us something the later one won't.]
6929         */
6930
6931         data.longest_fixed = newSVpvs("");
6932         data.longest_float = newSVpvs("");
6933         data.last_found = newSVpvs("");
6934         data.longest = &(data.longest_fixed);
6935         ENTER_with_name("study_chunk");
6936         SAVEFREESV(data.longest_fixed);
6937         SAVEFREESV(data.longest_float);
6938         SAVEFREESV(data.last_found);
6939         first = scan;
6940         if (!ri->regstclass) {
6941             ssc_init(pRExC_state, &ch_class);
6942             data.start_class = &ch_class;
6943             stclass_flag = SCF_DO_STCLASS_AND;
6944         } else                          /* XXXX Check for BOUND? */
6945             stclass_flag = 0;
6946         data.last_closep = &last_close;
6947
6948         DEBUG_RExC_seen();
6949         minlen = study_chunk(pRExC_state, &first, &minlen, &fake,
6950                              scan + RExC_size, /* Up to end */
6951             &data, -1, 0, NULL,
6952             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag
6953                           | (restudied ? SCF_TRIE_DOING_RESTUDY : 0),
6954             0);
6955
6956
6957         CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
6958
6959
6960         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
6961              && data.last_start_min == 0 && data.last_end > 0
6962              && !RExC_seen_zerolen
6963              && !(RExC_seen & REG_VERBARG_SEEN)
6964              && !(RExC_seen & REG_GPOS_SEEN)
6965         ){
6966             r->extflags |= RXf_CHECK_ALL;
6967         }
6968         scan_commit(pRExC_state, &data,&minlen,0);
6969
6970         longest_float_length = CHR_SVLEN(data.longest_float);
6971
6972         if (! ((SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
6973                    && data.offset_fixed == data.offset_float_min
6974                    && SvCUR(data.longest_fixed) == SvCUR(data.longest_float)))
6975             && S_setup_longest (aTHX_ pRExC_state,
6976                                     data.longest_float,
6977                                     &(r->float_utf8),
6978                                     &(r->float_substr),
6979                                     &(r->float_end_shift),
6980                                     data.lookbehind_float,
6981                                     data.offset_float_min,
6982                                     data.minlen_float,
6983                                     longest_float_length,
6984                                     cBOOL(data.flags & SF_FL_BEFORE_EOL),
6985                                     cBOOL(data.flags & SF_FL_BEFORE_MEOL)))
6986         {
6987             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
6988             r->float_max_offset = data.offset_float_max;
6989             if (data.offset_float_max < SSize_t_MAX) /* Don't offset infinity */
6990                 r->float_max_offset -= data.lookbehind_float;
6991             SvREFCNT_inc_simple_void_NN(data.longest_float);
6992         }
6993         else {
6994             r->float_substr = r->float_utf8 = NULL;
6995             longest_float_length = 0;
6996         }
6997
6998         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
6999
7000         if (S_setup_longest (aTHX_ pRExC_state,
7001                                 data.longest_fixed,
7002                                 &(r->anchored_utf8),
7003                                 &(r->anchored_substr),
7004                                 &(r->anchored_end_shift),
7005                                 data.lookbehind_fixed,
7006                                 data.offset_fixed,
7007                                 data.minlen_fixed,
7008                                 longest_fixed_length,
7009                                 cBOOL(data.flags & SF_FIX_BEFORE_EOL),
7010                                 cBOOL(data.flags & SF_FIX_BEFORE_MEOL)))
7011         {
7012             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
7013             SvREFCNT_inc_simple_void_NN(data.longest_fixed);
7014         }
7015         else {
7016             r->anchored_substr = r->anchored_utf8 = NULL;
7017             longest_fixed_length = 0;
7018         }
7019         LEAVE_with_name("study_chunk");
7020
7021         if (ri->regstclass
7022             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
7023             ri->regstclass = NULL;
7024
7025         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
7026             && stclass_flag
7027             && ! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
7028             && !ssc_is_anything(data.start_class))
7029         {
7030             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7031
7032             ssc_finalize(pRExC_state, data.start_class);
7033
7034             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7035             StructCopy(data.start_class,
7036                        (regnode_ssc*)RExC_rxi->data->data[n],
7037                        regnode_ssc);
7038             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7039             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7040             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
7041                       regprop(r, sv, (regnode*)data.start_class, NULL);
7042                       PerlIO_printf(Perl_debug_log,
7043                                     "synthetic stclass \"%s\".\n",
7044                                     SvPVX_const(sv));});
7045             data.start_class = NULL;
7046         }
7047
7048         /* A temporary algorithm prefers floated substr to fixed one to dig
7049          * more info. */
7050         if (longest_fixed_length > longest_float_length) {
7051             r->substrs->check_ix = 0;
7052             r->check_end_shift = r->anchored_end_shift;
7053             r->check_substr = r->anchored_substr;
7054             r->check_utf8 = r->anchored_utf8;
7055             r->check_offset_min = r->check_offset_max = r->anchored_offset;
7056             if (r->intflags & (PREGf_ANCH_SBOL|PREGf_ANCH_GPOS))
7057                 r->intflags |= PREGf_NOSCAN;
7058         }
7059         else {
7060             r->substrs->check_ix = 1;
7061             r->check_end_shift = r->float_end_shift;
7062             r->check_substr = r->float_substr;
7063             r->check_utf8 = r->float_utf8;
7064             r->check_offset_min = r->float_min_offset;
7065             r->check_offset_max = r->float_max_offset;
7066         }
7067         if ((r->check_substr || r->check_utf8) ) {
7068             r->extflags |= RXf_USE_INTUIT;
7069             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
7070                 r->extflags |= RXf_INTUIT_TAIL;
7071         }
7072         r->substrs->data[0].max_offset = r->substrs->data[0].min_offset;
7073
7074         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
7075         if ( (STRLEN)minlen < longest_float_length )
7076             minlen= longest_float_length;
7077         if ( (STRLEN)minlen < longest_fixed_length )
7078             minlen= longest_fixed_length;
7079         */
7080     }
7081     else {
7082         /* Several toplevels. Best we can is to set minlen. */
7083         SSize_t fake;
7084         regnode_ssc ch_class;
7085         SSize_t last_close = 0;
7086
7087         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
7088
7089         scan = ri->program + 1;
7090         ssc_init(pRExC_state, &ch_class);
7091         data.start_class = &ch_class;
7092         data.last_closep = &last_close;
7093
7094         DEBUG_RExC_seen();
7095         minlen = study_chunk(pRExC_state,
7096             &scan, &minlen, &fake, scan + RExC_size, &data, -1, 0, NULL,
7097             SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied
7098                                                       ? SCF_TRIE_DOING_RESTUDY
7099                                                       : 0),
7100             0);
7101
7102         CHECK_RESTUDY_GOTO_butfirst(NOOP);
7103
7104         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
7105                 = r->float_substr = r->float_utf8 = NULL;
7106
7107         if (! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
7108             && ! ssc_is_anything(data.start_class))
7109         {
7110             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7111
7112             ssc_finalize(pRExC_state, data.start_class);
7113
7114             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7115             StructCopy(data.start_class,
7116                        (regnode_ssc*)RExC_rxi->data->data[n],
7117                        regnode_ssc);
7118             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7119             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7120             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
7121                       regprop(r, sv, (regnode*)data.start_class, NULL);
7122                       PerlIO_printf(Perl_debug_log,
7123                                     "synthetic stclass \"%s\".\n",
7124                                     SvPVX_const(sv));});
7125             data.start_class = NULL;
7126         }
7127     }
7128
7129     if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) {
7130         r->extflags |= RXf_UNBOUNDED_QUANTIFIER_SEEN;
7131         r->maxlen = REG_INFTY;
7132     }
7133     else {
7134         r->maxlen = RExC_maxlen;
7135     }
7136
7137     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
7138        the "real" pattern. */
7139     DEBUG_OPTIMISE_r({
7140         PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf" maxlen:%"IVdf"\n",
7141                       (IV)minlen, (IV)r->minlen, (IV)RExC_maxlen);
7142     });
7143     r->minlenret = minlen;
7144     if (r->minlen < minlen)
7145         r->minlen = minlen;
7146
7147     if (RExC_seen & REG_GPOS_SEEN)
7148         r->intflags |= PREGf_GPOS_SEEN;
7149     if (RExC_seen & REG_LOOKBEHIND_SEEN)
7150         r->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the
7151                                                 lookbehind */
7152     if (pRExC_state->num_code_blocks)
7153         r->extflags |= RXf_EVAL_SEEN;
7154     if (RExC_seen & REG_CANY_SEEN)
7155         r->intflags |= PREGf_CANY_SEEN;
7156     if (RExC_seen & REG_VERBARG_SEEN)
7157     {
7158         r->intflags |= PREGf_VERBARG_SEEN;
7159         r->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */
7160     }
7161     if (RExC_seen & REG_CUTGROUP_SEEN)
7162         r->intflags |= PREGf_CUTGROUP_SEEN;
7163     if (pm_flags & PMf_USE_RE_EVAL)
7164         r->intflags |= PREGf_USE_RE_EVAL;
7165     if (RExC_paren_names)
7166         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
7167     else
7168         RXp_PAREN_NAMES(r) = NULL;
7169
7170     /* If we have seen an anchor in our pattern then we set the extflag RXf_IS_ANCHORED
7171      * so it can be used in pp.c */
7172     if (r->intflags & PREGf_ANCH)
7173         r->extflags |= RXf_IS_ANCHORED;
7174
7175
7176     {
7177         /* this is used to identify "special" patterns that might result
7178          * in Perl NOT calling the regex engine and instead doing the match "itself",
7179          * particularly special cases in split//. By having the regex compiler
7180          * do this pattern matching at a regop level (instead of by inspecting the pattern)
7181          * we avoid weird issues with equivalent patterns resulting in different behavior,
7182          * AND we allow non Perl engines to get the same optimizations by the setting the
7183          * flags appropriately - Yves */
7184         regnode *first = ri->program + 1;
7185         U8 fop = OP(first);
7186         regnode *next = NEXTOPER(first);
7187         U8 nop = OP(next);
7188
7189         if (PL_regkind[fop] == NOTHING && nop == END)
7190             r->extflags |= RXf_NULL;
7191         else if ((fop == MBOL || (fop == SBOL && !first->flags)) && nop == END)
7192             /* when fop is SBOL first->flags will be true only when it was
7193              * produced by parsing /\A/, and not when parsing /^/. This is
7194              * very important for the split code as there we want to
7195              * treat /^/ as /^/m, but we do not want to treat /\A/ as /^/m.
7196              * See rt #122761 for more details. -- Yves */
7197             r->extflags |= RXf_START_ONLY;
7198         else if (fop == PLUS
7199                  && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE
7200                  && OP(regnext(first)) == END)
7201             r->extflags |= RXf_WHITE;
7202         else if ( r->extflags & RXf_SPLIT
7203                   && fop == EXACT
7204                   && STR_LEN(first) == 1
7205                   && *(STRING(first)) == ' '
7206                   && OP(regnext(first)) == END )
7207             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
7208
7209     }
7210
7211     if (RExC_contains_locale) {
7212         RXp_EXTFLAGS(r) |= RXf_TAINTED;
7213     }
7214
7215 #ifdef DEBUGGING
7216     if (RExC_paren_names) {
7217         ri->name_list_idx = add_data( pRExC_state, STR_WITH_LEN("a"));
7218         ri->data->data[ri->name_list_idx]
7219                                    = (void*)SvREFCNT_inc(RExC_paren_name_list);
7220     } else
7221 #endif
7222         ri->name_list_idx = 0;
7223
7224     if (RExC_recurse_count) {
7225         for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
7226             const regnode *scan = RExC_recurse[RExC_recurse_count-1];
7227             ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
7228         }
7229     }
7230     Newxz(r->offs, RExC_npar, regexp_paren_pair);
7231     /* assume we don't need to swap parens around before we match */
7232
7233     DEBUG_DUMP_r({
7234         DEBUG_RExC_seen();
7235         PerlIO_printf(Perl_debug_log,"Final program:\n");
7236         regdump(r);
7237     });
7238 #ifdef RE_TRACK_PATTERN_OFFSETS
7239     DEBUG_OFFSETS_r(if (ri->u.offsets) {
7240         const STRLEN len = ri->u.offsets[0];
7241         STRLEN i;
7242         GET_RE_DEBUG_FLAGS_DECL;
7243         PerlIO_printf(Perl_debug_log,
7244                       "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
7245         for (i = 1; i <= len; i++) {
7246             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
7247                 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
7248                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
7249             }
7250         PerlIO_printf(Perl_debug_log, "\n");
7251     });
7252 #endif
7253
7254 #ifdef USE_ITHREADS
7255     /* under ithreads the ?pat? PMf_USED flag on the pmop is simulated
7256      * by setting the regexp SV to readonly-only instead. If the
7257      * pattern's been recompiled, the USEDness should remain. */
7258     if (old_re && SvREADONLY(old_re))
7259         SvREADONLY_on(rx);
7260 #endif
7261     return rx;
7262 }
7263
7264
7265 SV*
7266 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
7267                     const U32 flags)
7268 {
7269     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
7270
7271     PERL_UNUSED_ARG(value);
7272
7273     if (flags & RXapif_FETCH) {
7274         return reg_named_buff_fetch(rx, key, flags);
7275     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
7276         Perl_croak_no_modify();
7277         return NULL;
7278     } else if (flags & RXapif_EXISTS) {
7279         return reg_named_buff_exists(rx, key, flags)
7280             ? &PL_sv_yes
7281             : &PL_sv_no;
7282     } else if (flags & RXapif_REGNAMES) {
7283         return reg_named_buff_all(rx, flags);
7284     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
7285         return reg_named_buff_scalar(rx, flags);
7286     } else {
7287         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
7288         return NULL;
7289     }
7290 }
7291
7292 SV*
7293 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
7294                          const U32 flags)
7295 {
7296     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
7297     PERL_UNUSED_ARG(lastkey);
7298
7299     if (flags & RXapif_FIRSTKEY)
7300         return reg_named_buff_firstkey(rx, flags);
7301     else if (flags & RXapif_NEXTKEY)
7302         return reg_named_buff_nextkey(rx, flags);
7303     else {
7304         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter",
7305                                             (int)flags);
7306         return NULL;
7307     }
7308 }
7309
7310 SV*
7311 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
7312                           const U32 flags)
7313 {
7314     AV *retarray = NULL;
7315     SV *ret;
7316     struct regexp *const rx = ReANY(r);
7317
7318     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
7319
7320     if (flags & RXapif_ALL)
7321         retarray=newAV();
7322
7323     if (rx && RXp_PAREN_NAMES(rx)) {
7324         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
7325         if (he_str) {
7326             IV i;
7327             SV* sv_dat=HeVAL(he_str);
7328             I32 *nums=(I32*)SvPVX(sv_dat);
7329             for ( i=0; i<SvIVX(sv_dat); i++ ) {
7330                 if ((I32)(rx->nparens) >= nums[i]
7331                     && rx->offs[nums[i]].start != -1
7332                     && rx->offs[nums[i]].end != -1)
7333                 {
7334                     ret = newSVpvs("");
7335                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
7336                     if (!retarray)
7337                         return ret;
7338                 } else {
7339                     if (retarray)
7340                         ret = newSVsv(&PL_sv_undef);
7341                 }
7342                 if (retarray)
7343                     av_push(retarray, ret);
7344             }
7345             if (retarray)
7346                 return newRV_noinc(MUTABLE_SV(retarray));
7347         }
7348     }
7349     return NULL;
7350 }
7351
7352 bool
7353 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
7354                            const U32 flags)
7355 {
7356     struct regexp *const rx = ReANY(r);
7357
7358     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
7359
7360     if (rx && RXp_PAREN_NAMES(rx)) {
7361         if (flags & RXapif_ALL) {
7362             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
7363         } else {
7364             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
7365             if (sv) {
7366                 SvREFCNT_dec_NN(sv);
7367                 return TRUE;
7368             } else {
7369                 return FALSE;
7370             }
7371         }
7372     } else {
7373         return FALSE;
7374     }
7375 }
7376
7377 SV*
7378 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
7379 {
7380     struct regexp *const rx = ReANY(r);
7381
7382     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
7383
7384     if ( rx && RXp_PAREN_NAMES(rx) ) {
7385         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
7386
7387         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
7388     } else {
7389         return FALSE;
7390     }
7391 }
7392
7393 SV*
7394 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
7395 {
7396     struct regexp *const rx = ReANY(r);
7397     GET_RE_DEBUG_FLAGS_DECL;
7398
7399     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
7400
7401     if (rx && RXp_PAREN_NAMES(rx)) {
7402         HV *hv = RXp_PAREN_NAMES(rx);
7403         HE *temphe;
7404         while ( (temphe = hv_iternext_flags(hv,0)) ) {
7405             IV i;
7406             IV parno = 0;
7407             SV* sv_dat = HeVAL(temphe);
7408             I32 *nums = (I32*)SvPVX(sv_dat);
7409             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
7410                 if ((I32)(rx->lastparen) >= nums[i] &&
7411                     rx->offs[nums[i]].start != -1 &&
7412                     rx->offs[nums[i]].end != -1)
7413                 {
7414                     parno = nums[i];
7415                     break;
7416                 }
7417             }
7418             if (parno || flags & RXapif_ALL) {
7419                 return newSVhek(HeKEY_hek(temphe));
7420             }
7421         }
7422     }
7423     return NULL;
7424 }
7425
7426 SV*
7427 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
7428 {
7429     SV *ret;
7430     AV *av;
7431     SSize_t length;
7432     struct regexp *const rx = ReANY(r);
7433
7434     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
7435
7436     if (rx && RXp_PAREN_NAMES(rx)) {
7437         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
7438             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
7439         } else if (flags & RXapif_ONE) {
7440             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
7441             av = MUTABLE_AV(SvRV(ret));
7442             length = av_tindex(av);
7443             SvREFCNT_dec_NN(ret);
7444             return newSViv(length + 1);
7445         } else {
7446             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar",
7447                                                 (int)flags);
7448             return NULL;
7449         }
7450     }
7451     return &PL_sv_undef;
7452 }
7453
7454 SV*
7455 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
7456 {
7457     struct regexp *const rx = ReANY(r);
7458     AV *av = newAV();
7459
7460     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
7461
7462     if (rx && RXp_PAREN_NAMES(rx)) {
7463         HV *hv= RXp_PAREN_NAMES(rx);
7464         HE *temphe;
7465         (void)hv_iterinit(hv);
7466         while ( (temphe = hv_iternext_flags(hv,0)) ) {
7467             IV i;
7468             IV parno = 0;
7469             SV* sv_dat = HeVAL(temphe);
7470             I32 *nums = (I32*)SvPVX(sv_dat);
7471             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
7472                 if ((I32)(rx->lastparen) >= nums[i] &&
7473                     rx->offs[nums[i]].start != -1 &&
7474                     rx->offs[nums[i]].end != -1)
7475                 {
7476                     parno = nums[i];
7477                     break;
7478                 }
7479             }
7480             if (parno || flags & RXapif_ALL) {
7481                 av_push(av, newSVhek(HeKEY_hek(temphe)));
7482             }
7483         }
7484     }
7485
7486     return newRV_noinc(MUTABLE_SV(av));
7487 }
7488
7489 void
7490 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
7491                              SV * const sv)
7492 {
7493     struct regexp *const rx = ReANY(r);
7494     char *s = NULL;
7495     SSize_t i = 0;
7496     SSize_t s1, t1;
7497     I32 n = paren;
7498
7499     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
7500
7501     if (      n == RX_BUFF_IDX_CARET_PREMATCH
7502            || n == RX_BUFF_IDX_CARET_FULLMATCH
7503            || n == RX_BUFF_IDX_CARET_POSTMATCH
7504        )
7505     {
7506         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
7507         if (!keepcopy) {
7508             /* on something like
7509              *    $r = qr/.../;
7510              *    /$qr/p;
7511              * the KEEPCOPY is set on the PMOP rather than the regex */
7512             if (PL_curpm && r == PM_GETRE(PL_curpm))
7513                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
7514         }
7515         if (!keepcopy)
7516             goto ret_undef;
7517     }
7518
7519     if (!rx->subbeg)
7520         goto ret_undef;
7521
7522     if (n == RX_BUFF_IDX_CARET_FULLMATCH)
7523         /* no need to distinguish between them any more */
7524         n = RX_BUFF_IDX_FULLMATCH;
7525
7526     if ((n == RX_BUFF_IDX_PREMATCH || n == RX_BUFF_IDX_CARET_PREMATCH)
7527         && rx->offs[0].start != -1)
7528     {
7529         /* $`, ${^PREMATCH} */
7530         i = rx->offs[0].start;
7531         s = rx->subbeg;
7532     }
7533     else
7534     if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
7535         && rx->offs[0].end != -1)
7536     {
7537         /* $', ${^POSTMATCH} */
7538         s = rx->subbeg - rx->suboffset + rx->offs[0].end;
7539         i = rx->sublen + rx->suboffset - rx->offs[0].end;
7540     }
7541     else
7542     if ( 0 <= n && n <= (I32)rx->nparens &&
7543         (s1 = rx->offs[n].start) != -1 &&
7544         (t1 = rx->offs[n].end) != -1)
7545     {
7546         /* $&, ${^MATCH},  $1 ... */
7547         i = t1 - s1;
7548         s = rx->subbeg + s1 - rx->suboffset;
7549     } else {
7550         goto ret_undef;
7551     }
7552
7553     assert(s >= rx->subbeg);
7554     assert((STRLEN)rx->sublen >= (STRLEN)((s - rx->subbeg) + i) );
7555     if (i >= 0) {
7556 #ifdef NO_TAINT_SUPPORT
7557         sv_setpvn(sv, s, i);
7558 #else
7559         const int oldtainted = TAINT_get;
7560         TAINT_NOT;
7561         sv_setpvn(sv, s, i);
7562         TAINT_set(oldtainted);
7563 #endif
7564         if ( (rx->intflags & PREGf_CANY_SEEN)
7565             ? (RXp_MATCH_UTF8(rx)
7566                         && (!i || is_utf8_string((U8*)s, i)))
7567             : (RXp_MATCH_UTF8(rx)) )
7568         {
7569             SvUTF8_on(sv);
7570         }
7571         else
7572             SvUTF8_off(sv);
7573         if (TAINTING_get) {
7574             if (RXp_MATCH_TAINTED(rx)) {
7575                 if (SvTYPE(sv) >= SVt_PVMG) {
7576                     MAGIC* const mg = SvMAGIC(sv);
7577                     MAGIC* mgt;
7578                     TAINT;
7579                     SvMAGIC_set(sv, mg->mg_moremagic);
7580                     SvTAINT(sv);
7581                     if ((mgt = SvMAGIC(sv))) {
7582                         mg->mg_moremagic = mgt;
7583                         SvMAGIC_set(sv, mg);
7584                     }
7585                 } else {
7586                     TAINT;
7587                     SvTAINT(sv);
7588                 }
7589             } else
7590                 SvTAINTED_off(sv);
7591         }
7592     } else {
7593       ret_undef:
7594         sv_setsv(sv,&PL_sv_undef);
7595         return;
7596     }
7597 }
7598
7599 void
7600 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
7601                                                          SV const * const value)
7602 {
7603     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
7604
7605     PERL_UNUSED_ARG(rx);
7606     PERL_UNUSED_ARG(paren);
7607     PERL_UNUSED_ARG(value);
7608
7609     if (!PL_localizing)
7610         Perl_croak_no_modify();
7611 }
7612
7613 I32
7614 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
7615                               const I32 paren)
7616 {
7617     struct regexp *const rx = ReANY(r);
7618     I32 i;
7619     I32 s1, t1;
7620
7621     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
7622
7623     if (   paren == RX_BUFF_IDX_CARET_PREMATCH
7624         || paren == RX_BUFF_IDX_CARET_FULLMATCH
7625         || paren == RX_BUFF_IDX_CARET_POSTMATCH
7626     )
7627     {
7628         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
7629         if (!keepcopy) {
7630             /* on something like
7631              *    $r = qr/.../;
7632              *    /$qr/p;
7633              * the KEEPCOPY is set on the PMOP rather than the regex */
7634             if (PL_curpm && r == PM_GETRE(PL_curpm))
7635                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
7636         }
7637         if (!keepcopy)
7638             goto warn_undef;
7639     }
7640
7641     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
7642     switch (paren) {
7643       case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */
7644       case RX_BUFF_IDX_PREMATCH:       /* $` */
7645         if (rx->offs[0].start != -1) {
7646                         i = rx->offs[0].start;
7647                         if (i > 0) {
7648                                 s1 = 0;
7649                                 t1 = i;
7650                                 goto getlen;
7651                         }
7652             }
7653         return 0;
7654
7655       case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */
7656       case RX_BUFF_IDX_POSTMATCH:       /* $' */
7657             if (rx->offs[0].end != -1) {
7658                         i = rx->sublen - rx->offs[0].end;
7659                         if (i > 0) {
7660                                 s1 = rx->offs[0].end;
7661                                 t1 = rx->sublen;
7662                                 goto getlen;
7663                         }
7664             }
7665         return 0;
7666
7667       default: /* $& / ${^MATCH}, $1, $2, ... */
7668             if (paren <= (I32)rx->nparens &&
7669             (s1 = rx->offs[paren].start) != -1 &&
7670             (t1 = rx->offs[paren].end) != -1)
7671             {
7672             i = t1 - s1;
7673             goto getlen;
7674         } else {
7675           warn_undef:
7676             if (ckWARN(WARN_UNINITIALIZED))
7677                 report_uninit((const SV *)sv);
7678             return 0;
7679         }
7680     }
7681   getlen:
7682     if (i > 0 && RXp_MATCH_UTF8(rx)) {
7683         const char * const s = rx->subbeg - rx->suboffset + s1;
7684         const U8 *ep;
7685         STRLEN el;
7686
7687         i = t1 - s1;
7688         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
7689                         i = el;
7690     }
7691     return i;
7692 }
7693
7694 SV*
7695 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
7696 {
7697     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
7698         PERL_UNUSED_ARG(rx);
7699         if (0)
7700             return NULL;
7701         else
7702             return newSVpvs("Regexp");
7703 }
7704
7705 /* Scans the name of a named buffer from the pattern.
7706  * If flags is REG_RSN_RETURN_NULL returns null.
7707  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
7708  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
7709  * to the parsed name as looked up in the RExC_paren_names hash.
7710  * If there is an error throws a vFAIL().. type exception.
7711  */
7712
7713 #define REG_RSN_RETURN_NULL    0
7714 #define REG_RSN_RETURN_NAME    1
7715 #define REG_RSN_RETURN_DATA    2
7716
7717 STATIC SV*
7718 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
7719 {
7720     char *name_start = RExC_parse;
7721
7722     PERL_ARGS_ASSERT_REG_SCAN_NAME;
7723
7724     assert (RExC_parse <= RExC_end);
7725     if (RExC_parse == RExC_end) NOOP;
7726     else if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
7727          /* skip IDFIRST by using do...while */
7728         if (UTF)
7729             do {
7730                 RExC_parse += UTF8SKIP(RExC_parse);
7731             } while (isWORDCHAR_utf8((U8*)RExC_parse));
7732         else
7733             do {
7734                 RExC_parse++;
7735             } while (isWORDCHAR(*RExC_parse));
7736     } else {
7737         RExC_parse++; /* so the <- from the vFAIL is after the offending
7738                          character */
7739         vFAIL("Group name must start with a non-digit word character");
7740     }
7741     if ( flags ) {
7742         SV* sv_name
7743             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
7744                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
7745         if ( flags == REG_RSN_RETURN_NAME)
7746             return sv_name;
7747         else if (flags==REG_RSN_RETURN_DATA) {
7748             HE *he_str = NULL;
7749             SV *sv_dat = NULL;
7750             if ( ! sv_name )      /* should not happen*/
7751                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
7752             if (RExC_paren_names)
7753                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
7754             if ( he_str )
7755                 sv_dat = HeVAL(he_str);
7756             if ( ! sv_dat )
7757                 vFAIL("Reference to nonexistent named group");
7758             return sv_dat;
7759         }
7760         else {
7761             Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
7762                        (unsigned long) flags);
7763         }
7764         assert(0); /* NOT REACHED */
7765     }
7766     return NULL;
7767 }
7768
7769 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
7770     int rem=(int)(RExC_end - RExC_parse);                       \
7771     int cut;                                                    \
7772     int num;                                                    \
7773     int iscut=0;                                                \
7774     if (rem>10) {                                               \
7775         rem=10;                                                 \
7776         iscut=1;                                                \
7777     }                                                           \
7778     cut=10-rem;                                                 \
7779     if (RExC_lastparse!=RExC_parse)                             \
7780         PerlIO_printf(Perl_debug_log," >%.*s%-*s",              \
7781             rem, RExC_parse,                                    \
7782             cut + 4,                                            \
7783             iscut ? "..." : "<"                                 \
7784         );                                                      \
7785     else                                                        \
7786         PerlIO_printf(Perl_debug_log,"%16s","");                \
7787                                                                 \
7788     if (SIZE_ONLY)                                              \
7789        num = RExC_size + 1;                                     \
7790     else                                                        \
7791        num=REG_NODE_NUM(RExC_emit);                             \
7792     if (RExC_lastnum!=num)                                      \
7793        PerlIO_printf(Perl_debug_log,"|%4d",num);                \
7794     else                                                        \
7795        PerlIO_printf(Perl_debug_log,"|%4s","");                 \
7796     PerlIO_printf(Perl_debug_log,"|%*s%-4s",                    \
7797         (int)((depth*2)), "",                                   \
7798         (funcname)                                              \
7799     );                                                          \
7800     RExC_lastnum=num;                                           \
7801     RExC_lastparse=RExC_parse;                                  \
7802 })
7803
7804
7805
7806 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
7807     DEBUG_PARSE_MSG((funcname));                            \
7808     PerlIO_printf(Perl_debug_log,"%4s","\n");               \
7809 })
7810 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({           \
7811     DEBUG_PARSE_MSG((funcname));                            \
7812     PerlIO_printf(Perl_debug_log,fmt "\n",args);               \
7813 })
7814
7815 /* This section of code defines the inversion list object and its methods.  The
7816  * interfaces are highly subject to change, so as much as possible is static to
7817  * this file.  An inversion list is here implemented as a malloc'd C UV array
7818  * as an SVt_INVLIST scalar.
7819  *
7820  * An inversion list for Unicode is an array of code points, sorted by ordinal
7821  * number.  The zeroth element is the first code point in the list.  The 1th
7822  * element is the first element beyond that not in the list.  In other words,
7823  * the first range is
7824  *  invlist[0]..(invlist[1]-1)
7825  * The other ranges follow.  Thus every element whose index is divisible by two
7826  * marks the beginning of a range that is in the list, and every element not
7827  * divisible by two marks the beginning of a range not in the list.  A single
7828  * element inversion list that contains the single code point N generally
7829  * consists of two elements
7830  *  invlist[0] == N
7831  *  invlist[1] == N+1
7832  * (The exception is when N is the highest representable value on the
7833  * machine, in which case the list containing just it would be a single
7834  * element, itself.  By extension, if the last range in the list extends to
7835  * infinity, then the first element of that range will be in the inversion list
7836  * at a position that is divisible by two, and is the final element in the
7837  * list.)
7838  * Taking the complement (inverting) an inversion list is quite simple, if the
7839  * first element is 0, remove it; otherwise add a 0 element at the beginning.
7840  * This implementation reserves an element at the beginning of each inversion
7841  * list to always contain 0; there is an additional flag in the header which
7842  * indicates if the list begins at the 0, or is offset to begin at the next
7843  * element.
7844  *
7845  * More about inversion lists can be found in "Unicode Demystified"
7846  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
7847  * More will be coming when functionality is added later.
7848  *
7849  * The inversion list data structure is currently implemented as an SV pointing
7850  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
7851  * array of UV whose memory management is automatically handled by the existing
7852  * facilities for SV's.
7853  *
7854  * Some of the methods should always be private to the implementation, and some
7855  * should eventually be made public */
7856
7857 /* The header definitions are in F<inline_invlist.c> */
7858
7859 PERL_STATIC_INLINE UV*
7860 S__invlist_array_init(SV* const invlist, const bool will_have_0)
7861 {
7862     /* Returns a pointer to the first element in the inversion list's array.
7863      * This is called upon initialization of an inversion list.  Where the
7864      * array begins depends on whether the list has the code point U+0000 in it
7865      * or not.  The other parameter tells it whether the code that follows this
7866      * call is about to put a 0 in the inversion list or not.  The first
7867      * element is either the element reserved for 0, if TRUE, or the element
7868      * after it, if FALSE */
7869
7870     bool* offset = get_invlist_offset_addr(invlist);
7871     UV* zero_addr = (UV *) SvPVX(invlist);
7872
7873     PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
7874
7875     /* Must be empty */
7876     assert(! _invlist_len(invlist));
7877
7878     *zero_addr = 0;
7879
7880     /* 1^1 = 0; 1^0 = 1 */
7881     *offset = 1 ^ will_have_0;
7882     return zero_addr + *offset;
7883 }
7884
7885 PERL_STATIC_INLINE UV*
7886 S_invlist_array(SV* const invlist)
7887 {
7888     /* Returns the pointer to the inversion list's array.  Every time the
7889      * length changes, this needs to be called in case malloc or realloc moved
7890      * it */
7891
7892     PERL_ARGS_ASSERT_INVLIST_ARRAY;
7893
7894     /* Must not be empty.  If these fail, you probably didn't check for <len>
7895      * being non-zero before trying to get the array */
7896     assert(_invlist_len(invlist));
7897
7898     /* The very first element always contains zero, The array begins either
7899      * there, or if the inversion list is offset, at the element after it.
7900      * The offset header field determines which; it contains 0 or 1 to indicate
7901      * how much additionally to add */
7902     assert(0 == *(SvPVX(invlist)));
7903     return ((UV *) SvPVX(invlist) + *get_invlist_offset_addr(invlist));
7904 }
7905
7906 PERL_STATIC_INLINE void
7907 S_invlist_set_len(pTHX_ SV* const invlist, const UV len, const bool offset)
7908 {
7909     /* Sets the current number of elements stored in the inversion list.
7910      * Updates SvCUR correspondingly */
7911     PERL_UNUSED_CONTEXT;
7912     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
7913
7914     assert(SvTYPE(invlist) == SVt_INVLIST);
7915
7916     SvCUR_set(invlist,
7917               (len == 0)
7918                ? 0
7919                : TO_INTERNAL_SIZE(len + offset));
7920     assert(SvLEN(invlist) == 0 || SvCUR(invlist) <= SvLEN(invlist));
7921 }
7922
7923 PERL_STATIC_INLINE IV*
7924 S_get_invlist_previous_index_addr(SV* invlist)
7925 {
7926     /* Return the address of the IV that is reserved to hold the cached index
7927      * */
7928     PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR;
7929
7930     assert(SvTYPE(invlist) == SVt_INVLIST);
7931
7932     return &(((XINVLIST*) SvANY(invlist))->prev_index);
7933 }
7934
7935 PERL_STATIC_INLINE IV
7936 S_invlist_previous_index(SV* const invlist)
7937 {
7938     /* Returns cached index of previous search */
7939
7940     PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX;
7941
7942     return *get_invlist_previous_index_addr(invlist);
7943 }
7944
7945 PERL_STATIC_INLINE void
7946 S_invlist_set_previous_index(SV* const invlist, const IV index)
7947 {
7948     /* Caches <index> for later retrieval */
7949
7950     PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX;
7951
7952     assert(index == 0 || index < (int) _invlist_len(invlist));
7953
7954     *get_invlist_previous_index_addr(invlist) = index;
7955 }
7956
7957 PERL_STATIC_INLINE UV
7958 S_invlist_max(SV* const invlist)
7959 {
7960     /* Returns the maximum number of elements storable in the inversion list's
7961      * array, without having to realloc() */
7962
7963     PERL_ARGS_ASSERT_INVLIST_MAX;
7964
7965     assert(SvTYPE(invlist) == SVt_INVLIST);
7966
7967     /* Assumes worst case, in which the 0 element is not counted in the
7968      * inversion list, so subtracts 1 for that */
7969     return SvLEN(invlist) == 0  /* This happens under _new_invlist_C_array */
7970            ? FROM_INTERNAL_SIZE(SvCUR(invlist)) - 1
7971            : FROM_INTERNAL_SIZE(SvLEN(invlist)) - 1;
7972 }
7973
7974 #ifndef PERL_IN_XSUB_RE
7975 SV*
7976 Perl__new_invlist(pTHX_ IV initial_size)
7977 {
7978
7979     /* Return a pointer to a newly constructed inversion list, with enough
7980      * space to store 'initial_size' elements.  If that number is negative, a
7981      * system default is used instead */
7982
7983     SV* new_list;
7984
7985     if (initial_size < 0) {
7986         initial_size = 10;
7987     }
7988
7989     /* Allocate the initial space */
7990     new_list = newSV_type(SVt_INVLIST);
7991
7992     /* First 1 is in case the zero element isn't in the list; second 1 is for
7993      * trailing NUL */
7994     SvGROW(new_list, TO_INTERNAL_SIZE(initial_size + 1) + 1);
7995     invlist_set_len(new_list, 0, 0);
7996
7997     /* Force iterinit() to be used to get iteration to work */
7998     *get_invlist_iter_addr(new_list) = (STRLEN) UV_MAX;
7999
8000     *get_invlist_previous_index_addr(new_list) = 0;
8001
8002     return new_list;
8003 }
8004
8005 SV*
8006 Perl__new_invlist_C_array(pTHX_ const UV* const list)
8007 {
8008     /* Return a pointer to a newly constructed inversion list, initialized to
8009      * point to <list>, which has to be in the exact correct inversion list
8010      * form, including internal fields.  Thus this is a dangerous routine that
8011      * should not be used in the wrong hands.  The passed in 'list' contains
8012      * several header fields at the beginning that are not part of the
8013      * inversion list body proper */
8014
8015     const STRLEN length = (STRLEN) list[0];
8016     const UV version_id =          list[1];
8017     const bool offset   =    cBOOL(list[2]);
8018 #define HEADER_LENGTH 3
8019     /* If any of the above changes in any way, you must change HEADER_LENGTH
8020      * (if appropriate) and regenerate INVLIST_VERSION_ID by running
8021      *      perl -E 'say int(rand 2**31-1)'
8022      */
8023 #define INVLIST_VERSION_ID 148565664 /* This is a combination of a version and
8024                                         data structure type, so that one being
8025                                         passed in can be validated to be an
8026                                         inversion list of the correct vintage.
8027                                        */
8028
8029     SV* invlist = newSV_type(SVt_INVLIST);
8030
8031     PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
8032
8033     if (version_id != INVLIST_VERSION_ID) {
8034         Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
8035     }
8036
8037     /* The generated array passed in includes header elements that aren't part
8038      * of the list proper, so start it just after them */
8039     SvPV_set(invlist, (char *) (list + HEADER_LENGTH));
8040
8041     SvLEN_set(invlist, 0);  /* Means we own the contents, and the system
8042                                shouldn't touch it */
8043
8044     *(get_invlist_offset_addr(invlist)) = offset;
8045
8046     /* The 'length' passed to us is the physical number of elements in the
8047      * inversion list.  But if there is an offset the logical number is one
8048      * less than that */
8049     invlist_set_len(invlist, length  - offset, offset);
8050
8051     invlist_set_previous_index(invlist, 0);
8052
8053     /* Initialize the iteration pointer. */
8054     invlist_iterfinish(invlist);
8055
8056     SvREADONLY_on(invlist);
8057
8058     return invlist;
8059 }
8060 #endif /* ifndef PERL_IN_XSUB_RE */
8061
8062 STATIC void
8063 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
8064 {
8065     /* Grow the maximum size of an inversion list */
8066
8067     PERL_ARGS_ASSERT_INVLIST_EXTEND;
8068
8069     assert(SvTYPE(invlist) == SVt_INVLIST);
8070
8071     /* Add one to account for the zero element at the beginning which may not
8072      * be counted by the calling parameters */
8073     SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max + 1));
8074 }
8075
8076 PERL_STATIC_INLINE void
8077 S_invlist_trim(SV* const invlist)
8078 {
8079     PERL_ARGS_ASSERT_INVLIST_TRIM;
8080
8081     assert(SvTYPE(invlist) == SVt_INVLIST);
8082
8083     /* Change the length of the inversion list to how many entries it currently
8084      * has */
8085     SvPV_shrink_to_cur((SV *) invlist);
8086 }
8087
8088 STATIC void
8089 S__append_range_to_invlist(pTHX_ SV* const invlist,
8090                                  const UV start, const UV end)
8091 {
8092    /* Subject to change or removal.  Append the range from 'start' to 'end' at
8093     * the end of the inversion list.  The range must be above any existing
8094     * ones. */
8095
8096     UV* array;
8097     UV max = invlist_max(invlist);
8098     UV len = _invlist_len(invlist);
8099     bool offset;
8100
8101     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
8102
8103     if (len == 0) { /* Empty lists must be initialized */
8104         offset = start != 0;
8105         array = _invlist_array_init(invlist, ! offset);
8106     }
8107     else {
8108         /* Here, the existing list is non-empty. The current max entry in the
8109          * list is generally the first value not in the set, except when the
8110          * set extends to the end of permissible values, in which case it is
8111          * the first entry in that final set, and so this call is an attempt to
8112          * append out-of-order */
8113
8114         UV final_element = len - 1;
8115         array = invlist_array(invlist);
8116         if (array[final_element] > start
8117             || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
8118         {
8119             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",
8120                      array[final_element], start,
8121                      ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
8122         }
8123
8124         /* Here, it is a legal append.  If the new range begins with the first
8125          * value not in the set, it is extending the set, so the new first
8126          * value not in the set is one greater than the newly extended range.
8127          * */
8128         offset = *get_invlist_offset_addr(invlist);
8129         if (array[final_element] == start) {
8130             if (end != UV_MAX) {
8131                 array[final_element] = end + 1;
8132             }
8133             else {
8134                 /* But if the end is the maximum representable on the machine,
8135                  * just let the range that this would extend to have no end */
8136                 invlist_set_len(invlist, len - 1, offset);
8137             }
8138             return;
8139         }
8140     }
8141
8142     /* Here the new range doesn't extend any existing set.  Add it */
8143
8144     len += 2;   /* Includes an element each for the start and end of range */
8145
8146     /* If wll overflow the existing space, extend, which may cause the array to
8147      * be moved */
8148     if (max < len) {
8149         invlist_extend(invlist, len);
8150
8151         /* Have to set len here to avoid assert failure in invlist_array() */
8152         invlist_set_len(invlist, len, offset);
8153
8154         array = invlist_array(invlist);
8155     }
8156     else {
8157         invlist_set_len(invlist, len, offset);
8158     }
8159
8160     /* The next item on the list starts the range, the one after that is
8161      * one past the new range.  */
8162     array[len - 2] = start;
8163     if (end != UV_MAX) {
8164         array[len - 1] = end + 1;
8165     }
8166     else {
8167         /* But if the end is the maximum representable on the machine, just let
8168          * the range have no end */
8169         invlist_set_len(invlist, len - 1, offset);
8170     }
8171 }
8172
8173 #ifndef PERL_IN_XSUB_RE
8174
8175 IV
8176 Perl__invlist_search(SV* const invlist, const UV cp)
8177 {
8178     /* Searches the inversion list for the entry that contains the input code
8179      * point <cp>.  If <cp> is not in the list, -1 is returned.  Otherwise, the
8180      * return value is the index into the list's array of the range that
8181      * contains <cp> */
8182
8183     IV low = 0;
8184     IV mid;
8185     IV high = _invlist_len(invlist);
8186     const IV highest_element = high - 1;
8187     const UV* array;
8188
8189     PERL_ARGS_ASSERT__INVLIST_SEARCH;
8190
8191     /* If list is empty, return failure. */
8192     if (high == 0) {
8193         return -1;
8194     }
8195
8196     /* (We can't get the array unless we know the list is non-empty) */
8197     array = invlist_array(invlist);
8198
8199     mid = invlist_previous_index(invlist);
8200     assert(mid >=0 && mid <= highest_element);
8201
8202     /* <mid> contains the cache of the result of the previous call to this
8203      * function (0 the first time).  See if this call is for the same result,
8204      * or if it is for mid-1.  This is under the theory that calls to this
8205      * function will often be for related code points that are near each other.
8206      * And benchmarks show that caching gives better results.  We also test
8207      * here if the code point is within the bounds of the list.  These tests
8208      * replace others that would have had to be made anyway to make sure that
8209      * the array bounds were not exceeded, and these give us extra information
8210      * at the same time */
8211     if (cp >= array[mid]) {
8212         if (cp >= array[highest_element]) {
8213             return highest_element;
8214         }
8215
8216         /* Here, array[mid] <= cp < array[highest_element].  This means that
8217          * the final element is not the answer, so can exclude it; it also
8218          * means that <mid> is not the final element, so can refer to 'mid + 1'
8219          * safely */
8220         if (cp < array[mid + 1]) {
8221             return mid;
8222         }
8223         high--;
8224         low = mid + 1;
8225     }
8226     else { /* cp < aray[mid] */
8227         if (cp < array[0]) { /* Fail if outside the array */
8228             return -1;
8229         }
8230         high = mid;
8231         if (cp >= array[mid - 1]) {
8232             goto found_entry;
8233         }
8234     }
8235
8236     /* Binary search.  What we are looking for is <i> such that
8237      *  array[i] <= cp < array[i+1]
8238      * The loop below converges on the i+1.  Note that there may not be an
8239      * (i+1)th element in the array, and things work nonetheless */
8240     while (low < high) {
8241         mid = (low + high) / 2;
8242         assert(mid <= highest_element);
8243         if (array[mid] <= cp) { /* cp >= array[mid] */
8244             low = mid + 1;
8245
8246             /* We could do this extra test to exit the loop early.
8247             if (cp < array[low]) {
8248                 return mid;
8249             }
8250             */
8251         }
8252         else { /* cp < array[mid] */
8253             high = mid;
8254         }
8255     }
8256
8257   found_entry:
8258     high--;
8259     invlist_set_previous_index(invlist, high);
8260     return high;
8261 }
8262
8263 void
8264 Perl__invlist_populate_swatch(SV* const invlist,
8265                               const UV start, const UV end, U8* swatch)
8266 {
8267     /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
8268      * but is used when the swash has an inversion list.  This makes this much
8269      * faster, as it uses a binary search instead of a linear one.  This is
8270      * intimately tied to that function, and perhaps should be in utf8.c,
8271      * except it is intimately tied to inversion lists as well.  It assumes
8272      * that <swatch> is all 0's on input */
8273
8274     UV current = start;
8275     const IV len = _invlist_len(invlist);
8276     IV i;
8277     const UV * array;
8278
8279     PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
8280
8281     if (len == 0) { /* Empty inversion list */
8282         return;
8283     }
8284
8285     array = invlist_array(invlist);
8286
8287     /* Find which element it is */
8288     i = _invlist_search(invlist, start);
8289
8290     /* We populate from <start> to <end> */
8291     while (current < end) {
8292         UV upper;
8293
8294         /* The inversion list gives the results for every possible code point
8295          * after the first one in the list.  Only those ranges whose index is
8296          * even are ones that the inversion list matches.  For the odd ones,
8297          * and if the initial code point is not in the list, we have to skip
8298          * forward to the next element */
8299         if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
8300             i++;
8301             if (i >= len) { /* Finished if beyond the end of the array */
8302                 return;
8303             }
8304             current = array[i];
8305             if (current >= end) {   /* Finished if beyond the end of what we
8306                                        are populating */
8307                 if (LIKELY(end < UV_MAX)) {
8308                     return;
8309                 }
8310
8311                 /* We get here when the upper bound is the maximum
8312                  * representable on the machine, and we are looking for just
8313                  * that code point.  Have to special case it */
8314                 i = len;
8315                 goto join_end_of_list;
8316             }
8317         }
8318         assert(current >= start);
8319
8320         /* The current range ends one below the next one, except don't go past
8321          * <end> */
8322         i++;
8323         upper = (i < len && array[i] < end) ? array[i] : end;
8324
8325         /* Here we are in a range that matches.  Populate a bit in the 3-bit U8
8326          * for each code point in it */
8327         for (; current < upper; current++) {
8328             const STRLEN offset = (STRLEN)(current - start);
8329             swatch[offset >> 3] |= 1 << (offset & 7);
8330         }
8331
8332     join_end_of_list:
8333
8334         /* Quit if at the end of the list */
8335         if (i >= len) {
8336
8337             /* But first, have to deal with the highest possible code point on
8338              * the platform.  The previous code assumes that <end> is one
8339              * beyond where we want to populate, but that is impossible at the
8340              * platform's infinity, so have to handle it specially */
8341             if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
8342             {
8343                 const STRLEN offset = (STRLEN)(end - start);
8344                 swatch[offset >> 3] |= 1 << (offset & 7);
8345             }
8346             return;
8347         }
8348
8349         /* Advance to the next range, which will be for code points not in the
8350          * inversion list */
8351         current = array[i];
8352     }
8353
8354     return;
8355 }
8356
8357 void
8358 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
8359                                          const bool complement_b, SV** output)
8360 {
8361     /* Take the union of two inversion lists and point <output> to it.  *output
8362      * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
8363      * the reference count to that list will be decremented if not already a
8364      * temporary (mortal); otherwise *output will be made correspondingly
8365      * mortal.  The first list, <a>, may be NULL, in which case a copy of the
8366      * second list is returned.  If <complement_b> is TRUE, the union is taken
8367      * of the complement (inversion) of <b> instead of b itself.
8368      *
8369      * The basis for this comes from "Unicode Demystified" Chapter 13 by
8370      * Richard Gillam, published by Addison-Wesley, and explained at some
8371      * length there.  The preface says to incorporate its examples into your
8372      * code at your own risk.
8373      *
8374      * The algorithm is like a merge sort.
8375      *
8376      * XXX A potential performance improvement is to keep track as we go along
8377      * if only one of the inputs contributes to the result, meaning the other
8378      * is a subset of that one.  In that case, we can skip the final copy and
8379      * return the larger of the input lists, but then outside code might need
8380      * to keep track of whether to free the input list or not */
8381
8382     const UV* array_a;    /* a's array */
8383     const UV* array_b;
8384     UV len_a;       /* length of a's array */
8385     UV len_b;
8386
8387     SV* u;                      /* the resulting union */
8388     UV* array_u;
8389     UV len_u;
8390
8391     UV i_a = 0;             /* current index into a's array */
8392     UV i_b = 0;
8393     UV i_u = 0;
8394
8395     /* running count, as explained in the algorithm source book; items are
8396      * stopped accumulating and are output when the count changes to/from 0.
8397      * The count is incremented when we start a range that's in the set, and
8398      * decremented when we start a range that's not in the set.  So its range
8399      * is 0 to 2.  Only when the count is zero is something not in the set.
8400      */
8401     UV count = 0;
8402
8403     PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
8404     assert(a != b);
8405
8406     /* If either one is empty, the union is the other one */
8407     if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
8408         bool make_temp = FALSE; /* Should we mortalize the result? */
8409
8410         if (*output == a) {
8411             if (a != NULL) {
8412                 if (! (make_temp = cBOOL(SvTEMP(a)))) {
8413                     SvREFCNT_dec_NN(a);
8414                 }
8415             }
8416         }
8417         if (*output != b) {
8418             *output = invlist_clone(b);
8419             if (complement_b) {
8420                 _invlist_invert(*output);
8421             }
8422         } /* else *output already = b; */
8423
8424         if (make_temp) {
8425             sv_2mortal(*output);
8426         }
8427         return;
8428     }
8429     else if ((len_b = _invlist_len(b)) == 0) {
8430         bool make_temp = FALSE;
8431         if (*output == b) {
8432             if (! (make_temp = cBOOL(SvTEMP(b)))) {
8433                 SvREFCNT_dec_NN(b);
8434             }
8435         }
8436
8437         /* The complement of an empty list is a list that has everything in it,
8438          * so the union with <a> includes everything too */
8439         if (complement_b) {
8440             if (a == *output) {
8441                 if (! (make_temp = cBOOL(SvTEMP(a)))) {
8442                     SvREFCNT_dec_NN(a);
8443                 }
8444             }
8445             *output = _new_invlist(1);
8446             _append_range_to_invlist(*output, 0, UV_MAX);
8447         }
8448         else if (*output != a) {
8449             *output = invlist_clone(a);
8450         }
8451         /* else *output already = a; */
8452
8453         if (make_temp) {
8454             sv_2mortal(*output);
8455         }
8456         return;
8457     }
8458
8459     /* Here both lists exist and are non-empty */
8460     array_a = invlist_array(a);
8461     array_b = invlist_array(b);
8462
8463     /* If are to take the union of 'a' with the complement of b, set it
8464      * up so are looking at b's complement. */
8465     if (complement_b) {
8466
8467         /* To complement, we invert: if the first element is 0, remove it.  To
8468          * do this, we just pretend the array starts one later */
8469         if (array_b[0] == 0) {
8470             array_b++;
8471             len_b--;
8472         }
8473         else {
8474
8475             /* But if the first element is not zero, we pretend the list starts
8476              * at the 0 that is always stored immediately before the array. */
8477             array_b--;
8478             len_b++;
8479         }
8480     }
8481
8482     /* Size the union for the worst case: that the sets are completely
8483      * disjoint */
8484     u = _new_invlist(len_a + len_b);
8485
8486     /* Will contain U+0000 if either component does */
8487     array_u = _invlist_array_init(u, (len_a > 0 && array_a[0] == 0)
8488                                       || (len_b > 0 && array_b[0] == 0));
8489
8490     /* Go through each list item by item, stopping when exhausted one of
8491      * them */
8492     while (i_a < len_a && i_b < len_b) {
8493         UV cp;      /* The element to potentially add to the union's array */
8494         bool cp_in_set;   /* is it in the the input list's set or not */
8495
8496         /* We need to take one or the other of the two inputs for the union.
8497          * Since we are merging two sorted lists, we take the smaller of the
8498          * next items.  In case of a tie, we take the one that is in its set
8499          * first.  If we took one not in the set first, it would decrement the
8500          * count, possibly to 0 which would cause it to be output as ending the
8501          * range, and the next time through we would take the same number, and
8502          * output it again as beginning the next range.  By doing it the
8503          * opposite way, there is no possibility that the count will be
8504          * momentarily decremented to 0, and thus the two adjoining ranges will
8505          * be seamlessly merged.  (In a tie and both are in the set or both not
8506          * in the set, it doesn't matter which we take first.) */
8507         if (array_a[i_a] < array_b[i_b]
8508             || (array_a[i_a] == array_b[i_b]
8509                 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
8510         {
8511             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
8512             cp= array_a[i_a++];
8513         }
8514         else {
8515             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
8516             cp = array_b[i_b++];
8517         }
8518
8519         /* Here, have chosen which of the two inputs to look at.  Only output
8520          * if the running count changes to/from 0, which marks the
8521          * beginning/end of a range in that's in the set */
8522         if (cp_in_set) {
8523             if (count == 0) {
8524                 array_u[i_u++] = cp;
8525             }
8526             count++;
8527         }
8528         else {
8529             count--;
8530             if (count == 0) {
8531                 array_u[i_u++] = cp;
8532             }
8533         }
8534     }
8535
8536     /* Here, we are finished going through at least one of the lists, which
8537      * means there is something remaining in at most one.  We check if the list
8538      * that hasn't been exhausted is positioned such that we are in the middle
8539      * of a range in its set or not.  (i_a and i_b point to the element beyond
8540      * the one we care about.) If in the set, we decrement 'count'; if 0, there
8541      * is potentially more to output.
8542      * There are four cases:
8543      *  1) Both weren't in their sets, count is 0, and remains 0.  What's left
8544      *     in the union is entirely from the non-exhausted set.
8545      *  2) Both were in their sets, count is 2.  Nothing further should
8546      *     be output, as everything that remains will be in the exhausted
8547      *     list's set, hence in the union; decrementing to 1 but not 0 insures
8548      *     that
8549      *  3) the exhausted was in its set, non-exhausted isn't, count is 1.
8550      *     Nothing further should be output because the union includes
8551      *     everything from the exhausted set.  Not decrementing ensures that.
8552      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1;
8553      *     decrementing to 0 insures that we look at the remainder of the
8554      *     non-exhausted set */
8555     if ((i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
8556         || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
8557     {
8558         count--;
8559     }
8560
8561     /* The final length is what we've output so far, plus what else is about to
8562      * be output.  (If 'count' is non-zero, then the input list we exhausted
8563      * has everything remaining up to the machine's limit in its set, and hence
8564      * in the union, so there will be no further output. */
8565     len_u = i_u;
8566     if (count == 0) {
8567         /* At most one of the subexpressions will be non-zero */
8568         len_u += (len_a - i_a) + (len_b - i_b);
8569     }
8570
8571     /* Set result to final length, which can change the pointer to array_u, so
8572      * re-find it */
8573     if (len_u != _invlist_len(u)) {
8574         invlist_set_len(u, len_u, *get_invlist_offset_addr(u));
8575         invlist_trim(u);
8576         array_u = invlist_array(u);
8577     }
8578
8579     /* When 'count' is 0, the list that was exhausted (if one was shorter than
8580      * the other) ended with everything above it not in its set.  That means
8581      * that the remaining part of the union is precisely the same as the
8582      * non-exhausted list, so can just copy it unchanged.  (If both list were
8583      * exhausted at the same time, then the operations below will be both 0.)
8584      */
8585     if (count == 0) {
8586         IV copy_count; /* At most one will have a non-zero copy count */
8587         if ((copy_count = len_a - i_a) > 0) {
8588             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
8589         }
8590         else if ((copy_count = len_b - i_b) > 0) {
8591             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
8592         }
8593     }
8594
8595     /*  We may be removing a reference to one of the inputs.  If so, the output
8596      *  is made mortal if the input was.  (Mortal SVs shouldn't have their ref
8597      *  count decremented) */
8598     if (a == *output || b == *output) {
8599         assert(! invlist_is_iterating(*output));
8600         if ((SvTEMP(*output))) {
8601             sv_2mortal(u);
8602         }
8603         else {
8604             SvREFCNT_dec_NN(*output);
8605         }
8606     }
8607
8608     *output = u;
8609
8610     return;
8611 }
8612
8613 void
8614 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
8615                                                const bool complement_b, SV** i)
8616 {
8617     /* Take the intersection of two inversion lists and point <i> to it.  *i
8618      * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
8619      * the reference count to that list will be decremented if not already a
8620      * temporary (mortal); otherwise *i will be made correspondingly mortal.
8621      * The first list, <a>, may be NULL, in which case an empty list is
8622      * returned.  If <complement_b> is TRUE, the result will be the
8623      * intersection of <a> and the complement (or inversion) of <b> instead of
8624      * <b> directly.
8625      *
8626      * The basis for this comes from "Unicode Demystified" Chapter 13 by
8627      * Richard Gillam, published by Addison-Wesley, and explained at some
8628      * length there.  The preface says to incorporate its examples into your
8629      * code at your own risk.  In fact, it had bugs
8630      *
8631      * The algorithm is like a merge sort, and is essentially the same as the
8632      * union above
8633      */
8634
8635     const UV* array_a;          /* a's array */
8636     const UV* array_b;
8637     UV len_a;   /* length of a's array */
8638     UV len_b;
8639
8640     SV* r;                   /* the resulting intersection */
8641     UV* array_r;
8642     UV len_r;
8643
8644     UV i_a = 0;             /* current index into a's array */
8645     UV i_b = 0;
8646     UV i_r = 0;
8647
8648     /* running count, as explained in the algorithm source book; items are
8649      * stopped accumulating and are output when the count changes to/from 2.
8650      * The count is incremented when we start a range that's in the set, and
8651      * decremented when we start a range that's not in the set.  So its range
8652      * is 0 to 2.  Only when the count is 2 is something in the intersection.
8653      */
8654     UV count = 0;
8655
8656     PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
8657     assert(a != b);
8658
8659     /* Special case if either one is empty */
8660     len_a = (a == NULL) ? 0 : _invlist_len(a);
8661     if ((len_a == 0) || ((len_b = _invlist_len(b)) == 0)) {
8662         bool make_temp = FALSE;
8663
8664         if (len_a != 0 && complement_b) {
8665
8666             /* Here, 'a' is not empty, therefore from the above 'if', 'b' must
8667              * be empty.  Here, also we are using 'b's complement, which hence
8668              * must be every possible code point.  Thus the intersection is
8669              * simply 'a'. */
8670             if (*i != a) {
8671                 if (*i == b) {
8672                     if (! (make_temp = cBOOL(SvTEMP(b)))) {
8673                         SvREFCNT_dec_NN(b);
8674                     }
8675                 }
8676
8677                 *i = invlist_clone(a);
8678             }
8679             /* else *i is already 'a' */
8680
8681             if (make_temp) {
8682                 sv_2mortal(*i);
8683             }
8684             return;
8685         }
8686
8687         /* Here, 'a' or 'b' is empty and not using the complement of 'b'.  The
8688          * intersection must be empty */
8689         if (*i == a) {
8690             if (! (make_temp = cBOOL(SvTEMP(a)))) {
8691                 SvREFCNT_dec_NN(a);
8692             }
8693         }
8694         else if (*i == b) {
8695             if (! (make_temp = cBOOL(SvTEMP(b)))) {
8696                 SvREFCNT_dec_NN(b);
8697             }
8698         }
8699         *i = _new_invlist(0);
8700         if (make_temp) {
8701             sv_2mortal(*i);
8702         }
8703
8704         return;
8705     }
8706
8707     /* Here both lists exist and are non-empty */
8708     array_a = invlist_array(a);
8709     array_b = invlist_array(b);
8710
8711     /* If are to take the intersection of 'a' with the complement of b, set it
8712      * up so are looking at b's complement. */
8713     if (complement_b) {
8714
8715         /* To complement, we invert: if the first element is 0, remove it.  To
8716          * do this, we just pretend the array starts one later */
8717         if (array_b[0] == 0) {
8718             array_b++;
8719             len_b--;
8720         }
8721         else {
8722
8723             /* But if the first element is not zero, we pretend the list starts
8724              * at the 0 that is always stored immediately before the array. */
8725             array_b--;
8726             len_b++;
8727         }
8728     }
8729
8730     /* Size the intersection for the worst case: that the intersection ends up
8731      * fragmenting everything to be completely disjoint */
8732     r= _new_invlist(len_a + len_b);
8733
8734     /* Will contain U+0000 iff both components do */
8735     array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
8736                                      && len_b > 0 && array_b[0] == 0);
8737
8738     /* Go through each list item by item, stopping when exhausted one of
8739      * them */
8740     while (i_a < len_a && i_b < len_b) {
8741         UV cp;      /* The element to potentially add to the intersection's
8742                        array */
8743         bool cp_in_set; /* Is it in the input list's set or not */
8744
8745         /* We need to take one or the other of the two inputs for the
8746          * intersection.  Since we are merging two sorted lists, we take the
8747          * smaller of the next items.  In case of a tie, we take the one that
8748          * is not in its set first (a difference from the union algorithm).  If
8749          * we took one in the set first, it would increment the count, possibly
8750          * to 2 which would cause it to be output as starting a range in the
8751          * intersection, and the next time through we would take that same
8752          * number, and output it again as ending the set.  By doing it the
8753          * opposite of this, there is no possibility that the count will be
8754          * momentarily incremented to 2.  (In a tie and both are in the set or
8755          * both not in the set, it doesn't matter which we take first.) */
8756         if (array_a[i_a] < array_b[i_b]
8757             || (array_a[i_a] == array_b[i_b]
8758                 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
8759         {
8760             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
8761             cp= array_a[i_a++];
8762         }
8763         else {
8764             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
8765             cp= array_b[i_b++];
8766         }
8767
8768         /* Here, have chosen which of the two inputs to look at.  Only output
8769          * if the running count changes to/from 2, which marks the
8770          * beginning/end of a range that's in the intersection */
8771         if (cp_in_set) {
8772             count++;
8773             if (count == 2) {
8774                 array_r[i_r++] = cp;
8775             }
8776         }
8777         else {
8778             if (count == 2) {
8779                 array_r[i_r++] = cp;
8780             }
8781             count--;
8782         }
8783     }
8784
8785     /* Here, we are finished going through at least one of the lists, which
8786      * means there is something remaining in at most one.  We check if the list
8787      * that has been exhausted is positioned such that we are in the middle
8788      * of a range in its set or not.  (i_a and i_b point to elements 1 beyond
8789      * the ones we care about.)  There are four cases:
8790      *  1) Both weren't in their sets, count is 0, and remains 0.  There's
8791      *     nothing left in the intersection.
8792      *  2) Both were in their sets, count is 2 and perhaps is incremented to
8793      *     above 2.  What should be output is exactly that which is in the
8794      *     non-exhausted set, as everything it has is also in the intersection
8795      *     set, and everything it doesn't have can't be in the intersection
8796      *  3) The exhausted was in its set, non-exhausted isn't, count is 1, and
8797      *     gets incremented to 2.  Like the previous case, the intersection is
8798      *     everything that remains in the non-exhausted set.
8799      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1, and
8800      *     remains 1.  And the intersection has nothing more. */
8801     if ((i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
8802         || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
8803     {
8804         count++;
8805     }
8806
8807     /* The final length is what we've output so far plus what else is in the
8808      * intersection.  At most one of the subexpressions below will be non-zero
8809      * */
8810     len_r = i_r;
8811     if (count >= 2) {
8812         len_r += (len_a - i_a) + (len_b - i_b);
8813     }
8814
8815     /* Set result to final length, which can change the pointer to array_r, so
8816      * re-find it */
8817     if (len_r != _invlist_len(r)) {
8818         invlist_set_len(r, len_r, *get_invlist_offset_addr(r));
8819         invlist_trim(r);
8820         array_r = invlist_array(r);
8821     }
8822
8823     /* Finish outputting any remaining */
8824     if (count >= 2) { /* At most one will have a non-zero copy count */
8825         IV copy_count;
8826         if ((copy_count = len_a - i_a) > 0) {
8827             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
8828         }
8829         else if ((copy_count = len_b - i_b) > 0) {
8830             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
8831         }
8832     }
8833
8834     /*  We may be removing a reference to one of the inputs.  If so, the output
8835      *  is made mortal if the input was.  (Mortal SVs shouldn't have their ref
8836      *  count decremented) */
8837     if (a == *i || b == *i) {
8838         assert(! invlist_is_iterating(*i));
8839         if (SvTEMP(*i)) {
8840             sv_2mortal(r);
8841         }
8842         else {
8843             SvREFCNT_dec_NN(*i);
8844         }
8845     }
8846
8847     *i = r;
8848
8849     return;
8850 }
8851
8852 SV*
8853 Perl__add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end)
8854 {
8855     /* Add the range from 'start' to 'end' inclusive to the inversion list's
8856      * set.  A pointer to the inversion list is returned.  This may actually be
8857      * a new list, in which case the passed in one has been destroyed.  The
8858      * passed in inversion list can be NULL, in which case a new one is created
8859      * with just the one range in it */
8860
8861     SV* range_invlist;
8862     UV len;
8863
8864     if (invlist == NULL) {
8865         invlist = _new_invlist(2);
8866         len = 0;
8867     }
8868     else {
8869         len = _invlist_len(invlist);
8870     }
8871
8872     /* If comes after the final entry actually in the list, can just append it
8873      * to the end, */
8874     if (len == 0
8875         || (! ELEMENT_RANGE_MATCHES_INVLIST(len - 1)
8876             && start >= invlist_array(invlist)[len - 1]))
8877     {
8878         _append_range_to_invlist(invlist, start, end);
8879         return invlist;
8880     }
8881
8882     /* Here, can't just append things, create and return a new inversion list
8883      * which is the union of this range and the existing inversion list */
8884     range_invlist = _new_invlist(2);
8885     _append_range_to_invlist(range_invlist, start, end);
8886
8887     _invlist_union(invlist, range_invlist, &invlist);
8888
8889     /* The temporary can be freed */
8890     SvREFCNT_dec_NN(range_invlist);
8891
8892     return invlist;
8893 }
8894
8895 SV*
8896 Perl__setup_canned_invlist(pTHX_ const STRLEN size, const UV element0,
8897                                  UV** other_elements_ptr)
8898 {
8899     /* Create and return an inversion list whose contents are to be populated
8900      * by the caller.  The caller gives the number of elements (in 'size') and
8901      * the very first element ('element0').  This function will set
8902      * '*other_elements_ptr' to an array of UVs, where the remaining elements
8903      * are to be placed.
8904      *
8905      * Obviously there is some trust involved that the caller will properly
8906      * fill in the other elements of the array.
8907      *
8908      * (The first element needs to be passed in, as the underlying code does
8909      * things differently depending on whether it is zero or non-zero) */
8910
8911     SV* invlist = _new_invlist(size);
8912     bool offset;
8913
8914     PERL_ARGS_ASSERT__SETUP_CANNED_INVLIST;
8915
8916     _append_range_to_invlist(invlist, element0, element0);
8917     offset = *get_invlist_offset_addr(invlist);
8918
8919     invlist_set_len(invlist, size, offset);
8920     *other_elements_ptr = invlist_array(invlist) + 1;
8921     return invlist;
8922 }
8923
8924 #endif
8925
8926 PERL_STATIC_INLINE SV*
8927 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
8928     return _add_range_to_invlist(invlist, cp, cp);
8929 }
8930
8931 #ifndef PERL_IN_XSUB_RE
8932 void
8933 Perl__invlist_invert(pTHX_ SV* const invlist)
8934 {
8935     /* Complement the input inversion list.  This adds a 0 if the list didn't
8936      * have a zero; removes it otherwise.  As described above, the data
8937      * structure is set up so that this is very efficient */
8938
8939     PERL_ARGS_ASSERT__INVLIST_INVERT;
8940
8941     assert(! invlist_is_iterating(invlist));
8942
8943     /* The inverse of matching nothing is matching everything */
8944     if (_invlist_len(invlist) == 0) {
8945         _append_range_to_invlist(invlist, 0, UV_MAX);
8946         return;
8947     }
8948
8949     *get_invlist_offset_addr(invlist) = ! *get_invlist_offset_addr(invlist);
8950 }
8951
8952 #endif
8953
8954 PERL_STATIC_INLINE SV*
8955 S_invlist_clone(pTHX_ SV* const invlist)
8956 {
8957
8958     /* Return a new inversion list that is a copy of the input one, which is
8959      * unchanged.  The new list will not be mortal even if the old one was. */
8960
8961     /* Need to allocate extra space to accommodate Perl's addition of a
8962      * trailing NUL to SvPV's, since it thinks they are always strings */
8963     SV* new_invlist = _new_invlist(_invlist_len(invlist) + 1);
8964     STRLEN physical_length = SvCUR(invlist);
8965     bool offset = *(get_invlist_offset_addr(invlist));
8966
8967     PERL_ARGS_ASSERT_INVLIST_CLONE;
8968
8969     *(get_invlist_offset_addr(new_invlist)) = offset;
8970     invlist_set_len(new_invlist, _invlist_len(invlist), offset);
8971     Copy(SvPVX(invlist), SvPVX(new_invlist), physical_length, char);
8972
8973     return new_invlist;
8974 }
8975
8976 PERL_STATIC_INLINE STRLEN*
8977 S_get_invlist_iter_addr(SV* invlist)
8978 {
8979     /* Return the address of the UV that contains the current iteration
8980      * position */
8981
8982     PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
8983
8984     assert(SvTYPE(invlist) == SVt_INVLIST);
8985
8986     return &(((XINVLIST*) SvANY(invlist))->iterator);
8987 }
8988
8989 PERL_STATIC_INLINE void
8990 S_invlist_iterinit(SV* invlist) /* Initialize iterator for invlist */
8991 {
8992     PERL_ARGS_ASSERT_INVLIST_ITERINIT;
8993
8994     *get_invlist_iter_addr(invlist) = 0;
8995 }
8996
8997 PERL_STATIC_INLINE void
8998 S_invlist_iterfinish(SV* invlist)
8999 {
9000     /* Terminate iterator for invlist.  This is to catch development errors.
9001      * Any iteration that is interrupted before completed should call this
9002      * function.  Functions that add code points anywhere else but to the end
9003      * of an inversion list assert that they are not in the middle of an
9004      * iteration.  If they were, the addition would make the iteration
9005      * problematical: if the iteration hadn't reached the place where things
9006      * were being added, it would be ok */
9007
9008     PERL_ARGS_ASSERT_INVLIST_ITERFINISH;
9009
9010     *get_invlist_iter_addr(invlist) = (STRLEN) UV_MAX;
9011 }
9012
9013 STATIC bool
9014 S_invlist_iternext(SV* invlist, UV* start, UV* end)
9015 {
9016     /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
9017      * This call sets in <*start> and <*end>, the next range in <invlist>.
9018      * Returns <TRUE> if successful and the next call will return the next
9019      * range; <FALSE> if was already at the end of the list.  If the latter,
9020      * <*start> and <*end> are unchanged, and the next call to this function
9021      * will start over at the beginning of the list */
9022
9023     STRLEN* pos = get_invlist_iter_addr(invlist);
9024     UV len = _invlist_len(invlist);
9025     UV *array;
9026
9027     PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
9028
9029     if (*pos >= len) {
9030         *pos = (STRLEN) UV_MAX; /* Force iterinit() to be required next time */
9031         return FALSE;
9032     }
9033
9034     array = invlist_array(invlist);
9035
9036     *start = array[(*pos)++];
9037
9038     if (*pos >= len) {
9039         *end = UV_MAX;
9040     }
9041     else {
9042         *end = array[(*pos)++] - 1;
9043     }
9044
9045     return TRUE;
9046 }
9047
9048 PERL_STATIC_INLINE bool
9049 S_invlist_is_iterating(SV* const invlist)
9050 {
9051     PERL_ARGS_ASSERT_INVLIST_IS_ITERATING;
9052
9053     return *(get_invlist_iter_addr(invlist)) < (STRLEN) UV_MAX;
9054 }
9055
9056 PERL_STATIC_INLINE UV
9057 S_invlist_highest(SV* const invlist)
9058 {
9059     /* Returns the highest code point that matches an inversion list.  This API
9060      * has an ambiguity, as it returns 0 under either the highest is actually
9061      * 0, or if the list is empty.  If this distinction matters to you, check
9062      * for emptiness before calling this function */
9063
9064     UV len = _invlist_len(invlist);
9065     UV *array;
9066
9067     PERL_ARGS_ASSERT_INVLIST_HIGHEST;
9068
9069     if (len == 0) {
9070         return 0;
9071     }
9072
9073     array = invlist_array(invlist);
9074
9075     /* The last element in the array in the inversion list always starts a
9076      * range that goes to infinity.  That range may be for code points that are
9077      * matched in the inversion list, or it may be for ones that aren't
9078      * matched.  In the latter case, the highest code point in the set is one
9079      * less than the beginning of this range; otherwise it is the final element
9080      * of this range: infinity */
9081     return (ELEMENT_RANGE_MATCHES_INVLIST(len - 1))
9082            ? UV_MAX
9083            : array[len - 1] - 1;
9084 }
9085
9086 #ifndef PERL_IN_XSUB_RE
9087 SV *
9088 Perl__invlist_contents(pTHX_ SV* const invlist)
9089 {
9090     /* Get the contents of an inversion list into a string SV so that they can
9091      * be printed out.  It uses the format traditionally done for debug tracing
9092      */
9093
9094     UV start, end;
9095     SV* output = newSVpvs("\n");
9096
9097     PERL_ARGS_ASSERT__INVLIST_CONTENTS;
9098
9099     assert(! invlist_is_iterating(invlist));
9100
9101     invlist_iterinit(invlist);
9102     while (invlist_iternext(invlist, &start, &end)) {
9103         if (end == UV_MAX) {
9104             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\tINFINITY\n", start);
9105         }
9106         else if (end != start) {
9107             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\t%04"UVXf"\n",
9108                     start,       end);
9109         }
9110         else {
9111             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\n", start);
9112         }
9113     }
9114
9115     return output;
9116 }
9117 #endif
9118
9119 #ifndef PERL_IN_XSUB_RE
9120 void
9121 Perl__invlist_dump(pTHX_ PerlIO *file, I32 level,
9122                          const char * const indent, SV* const invlist)
9123 {
9124     /* Designed to be called only by do_sv_dump().  Dumps out the ranges of the
9125      * inversion list 'invlist' to 'file' at 'level'  Each line is prefixed by
9126      * the string 'indent'.  The output looks like this:
9127          [0] 0x000A .. 0x000D
9128          [2] 0x0085
9129          [4] 0x2028 .. 0x2029
9130          [6] 0x3104 .. INFINITY
9131      * This means that the first range of code points matched by the list are
9132      * 0xA through 0xD; the second range contains only the single code point
9133      * 0x85, etc.  An inversion list is an array of UVs.  Two array elements
9134      * are used to define each range (except if the final range extends to
9135      * infinity, only a single element is needed).  The array index of the
9136      * first element for the corresponding range is given in brackets. */
9137
9138     UV start, end;
9139     STRLEN count = 0;
9140
9141     PERL_ARGS_ASSERT__INVLIST_DUMP;
9142
9143     if (invlist_is_iterating(invlist)) {
9144         Perl_dump_indent(aTHX_ level, file,
9145              "%sCan't dump inversion list because is in middle of iterating\n",
9146              indent);
9147         return;
9148     }
9149
9150     invlist_iterinit(invlist);
9151     while (invlist_iternext(invlist, &start, &end)) {
9152         if (end == UV_MAX) {
9153             Perl_dump_indent(aTHX_ level, file,
9154                                        "%s[%"UVuf"] 0x%04"UVXf" .. INFINITY\n",
9155                                    indent, (UV)count, start);
9156         }
9157         else if (end != start) {
9158             Perl_dump_indent(aTHX_ level, file,
9159                                     "%s[%"UVuf"] 0x%04"UVXf" .. 0x%04"UVXf"\n",
9160                                 indent, (UV)count, start,         end);
9161         }
9162         else {
9163             Perl_dump_indent(aTHX_ level, file, "%s[%"UVuf"] 0x%04"UVXf"\n",
9164                                             indent, (UV)count, start);
9165         }
9166         count += 2;
9167     }
9168 }
9169
9170 void
9171 Perl__load_PL_utf8_foldclosures (pTHX)
9172 {
9173     assert(! PL_utf8_foldclosures);
9174
9175     /* If the folds haven't been read in, call a fold function
9176      * to force that */
9177     if (! PL_utf8_tofold) {
9178         U8 dummy[UTF8_MAXBYTES_CASE+1];
9179
9180         /* This string is just a short named one above \xff */
9181         to_utf8_fold((U8*) HYPHEN_UTF8, dummy, NULL);
9182         assert(PL_utf8_tofold); /* Verify that worked */
9183     }
9184     PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
9185 }
9186 #endif
9187
9188 #ifdef PERL_ARGS_ASSERT__INVLISTEQ
9189 bool
9190 S__invlistEQ(pTHX_ SV* const a, SV* const b, const bool complement_b)
9191 {
9192     /* Return a boolean as to if the two passed in inversion lists are
9193      * identical.  The final argument, if TRUE, says to take the complement of
9194      * the second inversion list before doing the comparison */
9195
9196     const UV* array_a = invlist_array(a);
9197     const UV* array_b = invlist_array(b);
9198     UV len_a = _invlist_len(a);
9199     UV len_b = _invlist_len(b);
9200
9201     UV i = 0;               /* current index into the arrays */
9202     bool retval = TRUE;     /* Assume are identical until proven otherwise */
9203
9204     PERL_ARGS_ASSERT__INVLISTEQ;
9205
9206     /* If are to compare 'a' with the complement of b, set it
9207      * up so are looking at b's complement. */
9208     if (complement_b) {
9209
9210         /* The complement of nothing is everything, so <a> would have to have
9211          * just one element, starting at zero (ending at infinity) */
9212         if (len_b == 0) {
9213             return (len_a == 1 && array_a[0] == 0);
9214         }
9215         else if (array_b[0] == 0) {
9216
9217             /* Otherwise, to complement, we invert.  Here, the first element is
9218              * 0, just remove it.  To do this, we just pretend the array starts
9219              * one later */
9220
9221             array_b++;
9222             len_b--;
9223         }
9224         else {
9225
9226             /* But if the first element is not zero, we pretend the list starts
9227              * at the 0 that is always stored immediately before the array. */
9228             array_b--;
9229             len_b++;
9230         }
9231     }
9232
9233     /* Make sure that the lengths are the same, as well as the final element
9234      * before looping through the remainder.  (Thus we test the length, final,
9235      * and first elements right off the bat) */
9236     if (len_a != len_b || array_a[len_a-1] != array_b[len_a-1]) {
9237         retval = FALSE;
9238     }
9239     else for (i = 0; i < len_a - 1; i++) {
9240         if (array_a[i] != array_b[i]) {
9241             retval = FALSE;
9242             break;
9243         }
9244     }
9245
9246     return retval;
9247 }
9248 #endif
9249
9250 #undef HEADER_LENGTH
9251 #undef TO_INTERNAL_SIZE
9252 #undef FROM_INTERNAL_SIZE
9253 #undef INVLIST_VERSION_ID
9254
9255 /* End of inversion list object */
9256
9257 STATIC void
9258 S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state)
9259 {
9260     /* This parses the flags that are in either the '(?foo)' or '(?foo:bar)'
9261      * constructs, and updates RExC_flags with them.  On input, RExC_parse
9262      * should point to the first flag; it is updated on output to point to the
9263      * final ')' or ':'.  There needs to be at least one flag, or this will
9264      * abort */
9265
9266     /* for (?g), (?gc), and (?o) warnings; warning
9267        about (?c) will warn about (?g) -- japhy    */
9268
9269 #define WASTED_O  0x01
9270 #define WASTED_G  0x02
9271 #define WASTED_C  0x04
9272 #define WASTED_GC (WASTED_G|WASTED_C)
9273     I32 wastedflags = 0x00;
9274     U32 posflags = 0, negflags = 0;
9275     U32 *flagsp = &posflags;
9276     char has_charset_modifier = '\0';
9277     regex_charset cs;
9278     bool has_use_defaults = FALSE;
9279     const char* const seqstart = RExC_parse - 1; /* Point to the '?' */
9280
9281     PERL_ARGS_ASSERT_PARSE_LPAREN_QUESTION_FLAGS;
9282
9283     /* '^' as an initial flag sets certain defaults */
9284     if (UCHARAT(RExC_parse) == '^') {
9285         RExC_parse++;
9286         has_use_defaults = TRUE;
9287         STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
9288         set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
9289                                         ? REGEX_UNICODE_CHARSET
9290                                         : REGEX_DEPENDS_CHARSET);
9291     }
9292
9293     cs = get_regex_charset(RExC_flags);
9294     if (cs == REGEX_DEPENDS_CHARSET
9295         && (RExC_utf8 || RExC_uni_semantics))
9296     {
9297         cs = REGEX_UNICODE_CHARSET;
9298     }
9299
9300     while (*RExC_parse) {
9301         /* && strchr("iogcmsx", *RExC_parse) */
9302         /* (?g), (?gc) and (?o) are useless here
9303            and must be globally applied -- japhy */
9304         switch (*RExC_parse) {
9305
9306             /* Code for the imsx flags */
9307             CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
9308
9309             case LOCALE_PAT_MOD:
9310                 if (has_charset_modifier) {
9311                     goto excess_modifier;
9312                 }
9313                 else if (flagsp == &negflags) {
9314                     goto neg_modifier;
9315                 }
9316                 cs = REGEX_LOCALE_CHARSET;
9317                 has_charset_modifier = LOCALE_PAT_MOD;
9318                 break;
9319             case UNICODE_PAT_MOD:
9320                 if (has_charset_modifier) {
9321                     goto excess_modifier;
9322                 }
9323                 else if (flagsp == &negflags) {
9324                     goto neg_modifier;
9325                 }
9326                 cs = REGEX_UNICODE_CHARSET;
9327                 has_charset_modifier = UNICODE_PAT_MOD;
9328                 break;
9329             case ASCII_RESTRICT_PAT_MOD:
9330                 if (flagsp == &negflags) {
9331                     goto neg_modifier;
9332                 }
9333                 if (has_charset_modifier) {
9334                     if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
9335                         goto excess_modifier;
9336                     }
9337                     /* Doubled modifier implies more restricted */
9338                     cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
9339                 }
9340                 else {
9341                     cs = REGEX_ASCII_RESTRICTED_CHARSET;
9342                 }
9343                 has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
9344                 break;
9345             case DEPENDS_PAT_MOD:
9346                 if (has_use_defaults) {
9347                     goto fail_modifiers;
9348                 }
9349                 else if (flagsp == &negflags) {
9350                     goto neg_modifier;
9351                 }
9352                 else if (has_charset_modifier) {
9353                     goto excess_modifier;
9354                 }
9355
9356                 /* The dual charset means unicode semantics if the
9357                  * pattern (or target, not known until runtime) are
9358                  * utf8, or something in the pattern indicates unicode
9359                  * semantics */
9360                 cs = (RExC_utf8 || RExC_uni_semantics)
9361                      ? REGEX_UNICODE_CHARSET
9362                      : REGEX_DEPENDS_CHARSET;
9363                 has_charset_modifier = DEPENDS_PAT_MOD;
9364                 break;
9365             excess_modifier:
9366                 RExC_parse++;
9367                 if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
9368                     vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
9369                 }
9370                 else if (has_charset_modifier == *(RExC_parse - 1)) {
9371                     vFAIL2("Regexp modifier \"%c\" may not appear twice",
9372                                         *(RExC_parse - 1));
9373                 }
9374                 else {
9375                     vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
9376                 }
9377                 /*NOTREACHED*/
9378             neg_modifier:
9379                 RExC_parse++;
9380                 vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"",
9381                                     *(RExC_parse - 1));
9382                 /*NOTREACHED*/
9383             case ONCE_PAT_MOD: /* 'o' */
9384             case GLOBAL_PAT_MOD: /* 'g' */
9385                 if (PASS2 && ckWARN(WARN_REGEXP)) {
9386                     const I32 wflagbit = *RExC_parse == 'o'
9387                                          ? WASTED_O
9388                                          : WASTED_G;
9389                     if (! (wastedflags & wflagbit) ) {
9390                         wastedflags |= wflagbit;
9391                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
9392                         vWARN5(
9393                             RExC_parse + 1,
9394                             "Useless (%s%c) - %suse /%c modifier",
9395                             flagsp == &negflags ? "?-" : "?",
9396                             *RExC_parse,
9397                             flagsp == &negflags ? "don't " : "",
9398                             *RExC_parse
9399                         );
9400                     }
9401                 }
9402                 break;
9403
9404             case CONTINUE_PAT_MOD: /* 'c' */
9405                 if (PASS2 && ckWARN(WARN_REGEXP)) {
9406                     if (! (wastedflags & WASTED_C) ) {
9407                         wastedflags |= WASTED_GC;
9408                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
9409                         vWARN3(
9410                             RExC_parse + 1,
9411                             "Useless (%sc) - %suse /gc modifier",
9412                             flagsp == &negflags ? "?-" : "?",
9413                             flagsp == &negflags ? "don't " : ""
9414                         );
9415                     }
9416                 }
9417                 break;
9418             case KEEPCOPY_PAT_MOD: /* 'p' */
9419                 if (flagsp == &negflags) {
9420                     if (PASS2)
9421                         ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
9422                 } else {
9423                     *flagsp |= RXf_PMf_KEEPCOPY;
9424                 }
9425                 break;
9426             case '-':
9427                 /* A flag is a default iff it is following a minus, so
9428                  * if there is a minus, it means will be trying to
9429                  * re-specify a default which is an error */
9430                 if (has_use_defaults || flagsp == &negflags) {
9431                     goto fail_modifiers;
9432                 }
9433                 flagsp = &negflags;
9434                 wastedflags = 0;  /* reset so (?g-c) warns twice */
9435                 break;
9436             case ':':
9437             case ')':
9438                 RExC_flags |= posflags;
9439                 RExC_flags &= ~negflags;
9440                 set_regex_charset(&RExC_flags, cs);
9441                 if (RExC_flags & RXf_PMf_FOLD) {
9442                     RExC_contains_i = 1;
9443                 }
9444                 return;
9445                 /*NOTREACHED*/
9446             default:
9447             fail_modifiers:
9448                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
9449                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
9450                 vFAIL2utf8f("Sequence (%"UTF8f"...) not recognized",
9451                       UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
9452                 /*NOTREACHED*/
9453         }
9454
9455         ++RExC_parse;
9456     }
9457 }
9458
9459 /*
9460  - reg - regular expression, i.e. main body or parenthesized thing
9461  *
9462  * Caller must absorb opening parenthesis.
9463  *
9464  * Combining parenthesis handling with the base level of regular expression
9465  * is a trifle forced, but the need to tie the tails of the branches to what
9466  * follows makes it hard to avoid.
9467  */
9468 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
9469 #ifdef DEBUGGING
9470 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
9471 #else
9472 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
9473 #endif
9474
9475 /* Returns NULL, setting *flagp to TRYAGAIN at the end of (?) that only sets
9476    flags. Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan
9477    needs to be restarted.
9478    Otherwise would only return NULL if regbranch() returns NULL, which
9479    cannot happen.  */
9480 STATIC regnode *
9481 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
9482     /* paren: Parenthesized? 0=top; 1,2=inside '(': changed to letter.
9483      * 2 is like 1, but indicates that nextchar() has been called to advance
9484      * RExC_parse beyond the '('.  Things like '(?' are indivisible tokens, and
9485      * this flag alerts us to the need to check for that */
9486 {
9487     regnode *ret;               /* Will be the head of the group. */
9488     regnode *br;
9489     regnode *lastbr;
9490     regnode *ender = NULL;
9491     I32 parno = 0;
9492     I32 flags;
9493     U32 oregflags = RExC_flags;
9494     bool have_branch = 0;
9495     bool is_open = 0;
9496     I32 freeze_paren = 0;
9497     I32 after_freeze = 0;
9498     I32 num; /* numeric backreferences */
9499
9500     char * parse_start = RExC_parse; /* MJD */
9501     char * const oregcomp_parse = RExC_parse;
9502
9503     GET_RE_DEBUG_FLAGS_DECL;
9504
9505     PERL_ARGS_ASSERT_REG;
9506     DEBUG_PARSE("reg ");
9507
9508     *flagp = 0;                         /* Tentatively. */
9509
9510
9511     /* Make an OPEN node, if parenthesized. */
9512     if (paren) {
9513
9514         /* Under /x, space and comments can be gobbled up between the '(' and
9515          * here (if paren ==2).  The forms '(*VERB' and '(?...' disallow such
9516          * intervening space, as the sequence is a token, and a token should be
9517          * indivisible */
9518         bool has_intervening_patws = paren == 2 && *(RExC_parse - 1) != '(';
9519
9520         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
9521             char *start_verb = RExC_parse;
9522             STRLEN verb_len = 0;
9523             char *start_arg = NULL;
9524             unsigned char op = 0;
9525             int argok = 1;
9526             int internal_argval = 0; /* internal_argval is only useful if
9527                                         !argok */
9528
9529             if (has_intervening_patws) {
9530                 RExC_parse++;
9531                 vFAIL("In '(*VERB...)', the '(' and '*' must be adjacent");
9532             }
9533             while ( *RExC_parse && *RExC_parse != ')' ) {
9534                 if ( *RExC_parse == ':' ) {
9535                     start_arg = RExC_parse + 1;
9536                     break;
9537                 }
9538                 RExC_parse++;
9539             }
9540             ++start_verb;
9541             verb_len = RExC_parse - start_verb;
9542             if ( start_arg ) {
9543                 RExC_parse++;
9544                 while ( *RExC_parse && *RExC_parse != ')' )
9545                     RExC_parse++;
9546                 if ( *RExC_parse != ')' )
9547                     vFAIL("Unterminated verb pattern argument");
9548                 if ( RExC_parse == start_arg )
9549                     start_arg = NULL;
9550             } else {
9551                 if ( *RExC_parse != ')' )
9552                     vFAIL("Unterminated verb pattern");
9553             }
9554
9555             switch ( *start_verb ) {
9556             case 'A':  /* (*ACCEPT) */
9557                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
9558                     op = ACCEPT;
9559                     internal_argval = RExC_nestroot;
9560                 }
9561                 break;
9562             case 'C':  /* (*COMMIT) */
9563                 if ( memEQs(start_verb,verb_len,"COMMIT") )
9564                     op = COMMIT;
9565                 break;
9566             case 'F':  /* (*FAIL) */
9567                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
9568                     op = OPFAIL;
9569                     argok = 0;
9570                 }
9571                 break;
9572             case ':':  /* (*:NAME) */
9573             case 'M':  /* (*MARK:NAME) */
9574                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
9575                     op = MARKPOINT;
9576                     argok = -1;
9577                 }
9578                 break;
9579             case 'P':  /* (*PRUNE) */
9580                 if ( memEQs(start_verb,verb_len,"PRUNE") )
9581                     op = PRUNE;
9582                 break;
9583             case 'S':   /* (*SKIP) */
9584                 if ( memEQs(start_verb,verb_len,"SKIP") )
9585                     op = SKIP;
9586                 break;
9587             case 'T':  /* (*THEN) */
9588                 /* [19:06] <TimToady> :: is then */
9589                 if ( memEQs(start_verb,verb_len,"THEN") ) {
9590                     op = CUTGROUP;
9591                     RExC_seen |= REG_CUTGROUP_SEEN;
9592                 }
9593                 break;
9594             }
9595             if ( ! op ) {
9596                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
9597                 vFAIL2utf8f(
9598                     "Unknown verb pattern '%"UTF8f"'",
9599                     UTF8fARG(UTF, verb_len, start_verb));
9600             }
9601             if ( argok ) {
9602                 if ( start_arg && internal_argval ) {
9603                     vFAIL3("Verb pattern '%.*s' may not have an argument",
9604                         verb_len, start_verb);
9605                 } else if ( argok < 0 && !start_arg ) {
9606                     vFAIL3("Verb pattern '%.*s' has a mandatory argument",
9607                         verb_len, start_verb);
9608                 } else {
9609                     ret = reganode(pRExC_state, op, internal_argval);
9610                     if ( ! internal_argval && ! SIZE_ONLY ) {
9611                         if (start_arg) {
9612                             SV *sv = newSVpvn( start_arg,
9613                                                RExC_parse - start_arg);
9614                             ARG(ret) = add_data( pRExC_state,
9615                                                  STR_WITH_LEN("S"));
9616                             RExC_rxi->data->data[ARG(ret)]=(void*)sv;
9617                             ret->flags = 0;
9618                         } else {
9619                             ret->flags = 1;
9620                         }
9621                     }
9622                 }
9623                 if (!internal_argval)
9624                     RExC_seen |= REG_VERBARG_SEEN;
9625             } else if ( start_arg ) {
9626                 vFAIL3("Verb pattern '%.*s' may not have an argument",
9627                         verb_len, start_verb);
9628             } else {
9629                 ret = reg_node(pRExC_state, op);
9630             }
9631             nextchar(pRExC_state);
9632             return ret;
9633         }
9634         else if (*RExC_parse == '?') { /* (?...) */
9635             bool is_logical = 0;
9636             const char * const seqstart = RExC_parse;
9637             const char * endptr;
9638             if (has_intervening_patws) {
9639                 RExC_parse++;
9640                 vFAIL("In '(?...)', the '(' and '?' must be adjacent");
9641             }
9642
9643             RExC_parse++;
9644             paren = *RExC_parse++;
9645             ret = NULL;                 /* For look-ahead/behind. */
9646             switch (paren) {
9647
9648             case 'P':   /* (?P...) variants for those used to PCRE/Python */
9649                 paren = *RExC_parse++;
9650                 if ( paren == '<')         /* (?P<...>) named capture */
9651                     goto named_capture;
9652                 else if (paren == '>') {   /* (?P>name) named recursion */
9653                     goto named_recursion;
9654                 }
9655                 else if (paren == '=') {   /* (?P=...)  named backref */
9656                     /* this pretty much dupes the code for \k<NAME> in
9657                      * regatom(), if you change this make sure you change that
9658                      * */
9659                     char* name_start = RExC_parse;
9660                     U32 num = 0;
9661                     SV *sv_dat = reg_scan_name(pRExC_state,
9662                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
9663                     if (RExC_parse == name_start || *RExC_parse != ')')
9664                         /* diag_listed_as: Sequence ?P=... not terminated in regex; marked by <-- HERE in m/%s/ */
9665                         vFAIL2("Sequence %.3s... not terminated",parse_start);
9666
9667                     if (!SIZE_ONLY) {
9668                         num = add_data( pRExC_state, STR_WITH_LEN("S"));
9669                         RExC_rxi->data->data[num]=(void*)sv_dat;
9670                         SvREFCNT_inc_simple_void(sv_dat);
9671                     }
9672                     RExC_sawback = 1;
9673                     ret = reganode(pRExC_state,
9674                                    ((! FOLD)
9675                                      ? NREF
9676                                      : (ASCII_FOLD_RESTRICTED)
9677                                        ? NREFFA
9678                                        : (AT_LEAST_UNI_SEMANTICS)
9679                                          ? NREFFU
9680                                          : (LOC)
9681                                            ? NREFFL
9682                                            : NREFF),
9683                                     num);
9684                     *flagp |= HASWIDTH;
9685
9686                     Set_Node_Offset(ret, parse_start+1);
9687                     Set_Node_Cur_Length(ret, parse_start);
9688
9689                     nextchar(pRExC_state);
9690                     return ret;
9691                 }
9692                 RExC_parse++;
9693                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
9694                 vFAIL3("Sequence (%.*s...) not recognized",
9695                                 RExC_parse-seqstart, seqstart);
9696                 /*NOTREACHED*/
9697             case '<':           /* (?<...) */
9698                 if (*RExC_parse == '!')
9699                     paren = ',';
9700                 else if (*RExC_parse != '=')
9701               named_capture:
9702                 {               /* (?<...>) */
9703                     char *name_start;
9704                     SV *svname;
9705                     paren= '>';
9706             case '\'':          /* (?'...') */
9707                     name_start= RExC_parse;
9708                     svname = reg_scan_name(pRExC_state,
9709                         SIZE_ONLY    /* reverse test from the others */
9710                         ? REG_RSN_RETURN_NAME
9711                         : REG_RSN_RETURN_NULL);
9712                     if (RExC_parse == name_start || *RExC_parse != paren)
9713                         vFAIL2("Sequence (?%c... not terminated",
9714                             paren=='>' ? '<' : paren);
9715                     if (SIZE_ONLY) {
9716                         HE *he_str;
9717                         SV *sv_dat = NULL;
9718                         if (!svname) /* shouldn't happen */
9719                             Perl_croak(aTHX_
9720                                 "panic: reg_scan_name returned NULL");
9721                         if (!RExC_paren_names) {
9722                             RExC_paren_names= newHV();
9723                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
9724 #ifdef DEBUGGING
9725                             RExC_paren_name_list= newAV();
9726                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
9727 #endif
9728                         }
9729                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
9730                         if ( he_str )
9731                             sv_dat = HeVAL(he_str);
9732                         if ( ! sv_dat ) {
9733                             /* croak baby croak */
9734                             Perl_croak(aTHX_
9735                                 "panic: paren_name hash element allocation failed");
9736                         } else if ( SvPOK(sv_dat) ) {
9737                             /* (?|...) can mean we have dupes so scan to check
9738                                its already been stored. Maybe a flag indicating
9739                                we are inside such a construct would be useful,
9740                                but the arrays are likely to be quite small, so
9741                                for now we punt -- dmq */
9742                             IV count = SvIV(sv_dat);
9743                             I32 *pv = (I32*)SvPVX(sv_dat);
9744                             IV i;
9745                             for ( i = 0 ; i < count ; i++ ) {
9746                                 if ( pv[i] == RExC_npar ) {
9747                                     count = 0;
9748                                     break;
9749                                 }
9750                             }
9751                             if ( count ) {
9752                                 pv = (I32*)SvGROW(sv_dat,
9753                                                 SvCUR(sv_dat) + sizeof(I32)+1);
9754                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
9755                                 pv[count] = RExC_npar;
9756                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
9757                             }
9758                         } else {
9759                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
9760                             sv_setpvn(sv_dat, (char *)&(RExC_npar),
9761                                                                 sizeof(I32));
9762                             SvIOK_on(sv_dat);
9763                             SvIV_set(sv_dat, 1);
9764                         }
9765 #ifdef DEBUGGING
9766                         /* Yes this does cause a memory leak in debugging Perls
9767                          * */
9768                         if (!av_store(RExC_paren_name_list,
9769                                       RExC_npar, SvREFCNT_inc(svname)))
9770                             SvREFCNT_dec_NN(svname);
9771 #endif
9772
9773                         /*sv_dump(sv_dat);*/
9774                     }
9775                     nextchar(pRExC_state);
9776                     paren = 1;
9777                     goto capturing_parens;
9778                 }
9779                 RExC_seen |= REG_LOOKBEHIND_SEEN;
9780                 RExC_in_lookbehind++;
9781                 RExC_parse++;
9782                 /* FALLTHROUGH */
9783             case '=':           /* (?=...) */
9784                 RExC_seen_zerolen++;
9785                 break;
9786             case '!':           /* (?!...) */
9787                 RExC_seen_zerolen++;
9788                 if (*RExC_parse == ')') {
9789                     ret=reg_node(pRExC_state, OPFAIL);
9790                     nextchar(pRExC_state);
9791                     return ret;
9792                 }
9793                 break;
9794             case '|':           /* (?|...) */
9795                 /* branch reset, behave like a (?:...) except that
9796                    buffers in alternations share the same numbers */
9797                 paren = ':';
9798                 after_freeze = freeze_paren = RExC_npar;
9799                 break;
9800             case ':':           /* (?:...) */
9801             case '>':           /* (?>...) */
9802                 break;
9803             case '$':           /* (?$...) */
9804             case '@':           /* (?@...) */
9805                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
9806                 break;
9807             case '0' :           /* (?0) */
9808             case 'R' :           /* (?R) */
9809                 if (*RExC_parse != ')')
9810                     FAIL("Sequence (?R) not terminated");
9811                 ret = reg_node(pRExC_state, GOSTART);
9812                     RExC_seen |= REG_GOSTART_SEEN;
9813                 *flagp |= POSTPONED;
9814                 nextchar(pRExC_state);
9815                 return ret;
9816                 /*notreached*/
9817             /* named and numeric backreferences */
9818             case '&':            /* (?&NAME) */
9819                 parse_start = RExC_parse - 1;
9820               named_recursion:
9821                 {
9822                     SV *sv_dat = reg_scan_name(pRExC_state,
9823                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
9824                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
9825                 }
9826                 if (RExC_parse == RExC_end || *RExC_parse != ')')
9827                     vFAIL("Sequence (?&... not terminated");
9828                 goto gen_recurse_regop;
9829                 assert(0); /* NOT REACHED */
9830             case '+':
9831                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
9832                     RExC_parse++;
9833                     vFAIL("Illegal pattern");
9834                 }
9835                 goto parse_recursion;
9836                 /* NOT REACHED*/
9837             case '-': /* (?-1) */
9838                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
9839                     RExC_parse--; /* rewind to let it be handled later */
9840                     goto parse_flags;
9841                 }
9842                 /* FALLTHROUGH */
9843             case '1': case '2': case '3': case '4': /* (?1) */
9844             case '5': case '6': case '7': case '8': case '9':
9845                 RExC_parse--;
9846               parse_recursion:
9847                 {
9848                     bool is_neg = FALSE;
9849                     parse_start = RExC_parse - 1; /* MJD */
9850                     if (*RExC_parse == '-') {
9851                         RExC_parse++;
9852                         is_neg = TRUE;
9853                     }
9854                     num = grok_atou(RExC_parse, &endptr);
9855                     if (endptr)
9856                         RExC_parse = (char*)endptr;
9857                     if (is_neg) {
9858                         /* Some limit for num? */
9859                         num = -num;
9860                     }
9861                 }
9862                 if (*RExC_parse!=')')
9863                     vFAIL("Expecting close bracket");
9864
9865               gen_recurse_regop:
9866                 if ( paren == '-' ) {
9867                     /*
9868                     Diagram of capture buffer numbering.
9869                     Top line is the normal capture buffer numbers
9870                     Bottom line is the negative indexing as from
9871                     the X (the (?-2))
9872
9873                     +   1 2    3 4 5 X          6 7
9874                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
9875                     -   5 4    3 2 1 X          x x
9876
9877                     */
9878                     num = RExC_npar + num;
9879                     if (num < 1)  {
9880                         RExC_parse++;
9881                         vFAIL("Reference to nonexistent group");
9882                     }
9883                 } else if ( paren == '+' ) {
9884                     num = RExC_npar + num - 1;
9885                 }
9886
9887                 ret = reganode(pRExC_state, GOSUB, num);
9888                 if (!SIZE_ONLY) {
9889                     if (num > (I32)RExC_rx->nparens) {
9890                         RExC_parse++;
9891                         vFAIL("Reference to nonexistent group");
9892                     }
9893                     ARG2L_SET( ret, RExC_recurse_count++);
9894                     RExC_emit++;
9895                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
9896                         "Recurse #%"UVuf" to %"IVdf"\n",
9897                               (UV)ARG(ret), (IV)ARG2L(ret)));
9898                 } else {
9899                     RExC_size++;
9900                 }
9901                     RExC_seen |= REG_RECURSE_SEEN;
9902                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
9903                 Set_Node_Offset(ret, parse_start); /* MJD */
9904
9905                 *flagp |= POSTPONED;
9906                 nextchar(pRExC_state);
9907                 return ret;
9908
9909             assert(0); /* NOT REACHED */
9910
9911             case '?':           /* (??...) */
9912                 is_logical = 1;
9913                 if (*RExC_parse != '{') {
9914                     RExC_parse++;
9915                     /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
9916                     vFAIL2utf8f(
9917                         "Sequence (%"UTF8f"...) not recognized",
9918                         UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
9919                     /*NOTREACHED*/
9920                 }
9921                 *flagp |= POSTPONED;
9922                 paren = *RExC_parse++;
9923                 /* FALLTHROUGH */
9924             case '{':           /* (?{...}) */
9925             {
9926                 U32 n = 0;
9927                 struct reg_code_block *cb;
9928
9929                 RExC_seen_zerolen++;
9930
9931                 if (   !pRExC_state->num_code_blocks
9932                     || pRExC_state->code_index >= pRExC_state->num_code_blocks
9933                     || pRExC_state->code_blocks[pRExC_state->code_index].start
9934                         != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
9935                             - RExC_start)
9936                 ) {
9937                     if (RExC_pm_flags & PMf_USE_RE_EVAL)
9938                         FAIL("panic: Sequence (?{...}): no code block found\n");
9939                     FAIL("Eval-group not allowed at runtime, use re 'eval'");
9940                 }
9941                 /* this is a pre-compiled code block (?{...}) */
9942                 cb = &pRExC_state->code_blocks[pRExC_state->code_index];
9943                 RExC_parse = RExC_start + cb->end;
9944                 if (!SIZE_ONLY) {
9945                     OP *o = cb->block;
9946                     if (cb->src_regex) {
9947                         n = add_data(pRExC_state, STR_WITH_LEN("rl"));
9948                         RExC_rxi->data->data[n] =
9949                             (void*)SvREFCNT_inc((SV*)cb->src_regex);
9950                         RExC_rxi->data->data[n+1] = (void*)o;
9951                     }
9952                     else {
9953                         n = add_data(pRExC_state,
9954                                (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l", 1);
9955                         RExC_rxi->data->data[n] = (void*)o;
9956                     }
9957                 }
9958                 pRExC_state->code_index++;
9959                 nextchar(pRExC_state);
9960
9961                 if (is_logical) {
9962                     regnode *eval;
9963                     ret = reg_node(pRExC_state, LOGICAL);
9964                     eval = reganode(pRExC_state, EVAL, n);
9965                     if (!SIZE_ONLY) {
9966                         ret->flags = 2;
9967                         /* for later propagation into (??{}) return value */
9968                         eval->flags = (U8) (RExC_flags & RXf_PMf_COMPILETIME);
9969                     }
9970                     REGTAIL(pRExC_state, ret, eval);
9971                     /* deal with the length of this later - MJD */
9972                     return ret;
9973                 }
9974                 ret = reganode(pRExC_state, EVAL, n);
9975                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
9976                 Set_Node_Offset(ret, parse_start);
9977                 return ret;
9978             }
9979             case '(':           /* (?(?{...})...) and (?(?=...)...) */
9980             {
9981                 int is_define= 0;
9982                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
9983                     if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
9984                         || RExC_parse[1] == '<'
9985                         || RExC_parse[1] == '{') { /* Lookahead or eval. */
9986                         I32 flag;
9987                         regnode *tail;
9988
9989                         ret = reg_node(pRExC_state, LOGICAL);
9990                         if (!SIZE_ONLY)
9991                             ret->flags = 1;
9992
9993                         tail = reg(pRExC_state, 1, &flag, depth+1);
9994                         if (flag & RESTART_UTF8) {
9995                             *flagp = RESTART_UTF8;
9996                             return NULL;
9997                         }
9998                         REGTAIL(pRExC_state, ret, tail);
9999                         goto insert_if;
10000                     }
10001                     /* Fall through to â€˜Unknown switch condition’ at the
10002                        end of the if/else chain. */
10003                 }
10004                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
10005                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
10006                 {
10007                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
10008                     char *name_start= RExC_parse++;
10009                     U32 num = 0;
10010                     SV *sv_dat=reg_scan_name(pRExC_state,
10011                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
10012                     if (RExC_parse == name_start || *RExC_parse != ch)
10013                         vFAIL2("Sequence (?(%c... not terminated",
10014                             (ch == '>' ? '<' : ch));
10015                     RExC_parse++;
10016                     if (!SIZE_ONLY) {
10017                         num = add_data( pRExC_state, STR_WITH_LEN("S"));
10018                         RExC_rxi->data->data[num]=(void*)sv_dat;
10019                         SvREFCNT_inc_simple_void(sv_dat);
10020                     }
10021                     ret = reganode(pRExC_state,NGROUPP,num);
10022                     goto insert_if_check_paren;
10023                 }
10024                 else if (RExC_parse[0] == 'D' &&
10025                          RExC_parse[1] == 'E' &&
10026                          RExC_parse[2] == 'F' &&
10027                          RExC_parse[3] == 'I' &&
10028                          RExC_parse[4] == 'N' &&
10029                          RExC_parse[5] == 'E')
10030                 {
10031                     ret = reganode(pRExC_state,DEFINEP,0);
10032                     RExC_parse +=6 ;
10033                     is_define = 1;
10034                     goto insert_if_check_paren;
10035                 }
10036                 else if (RExC_parse[0] == 'R') {
10037                     RExC_parse++;
10038                     parno = 0;
10039                     if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
10040                         parno = grok_atou(RExC_parse, &endptr);
10041                         if (endptr)
10042                             RExC_parse = (char*)endptr;
10043                     } else if (RExC_parse[0] == '&') {
10044                         SV *sv_dat;
10045                         RExC_parse++;
10046                         sv_dat = reg_scan_name(pRExC_state,
10047                             SIZE_ONLY
10048                             ? REG_RSN_RETURN_NULL
10049                             : REG_RSN_RETURN_DATA);
10050                         parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
10051                     }
10052                     ret = reganode(pRExC_state,INSUBP,parno);
10053                     goto insert_if_check_paren;
10054                 }
10055                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
10056                     /* (?(1)...) */
10057                     char c;
10058                     char *tmp;
10059                     parno = grok_atou(RExC_parse, &endptr);
10060                     if (endptr)
10061                         RExC_parse = (char*)endptr;
10062                     ret = reganode(pRExC_state, GROUPP, parno);
10063
10064                  insert_if_check_paren:
10065                     if (*(tmp = nextchar(pRExC_state)) != ')') {
10066                         /* nextchar also skips comments, so undo its work
10067                          * and skip over the the next character.
10068                          */
10069                         RExC_parse = tmp;
10070                         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10071                         vFAIL("Switch condition not recognized");
10072                     }
10073                   insert_if:
10074                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
10075                     br = regbranch(pRExC_state, &flags, 1,depth+1);
10076                     if (br == NULL) {
10077                         if (flags & RESTART_UTF8) {
10078                             *flagp = RESTART_UTF8;
10079                             return NULL;
10080                         }
10081                         FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"",
10082                               (UV) flags);
10083                     } else
10084                         REGTAIL(pRExC_state, br, reganode(pRExC_state,
10085                                                           LONGJMP, 0));
10086                     c = *nextchar(pRExC_state);
10087                     if (flags&HASWIDTH)
10088                         *flagp |= HASWIDTH;
10089                     if (c == '|') {
10090                         if (is_define)
10091                             vFAIL("(?(DEFINE)....) does not allow branches");
10092
10093                         /* Fake one for optimizer.  */
10094                         lastbr = reganode(pRExC_state, IFTHEN, 0);
10095
10096                         if (!regbranch(pRExC_state, &flags, 1,depth+1)) {
10097                             if (flags & RESTART_UTF8) {
10098                                 *flagp = RESTART_UTF8;
10099                                 return NULL;
10100                             }
10101                             FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"",
10102                                   (UV) flags);
10103                         }
10104                         REGTAIL(pRExC_state, ret, lastbr);
10105                         if (flags&HASWIDTH)
10106                             *flagp |= HASWIDTH;
10107                         c = *nextchar(pRExC_state);
10108                     }
10109                     else
10110                         lastbr = NULL;
10111                     if (c != ')')
10112                         vFAIL("Switch (?(condition)... contains too many branches");
10113                     ender = reg_node(pRExC_state, TAIL);
10114                     REGTAIL(pRExC_state, br, ender);
10115                     if (lastbr) {
10116                         REGTAIL(pRExC_state, lastbr, ender);
10117                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
10118                     }
10119                     else
10120                         REGTAIL(pRExC_state, ret, ender);
10121                     RExC_size++; /* XXX WHY do we need this?!!
10122                                     For large programs it seems to be required
10123                                     but I can't figure out why. -- dmq*/
10124                     return ret;
10125                 }
10126                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10127                 vFAIL("Unknown switch condition (?(...))");
10128             }
10129             case '[':           /* (?[ ... ]) */
10130                 return handle_regex_sets(pRExC_state, NULL, flagp, depth,
10131                                          oregcomp_parse);
10132             case 0:
10133                 RExC_parse--; /* for vFAIL to print correctly */
10134                 vFAIL("Sequence (? incomplete");
10135                 break;
10136             default: /* e.g., (?i) */
10137                 --RExC_parse;
10138               parse_flags:
10139                 parse_lparen_question_flags(pRExC_state);
10140                 if (UCHARAT(RExC_parse) != ':') {
10141                     nextchar(pRExC_state);
10142                     *flagp = TRYAGAIN;
10143                     return NULL;
10144                 }
10145                 paren = ':';
10146                 nextchar(pRExC_state);
10147                 ret = NULL;
10148                 goto parse_rest;
10149             } /* end switch */
10150         }
10151         else {                  /* (...) */
10152           capturing_parens:
10153             parno = RExC_npar;
10154             RExC_npar++;
10155
10156             ret = reganode(pRExC_state, OPEN, parno);
10157             if (!SIZE_ONLY ){
10158                 if (!RExC_nestroot)
10159                     RExC_nestroot = parno;
10160                 if (RExC_seen & REG_RECURSE_SEEN
10161                     && !RExC_open_parens[parno-1])
10162                 {
10163                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
10164                         "Setting open paren #%"IVdf" to %d\n",
10165                         (IV)parno, REG_NODE_NUM(ret)));
10166                     RExC_open_parens[parno-1]= ret;
10167                 }
10168             }
10169             Set_Node_Length(ret, 1); /* MJD */
10170             Set_Node_Offset(ret, RExC_parse); /* MJD */
10171             is_open = 1;
10172         }
10173     }
10174     else                        /* ! paren */
10175         ret = NULL;
10176
10177    parse_rest:
10178     /* Pick up the branches, linking them together. */
10179     parse_start = RExC_parse;   /* MJD */
10180     br = regbranch(pRExC_state, &flags, 1,depth+1);
10181
10182     /*     branch_len = (paren != 0); */
10183
10184     if (br == NULL) {
10185         if (flags & RESTART_UTF8) {
10186             *flagp = RESTART_UTF8;
10187             return NULL;
10188         }
10189         FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"", (UV) flags);
10190     }
10191     if (*RExC_parse == '|') {
10192         if (!SIZE_ONLY && RExC_extralen) {
10193             reginsert(pRExC_state, BRANCHJ, br, depth+1);
10194         }
10195         else {                  /* MJD */
10196             reginsert(pRExC_state, BRANCH, br, depth+1);
10197             Set_Node_Length(br, paren != 0);
10198             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
10199         }
10200         have_branch = 1;
10201         if (SIZE_ONLY)
10202             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
10203     }
10204     else if (paren == ':') {
10205         *flagp |= flags&SIMPLE;
10206     }
10207     if (is_open) {                              /* Starts with OPEN. */
10208         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
10209     }
10210     else if (paren != '?')              /* Not Conditional */
10211         ret = br;
10212     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
10213     lastbr = br;
10214     while (*RExC_parse == '|') {
10215         if (!SIZE_ONLY && RExC_extralen) {
10216             ender = reganode(pRExC_state, LONGJMP,0);
10217
10218             /* Append to the previous. */
10219             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
10220         }
10221         if (SIZE_ONLY)
10222             RExC_extralen += 2;         /* Account for LONGJMP. */
10223         nextchar(pRExC_state);
10224         if (freeze_paren) {
10225             if (RExC_npar > after_freeze)
10226                 after_freeze = RExC_npar;
10227             RExC_npar = freeze_paren;
10228         }
10229         br = regbranch(pRExC_state, &flags, 0, depth+1);
10230
10231         if (br == NULL) {
10232             if (flags & RESTART_UTF8) {
10233                 *flagp = RESTART_UTF8;
10234                 return NULL;
10235             }
10236             FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"", (UV) flags);
10237         }
10238         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
10239         lastbr = br;
10240         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
10241     }
10242
10243     if (have_branch || paren != ':') {
10244         /* Make a closing node, and hook it on the end. */
10245         switch (paren) {
10246         case ':':
10247             ender = reg_node(pRExC_state, TAIL);
10248             break;
10249         case 1: case 2:
10250             ender = reganode(pRExC_state, CLOSE, parno);
10251             if (!SIZE_ONLY && RExC_seen & REG_RECURSE_SEEN) {
10252                 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
10253                         "Setting close paren #%"IVdf" to %d\n",
10254                         (IV)parno, REG_NODE_NUM(ender)));
10255                 RExC_close_parens[parno-1]= ender;
10256                 if (RExC_nestroot == parno)
10257                     RExC_nestroot = 0;
10258             }
10259             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
10260             Set_Node_Length(ender,1); /* MJD */
10261             break;
10262         case '<':
10263         case ',':
10264         case '=':
10265         case '!':
10266             *flagp &= ~HASWIDTH;
10267             /* FALLTHROUGH */
10268         case '>':
10269             ender = reg_node(pRExC_state, SUCCEED);
10270             break;
10271         case 0:
10272             ender = reg_node(pRExC_state, END);
10273             if (!SIZE_ONLY) {
10274                 assert(!RExC_opend); /* there can only be one! */
10275                 RExC_opend = ender;
10276             }
10277             break;
10278         }
10279         DEBUG_PARSE_r(if (!SIZE_ONLY) {
10280             SV * const mysv_val1=sv_newmortal();
10281             SV * const mysv_val2=sv_newmortal();
10282             DEBUG_PARSE_MSG("lsbr");
10283             regprop(RExC_rx, mysv_val1, lastbr, NULL);
10284             regprop(RExC_rx, mysv_val2, ender, NULL);
10285             PerlIO_printf(Perl_debug_log, "~ tying lastbr %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
10286                           SvPV_nolen_const(mysv_val1),
10287                           (IV)REG_NODE_NUM(lastbr),
10288                           SvPV_nolen_const(mysv_val2),
10289                           (IV)REG_NODE_NUM(ender),
10290                           (IV)(ender - lastbr)
10291             );
10292         });
10293         REGTAIL(pRExC_state, lastbr, ender);
10294
10295         if (have_branch && !SIZE_ONLY) {
10296             char is_nothing= 1;
10297             if (depth==1)
10298                 RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
10299
10300             /* Hook the tails of the branches to the closing node. */
10301             for (br = ret; br; br = regnext(br)) {
10302                 const U8 op = PL_regkind[OP(br)];
10303                 if (op == BRANCH) {
10304                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
10305                     if ( OP(NEXTOPER(br)) != NOTHING
10306                          || regnext(NEXTOPER(br)) != ender)
10307                         is_nothing= 0;
10308                 }
10309                 else if (op == BRANCHJ) {
10310                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
10311                     /* for now we always disable this optimisation * /
10312                     if ( OP(NEXTOPER(NEXTOPER(br))) != NOTHING
10313                          || regnext(NEXTOPER(NEXTOPER(br))) != ender)
10314                     */
10315                         is_nothing= 0;
10316                 }
10317             }
10318             if (is_nothing) {
10319                 br= PL_regkind[OP(ret)] != BRANCH ? regnext(ret) : ret;
10320                 DEBUG_PARSE_r(if (!SIZE_ONLY) {
10321                     SV * const mysv_val1=sv_newmortal();
10322                     SV * const mysv_val2=sv_newmortal();
10323                     DEBUG_PARSE_MSG("NADA");
10324                     regprop(RExC_rx, mysv_val1, ret, NULL);
10325                     regprop(RExC_rx, mysv_val2, ender, NULL);
10326                     PerlIO_printf(Perl_debug_log, "~ converting ret %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
10327                                   SvPV_nolen_const(mysv_val1),
10328                                   (IV)REG_NODE_NUM(ret),
10329                                   SvPV_nolen_const(mysv_val2),
10330                                   (IV)REG_NODE_NUM(ender),
10331                                   (IV)(ender - ret)
10332                     );
10333                 });
10334                 OP(br)= NOTHING;
10335                 if (OP(ender) == TAIL) {
10336                     NEXT_OFF(br)= 0;
10337                     RExC_emit= br + 1;
10338                 } else {
10339                     regnode *opt;
10340                     for ( opt= br + 1; opt < ender ; opt++ )
10341                         OP(opt)= OPTIMIZED;
10342                     NEXT_OFF(br)= ender - br;
10343                 }
10344             }
10345         }
10346     }
10347
10348     {
10349         const char *p;
10350         static const char parens[] = "=!<,>";
10351
10352         if (paren && (p = strchr(parens, paren))) {
10353             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
10354             int flag = (p - parens) > 1;
10355
10356             if (paren == '>')
10357                 node = SUSPEND, flag = 0;
10358             reginsert(pRExC_state, node,ret, depth+1);
10359             Set_Node_Cur_Length(ret, parse_start);
10360             Set_Node_Offset(ret, parse_start + 1);
10361             ret->flags = flag;
10362             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
10363         }
10364     }
10365
10366     /* Check for proper termination. */
10367     if (paren) {
10368         /* restore original flags, but keep (?p) */
10369         RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY);
10370         if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
10371             RExC_parse = oregcomp_parse;
10372             vFAIL("Unmatched (");
10373         }
10374     }
10375     else if (!paren && RExC_parse < RExC_end) {
10376         if (*RExC_parse == ')') {
10377             RExC_parse++;
10378             vFAIL("Unmatched )");
10379         }
10380         else
10381             FAIL("Junk on end of regexp");      /* "Can't happen". */
10382         assert(0); /* NOTREACHED */
10383     }
10384
10385     if (RExC_in_lookbehind) {
10386         RExC_in_lookbehind--;
10387     }
10388     if (after_freeze > RExC_npar)
10389         RExC_npar = after_freeze;
10390     return(ret);
10391 }
10392
10393 /*
10394  - regbranch - one alternative of an | operator
10395  *
10396  * Implements the concatenation operator.
10397  *
10398  * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
10399  * restarted.
10400  */
10401 STATIC regnode *
10402 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
10403 {
10404     regnode *ret;
10405     regnode *chain = NULL;
10406     regnode *latest;
10407     I32 flags = 0, c = 0;
10408     GET_RE_DEBUG_FLAGS_DECL;
10409
10410     PERL_ARGS_ASSERT_REGBRANCH;
10411
10412     DEBUG_PARSE("brnc");
10413
10414     if (first)
10415         ret = NULL;
10416     else {
10417         if (!SIZE_ONLY && RExC_extralen)
10418             ret = reganode(pRExC_state, BRANCHJ,0);
10419         else {
10420             ret = reg_node(pRExC_state, BRANCH);
10421             Set_Node_Length(ret, 1);
10422         }
10423     }
10424
10425     if (!first && SIZE_ONLY)
10426         RExC_extralen += 1;                     /* BRANCHJ */
10427
10428     *flagp = WORST;                     /* Tentatively. */
10429
10430     RExC_parse--;
10431     nextchar(pRExC_state);
10432     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
10433         flags &= ~TRYAGAIN;
10434         latest = regpiece(pRExC_state, &flags,depth+1);
10435         if (latest == NULL) {
10436             if (flags & TRYAGAIN)
10437                 continue;
10438             if (flags & RESTART_UTF8) {
10439                 *flagp = RESTART_UTF8;
10440                 return NULL;
10441             }
10442             FAIL2("panic: regpiece returned NULL, flags=%#"UVxf"", (UV) flags);
10443         }
10444         else if (ret == NULL)
10445             ret = latest;
10446         *flagp |= flags&(HASWIDTH|POSTPONED);
10447         if (chain == NULL)      /* First piece. */
10448             *flagp |= flags&SPSTART;
10449         else {
10450             RExC_naughty++;
10451             REGTAIL(pRExC_state, chain, latest);
10452         }
10453         chain = latest;
10454         c++;
10455     }
10456     if (chain == NULL) {        /* Loop ran zero times. */
10457         chain = reg_node(pRExC_state, NOTHING);
10458         if (ret == NULL)
10459             ret = chain;
10460     }
10461     if (c == 1) {
10462         *flagp |= flags&SIMPLE;
10463     }
10464
10465     return ret;
10466 }
10467
10468 /*
10469  - regpiece - something followed by possible [*+?]
10470  *
10471  * Note that the branching code sequences used for ? and the general cases
10472  * of * and + are somewhat optimized:  they use the same NOTHING node as
10473  * both the endmarker for their branch list and the body of the last branch.
10474  * It might seem that this node could be dispensed with entirely, but the
10475  * endmarker role is not redundant.
10476  *
10477  * Returns NULL, setting *flagp to TRYAGAIN if regatom() returns NULL with
10478  * TRYAGAIN.
10479  * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
10480  * restarted.
10481  */
10482 STATIC regnode *
10483 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
10484 {
10485     regnode *ret;
10486     char op;
10487     char *next;
10488     I32 flags;
10489     const char * const origparse = RExC_parse;
10490     I32 min;
10491     I32 max = REG_INFTY;
10492 #ifdef RE_TRACK_PATTERN_OFFSETS
10493     char *parse_start;
10494 #endif
10495     const char *maxpos = NULL;
10496
10497     /* Save the original in case we change the emitted regop to a FAIL. */
10498     regnode * const orig_emit = RExC_emit;
10499
10500     GET_RE_DEBUG_FLAGS_DECL;
10501
10502     PERL_ARGS_ASSERT_REGPIECE;
10503
10504     DEBUG_PARSE("piec");
10505
10506     ret = regatom(pRExC_state, &flags,depth+1);
10507     if (ret == NULL) {
10508         if (flags & (TRYAGAIN|RESTART_UTF8))
10509             *flagp |= flags & (TRYAGAIN|RESTART_UTF8);
10510         else
10511             FAIL2("panic: regatom returned NULL, flags=%#"UVxf"", (UV) flags);
10512         return(NULL);
10513     }
10514
10515     op = *RExC_parse;
10516
10517     if (op == '{' && regcurly(RExC_parse)) {
10518         maxpos = NULL;
10519 #ifdef RE_TRACK_PATTERN_OFFSETS
10520         parse_start = RExC_parse; /* MJD */
10521 #endif
10522         next = RExC_parse + 1;
10523         while (isDIGIT(*next) || *next == ',') {
10524             if (*next == ',') {
10525                 if (maxpos)
10526                     break;
10527                 else
10528                     maxpos = next;
10529             }
10530             next++;
10531         }
10532         if (*next == '}') {             /* got one */
10533             const char* endptr;
10534             if (!maxpos)
10535                 maxpos = next;
10536             RExC_parse++;
10537             min = grok_atou(RExC_parse, &endptr);
10538             if (*maxpos == ',')
10539                 maxpos++;
10540             else
10541                 maxpos = RExC_parse;
10542             max = grok_atou(maxpos, &endptr);
10543             if (!max && *maxpos != '0')
10544                 max = REG_INFTY;                /* meaning "infinity" */
10545             else if (max >= REG_INFTY)
10546                 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
10547             RExC_parse = next;
10548             nextchar(pRExC_state);
10549             if (max < min) {    /* If can't match, warn and optimize to fail
10550                                    unconditionally */
10551                 if (SIZE_ONLY) {
10552
10553                     /* We can't back off the size because we have to reserve
10554                      * enough space for all the things we are about to throw
10555                      * away, but we can shrink it by the ammount we are about
10556                      * to re-use here */
10557                     RExC_size = PREVOPER(RExC_size) - regarglen[(U8)OPFAIL];
10558                 }
10559                 else {
10560                     ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
10561                     RExC_emit = orig_emit;
10562                 }
10563                 ret = reg_node(pRExC_state, OPFAIL);
10564                 return ret;
10565             }
10566             else if (min == max
10567                      && RExC_parse < RExC_end
10568                      && (*RExC_parse == '?' || *RExC_parse == '+'))
10569             {
10570                 if (PASS2) {
10571                     ckWARN2reg(RExC_parse + 1,
10572                                "Useless use of greediness modifier '%c'",
10573                                *RExC_parse);
10574                 }
10575                 /* Absorb the modifier, so later code doesn't see nor use
10576                     * it */
10577                 nextchar(pRExC_state);
10578             }
10579
10580         do_curly:
10581             if ((flags&SIMPLE)) {
10582                 RExC_naughty += 2 + RExC_naughty / 2;
10583                 reginsert(pRExC_state, CURLY, ret, depth+1);
10584                 Set_Node_Offset(ret, parse_start+1); /* MJD */
10585                 Set_Node_Cur_Length(ret, parse_start);
10586             }
10587             else {
10588                 regnode * const w = reg_node(pRExC_state, WHILEM);
10589
10590                 w->flags = 0;
10591                 REGTAIL(pRExC_state, ret, w);
10592                 if (!SIZE_ONLY && RExC_extralen) {
10593                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
10594                     reginsert(pRExC_state, NOTHING,ret, depth+1);
10595                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
10596                 }
10597                 reginsert(pRExC_state, CURLYX,ret, depth+1);
10598                                 /* MJD hk */
10599                 Set_Node_Offset(ret, parse_start+1);
10600                 Set_Node_Length(ret,
10601                                 op == '{' ? (RExC_parse - parse_start) : 1);
10602
10603                 if (!SIZE_ONLY && RExC_extralen)
10604                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
10605                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
10606                 if (SIZE_ONLY)
10607                     RExC_whilem_seen++, RExC_extralen += 3;
10608                 RExC_naughty += 4 + RExC_naughty;       /* compound interest */
10609             }
10610             ret->flags = 0;
10611
10612             if (min > 0)
10613                 *flagp = WORST;
10614             if (max > 0)
10615                 *flagp |= HASWIDTH;
10616             if (!SIZE_ONLY) {
10617                 ARG1_SET(ret, (U16)min);
10618                 ARG2_SET(ret, (U16)max);
10619             }
10620             if (max == REG_INFTY)
10621                 RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
10622
10623             goto nest_check;
10624         }
10625     }
10626
10627     if (!ISMULT1(op)) {
10628         *flagp = flags;
10629         return(ret);
10630     }
10631
10632 #if 0                           /* Now runtime fix should be reliable. */
10633
10634     /* if this is reinstated, don't forget to put this back into perldiag:
10635
10636             =item Regexp *+ operand could be empty at {#} in regex m/%s/
10637
10638            (F) The part of the regexp subject to either the * or + quantifier
10639            could match an empty string. The {#} shows in the regular
10640            expression about where the problem was discovered.
10641
10642     */
10643
10644     if (!(flags&HASWIDTH) && op != '?')
10645       vFAIL("Regexp *+ operand could be empty");
10646 #endif
10647
10648 #ifdef RE_TRACK_PATTERN_OFFSETS
10649     parse_start = RExC_parse;
10650 #endif
10651     nextchar(pRExC_state);
10652
10653     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
10654
10655     if (op == '*' && (flags&SIMPLE)) {
10656         reginsert(pRExC_state, STAR, ret, depth+1);
10657         ret->flags = 0;
10658         RExC_naughty += 4;
10659         RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
10660     }
10661     else if (op == '*') {
10662         min = 0;
10663         goto do_curly;
10664     }
10665     else if (op == '+' && (flags&SIMPLE)) {
10666         reginsert(pRExC_state, PLUS, ret, depth+1);
10667         ret->flags = 0;
10668         RExC_naughty += 3;
10669         RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
10670     }
10671     else if (op == '+') {
10672         min = 1;
10673         goto do_curly;
10674     }
10675     else if (op == '?') {
10676         min = 0; max = 1;
10677         goto do_curly;
10678     }
10679   nest_check:
10680     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
10681         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
10682         ckWARN2reg(RExC_parse,
10683                    "%"UTF8f" matches null string many times",
10684                    UTF8fARG(UTF, (RExC_parse >= origparse
10685                                  ? RExC_parse - origparse
10686                                  : 0),
10687                    origparse));
10688         (void)ReREFCNT_inc(RExC_rx_sv);
10689     }
10690
10691     if (RExC_parse < RExC_end && *RExC_parse == '?') {
10692         nextchar(pRExC_state);
10693         reginsert(pRExC_state, MINMOD, ret, depth+1);
10694         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
10695     }
10696     else
10697     if (RExC_parse < RExC_end && *RExC_parse == '+') {
10698         regnode *ender;
10699         nextchar(pRExC_state);
10700         ender = reg_node(pRExC_state, SUCCEED);
10701         REGTAIL(pRExC_state, ret, ender);
10702         reginsert(pRExC_state, SUSPEND, ret, depth+1);
10703         ret->flags = 0;
10704         ender = reg_node(pRExC_state, TAIL);
10705         REGTAIL(pRExC_state, ret, ender);
10706     }
10707
10708     if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
10709         RExC_parse++;
10710         vFAIL("Nested quantifiers");
10711     }
10712
10713     return(ret);
10714 }
10715
10716 STATIC STRLEN
10717 S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p,
10718                       UV *valuep, I32 *flagp, U32 depth, SV** substitute_parse
10719     )
10720 {
10721
10722  /* This is expected to be called by a parser routine that has recognized '\N'
10723    and needs to handle the rest. RExC_parse is expected to point at the first
10724    char following the N at the time of the call.  On successful return,
10725    RExC_parse has been updated to point to just after the sequence identified
10726    by this routine, <*flagp> has been updated, and the non-NULL input pointers
10727    have been set appropriately.
10728
10729    The typical case for this is \N{some character name}.  This is usually
10730    called while parsing the input, filling in or ready to fill in an EXACTish
10731    node, and the code point for the character should be returned, so that it
10732    can be added to the node, and parsing continued with the next input
10733    character.  But it may be that instead of a single character the \N{}
10734    expands to more than one, a named sequence.  In this case any following
10735    quantifier applies to the whole sequence, and it is easier, given the code
10736    structure that calls this, to handle it from a different area of the code.
10737    For this reason, the input parameters can be set so that it returns valid
10738    only on one or the other of these cases.
10739
10740    Another possibility is for the input to be an empty \N{}, which for
10741    backwards compatibility we accept, but generate a NOTHING node which should
10742    later get optimized out.  This is handled from the area of code which can
10743    handle a named sequence, so if called with the parameters for the other, it
10744    fails.
10745
10746    Still another possibility is for the \N to mean [^\n], and not a single
10747    character or explicit sequence at all.  This is determined by context.
10748    Again, this is handled from the area of code which can handle a named
10749    sequence, so if called with the parameters for the other, it also fails.
10750
10751    And the final possibility is for the \N to be called from within a bracketed
10752    character class.  In this case the [^\n] meaning makes no sense, and so is
10753    an error.  Other anomalous situations are left to the calling code to handle.
10754
10755    For non-single-quoted regexes, the tokenizer has attempted to decide which
10756    of the above applies, and in the case of a named sequence, has converted it
10757    into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...},
10758    where c1... are the characters in the sequence.  For single-quoted regexes,
10759    the tokenizer passes the \N sequence through unchanged; this code will not
10760    attempt to determine this nor expand those, instead raising a syntax error.
10761    The net effect is that if the beginning of the passed-in pattern isn't '{U+'
10762    or there is no '}', it signals that this \N occurrence means to match a
10763    non-newline. (This mostly was done because of [perl #56444].)
10764
10765    The API is somewhat convoluted due to historical and the above reasons.
10766
10767    The function raises an error (via vFAIL), and doesn't return for various
10768    syntax errors.  For other failures, it returns (STRLEN) -1.  For successes,
10769    it returns a count of how many characters were accounted for by it.  (This
10770    can be 0 for \N{}; 1 for it meaning [^\n]; and otherwise the number of code
10771    points in the sequence.  It sets <node_p>, <valuep>, and/or
10772    <substitute_parse> on success.
10773
10774    If <valuep> is non-null, it means the caller can accept an input sequence
10775    consisting of a just a single code point; <*valuep> is set to the value
10776    of the only or first code point in the input.
10777
10778    If <substitute_parse> is non-null, it means the caller can accept an input
10779    sequence consisting of one or more code points; <*substitute_parse> is a
10780    newly created mortal SV* in this case, containing \x{} escapes representing
10781    those code points.
10782
10783    Both <valuep> and <substitute_parse> can be non-NULL.
10784
10785    If <node_p> is non-null, <substitute_parse> must be NULL.  This signifies
10786    that the caller can accept any legal sequence other than a single code
10787    point.  To wit, <*node_p> is set as follows:
10788     1) \N means not-a-NL: points to a newly created REG_ANY node; return is 1
10789     2) \N{}:              points to a new NOTHING node; return is 0
10790     3) otherwise:         points to a new EXACT node containing the resolved
10791                           string; return is the number of code points in the
10792                           string.  This will never be 1.
10793    Note that failure is returned for single code point sequences if <valuep> is
10794    null and <node_p> is not.
10795  */
10796
10797     char * endbrace;    /* '}' following the name */
10798     char* p;
10799     char *endchar;      /* Points to '.' or '}' ending cur char in the input
10800                            stream */
10801     bool has_multiple_chars; /* true if the input stream contains a sequence of
10802                                 more than one character */
10803     bool in_char_class = substitute_parse != NULL;
10804     STRLEN count = 0;   /* Number of characters in this sequence */
10805
10806     GET_RE_DEBUG_FLAGS_DECL;
10807
10808     PERL_ARGS_ASSERT_GROK_BSLASH_N;
10809
10810     GET_RE_DEBUG_FLAGS;
10811
10812     assert(cBOOL(node_p) ^ cBOOL(valuep));  /* Exactly one should be set */
10813     assert(! (node_p && substitute_parse)); /* At most 1 should be set */
10814
10815     /* The [^\n] meaning of \N ignores spaces and comments under the /x
10816      * modifier.  The other meaning does not, so use a temporary until we find
10817      * out which we are being called with */
10818     p = (RExC_flags & RXf_PMf_EXTENDED)
10819         ? regpatws(pRExC_state, RExC_parse,
10820                                 TRUE) /* means recognize comments */
10821         : RExC_parse;
10822
10823     /* Disambiguate between \N meaning a named character versus \N meaning
10824      * [^\n].  The former is assumed when it can't be the latter. */
10825     if (*p != '{' || regcurly(p)) {
10826         RExC_parse = p;
10827         if (! node_p) {
10828             /* no bare \N allowed in a charclass */
10829             if (in_char_class) {
10830                 vFAIL("\\N in a character class must be a named character: \\N{...}");
10831             }
10832             return (STRLEN) -1;
10833         }
10834         RExC_parse--;   /* Need to back off so nextchar() doesn't skip the
10835                            current char */
10836         nextchar(pRExC_state);
10837         *node_p = reg_node(pRExC_state, REG_ANY);
10838         *flagp |= HASWIDTH|SIMPLE;
10839         RExC_naughty++;
10840         Set_Node_Length(*node_p, 1); /* MJD */
10841         return 1;
10842     }
10843
10844     /* Here, we have decided it should be a named character or sequence */
10845
10846     /* The test above made sure that the next real character is a '{', but
10847      * under the /x modifier, it could be separated by space (or a comment and
10848      * \n) and this is not allowed (for consistency with \x{...} and the
10849      * tokenizer handling of \N{NAME}). */
10850     if (*RExC_parse != '{') {
10851         vFAIL("Missing braces on \\N{}");
10852     }
10853
10854     RExC_parse++;       /* Skip past the '{' */
10855
10856     if (! (endbrace = strchr(RExC_parse, '}')) /* no trailing brace */
10857         || ! (endbrace == RExC_parse            /* nothing between the {} */
10858               || (endbrace - RExC_parse >= 2    /* U+ (bad hex is checked below
10859                                                  */
10860                   && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg)
10861                                                      */
10862     {
10863         if (endbrace) RExC_parse = endbrace;    /* position msg's '<--HERE' */
10864         vFAIL("\\N{NAME} must be resolved by the lexer");
10865     }
10866
10867     if (endbrace == RExC_parse) {   /* empty: \N{} */
10868         if (node_p) {
10869             *node_p = reg_node(pRExC_state,NOTHING);
10870         }
10871         else if (! in_char_class) {
10872             return (STRLEN) -1;
10873         }
10874         nextchar(pRExC_state);
10875         return 0;
10876     }
10877
10878     RExC_uni_semantics = 1; /* Unicode named chars imply Unicode semantics */
10879     RExC_parse += 2;    /* Skip past the 'U+' */
10880
10881     endchar = RExC_parse + strcspn(RExC_parse, ".}");
10882
10883     /* Code points are separated by dots.  If none, there is only one code
10884      * point, and is terminated by the brace */
10885     has_multiple_chars = (endchar < endbrace);
10886
10887     /* We get the first code point if we want it, and either there is only one,
10888      * or we can accept both cases of one and more than one */
10889     if (valuep && (substitute_parse || ! has_multiple_chars)) {
10890         STRLEN length_of_hex = (STRLEN)(endchar - RExC_parse);
10891         I32 grok_hex_flags = PERL_SCAN_ALLOW_UNDERSCORES
10892                            | PERL_SCAN_DISALLOW_PREFIX
10893
10894                              /* No errors in the first pass (See [perl
10895                               * #122671].)  We let the code below find the
10896                               * errors when there are multiple chars. */
10897                            | ((SIZE_ONLY || has_multiple_chars)
10898                               ? PERL_SCAN_SILENT_ILLDIGIT
10899                               : 0);
10900
10901         *valuep = grok_hex(RExC_parse, &length_of_hex, &grok_hex_flags, NULL);
10902
10903         /* The tokenizer should have guaranteed validity, but it's possible to
10904          * bypass it by using single quoting, so check.  Don't do the check
10905          * here when there are multiple chars; we do it below anyway. */
10906         if (! has_multiple_chars) {
10907             if (length_of_hex == 0
10908                 || length_of_hex != (STRLEN)(endchar - RExC_parse) )
10909             {
10910                 RExC_parse += length_of_hex;    /* Includes all the valid */
10911                 RExC_parse += (RExC_orig_utf8)  /* point to after 1st invalid */
10912                                 ? UTF8SKIP(RExC_parse)
10913                                 : 1;
10914                 /* Guard against malformed utf8 */
10915                 if (RExC_parse >= endchar) {
10916                     RExC_parse = endchar;
10917                 }
10918                 vFAIL("Invalid hexadecimal number in \\N{U+...}");
10919             }
10920
10921             RExC_parse = endbrace + 1;
10922             return 1;
10923         }
10924     }
10925
10926     /* Here, we should have already handled the case where a single character
10927      * is expected and found.  So it is a failure if we aren't expecting
10928      * multiple chars and got them; or didn't get them but wanted them.  We
10929      * fail without advancing the parse, so that the caller can try again with
10930      * different acceptance criteria */
10931     if ((! node_p && ! substitute_parse) || ! has_multiple_chars) {
10932         RExC_parse = p;
10933         return (STRLEN) -1;
10934     }
10935
10936     {
10937
10938         /* What is done here is to convert this to a sub-pattern of the form
10939          * \x{char1}\x{char2}...
10940          * and then either return it in <*substitute_parse> if non-null; or
10941          * call reg recursively to parse it (enclosing in "(?: ... )" ).  That
10942          * way, it retains its atomicness, while not having to worry about
10943          * special handling that some code points may have.  toke.c has
10944          * converted the original Unicode values to native, so that we can just
10945          * pass on the hex values unchanged.  We do have to set a flag to keep
10946          * recoding from happening in the recursion */
10947
10948         SV * dummy = NULL;
10949         STRLEN len;
10950         char *orig_end = RExC_end;
10951         I32 flags;
10952
10953         if (substitute_parse) {
10954             *substitute_parse = newSVpvs("");
10955         }
10956         else {
10957             substitute_parse = &dummy;
10958             *substitute_parse = newSVpvs("?:");
10959         }
10960         *substitute_parse = sv_2mortal(*substitute_parse);
10961
10962         while (RExC_parse < endbrace) {
10963
10964             /* Convert to notation the rest of the code understands */
10965             sv_catpv(*substitute_parse, "\\x{");
10966             sv_catpvn(*substitute_parse, RExC_parse, endchar - RExC_parse);
10967             sv_catpv(*substitute_parse, "}");
10968
10969             /* Point to the beginning of the next character in the sequence. */
10970             RExC_parse = endchar + 1;
10971             endchar = RExC_parse + strcspn(RExC_parse, ".}");
10972
10973             count++;
10974         }
10975         if (! in_char_class) {
10976             sv_catpv(*substitute_parse, ")");
10977         }
10978
10979         RExC_parse = SvPV(*substitute_parse, len);
10980
10981         /* Don't allow empty number */
10982         if (len < (STRLEN) ((substitute_parse) ? 6 : 8)) {
10983             RExC_parse = endbrace;
10984             vFAIL("Invalid hexadecimal number in \\N{U+...}");
10985         }
10986         RExC_end = RExC_parse + len;
10987
10988         /* The values are Unicode, and therefore not subject to recoding */
10989         RExC_override_recoding = 1;
10990
10991         if (node_p) {
10992             if (!(*node_p = reg(pRExC_state, 1, &flags, depth+1))) {
10993                 if (flags & RESTART_UTF8) {
10994                     *flagp = RESTART_UTF8;
10995                     return (STRLEN) -1;
10996                 }
10997                 FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#"UVxf"",
10998                     (UV) flags);
10999             }
11000             *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
11001         }
11002
11003         RExC_parse = endbrace;
11004         RExC_end = orig_end;
11005         RExC_override_recoding = 0;
11006
11007         nextchar(pRExC_state);
11008     }
11009
11010     return count;
11011 }
11012
11013
11014 /*
11015  * reg_recode
11016  *
11017  * It returns the code point in utf8 for the value in *encp.
11018  *    value: a code value in the source encoding
11019  *    encp:  a pointer to an Encode object
11020  *
11021  * If the result from Encode is not a single character,
11022  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
11023  */
11024 STATIC UV
11025 S_reg_recode(pTHX_ const char value, SV **encp)
11026 {
11027     STRLEN numlen = 1;
11028     SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP);
11029     const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
11030     const STRLEN newlen = SvCUR(sv);
11031     UV uv = UNICODE_REPLACEMENT;
11032
11033     PERL_ARGS_ASSERT_REG_RECODE;
11034
11035     if (newlen)
11036         uv = SvUTF8(sv)
11037              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
11038              : *(U8*)s;
11039
11040     if (!newlen || numlen != newlen) {
11041         uv = UNICODE_REPLACEMENT;
11042         *encp = NULL;
11043     }
11044     return uv;
11045 }
11046
11047 PERL_STATIC_INLINE U8
11048 S_compute_EXACTish(RExC_state_t *pRExC_state)
11049 {
11050     U8 op;
11051
11052     PERL_ARGS_ASSERT_COMPUTE_EXACTISH;
11053
11054     if (! FOLD) {
11055         return EXACT;
11056     }
11057
11058     op = get_regex_charset(RExC_flags);
11059     if (op >= REGEX_ASCII_RESTRICTED_CHARSET) {
11060         op--; /* /a is same as /u, and map /aa's offset to what /a's would have
11061                  been, so there is no hole */
11062     }
11063
11064     return op + EXACTF;
11065 }
11066
11067 PERL_STATIC_INLINE void
11068 S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state,
11069                          regnode *node, I32* flagp, STRLEN len, UV code_point,
11070                          bool downgradable)
11071 {
11072     /* This knows the details about sizing an EXACTish node, setting flags for
11073      * it (by setting <*flagp>, and potentially populating it with a single
11074      * character.
11075      *
11076      * If <len> (the length in bytes) is non-zero, this function assumes that
11077      * the node has already been populated, and just does the sizing.  In this
11078      * case <code_point> should be the final code point that has already been
11079      * placed into the node.  This value will be ignored except that under some
11080      * circumstances <*flagp> is set based on it.
11081      *
11082      * If <len> is zero, the function assumes that the node is to contain only
11083      * the single character given by <code_point> and calculates what <len>
11084      * should be.  In pass 1, it sizes the node appropriately.  In pass 2, it
11085      * additionally will populate the node's STRING with <code_point> or its
11086      * fold if folding.
11087      *
11088      * In both cases <*flagp> is appropriately set
11089      *
11090      * It knows that under FOLD, the Latin Sharp S and UTF characters above
11091      * 255, must be folded (the former only when the rules indicate it can
11092      * match 'ss')
11093      *
11094      * When it does the populating, it looks at the flag 'downgradable'.  If
11095      * true with a node that folds, it checks if the single code point
11096      * participates in a fold, and if not downgrades the node to an EXACT.
11097      * This helps the optimizer */
11098
11099     bool len_passed_in = cBOOL(len != 0);
11100     U8 character[UTF8_MAXBYTES_CASE+1];
11101
11102     PERL_ARGS_ASSERT_ALLOC_MAYBE_POPULATE_EXACT;
11103
11104     /* Don't bother to check for downgrading in PASS1, as it doesn't make any
11105      * sizing difference, and is extra work that is thrown away */
11106     if (downgradable && ! PASS2) {
11107         downgradable = FALSE;
11108     }
11109
11110     if (! len_passed_in) {
11111         if (UTF) {
11112             if (UNI_IS_INVARIANT(code_point)) {
11113                 if (LOC || ! FOLD) {    /* /l defers folding until runtime */
11114                     *character = (U8) code_point;
11115                 }
11116                 else { /* Here is /i and not /l. (toFOLD() is defined on just
11117                           ASCII, which isn't the same thing as INVARIANT on
11118                           EBCDIC, but it works there, as the extra invariants
11119                           fold to themselves) */
11120                     *character = toFOLD((U8) code_point);
11121
11122                     /* We can downgrade to an EXACT node if this character
11123                      * isn't a folding one.  Note that this assumes that
11124                      * nothing above Latin1 folds to some other invariant than
11125                      * one of these alphabetics; otherwise we would also have
11126                      * to check:
11127                      *  && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
11128                      *      || ASCII_FOLD_RESTRICTED))
11129                      */
11130                     if (downgradable && PL_fold[code_point] == code_point) {
11131                         OP(node) = EXACT;
11132                     }
11133                 }
11134                 len = 1;
11135             }
11136             else if (FOLD && (! LOC
11137                               || ! is_PROBLEMATIC_LOCALE_FOLD_cp(code_point)))
11138             {   /* Folding, and ok to do so now */
11139                 UV folded = _to_uni_fold_flags(
11140                                    code_point,
11141                                    character,
11142                                    &len,
11143                                    FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
11144                                                       ? FOLD_FLAGS_NOMIX_ASCII
11145                                                       : 0));
11146                 if (downgradable
11147                     && folded == code_point /* This quickly rules out many
11148                                                cases, avoiding the
11149                                                _invlist_contains_cp() overhead
11150                                                for those.  */
11151                     && ! _invlist_contains_cp(PL_utf8_foldable, code_point))
11152                 {
11153                     OP(node) = EXACT;
11154                 }
11155             }
11156             else if (code_point <= MAX_UTF8_TWO_BYTE) {
11157
11158                 /* Not folding this cp, and can output it directly */
11159                 *character = UTF8_TWO_BYTE_HI(code_point);
11160                 *(character + 1) = UTF8_TWO_BYTE_LO(code_point);
11161                 len = 2;
11162             }
11163             else {
11164                 uvchr_to_utf8( character, code_point);
11165                 len = UTF8SKIP(character);
11166             }
11167         } /* Else pattern isn't UTF8.  */
11168         else if (! FOLD) {
11169             *character = (U8) code_point;
11170             len = 1;
11171         } /* Else is folded non-UTF8 */
11172         else if (LIKELY(code_point != LATIN_SMALL_LETTER_SHARP_S)) {
11173
11174             /* We don't fold any non-UTF8 except possibly the Sharp s  (see
11175              * comments at join_exact()); */
11176             *character = (U8) code_point;
11177             len = 1;
11178
11179             /* Can turn into an EXACT node if we know the fold at compile time,
11180              * and it folds to itself and doesn't particpate in other folds */
11181             if (downgradable
11182                 && ! LOC
11183                 && PL_fold_latin1[code_point] == code_point
11184                 && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
11185                     || (isASCII(code_point) && ASCII_FOLD_RESTRICTED)))
11186             {
11187                 OP(node) = EXACT;
11188             }
11189         } /* else is Sharp s.  May need to fold it */
11190         else if (AT_LEAST_UNI_SEMANTICS && ! ASCII_FOLD_RESTRICTED) {
11191             *character = 's';
11192             *(character + 1) = 's';
11193             len = 2;
11194         }
11195         else {
11196             *character = LATIN_SMALL_LETTER_SHARP_S;
11197             len = 1;
11198         }
11199     }
11200
11201     if (SIZE_ONLY) {
11202         RExC_size += STR_SZ(len);
11203     }
11204     else {
11205         RExC_emit += STR_SZ(len);
11206         STR_LEN(node) = len;
11207         if (! len_passed_in) {
11208             Copy((char *) character, STRING(node), len, char);
11209         }
11210     }
11211
11212     *flagp |= HASWIDTH;
11213
11214     /* A single character node is SIMPLE, except for the special-cased SHARP S
11215      * under /di. */
11216     if ((len == 1 || (UTF && len == UNISKIP(code_point)))
11217         && (code_point != LATIN_SMALL_LETTER_SHARP_S
11218             || ! FOLD || ! DEPENDS_SEMANTICS))
11219     {
11220         *flagp |= SIMPLE;
11221     }
11222
11223     /* The OP may not be well defined in PASS1 */
11224     if (PASS2 && OP(node) == EXACTFL) {
11225         RExC_contains_locale = 1;
11226     }
11227 }
11228
11229
11230 /* Parse backref decimal value, unless it's too big to sensibly be a backref,
11231  * in which case return I32_MAX (rather than possibly 32-bit wrapping) */
11232
11233 static I32
11234 S_backref_value(char *p)
11235 {
11236     const char* endptr;
11237     UV val = grok_atou(p, &endptr);
11238     if (endptr == p || endptr == NULL || val > I32_MAX)
11239         return I32_MAX;
11240     return (I32)val;
11241 }
11242
11243
11244 /*
11245  - regatom - the lowest level
11246
11247    Try to identify anything special at the start of the pattern. If there
11248    is, then handle it as required. This may involve generating a single regop,
11249    such as for an assertion; or it may involve recursing, such as to
11250    handle a () structure.
11251
11252    If the string doesn't start with something special then we gobble up
11253    as much literal text as we can.
11254
11255    Once we have been able to handle whatever type of thing started the
11256    sequence, we return.
11257
11258    Note: we have to be careful with escapes, as they can be both literal
11259    and special, and in the case of \10 and friends, context determines which.
11260
11261    A summary of the code structure is:
11262
11263    switch (first_byte) {
11264         cases for each special:
11265             handle this special;
11266             break;
11267         case '\\':
11268             switch (2nd byte) {
11269                 cases for each unambiguous special:
11270                     handle this special;
11271                     break;
11272                 cases for each ambigous special/literal:
11273                     disambiguate;
11274                     if (special)  handle here
11275                     else goto defchar;
11276                 default: // unambiguously literal:
11277                     goto defchar;
11278             }
11279         default:  // is a literal char
11280             // FALL THROUGH
11281         defchar:
11282             create EXACTish node for literal;
11283             while (more input and node isn't full) {
11284                 switch (input_byte) {
11285                    cases for each special;
11286                        make sure parse pointer is set so that the next call to
11287                            regatom will see this special first
11288                        goto loopdone; // EXACTish node terminated by prev. char
11289                    default:
11290                        append char to EXACTISH node;
11291                 }
11292                 get next input byte;
11293             }
11294         loopdone:
11295    }
11296    return the generated node;
11297
11298    Specifically there are two separate switches for handling
11299    escape sequences, with the one for handling literal escapes requiring
11300    a dummy entry for all of the special escapes that are actually handled
11301    by the other.
11302
11303    Returns NULL, setting *flagp to TRYAGAIN if reg() returns NULL with
11304    TRYAGAIN.
11305    Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
11306    restarted.
11307    Otherwise does not return NULL.
11308 */
11309
11310 STATIC regnode *
11311 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
11312 {
11313     regnode *ret = NULL;
11314     I32 flags = 0;
11315     char *parse_start = RExC_parse;
11316     U8 op;
11317     int invert = 0;
11318     U8 arg;
11319
11320     GET_RE_DEBUG_FLAGS_DECL;
11321
11322     *flagp = WORST;             /* Tentatively. */
11323
11324     DEBUG_PARSE("atom");
11325
11326     PERL_ARGS_ASSERT_REGATOM;
11327
11328 tryagain:
11329     switch ((U8)*RExC_parse) {
11330     case '^':
11331         RExC_seen_zerolen++;
11332         nextchar(pRExC_state);
11333         if (RExC_flags & RXf_PMf_MULTILINE)
11334             ret = reg_node(pRExC_state, MBOL);
11335         else
11336             ret = reg_node(pRExC_state, SBOL);
11337         Set_Node_Length(ret, 1); /* MJD */
11338         break;
11339     case '$':
11340         nextchar(pRExC_state);
11341         if (*RExC_parse)
11342             RExC_seen_zerolen++;
11343         if (RExC_flags & RXf_PMf_MULTILINE)
11344             ret = reg_node(pRExC_state, MEOL);
11345         else
11346             ret = reg_node(pRExC_state, SEOL);
11347         Set_Node_Length(ret, 1); /* MJD */
11348         break;
11349     case '.':
11350         nextchar(pRExC_state);
11351         if (RExC_flags & RXf_PMf_SINGLELINE)
11352             ret = reg_node(pRExC_state, SANY);
11353         else
11354             ret = reg_node(pRExC_state, REG_ANY);
11355         *flagp |= HASWIDTH|SIMPLE;
11356         RExC_naughty++;
11357         Set_Node_Length(ret, 1); /* MJD */
11358         break;
11359     case '[':
11360     {
11361         char * const oregcomp_parse = ++RExC_parse;
11362         ret = regclass(pRExC_state, flagp,depth+1,
11363                        FALSE, /* means parse the whole char class */
11364                        TRUE, /* allow multi-char folds */
11365                        FALSE, /* don't silence non-portable warnings. */
11366                        NULL);
11367         if (*RExC_parse != ']') {
11368             RExC_parse = oregcomp_parse;
11369             vFAIL("Unmatched [");
11370         }
11371         if (ret == NULL) {
11372             if (*flagp & RESTART_UTF8)
11373                 return NULL;
11374             FAIL2("panic: regclass returned NULL to regatom, flags=%#"UVxf"",
11375                   (UV) *flagp);
11376         }
11377         nextchar(pRExC_state);
11378         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
11379         break;
11380     }
11381     case '(':
11382         nextchar(pRExC_state);
11383         ret = reg(pRExC_state, 2, &flags,depth+1);
11384         if (ret == NULL) {
11385                 if (flags & TRYAGAIN) {
11386                     if (RExC_parse == RExC_end) {
11387                          /* Make parent create an empty node if needed. */
11388                         *flagp |= TRYAGAIN;
11389                         return(NULL);
11390                     }
11391                     goto tryagain;
11392                 }
11393                 if (flags & RESTART_UTF8) {
11394                     *flagp = RESTART_UTF8;
11395                     return NULL;
11396                 }
11397                 FAIL2("panic: reg returned NULL to regatom, flags=%#"UVxf"",
11398                                                                  (UV) flags);
11399         }
11400         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
11401         break;
11402     case '|':
11403     case ')':
11404         if (flags & TRYAGAIN) {
11405             *flagp |= TRYAGAIN;
11406             return NULL;
11407         }
11408         vFAIL("Internal urp");
11409                                 /* Supposed to be caught earlier. */
11410         break;
11411     case '?':
11412     case '+':
11413     case '*':
11414         RExC_parse++;
11415         vFAIL("Quantifier follows nothing");
11416         break;
11417     case '\\':
11418         /* Special Escapes
11419
11420            This switch handles escape sequences that resolve to some kind
11421            of special regop and not to literal text. Escape sequnces that
11422            resolve to literal text are handled below in the switch marked
11423            "Literal Escapes".
11424
11425            Every entry in this switch *must* have a corresponding entry
11426            in the literal escape switch. However, the opposite is not
11427            required, as the default for this switch is to jump to the
11428            literal text handling code.
11429         */
11430         switch ((U8)*++RExC_parse) {
11431         /* Special Escapes */
11432         case 'A':
11433             RExC_seen_zerolen++;
11434             ret = reg_node(pRExC_state, SBOL);
11435             /* SBOL is shared with /^/ so we set the flags so we can tell
11436              * /\A/ from /^/ in split. We check ret because first pass we
11437              * have no regop struct to set the flags on. */
11438             if (PASS2)
11439                 ret->flags = 1;
11440             *flagp |= SIMPLE;
11441             goto finish_meta_pat;
11442         case 'G':
11443             ret = reg_node(pRExC_state, GPOS);
11444             RExC_seen |= REG_GPOS_SEEN;
11445             *flagp |= SIMPLE;
11446             goto finish_meta_pat;
11447         case 'K':
11448             RExC_seen_zerolen++;
11449             ret = reg_node(pRExC_state, KEEPS);
11450             *flagp |= SIMPLE;
11451             /* XXX:dmq : disabling in-place substitution seems to
11452              * be necessary here to avoid cases of memory corruption, as
11453              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
11454              */
11455             RExC_seen |= REG_LOOKBEHIND_SEEN;
11456             goto finish_meta_pat;
11457         case 'Z':
11458             ret = reg_node(pRExC_state, SEOL);
11459             *flagp |= SIMPLE;
11460             RExC_seen_zerolen++;                /* Do not optimize RE away */
11461             goto finish_meta_pat;
11462         case 'z':
11463             ret = reg_node(pRExC_state, EOS);
11464             *flagp |= SIMPLE;
11465             RExC_seen_zerolen++;                /* Do not optimize RE away */
11466             goto finish_meta_pat;
11467         case 'C':
11468             ret = reg_node(pRExC_state, CANY);
11469             RExC_seen |= REG_CANY_SEEN;
11470             *flagp |= HASWIDTH|SIMPLE;
11471             if (PASS2) {
11472                 ckWARNdep(RExC_parse+1, "\\C is deprecated");
11473             }
11474             goto finish_meta_pat;
11475         case 'X':
11476             ret = reg_node(pRExC_state, CLUMP);
11477             *flagp |= HASWIDTH;
11478             goto finish_meta_pat;
11479
11480         case 'W':
11481             invert = 1;
11482             /* FALLTHROUGH */
11483         case 'w':
11484             arg = ANYOF_WORDCHAR;
11485             goto join_posix;
11486
11487         case 'b':
11488             RExC_seen_zerolen++;
11489             RExC_seen |= REG_LOOKBEHIND_SEEN;
11490             op = BOUND + get_regex_charset(RExC_flags);
11491             if (op > BOUNDA) {  /* /aa is same as /a */
11492                 op = BOUNDA;
11493             }
11494             else if (op == BOUNDL) {
11495                 RExC_contains_locale = 1;
11496             }
11497             ret = reg_node(pRExC_state, op);
11498             FLAGS(ret) = get_regex_charset(RExC_flags);
11499             *flagp |= SIMPLE;
11500             if ((U8) *(RExC_parse + 1) == '{') {
11501                 /* diag_listed_as: Use "%s" instead of "%s" */
11502                 vFAIL("Use \"\\b\\{\" instead of \"\\b{\"");
11503             }
11504             goto finish_meta_pat;
11505         case 'B':
11506             RExC_seen_zerolen++;
11507             RExC_seen |= REG_LOOKBEHIND_SEEN;
11508             op = NBOUND + get_regex_charset(RExC_flags);
11509             if (op > NBOUNDA) { /* /aa is same as /a */
11510                 op = NBOUNDA;
11511             }
11512             else if (op == NBOUNDL) {
11513                 RExC_contains_locale = 1;
11514             }
11515             ret = reg_node(pRExC_state, op);
11516             FLAGS(ret) = get_regex_charset(RExC_flags);
11517             *flagp |= SIMPLE;
11518             if ((U8) *(RExC_parse + 1) == '{') {
11519                 /* diag_listed_as: Use "%s" instead of "%s" */
11520                 vFAIL("Use \"\\B\\{\" instead of \"\\B{\"");
11521             }
11522             goto finish_meta_pat;
11523
11524         case 'D':
11525             invert = 1;
11526             /* FALLTHROUGH */
11527         case 'd':
11528             arg = ANYOF_DIGIT;
11529             goto join_posix;
11530
11531         case 'R':
11532             ret = reg_node(pRExC_state, LNBREAK);
11533             *flagp |= HASWIDTH|SIMPLE;
11534             goto finish_meta_pat;
11535
11536         case 'H':
11537             invert = 1;
11538             /* FALLTHROUGH */
11539         case 'h':
11540             arg = ANYOF_BLANK;
11541             op = POSIXU;
11542             goto join_posix_op_known;
11543
11544         case 'V':
11545             invert = 1;
11546             /* FALLTHROUGH */
11547         case 'v':
11548             arg = ANYOF_VERTWS;
11549             op = POSIXU;
11550             goto join_posix_op_known;
11551
11552         case 'S':
11553             invert = 1;
11554             /* FALLTHROUGH */
11555         case 's':
11556             arg = ANYOF_SPACE;
11557
11558         join_posix:
11559
11560             op = POSIXD + get_regex_charset(RExC_flags);
11561             if (op > POSIXA) {  /* /aa is same as /a */
11562                 op = POSIXA;
11563             }
11564             else if (op == POSIXL) {
11565                 RExC_contains_locale = 1;
11566             }
11567
11568         join_posix_op_known:
11569
11570             if (invert) {
11571                 op += NPOSIXD - POSIXD;
11572             }
11573
11574             ret = reg_node(pRExC_state, op);
11575             if (! SIZE_ONLY) {
11576                 FLAGS(ret) = namedclass_to_classnum(arg);
11577             }
11578
11579             *flagp |= HASWIDTH|SIMPLE;
11580             /* FALLTHROUGH */
11581
11582          finish_meta_pat:
11583             nextchar(pRExC_state);
11584             Set_Node_Length(ret, 2); /* MJD */
11585             break;
11586         case 'p':
11587         case 'P':
11588             {
11589 #ifdef DEBUGGING
11590                 char* parse_start = RExC_parse - 2;
11591 #endif
11592
11593                 RExC_parse--;
11594
11595                 ret = regclass(pRExC_state, flagp,depth+1,
11596                                TRUE, /* means just parse this element */
11597                                FALSE, /* don't allow multi-char folds */
11598                                FALSE, /* don't silence non-portable warnings.
11599                                          It would be a bug if these returned
11600                                          non-portables */
11601                                NULL);
11602                 /* regclass() can only return RESTART_UTF8 if multi-char folds
11603                    are allowed.  */
11604                 if (!ret)
11605                     FAIL2("panic: regclass returned NULL to regatom, flags=%#"UVxf"",
11606                           (UV) *flagp);
11607
11608                 RExC_parse--;
11609
11610                 Set_Node_Offset(ret, parse_start + 2);
11611                 Set_Node_Cur_Length(ret, parse_start);
11612                 nextchar(pRExC_state);
11613             }
11614             break;
11615         case 'N':
11616             /* Handle \N and \N{NAME} with multiple code points here and not
11617              * below because it can be multicharacter. join_exact() will join
11618              * them up later on.  Also this makes sure that things like
11619              * /\N{BLAH}+/ and \N{BLAH} being multi char Just Happen. dmq.
11620              * The options to the grok function call causes it to fail if the
11621              * sequence is just a single code point.  We then go treat it as
11622              * just another character in the current EXACT node, and hence it
11623              * gets uniform treatment with all the other characters.  The
11624              * special treatment for quantifiers is not needed for such single
11625              * character sequences */
11626             ++RExC_parse;
11627             if ((STRLEN) -1 == grok_bslash_N(pRExC_state, &ret, NULL, flagp,
11628                                              depth, FALSE))
11629             {
11630                 if (*flagp & RESTART_UTF8)
11631                     return NULL;
11632                 RExC_parse--;
11633                 goto defchar;
11634             }
11635             break;
11636         case 'k':    /* Handle \k<NAME> and \k'NAME' */
11637         parse_named_seq:
11638         {
11639             char ch= RExC_parse[1];
11640             if (ch != '<' && ch != '\'' && ch != '{') {
11641                 RExC_parse++;
11642                 /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
11643                 vFAIL2("Sequence %.2s... not terminated",parse_start);
11644             } else {
11645                 /* this pretty much dupes the code for (?P=...) in reg(), if
11646                    you change this make sure you change that */
11647                 char* name_start = (RExC_parse += 2);
11648                 U32 num = 0;
11649                 SV *sv_dat = reg_scan_name(pRExC_state,
11650                     SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
11651                 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
11652                 if (RExC_parse == name_start || *RExC_parse != ch)
11653                     /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
11654                     vFAIL2("Sequence %.3s... not terminated",parse_start);
11655
11656                 if (!SIZE_ONLY) {
11657                     num = add_data( pRExC_state, STR_WITH_LEN("S"));
11658                     RExC_rxi->data->data[num]=(void*)sv_dat;
11659                     SvREFCNT_inc_simple_void(sv_dat);
11660                 }
11661
11662                 RExC_sawback = 1;
11663                 ret = reganode(pRExC_state,
11664                                ((! FOLD)
11665                                  ? NREF
11666                                  : (ASCII_FOLD_RESTRICTED)
11667                                    ? NREFFA
11668                                    : (AT_LEAST_UNI_SEMANTICS)
11669                                      ? NREFFU
11670                                      : (LOC)
11671                                        ? NREFFL
11672                                        : NREFF),
11673                                 num);
11674                 *flagp |= HASWIDTH;
11675
11676                 /* override incorrect value set in reganode MJD */
11677                 Set_Node_Offset(ret, parse_start+1);
11678                 Set_Node_Cur_Length(ret, parse_start);
11679                 nextchar(pRExC_state);
11680
11681             }
11682             break;
11683         }
11684         case 'g':
11685         case '1': case '2': case '3': case '4':
11686         case '5': case '6': case '7': case '8': case '9':
11687             {
11688                 I32 num;
11689                 bool hasbrace = 0;
11690
11691                 if (*RExC_parse == 'g') {
11692                     bool isrel = 0;
11693
11694                     RExC_parse++;
11695                     if (*RExC_parse == '{') {
11696                         RExC_parse++;
11697                         hasbrace = 1;
11698                     }
11699                     if (*RExC_parse == '-') {
11700                         RExC_parse++;
11701                         isrel = 1;
11702                     }
11703                     if (hasbrace && !isDIGIT(*RExC_parse)) {
11704                         if (isrel) RExC_parse--;
11705                         RExC_parse -= 2;
11706                         goto parse_named_seq;
11707                     }
11708
11709                     num = S_backref_value(RExC_parse);
11710                     if (num == 0)
11711                         vFAIL("Reference to invalid group 0");
11712                     else if (num == I32_MAX) {
11713                          if (isDIGIT(*RExC_parse))
11714                             vFAIL("Reference to nonexistent group");
11715                         else
11716                             vFAIL("Unterminated \\g... pattern");
11717                     }
11718
11719                     if (isrel) {
11720                         num = RExC_npar - num;
11721                         if (num < 1)
11722                             vFAIL("Reference to nonexistent or unclosed group");
11723                     }
11724                 }
11725                 else {
11726                     num = S_backref_value(RExC_parse);
11727                     /* bare \NNN might be backref or octal - if it is larger than or equal
11728                      * RExC_npar then it is assumed to be and octal escape.
11729                      * Note RExC_npar is +1 from the actual number of parens*/
11730                     if (num == I32_MAX || (num > 9 && num >= RExC_npar
11731                             && *RExC_parse != '8' && *RExC_parse != '9'))
11732                     {
11733                         /* Probably a character specified in octal, e.g. \35 */
11734                         goto defchar;
11735                     }
11736                 }
11737
11738                 /* at this point RExC_parse definitely points to a backref
11739                  * number */
11740                 {
11741 #ifdef RE_TRACK_PATTERN_OFFSETS
11742                     char * const parse_start = RExC_parse - 1; /* MJD */
11743 #endif
11744                     while (isDIGIT(*RExC_parse))
11745                         RExC_parse++;
11746                     if (hasbrace) {
11747                         if (*RExC_parse != '}')
11748                             vFAIL("Unterminated \\g{...} pattern");
11749                         RExC_parse++;
11750                     }
11751                     if (!SIZE_ONLY) {
11752                         if (num > (I32)RExC_rx->nparens)
11753                             vFAIL("Reference to nonexistent group");
11754                     }
11755                     RExC_sawback = 1;
11756                     ret = reganode(pRExC_state,
11757                                    ((! FOLD)
11758                                      ? REF
11759                                      : (ASCII_FOLD_RESTRICTED)
11760                                        ? REFFA
11761                                        : (AT_LEAST_UNI_SEMANTICS)
11762                                          ? REFFU
11763                                          : (LOC)
11764                                            ? REFFL
11765                                            : REFF),
11766                                     num);
11767                     *flagp |= HASWIDTH;
11768
11769                     /* override incorrect value set in reganode MJD */
11770                     Set_Node_Offset(ret, parse_start+1);
11771                     Set_Node_Cur_Length(ret, parse_start);
11772                     RExC_parse--;
11773                     nextchar(pRExC_state);
11774                 }
11775             }
11776             break;
11777         case '\0':
11778             if (RExC_parse >= RExC_end)
11779                 FAIL("Trailing \\");
11780             /* FALLTHROUGH */
11781         default:
11782             /* Do not generate "unrecognized" warnings here, we fall
11783                back into the quick-grab loop below */
11784             parse_start--;
11785             goto defchar;
11786         }
11787         break;
11788
11789     case '#':
11790         if (RExC_flags & RXf_PMf_EXTENDED) {
11791             RExC_parse = reg_skipcomment( pRExC_state, RExC_parse );
11792             if (RExC_parse < RExC_end)
11793                 goto tryagain;
11794         }
11795         /* FALLTHROUGH */
11796
11797     default:
11798
11799             parse_start = RExC_parse - 1;
11800
11801             RExC_parse++;
11802
11803         defchar: {
11804             STRLEN len = 0;
11805             UV ender = 0;
11806             char *p;
11807             char *s;
11808 #define MAX_NODE_STRING_SIZE 127
11809             char foldbuf[MAX_NODE_STRING_SIZE+UTF8_MAXBYTES_CASE];
11810             char *s0;
11811             U8 upper_parse = MAX_NODE_STRING_SIZE;
11812             U8 node_type = compute_EXACTish(pRExC_state);
11813             bool next_is_quantifier;
11814             char * oldp = NULL;
11815
11816             /* We can convert EXACTF nodes to EXACTFU if they contain only
11817              * characters that match identically regardless of the target
11818              * string's UTF8ness.  The reason to do this is that EXACTF is not
11819              * trie-able, EXACTFU is.
11820              *
11821              * Similarly, we can convert EXACTFL nodes to EXACTFU if they
11822              * contain only above-Latin1 characters (hence must be in UTF8),
11823              * which don't participate in folds with Latin1-range characters,
11824              * as the latter's folds aren't known until runtime.  (We don't
11825              * need to figure this out until pass 2) */
11826             bool maybe_exactfu = PASS2
11827                                && (node_type == EXACTF || node_type == EXACTFL);
11828
11829             /* If a folding node contains only code points that don't
11830              * participate in folds, it can be changed into an EXACT node,
11831              * which allows the optimizer more things to look for */
11832             bool maybe_exact;
11833
11834             ret = reg_node(pRExC_state, node_type);
11835
11836             /* In pass1, folded, we use a temporary buffer instead of the
11837              * actual node, as the node doesn't exist yet */
11838             s = (SIZE_ONLY && FOLD) ? foldbuf : STRING(ret);
11839
11840             s0 = s;
11841
11842         reparse:
11843
11844             /* We do the EXACTFish to EXACT node only if folding.  (And we
11845              * don't need to figure this out until pass 2) */
11846             maybe_exact = FOLD && PASS2;
11847
11848             /* XXX The node can hold up to 255 bytes, yet this only goes to
11849              * 127.  I (khw) do not know why.  Keeping it somewhat less than
11850              * 255 allows us to not have to worry about overflow due to
11851              * converting to utf8 and fold expansion, but that value is
11852              * 255-UTF8_MAXBYTES_CASE.  join_exact() may join adjacent nodes
11853              * split up by this limit into a single one using the real max of
11854              * 255.  Even at 127, this breaks under rare circumstances.  If
11855              * folding, we do not want to split a node at a character that is a
11856              * non-final in a multi-char fold, as an input string could just
11857              * happen to want to match across the node boundary.  The join
11858              * would solve that problem if the join actually happens.  But a
11859              * series of more than two nodes in a row each of 127 would cause
11860              * the first join to succeed to get to 254, but then there wouldn't
11861              * be room for the next one, which could at be one of those split
11862              * multi-char folds.  I don't know of any fool-proof solution.  One
11863              * could back off to end with only a code point that isn't such a
11864              * non-final, but it is possible for there not to be any in the
11865              * entire node. */
11866             for (p = RExC_parse - 1;
11867                  len < upper_parse && p < RExC_end;
11868                  len++)
11869             {
11870                 oldp = p;
11871
11872                 if (RExC_flags & RXf_PMf_EXTENDED)
11873                     p = regpatws(pRExC_state, p,
11874                                           TRUE); /* means recognize comments */
11875                 switch ((U8)*p) {
11876                 case '^':
11877                 case '$':
11878                 case '.':
11879                 case '[':
11880                 case '(':
11881                 case ')':
11882                 case '|':
11883                     goto loopdone;
11884                 case '\\':
11885                     /* Literal Escapes Switch
11886
11887                        This switch is meant to handle escape sequences that
11888                        resolve to a literal character.
11889
11890                        Every escape sequence that represents something
11891                        else, like an assertion or a char class, is handled
11892                        in the switch marked 'Special Escapes' above in this
11893                        routine, but also has an entry here as anything that
11894                        isn't explicitly mentioned here will be treated as
11895                        an unescaped equivalent literal.
11896                     */
11897
11898                     switch ((U8)*++p) {
11899                     /* These are all the special escapes. */
11900                     case 'A':             /* Start assertion */
11901                     case 'b': case 'B':   /* Word-boundary assertion*/
11902                     case 'C':             /* Single char !DANGEROUS! */
11903                     case 'd': case 'D':   /* digit class */
11904                     case 'g': case 'G':   /* generic-backref, pos assertion */
11905                     case 'h': case 'H':   /* HORIZWS */
11906                     case 'k': case 'K':   /* named backref, keep marker */
11907                     case 'p': case 'P':   /* Unicode property */
11908                               case 'R':   /* LNBREAK */
11909                     case 's': case 'S':   /* space class */
11910                     case 'v': case 'V':   /* VERTWS */
11911                     case 'w': case 'W':   /* word class */
11912                     case 'X':             /* eXtended Unicode "combining
11913                                              character sequence" */
11914                     case 'z': case 'Z':   /* End of line/string assertion */
11915                         --p;
11916                         goto loopdone;
11917
11918                     /* Anything after here is an escape that resolves to a
11919                        literal. (Except digits, which may or may not)
11920                      */
11921                     case 'n':
11922                         ender = '\n';
11923                         p++;
11924                         break;
11925                     case 'N': /* Handle a single-code point named character. */
11926                         /* The options cause it to fail if a multiple code
11927                          * point sequence.  Handle those in the switch() above
11928                          * */
11929                         RExC_parse = p + 1;
11930                         if ((STRLEN) -1 == grok_bslash_N(pRExC_state, NULL,
11931                                                          &ender,
11932                                                          flagp,
11933                                                          depth,
11934                                                          FALSE
11935                         )) {
11936                             if (*flagp & RESTART_UTF8)
11937                                 FAIL("panic: grok_bslash_N set RESTART_UTF8");
11938                             RExC_parse = p = oldp;
11939                             goto loopdone;
11940                         }
11941                         p = RExC_parse;
11942                         if (ender > 0xff) {
11943                             REQUIRE_UTF8;
11944                         }
11945                         break;
11946                     case 'r':
11947                         ender = '\r';
11948                         p++;
11949                         break;
11950                     case 't':
11951                         ender = '\t';
11952                         p++;
11953                         break;
11954                     case 'f':
11955                         ender = '\f';
11956                         p++;
11957                         break;
11958                     case 'e':
11959                         ender = ESC_NATIVE;
11960                         p++;
11961                         break;
11962                     case 'a':
11963                         ender = '\a';
11964                         p++;
11965                         break;
11966                     case 'o':
11967                         {
11968                             UV result;
11969                             const char* error_msg;
11970
11971                             bool valid = grok_bslash_o(&p,
11972                                                        &result,
11973                                                        &error_msg,
11974                                                        PASS2, /* out warnings */
11975                                                        FALSE, /* not strict */
11976                                                        TRUE, /* Output warnings
11977                                                                 for non-
11978                                                                 portables */
11979                                                        UTF);
11980                             if (! valid) {
11981                                 RExC_parse = p; /* going to die anyway; point
11982                                                    to exact spot of failure */
11983                                 vFAIL(error_msg);
11984                             }
11985                             ender = result;
11986                             if (PL_encoding && ender < 0x100) {
11987                                 goto recode_encoding;
11988                             }
11989                             if (ender > 0xff) {
11990                                 REQUIRE_UTF8;
11991                             }
11992                             break;
11993                         }
11994                     case 'x':
11995                         {
11996                             UV result = UV_MAX; /* initialize to erroneous
11997                                                    value */
11998                             const char* error_msg;
11999
12000                             bool valid = grok_bslash_x(&p,
12001                                                        &result,
12002                                                        &error_msg,
12003                                                        PASS2, /* out warnings */
12004                                                        FALSE, /* not strict */
12005                                                        TRUE, /* Output warnings
12006                                                                 for non-
12007                                                                 portables */
12008                                                        UTF);
12009                             if (! valid) {
12010                                 RExC_parse = p; /* going to die anyway; point
12011                                                    to exact spot of failure */
12012                                 vFAIL(error_msg);
12013                             }
12014                             ender = result;
12015
12016                             if (PL_encoding && ender < 0x100) {
12017                                 goto recode_encoding;
12018                             }
12019                             if (ender > 0xff) {
12020                                 REQUIRE_UTF8;
12021                             }
12022                             break;
12023                         }
12024                     case 'c':
12025                         p++;
12026                         ender = grok_bslash_c(*p++, PASS2);
12027                         break;
12028                     case '8': case '9': /* must be a backreference */
12029                         --p;
12030                         goto loopdone;
12031                     case '1': case '2': case '3':case '4':
12032                     case '5': case '6': case '7':
12033                         /* When we parse backslash escapes there is ambiguity
12034                          * between backreferences and octal escapes. Any escape
12035                          * from \1 - \9 is a backreference, any multi-digit
12036                          * escape which does not start with 0 and which when
12037                          * evaluated as decimal could refer to an already
12038                          * parsed capture buffer is a backslash. Anything else
12039                          * is octal.
12040                          *
12041                          * Note this implies that \118 could be interpreted as
12042                          * 118 OR as "\11" . "8" depending on whether there
12043                          * were 118 capture buffers defined already in the
12044                          * pattern.  */
12045
12046                         /* NOTE, RExC_npar is 1 more than the actual number of
12047                          * parens we have seen so far, hence the < RExC_npar below. */
12048
12049                         if ( !isDIGIT(p[1]) || S_backref_value(p) < RExC_npar)
12050                         {  /* Not to be treated as an octal constant, go
12051                                    find backref */
12052                             --p;
12053                             goto loopdone;
12054                         }
12055                         /* FALLTHROUGH */
12056                     case '0':
12057                         {
12058                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
12059                             STRLEN numlen = 3;
12060                             ender = grok_oct(p, &numlen, &flags, NULL);
12061                             if (ender > 0xff) {
12062                                 REQUIRE_UTF8;
12063                             }
12064                             p += numlen;
12065                             if (PASS2   /* like \08, \178 */
12066                                 && numlen < 3
12067                                 && p < RExC_end
12068                                 && isDIGIT(*p) && ckWARN(WARN_REGEXP))
12069                             {
12070                                 reg_warn_non_literal_string(
12071                                          p + 1,
12072                                          form_short_octal_warning(p, numlen));
12073                             }
12074                         }
12075                         if (PL_encoding && ender < 0x100)
12076                             goto recode_encoding;
12077                         break;
12078                     recode_encoding:
12079                         if (! RExC_override_recoding) {
12080                             SV* enc = PL_encoding;
12081                             ender = reg_recode((const char)(U8)ender, &enc);
12082                             if (!enc && PASS2)
12083                                 ckWARNreg(p, "Invalid escape in the specified encoding");
12084                             REQUIRE_UTF8;
12085                         }
12086                         break;
12087                     case '\0':
12088                         if (p >= RExC_end)
12089                             FAIL("Trailing \\");
12090                         /* FALLTHROUGH */
12091                     default:
12092                         if (!SIZE_ONLY&& isALPHANUMERIC(*p)) {
12093                             /* Include any { following the alpha to emphasize
12094                              * that it could be part of an escape at some point
12095                              * in the future */
12096                             int len = (isALPHA(*p) && *(p + 1) == '{') ? 2 : 1;
12097                             ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
12098                         }
12099                         goto normal_default;
12100                     } /* End of switch on '\' */
12101                     break;
12102                 case '{':
12103                     /* Currently we don't warn when the lbrace is at the start
12104                      * of a construct.  This catches it in the middle of a
12105                      * literal string, or when its the first thing after
12106                      * something like "\b" */
12107                     if (! SIZE_ONLY
12108                         && (len || (p > RExC_start && isALPHA_A(*(p -1)))))
12109                     {
12110                         ckWARNregdep(p + 1, "Unescaped left brace in regex is deprecated, passed through");
12111                     }
12112                     /*FALLTHROUGH*/
12113                 default:    /* A literal character */
12114                   normal_default:
12115                     if (UTF8_IS_START(*p) && UTF) {
12116                         STRLEN numlen;
12117                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
12118                                                &numlen, UTF8_ALLOW_DEFAULT);
12119                         p += numlen;
12120                     }
12121                     else
12122                         ender = (U8) *p++;
12123                     break;
12124                 } /* End of switch on the literal */
12125
12126                 /* Here, have looked at the literal character and <ender>
12127                  * contains its ordinal, <p> points to the character after it
12128                  */
12129
12130                 if ( RExC_flags & RXf_PMf_EXTENDED)
12131                     p = regpatws(pRExC_state, p,
12132                                           TRUE); /* means recognize comments */
12133
12134                 /* If the next thing is a quantifier, it applies to this
12135                  * character only, which means that this character has to be in
12136                  * its own node and can't just be appended to the string in an
12137                  * existing node, so if there are already other characters in
12138                  * the node, close the node with just them, and set up to do
12139                  * this character again next time through, when it will be the
12140                  * only thing in its new node */
12141                 if ((next_is_quantifier = (p < RExC_end && ISMULT2(p))) && len)
12142                 {
12143                     p = oldp;
12144                     goto loopdone;
12145                 }
12146
12147                 if (! FOLD   /* The simple case, just append the literal */
12148                     || (LOC  /* Also don't fold for tricky chars under /l */
12149                         && is_PROBLEMATIC_LOCALE_FOLD_cp(ender)))
12150                 {
12151                     if (UTF) {
12152                         const STRLEN unilen = reguni(pRExC_state, ender, s);
12153                         if (unilen > 0) {
12154                            s   += unilen;
12155                            len += unilen;
12156                         }
12157
12158                         /* The loop increments <len> each time, as all but this
12159                          * path (and one other) through it add a single byte to
12160                          * the EXACTish node.  But this one has changed len to
12161                          * be the correct final value, so subtract one to
12162                          * cancel out the increment that follows */
12163                         len--;
12164                     }
12165                     else {
12166                         REGC((char)ender, s++);
12167                     }
12168
12169                     /* Can get here if folding only if is one of the /l
12170                      * characters whose fold depends on the locale.  The
12171                      * occurrence of any of these indicate that we can't
12172                      * simplify things */
12173                     if (FOLD) {
12174                         maybe_exact = FALSE;
12175                         maybe_exactfu = FALSE;
12176                     }
12177                 }
12178                 else             /* FOLD */
12179                      if (! ( UTF
12180                         /* See comments for join_exact() as to why we fold this
12181                          * non-UTF at compile time */
12182                         || (node_type == EXACTFU
12183                             && ender == LATIN_SMALL_LETTER_SHARP_S)))
12184                 {
12185                     /* Here, are folding and are not UTF-8 encoded; therefore
12186                      * the character must be in the range 0-255, and is not /l
12187                      * (Not /l because we already handled these under /l in
12188                      * is_PROBLEMATIC_LOCALE_FOLD_cp */
12189                     if (IS_IN_SOME_FOLD_L1(ender)) {
12190                         maybe_exact = FALSE;
12191
12192                         /* See if the character's fold differs between /d and
12193                          * /u.  This includes the multi-char fold SHARP S to
12194                          * 'ss' */
12195                         if (maybe_exactfu
12196                             && (PL_fold[ender] != PL_fold_latin1[ender]
12197                                 || ender == LATIN_SMALL_LETTER_SHARP_S
12198                                 || (len > 0
12199                                    && isALPHA_FOLD_EQ(ender, 's')
12200                                    && isALPHA_FOLD_EQ(*(s-1), 's'))))
12201                         {
12202                             maybe_exactfu = FALSE;
12203                         }
12204                     }
12205
12206                     /* Even when folding, we store just the input character, as
12207                      * we have an array that finds its fold quickly */
12208                     *(s++) = (char) ender;
12209                 }
12210                 else {  /* FOLD and UTF */
12211                     /* Unlike the non-fold case, we do actually have to
12212                      * calculate the results here in pass 1.  This is for two
12213                      * reasons, the folded length may be longer than the
12214                      * unfolded, and we have to calculate how many EXACTish
12215                      * nodes it will take; and we may run out of room in a node
12216                      * in the middle of a potential multi-char fold, and have
12217                      * to back off accordingly.  (Hence we can't use REGC for
12218                      * the simple case just below.) */
12219
12220                     UV folded;
12221                     if (isASCII(ender)) {
12222                         folded = toFOLD(ender);
12223                         *(s)++ = (U8) folded;
12224                     }
12225                     else {
12226                         STRLEN foldlen;
12227
12228                         folded = _to_uni_fold_flags(
12229                                      ender,
12230                                      (U8 *) s,
12231                                      &foldlen,
12232                                      FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
12233                                                         ? FOLD_FLAGS_NOMIX_ASCII
12234                                                         : 0));
12235                         s += foldlen;
12236
12237                         /* The loop increments <len> each time, as all but this
12238                          * path (and one other) through it add a single byte to
12239                          * the EXACTish node.  But this one has changed len to
12240                          * be the correct final value, so subtract one to
12241                          * cancel out the increment that follows */
12242                         len += foldlen - 1;
12243                     }
12244                     /* If this node only contains non-folding code points so
12245                      * far, see if this new one is also non-folding */
12246                     if (maybe_exact) {
12247                         if (folded != ender) {
12248                             maybe_exact = FALSE;
12249                         }
12250                         else {
12251                             /* Here the fold is the original; we have to check
12252                              * further to see if anything folds to it */
12253                             if (_invlist_contains_cp(PL_utf8_foldable,
12254                                                         ender))
12255                             {
12256                                 maybe_exact = FALSE;
12257                             }
12258                         }
12259                     }
12260                     ender = folded;
12261                 }
12262
12263                 if (next_is_quantifier) {
12264
12265                     /* Here, the next input is a quantifier, and to get here,
12266                      * the current character is the only one in the node.
12267                      * Also, here <len> doesn't include the final byte for this
12268                      * character */
12269                     len++;
12270                     goto loopdone;
12271                 }
12272
12273             } /* End of loop through literal characters */
12274
12275             /* Here we have either exhausted the input or ran out of room in
12276              * the node.  (If we encountered a character that can't be in the
12277              * node, transfer is made directly to <loopdone>, and so we
12278              * wouldn't have fallen off the end of the loop.)  In the latter
12279              * case, we artificially have to split the node into two, because
12280              * we just don't have enough space to hold everything.  This
12281              * creates a problem if the final character participates in a
12282              * multi-character fold in the non-final position, as a match that
12283              * should have occurred won't, due to the way nodes are matched,
12284              * and our artificial boundary.  So back off until we find a non-
12285              * problematic character -- one that isn't at the beginning or
12286              * middle of such a fold.  (Either it doesn't participate in any
12287              * folds, or appears only in the final position of all the folds it
12288              * does participate in.)  A better solution with far fewer false
12289              * positives, and that would fill the nodes more completely, would
12290              * be to actually have available all the multi-character folds to
12291              * test against, and to back-off only far enough to be sure that
12292              * this node isn't ending with a partial one.  <upper_parse> is set
12293              * further below (if we need to reparse the node) to include just
12294              * up through that final non-problematic character that this code
12295              * identifies, so when it is set to less than the full node, we can
12296              * skip the rest of this */
12297             if (FOLD && p < RExC_end && upper_parse == MAX_NODE_STRING_SIZE) {
12298
12299                 const STRLEN full_len = len;
12300
12301                 assert(len >= MAX_NODE_STRING_SIZE);
12302
12303                 /* Here, <s> points to the final byte of the final character.
12304                  * Look backwards through the string until find a non-
12305                  * problematic character */
12306
12307                 if (! UTF) {
12308
12309                     /* This has no multi-char folds to non-UTF characters */
12310                     if (ASCII_FOLD_RESTRICTED) {
12311                         goto loopdone;
12312                     }
12313
12314                     while (--s >= s0 && IS_NON_FINAL_FOLD(*s)) { }
12315                     len = s - s0 + 1;
12316                 }
12317                 else {
12318                     if (!  PL_NonL1NonFinalFold) {
12319                         PL_NonL1NonFinalFold = _new_invlist_C_array(
12320                                         NonL1_Perl_Non_Final_Folds_invlist);
12321                     }
12322
12323                     /* Point to the first byte of the final character */
12324                     s = (char *) utf8_hop((U8 *) s, -1);
12325
12326                     while (s >= s0) {   /* Search backwards until find
12327                                            non-problematic char */
12328                         if (UTF8_IS_INVARIANT(*s)) {
12329
12330                             /* There are no ascii characters that participate
12331                              * in multi-char folds under /aa.  In EBCDIC, the
12332                              * non-ascii invariants are all control characters,
12333                              * so don't ever participate in any folds. */
12334                             if (ASCII_FOLD_RESTRICTED
12335                                 || ! IS_NON_FINAL_FOLD(*s))
12336                             {
12337                                 break;
12338                             }
12339                         }
12340                         else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
12341                             if (! IS_NON_FINAL_FOLD(TWO_BYTE_UTF8_TO_NATIVE(
12342                                                                   *s, *(s+1))))
12343                             {
12344                                 break;
12345                             }
12346                         }
12347                         else if (! _invlist_contains_cp(
12348                                         PL_NonL1NonFinalFold,
12349                                         valid_utf8_to_uvchr((U8 *) s, NULL)))
12350                         {
12351                             break;
12352                         }
12353
12354                         /* Here, the current character is problematic in that
12355                          * it does occur in the non-final position of some
12356                          * fold, so try the character before it, but have to
12357                          * special case the very first byte in the string, so
12358                          * we don't read outside the string */
12359                         s = (s == s0) ? s -1 : (char *) utf8_hop((U8 *) s, -1);
12360                     } /* End of loop backwards through the string */
12361
12362                     /* If there were only problematic characters in the string,
12363                      * <s> will point to before s0, in which case the length
12364                      * should be 0, otherwise include the length of the
12365                      * non-problematic character just found */
12366                     len = (s < s0) ? 0 : s - s0 + UTF8SKIP(s);
12367                 }
12368
12369                 /* Here, have found the final character, if any, that is
12370                  * non-problematic as far as ending the node without splitting
12371                  * it across a potential multi-char fold.  <len> contains the
12372                  * number of bytes in the node up-to and including that
12373                  * character, or is 0 if there is no such character, meaning
12374                  * the whole node contains only problematic characters.  In
12375                  * this case, give up and just take the node as-is.  We can't
12376                  * do any better */
12377                 if (len == 0) {
12378                     len = full_len;
12379
12380                     /* If the node ends in an 's' we make sure it stays EXACTF,
12381                      * as if it turns into an EXACTFU, it could later get
12382                      * joined with another 's' that would then wrongly match
12383                      * the sharp s */
12384                     if (maybe_exactfu && isALPHA_FOLD_EQ(ender, 's'))
12385                     {
12386                         maybe_exactfu = FALSE;
12387                     }
12388                 } else {
12389
12390                     /* Here, the node does contain some characters that aren't
12391                      * problematic.  If one such is the final character in the
12392                      * node, we are done */
12393                     if (len == full_len) {
12394                         goto loopdone;
12395                     }
12396                     else if (len + ((UTF) ? UTF8SKIP(s) : 1) == full_len) {
12397
12398                         /* If the final character is problematic, but the
12399                          * penultimate is not, back-off that last character to
12400                          * later start a new node with it */
12401                         p = oldp;
12402                         goto loopdone;
12403                     }
12404
12405                     /* Here, the final non-problematic character is earlier
12406                      * in the input than the penultimate character.  What we do
12407                      * is reparse from the beginning, going up only as far as
12408                      * this final ok one, thus guaranteeing that the node ends
12409                      * in an acceptable character.  The reason we reparse is
12410                      * that we know how far in the character is, but we don't
12411                      * know how to correlate its position with the input parse.
12412                      * An alternate implementation would be to build that
12413                      * correlation as we go along during the original parse,
12414                      * but that would entail extra work for every node, whereas
12415                      * this code gets executed only when the string is too
12416                      * large for the node, and the final two characters are
12417                      * problematic, an infrequent occurrence.  Yet another
12418                      * possible strategy would be to save the tail of the
12419                      * string, and the next time regatom is called, initialize
12420                      * with that.  The problem with this is that unless you
12421                      * back off one more character, you won't be guaranteed
12422                      * regatom will get called again, unless regbranch,
12423                      * regpiece ... are also changed.  If you do back off that
12424                      * extra character, so that there is input guaranteed to
12425                      * force calling regatom, you can't handle the case where
12426                      * just the first character in the node is acceptable.  I
12427                      * (khw) decided to try this method which doesn't have that
12428                      * pitfall; if performance issues are found, we can do a
12429                      * combination of the current approach plus that one */
12430                     upper_parse = len;
12431                     len = 0;
12432                     s = s0;
12433                     goto reparse;
12434                 }
12435             }   /* End of verifying node ends with an appropriate char */
12436
12437         loopdone:   /* Jumped to when encounters something that shouldn't be in
12438                        the node */
12439
12440             /* I (khw) don't know if you can get here with zero length, but the
12441              * old code handled this situation by creating a zero-length EXACT
12442              * node.  Might as well be NOTHING instead */
12443             if (len == 0) {
12444                 OP(ret) = NOTHING;
12445             }
12446             else {
12447                 if (FOLD) {
12448                     /* If 'maybe_exact' is still set here, means there are no
12449                      * code points in the node that participate in folds;
12450                      * similarly for 'maybe_exactfu' and code points that match
12451                      * differently depending on UTF8ness of the target string
12452                      * (for /u), or depending on locale for /l */
12453                     if (maybe_exact) {
12454                         OP(ret) = EXACT;
12455                     }
12456                     else if (maybe_exactfu) {
12457                         OP(ret) = EXACTFU;
12458                     }
12459                 }
12460                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, len, ender,
12461                                            FALSE /* Don't look to see if could
12462                                                     be turned into an EXACT
12463                                                     node, as we have already
12464                                                     computed that */
12465                                           );
12466             }
12467
12468             RExC_parse = p - 1;
12469             Set_Node_Cur_Length(ret, parse_start);
12470             nextchar(pRExC_state);
12471             {
12472                 /* len is STRLEN which is unsigned, need to copy to signed */
12473                 IV iv = len;
12474                 if (iv < 0)
12475                     vFAIL("Internal disaster");
12476             }
12477
12478         } /* End of label 'defchar:' */
12479         break;
12480     } /* End of giant switch on input character */
12481
12482     return(ret);
12483 }
12484
12485 STATIC char *
12486 S_regpatws(RExC_state_t *pRExC_state, char *p , const bool recognize_comment )
12487 {
12488     /* Returns the next non-pattern-white space, non-comment character (the
12489      * latter only if 'recognize_comment is true) in the string p, which is
12490      * ended by RExC_end.  See also reg_skipcomment */
12491     const char *e = RExC_end;
12492
12493     PERL_ARGS_ASSERT_REGPATWS;
12494
12495     while (p < e) {
12496         STRLEN len;
12497         if ((len = is_PATWS_safe(p, e, UTF))) {
12498             p += len;
12499         }
12500         else if (recognize_comment && *p == '#') {
12501             p = reg_skipcomment(pRExC_state, p);
12502         }
12503         else
12504             break;
12505     }
12506     return p;
12507 }
12508
12509 STATIC void
12510 S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr)
12511 {
12512     /* Uses the inversion list '*invlist_ptr' to populate the ANYOF 'node'.  It
12513      * sets up the bitmap and any flags, removing those code points from the
12514      * inversion list, setting it to NULL should it become completely empty */
12515
12516     PERL_ARGS_ASSERT_POPULATE_ANYOF_FROM_INVLIST;
12517     assert(PL_regkind[OP(node)] == ANYOF);
12518
12519     ANYOF_BITMAP_ZERO(node);
12520     if (*invlist_ptr) {
12521
12522         /* This gets set if we actually need to modify things */
12523         bool change_invlist = FALSE;
12524
12525         UV start, end;
12526
12527         /* Start looking through *invlist_ptr */
12528         invlist_iterinit(*invlist_ptr);
12529         while (invlist_iternext(*invlist_ptr, &start, &end)) {
12530             UV high;
12531             int i;
12532
12533             if (end == UV_MAX && start <= NUM_ANYOF_CODE_POINTS) {
12534                 ANYOF_FLAGS(node) |= ANYOF_MATCHES_ALL_ABOVE_BITMAP;
12535             }
12536             else if (end >= NUM_ANYOF_CODE_POINTS) {
12537                 ANYOF_FLAGS(node) |= ANYOF_HAS_UTF8_NONBITMAP_MATCHES;
12538             }
12539
12540             /* Quit if are above what we should change */
12541             if (start >= NUM_ANYOF_CODE_POINTS) {
12542                 break;
12543             }
12544
12545             change_invlist = TRUE;
12546
12547             /* Set all the bits in the range, up to the max that we are doing */
12548             high = (end < NUM_ANYOF_CODE_POINTS - 1)
12549                    ? end
12550                    : NUM_ANYOF_CODE_POINTS - 1;
12551             for (i = start; i <= (int) high; i++) {
12552                 if (! ANYOF_BITMAP_TEST(node, i)) {
12553                     ANYOF_BITMAP_SET(node, i);
12554                 }
12555             }
12556         }
12557         invlist_iterfinish(*invlist_ptr);
12558
12559         /* Done with loop; remove any code points that are in the bitmap from
12560          * *invlist_ptr; similarly for code points above the bitmap if we have
12561          * a flag to match all of them anyways */
12562         if (change_invlist) {
12563             _invlist_subtract(*invlist_ptr, PL_InBitmap, invlist_ptr);
12564         }
12565         if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
12566             _invlist_intersection(*invlist_ptr, PL_InBitmap, invlist_ptr);
12567         }
12568
12569         /* If have completely emptied it, remove it completely */
12570         if (_invlist_len(*invlist_ptr) == 0) {
12571             SvREFCNT_dec_NN(*invlist_ptr);
12572             *invlist_ptr = NULL;
12573         }
12574     }
12575 }
12576
12577 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
12578    Character classes ([:foo:]) can also be negated ([:^foo:]).
12579    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
12580    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
12581    but trigger failures because they are currently unimplemented. */
12582
12583 #define POSIXCC_DONE(c)   ((c) == ':')
12584 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
12585 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
12586
12587 PERL_STATIC_INLINE I32
12588 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value, const bool strict)
12589 {
12590     I32 namedclass = OOB_NAMEDCLASS;
12591
12592     PERL_ARGS_ASSERT_REGPPOSIXCC;
12593
12594     if (value == '[' && RExC_parse + 1 < RExC_end &&
12595         /* I smell either [: or [= or [. -- POSIX has been here, right? */
12596         POSIXCC(UCHARAT(RExC_parse)))
12597     {
12598         const char c = UCHARAT(RExC_parse);
12599         char* const s = RExC_parse++;
12600
12601         while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
12602             RExC_parse++;
12603         if (RExC_parse == RExC_end) {
12604             if (strict) {
12605
12606                 /* Try to give a better location for the error (than the end of
12607                  * the string) by looking for the matching ']' */
12608                 RExC_parse = s;
12609                 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
12610                     RExC_parse++;
12611                 }
12612                 vFAIL2("Unmatched '%c' in POSIX class", c);
12613             }
12614             /* Grandfather lone [:, [=, [. */
12615             RExC_parse = s;
12616         }
12617         else {
12618             const char* const t = RExC_parse++; /* skip over the c */
12619             assert(*t == c);
12620
12621             if (UCHARAT(RExC_parse) == ']') {
12622                 const char *posixcc = s + 1;
12623                 RExC_parse++; /* skip over the ending ] */
12624
12625                 if (*s == ':') {
12626                     const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
12627                     const I32 skip = t - posixcc;
12628
12629                     /* Initially switch on the length of the name.  */
12630                     switch (skip) {
12631                     case 4:
12632                         if (memEQ(posixcc, "word", 4)) /* this is not POSIX,
12633                                                           this is the Perl \w
12634                                                         */
12635                             namedclass = ANYOF_WORDCHAR;
12636                         break;
12637                     case 5:
12638                         /* Names all of length 5.  */
12639                         /* alnum alpha ascii blank cntrl digit graph lower
12640                            print punct space upper  */
12641                         /* Offset 4 gives the best switch position.  */
12642                         switch (posixcc[4]) {
12643                         case 'a':
12644                             if (memEQ(posixcc, "alph", 4)) /* alpha */
12645                                 namedclass = ANYOF_ALPHA;
12646                             break;
12647                         case 'e':
12648                             if (memEQ(posixcc, "spac", 4)) /* space */
12649                                 namedclass = ANYOF_PSXSPC;
12650                             break;
12651                         case 'h':
12652                             if (memEQ(posixcc, "grap", 4)) /* graph */
12653                                 namedclass = ANYOF_GRAPH;
12654                             break;
12655                         case 'i':
12656                             if (memEQ(posixcc, "asci", 4)) /* ascii */
12657                                 namedclass = ANYOF_ASCII;
12658                             break;
12659                         case 'k':
12660                             if (memEQ(posixcc, "blan", 4)) /* blank */
12661                                 namedclass = ANYOF_BLANK;
12662                             break;
12663                         case 'l':
12664                             if (memEQ(posixcc, "cntr", 4)) /* cntrl */
12665                                 namedclass = ANYOF_CNTRL;
12666                             break;
12667                         case 'm':
12668                             if (memEQ(posixcc, "alnu", 4)) /* alnum */
12669                                 namedclass = ANYOF_ALPHANUMERIC;
12670                             break;
12671                         case 'r':
12672                             if (memEQ(posixcc, "lowe", 4)) /* lower */
12673                                 namedclass = (FOLD) ? ANYOF_CASED : ANYOF_LOWER;
12674                             else if (memEQ(posixcc, "uppe", 4)) /* upper */
12675                                 namedclass = (FOLD) ? ANYOF_CASED : ANYOF_UPPER;
12676                             break;
12677                         case 't':
12678                             if (memEQ(posixcc, "digi", 4)) /* digit */
12679                                 namedclass = ANYOF_DIGIT;
12680                             else if (memEQ(posixcc, "prin", 4)) /* print */
12681                                 namedclass = ANYOF_PRINT;
12682                             else if (memEQ(posixcc, "punc", 4)) /* punct */
12683                                 namedclass = ANYOF_PUNCT;
12684                             break;
12685                         }
12686                         break;
12687                     case 6:
12688                         if (memEQ(posixcc, "xdigit", 6))
12689                             namedclass = ANYOF_XDIGIT;
12690                         break;
12691                     }
12692
12693                     if (namedclass == OOB_NAMEDCLASS)
12694                         vFAIL2utf8f(
12695                             "POSIX class [:%"UTF8f":] unknown",
12696                             UTF8fARG(UTF, t - s - 1, s + 1));
12697
12698                     /* The #defines are structured so each complement is +1 to
12699                      * the normal one */
12700                     if (complement) {
12701                         namedclass++;
12702                     }
12703                     assert (posixcc[skip] == ':');
12704                     assert (posixcc[skip+1] == ']');
12705                 } else if (!SIZE_ONLY) {
12706                     /* [[=foo=]] and [[.foo.]] are still future. */
12707
12708                     /* adjust RExC_parse so the warning shows after
12709                        the class closes */
12710                     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
12711                         RExC_parse++;
12712                     vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
12713                 }
12714             } else {
12715                 /* Maternal grandfather:
12716                  * "[:" ending in ":" but not in ":]" */
12717                 if (strict) {
12718                     vFAIL("Unmatched '[' in POSIX class");
12719                 }
12720
12721                 /* Grandfather lone [:, [=, [. */
12722                 RExC_parse = s;
12723             }
12724         }
12725     }
12726
12727     return namedclass;
12728 }
12729
12730 STATIC bool
12731 S_could_it_be_a_POSIX_class(RExC_state_t *pRExC_state)
12732 {
12733     /* This applies some heuristics at the current parse position (which should
12734      * be at a '[') to see if what follows might be intended to be a [:posix:]
12735      * class.  It returns true if it really is a posix class, of course, but it
12736      * also can return true if it thinks that what was intended was a posix
12737      * class that didn't quite make it.
12738      *
12739      * It will return true for
12740      *      [:alphanumerics:
12741      *      [:alphanumerics]  (as long as the ] isn't followed immediately by a
12742      *                         ')' indicating the end of the (?[
12743      *      [:any garbage including %^&$ punctuation:]
12744      *
12745      * This is designed to be called only from S_handle_regex_sets; it could be
12746      * easily adapted to be called from the spot at the beginning of regclass()
12747      * that checks to see in a normal bracketed class if the surrounding []
12748      * have been omitted ([:word:] instead of [[:word:]]).  But doing so would
12749      * change long-standing behavior, so I (khw) didn't do that */
12750     char* p = RExC_parse + 1;
12751     char first_char = *p;
12752
12753     PERL_ARGS_ASSERT_COULD_IT_BE_A_POSIX_CLASS;
12754
12755     assert(*(p - 1) == '[');
12756
12757     if (! POSIXCC(first_char)) {
12758         return FALSE;
12759     }
12760
12761     p++;
12762     while (p < RExC_end && isWORDCHAR(*p)) p++;
12763
12764     if (p >= RExC_end) {
12765         return FALSE;
12766     }
12767
12768     if (p - RExC_parse > 2    /* Got at least 1 word character */
12769         && (*p == first_char
12770             || (*p == ']' && p + 1 < RExC_end && *(p + 1) != ')')))
12771     {
12772         return TRUE;
12773     }
12774
12775     p = (char *) memchr(RExC_parse, ']', RExC_end - RExC_parse);
12776
12777     return (p
12778             && p - RExC_parse > 2 /* [:] evaluates to colon;
12779                                       [::] is a bad posix class. */
12780             && first_char == *(p - 1));
12781 }
12782
12783 STATIC regnode *
12784 S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist,
12785                     I32 *flagp, U32 depth,
12786                     char * const oregcomp_parse)
12787 {
12788     /* Handle the (?[...]) construct to do set operations */
12789
12790     U8 curchar;
12791     UV start, end;      /* End points of code point ranges */
12792     SV* result_string;
12793     char *save_end, *save_parse;
12794     SV* final;
12795     STRLEN len;
12796     regnode* node;
12797     AV* stack;
12798     const bool save_fold = FOLD;
12799
12800     GET_RE_DEBUG_FLAGS_DECL;
12801
12802     PERL_ARGS_ASSERT_HANDLE_REGEX_SETS;
12803
12804     if (LOC) {
12805         vFAIL("(?[...]) not valid in locale");
12806     }
12807     RExC_uni_semantics = 1;
12808
12809     /* This will return only an ANYOF regnode, or (unlikely) something smaller
12810      * (such as EXACT).  Thus we can skip most everything if just sizing.  We
12811      * call regclass to handle '[]' so as to not have to reinvent its parsing
12812      * rules here (throwing away the size it computes each time).  And, we exit
12813      * upon an unescaped ']' that isn't one ending a regclass.  To do both
12814      * these things, we need to realize that something preceded by a backslash
12815      * is escaped, so we have to keep track of backslashes */
12816     if (PASS2) {
12817         Perl_ck_warner_d(aTHX_
12818             packWARN(WARN_EXPERIMENTAL__REGEX_SETS),
12819             "The regex_sets feature is experimental" REPORT_LOCATION,
12820                 UTF8fARG(UTF, (RExC_parse - RExC_precomp), RExC_precomp),
12821                 UTF8fARG(UTF,
12822                          RExC_end - RExC_start - (RExC_parse - RExC_precomp),
12823                          RExC_precomp + (RExC_parse - RExC_precomp)));
12824     }
12825     else {
12826         UV depth = 0; /* how many nested (?[...]) constructs */
12827
12828         while (RExC_parse < RExC_end) {
12829             SV* current = NULL;
12830             RExC_parse = regpatws(pRExC_state, RExC_parse,
12831                                           TRUE); /* means recognize comments */
12832             switch (*RExC_parse) {
12833                 case '?':
12834                     if (RExC_parse[1] == '[') depth++, RExC_parse++;
12835                     /* FALLTHROUGH */
12836                 default:
12837                     break;
12838                 case '\\':
12839                     /* Skip the next byte (which could cause us to end up in
12840                      * the middle of a UTF-8 character, but since none of those
12841                      * are confusable with anything we currently handle in this
12842                      * switch (invariants all), it's safe.  We'll just hit the
12843                      * default: case next time and keep on incrementing until
12844                      * we find one of the invariants we do handle. */
12845                     RExC_parse++;
12846                     break;
12847                 case '[':
12848                 {
12849                     /* If this looks like it is a [:posix:] class, leave the
12850                      * parse pointer at the '[' to fool regclass() into
12851                      * thinking it is part of a '[[:posix:]]'.  That function
12852                      * will use strict checking to force a syntax error if it
12853                      * doesn't work out to a legitimate class */
12854                     bool is_posix_class
12855                                     = could_it_be_a_POSIX_class(pRExC_state);
12856                     if (! is_posix_class) {
12857                         RExC_parse++;
12858                     }
12859
12860                     /* regclass() can only return RESTART_UTF8 if multi-char
12861                        folds are allowed.  */
12862                     if (!regclass(pRExC_state, flagp,depth+1,
12863                                   is_posix_class, /* parse the whole char
12864                                                      class only if not a
12865                                                      posix class */
12866                                   FALSE, /* don't allow multi-char folds */
12867                                   TRUE, /* silence non-portable warnings. */
12868                                   &current))
12869                         FAIL2("panic: regclass returned NULL to handle_sets, flags=%#"UVxf"",
12870                               (UV) *flagp);
12871
12872                     /* function call leaves parse pointing to the ']', except
12873                      * if we faked it */
12874                     if (is_posix_class) {
12875                         RExC_parse--;
12876                     }
12877
12878                     SvREFCNT_dec(current);   /* In case it returned something */
12879                     break;
12880                 }
12881
12882                 case ']':
12883                     if (depth--) break;
12884                     RExC_parse++;
12885                     if (RExC_parse < RExC_end
12886                         && *RExC_parse == ')')
12887                     {
12888                         node = reganode(pRExC_state, ANYOF, 0);
12889                         RExC_size += ANYOF_SKIP;
12890                         nextchar(pRExC_state);
12891                         Set_Node_Length(node,
12892                                 RExC_parse - oregcomp_parse + 1); /* MJD */
12893                         return node;
12894                     }
12895                     goto no_close;
12896             }
12897             RExC_parse++;
12898         }
12899
12900         no_close:
12901         FAIL("Syntax error in (?[...])");
12902     }
12903
12904     /* Pass 2 only after this.  Everything in this construct is a
12905      * metacharacter.  Operands begin with either a '\' (for an escape
12906      * sequence), or a '[' for a bracketed character class.  Any other
12907      * character should be an operator, or parenthesis for grouping.  Both
12908      * types of operands are handled by calling regclass() to parse them.  It
12909      * is called with a parameter to indicate to return the computed inversion
12910      * list.  The parsing here is implemented via a stack.  Each entry on the
12911      * stack is a single character representing one of the operators, or the
12912      * '('; or else a pointer to an operand inversion list. */
12913
12914 #define IS_OPERAND(a)  (! SvIOK(a))
12915
12916     /* The stack starts empty.  It is a syntax error if the first thing parsed
12917      * is a binary operator; everything else is pushed on the stack.  When an
12918      * operand is parsed, the top of the stack is examined.  If it is a binary
12919      * operator, the item before it should be an operand, and both are replaced
12920      * by the result of doing that operation on the new operand and the one on
12921      * the stack.   Thus a sequence of binary operands is reduced to a single
12922      * one before the next one is parsed.
12923      *
12924      * A unary operator may immediately follow a binary in the input, for
12925      * example
12926      *      [a] + ! [b]
12927      * When an operand is parsed and the top of the stack is a unary operator,
12928      * the operation is performed, and then the stack is rechecked to see if
12929      * this new operand is part of a binary operation; if so, it is handled as
12930      * above.
12931      *
12932      * A '(' is simply pushed on the stack; it is valid only if the stack is
12933      * empty, or the top element of the stack is an operator or another '('
12934      * (for which the parenthesized expression will become an operand).  By the
12935      * time the corresponding ')' is parsed everything in between should have
12936      * been parsed and evaluated to a single operand (or else is a syntax
12937      * error), and is handled as a regular operand */
12938
12939     sv_2mortal((SV *)(stack = newAV()));
12940
12941     while (RExC_parse < RExC_end) {
12942         I32 top_index = av_tindex(stack);
12943         SV** top_ptr;
12944         SV* current = NULL;
12945
12946         /* Skip white space */
12947         RExC_parse = regpatws(pRExC_state, RExC_parse,
12948                                          TRUE /* means recognize comments */ );
12949         if (RExC_parse >= RExC_end) {
12950             Perl_croak(aTHX_ "panic: Read past end of '(?[ ])'");
12951         }
12952         if ((curchar = UCHARAT(RExC_parse)) == ']') {
12953             break;
12954         }
12955
12956         switch (curchar) {
12957
12958             case '?':
12959                 if (av_tindex(stack) >= 0   /* This makes sure that we can
12960                                                safely subtract 1 from
12961                                                RExC_parse in the next clause.
12962                                                If we have something on the
12963                                                stack, we have parsed something
12964                                              */
12965                     && UCHARAT(RExC_parse - 1) == '('
12966                     && RExC_parse < RExC_end)
12967                 {
12968                     /* If is a '(?', could be an embedded '(?flags:(?[...])'.
12969                      * This happens when we have some thing like
12970                      *
12971                      *   my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
12972                      *   ...
12973                      *   qr/(?[ \p{Digit} & $thai_or_lao ])/;
12974                      *
12975                      * Here we would be handling the interpolated
12976                      * '$thai_or_lao'.  We handle this by a recursive call to
12977                      * ourselves which returns the inversion list the
12978                      * interpolated expression evaluates to.  We use the flags
12979                      * from the interpolated pattern. */
12980                     U32 save_flags = RExC_flags;
12981                     const char * const save_parse = ++RExC_parse;
12982
12983                     parse_lparen_question_flags(pRExC_state);
12984
12985                     if (RExC_parse == save_parse  /* Makes sure there was at
12986                                                      least one flag (or this
12987                                                      embedding wasn't compiled)
12988                                                    */
12989                         || RExC_parse >= RExC_end - 4
12990                         || UCHARAT(RExC_parse) != ':'
12991                         || UCHARAT(++RExC_parse) != '('
12992                         || UCHARAT(++RExC_parse) != '?'
12993                         || UCHARAT(++RExC_parse) != '[')
12994                     {
12995
12996                         /* In combination with the above, this moves the
12997                          * pointer to the point just after the first erroneous
12998                          * character (or if there are no flags, to where they
12999                          * should have been) */
13000                         if (RExC_parse >= RExC_end - 4) {
13001                             RExC_parse = RExC_end;
13002                         }
13003                         else if (RExC_parse != save_parse) {
13004                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
13005                         }
13006                         vFAIL("Expecting '(?flags:(?[...'");
13007                     }
13008                     RExC_parse++;
13009                     (void) handle_regex_sets(pRExC_state, &current, flagp,
13010                                                     depth+1, oregcomp_parse);
13011
13012                     /* Here, 'current' contains the embedded expression's
13013                      * inversion list, and RExC_parse points to the trailing
13014                      * ']'; the next character should be the ')' which will be
13015                      * paired with the '(' that has been put on the stack, so
13016                      * the whole embedded expression reduces to '(operand)' */
13017                     RExC_parse++;
13018
13019                     RExC_flags = save_flags;
13020                     goto handle_operand;
13021                 }
13022                 /* FALLTHROUGH */
13023
13024             default:
13025                 RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
13026                 vFAIL("Unexpected character");
13027
13028             case '\\':
13029                 /* regclass() can only return RESTART_UTF8 if multi-char
13030                    folds are allowed.  */
13031                 if (!regclass(pRExC_state, flagp,depth+1,
13032                               TRUE, /* means parse just the next thing */
13033                               FALSE, /* don't allow multi-char folds */
13034                               FALSE, /* don't silence non-portable warnings.  */
13035                               &current))
13036                     FAIL2("panic: regclass returned NULL to handle_sets, flags=%#"UVxf"",
13037                           (UV) *flagp);
13038                 /* regclass() will return with parsing just the \ sequence,
13039                  * leaving the parse pointer at the next thing to parse */
13040                 RExC_parse--;
13041                 goto handle_operand;
13042
13043             case '[':   /* Is a bracketed character class */
13044             {
13045                 bool is_posix_class = could_it_be_a_POSIX_class(pRExC_state);
13046
13047                 if (! is_posix_class) {
13048                     RExC_parse++;
13049                 }
13050
13051                 /* regclass() can only return RESTART_UTF8 if multi-char
13052                    folds are allowed.  */
13053                 if(!regclass(pRExC_state, flagp,depth+1,
13054                              is_posix_class, /* parse the whole char class
13055                                                 only if not a posix class */
13056                              FALSE, /* don't allow multi-char folds */
13057                              FALSE, /* don't silence non-portable warnings.  */
13058                              &current))
13059                     FAIL2("panic: regclass returned NULL to handle_sets, flags=%#"UVxf"",
13060                           (UV) *flagp);
13061                 /* function call leaves parse pointing to the ']', except if we
13062                  * faked it */
13063                 if (is_posix_class) {
13064                     RExC_parse--;
13065                 }
13066
13067                 goto handle_operand;
13068             }
13069
13070             case '&':
13071             case '|':
13072             case '+':
13073             case '-':
13074             case '^':
13075                 if (top_index < 0
13076                     || ( ! (top_ptr = av_fetch(stack, top_index, FALSE)))
13077                     || ! IS_OPERAND(*top_ptr))
13078                 {
13079                     RExC_parse++;
13080                     vFAIL2("Unexpected binary operator '%c' with no preceding operand", curchar);
13081                 }
13082                 av_push(stack, newSVuv(curchar));
13083                 break;
13084
13085             case '!':
13086                 av_push(stack, newSVuv(curchar));
13087                 break;
13088
13089             case '(':
13090                 if (top_index >= 0) {
13091                     top_ptr = av_fetch(stack, top_index, FALSE);
13092                     assert(top_ptr);
13093                     if (IS_OPERAND(*top_ptr)) {
13094                         RExC_parse++;
13095                         vFAIL("Unexpected '(' with no preceding operator");
13096                     }
13097                 }
13098                 av_push(stack, newSVuv(curchar));
13099                 break;
13100
13101             case ')':
13102             {
13103                 SV* lparen;
13104                 if (top_index < 1
13105                     || ! (current = av_pop(stack))
13106                     || ! IS_OPERAND(current)
13107                     || ! (lparen = av_pop(stack))
13108                     || IS_OPERAND(lparen)
13109                     || SvUV(lparen) != '(')
13110                 {
13111                     SvREFCNT_dec(current);
13112                     RExC_parse++;
13113                     vFAIL("Unexpected ')'");
13114                 }
13115                 top_index -= 2;
13116                 SvREFCNT_dec_NN(lparen);
13117
13118                 /* FALLTHROUGH */
13119             }
13120
13121               handle_operand:
13122
13123                 /* Here, we have an operand to process, in 'current' */
13124
13125                 if (top_index < 0) {    /* Just push if stack is empty */
13126                     av_push(stack, current);
13127                 }
13128                 else {
13129                     SV* top = av_pop(stack);
13130                     SV *prev = NULL;
13131                     char current_operator;
13132
13133                     if (IS_OPERAND(top)) {
13134                         SvREFCNT_dec_NN(top);
13135                         SvREFCNT_dec_NN(current);
13136                         vFAIL("Operand with no preceding operator");
13137                     }
13138                     current_operator = (char) SvUV(top);
13139                     switch (current_operator) {
13140                         case '(':   /* Push the '(' back on followed by the new
13141                                        operand */
13142                             av_push(stack, top);
13143                             av_push(stack, current);
13144                             SvREFCNT_inc(top);  /* Counters the '_dec' done
13145                                                    just after the 'break', so
13146                                                    it doesn't get wrongly freed
13147                                                  */
13148                             break;
13149
13150                         case '!':
13151                             _invlist_invert(current);
13152
13153                             /* Unlike binary operators, the top of the stack,
13154                              * now that this unary one has been popped off, may
13155                              * legally be an operator, and we now have operand
13156                              * for it. */
13157                             top_index--;
13158                             SvREFCNT_dec_NN(top);
13159                             goto handle_operand;
13160
13161                         case '&':
13162                             prev = av_pop(stack);
13163                             _invlist_intersection(prev,
13164                                                    current,
13165                                                    &current);
13166                             av_push(stack, current);
13167                             break;
13168
13169                         case '|':
13170                         case '+':
13171                             prev = av_pop(stack);
13172                             _invlist_union(prev, current, &current);
13173                             av_push(stack, current);
13174                             break;
13175
13176                         case '-':
13177                             prev = av_pop(stack);;
13178                             _invlist_subtract(prev, current, &current);
13179                             av_push(stack, current);
13180                             break;
13181
13182                         case '^':   /* The union minus the intersection */
13183                         {
13184                             SV* i = NULL;
13185                             SV* u = NULL;
13186                             SV* element;
13187
13188                             prev = av_pop(stack);
13189                             _invlist_union(prev, current, &u);
13190                             _invlist_intersection(prev, current, &i);
13191                             /* _invlist_subtract will overwrite current
13192                                 without freeing what it already contains */
13193                             element = current;
13194                             _invlist_subtract(u, i, &current);
13195                             av_push(stack, current);
13196                             SvREFCNT_dec_NN(i);
13197                             SvREFCNT_dec_NN(u);
13198                             SvREFCNT_dec_NN(element);
13199                             break;
13200                         }
13201
13202                         default:
13203                             Perl_croak(aTHX_ "panic: Unexpected item on '(?[ ])' stack");
13204                 }
13205                 SvREFCNT_dec_NN(top);
13206                 SvREFCNT_dec(prev);
13207             }
13208         }
13209
13210         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
13211     }
13212
13213     if (av_tindex(stack) < 0   /* Was empty */
13214         || ((final = av_pop(stack)) == NULL)
13215         || ! IS_OPERAND(final)
13216         || av_tindex(stack) >= 0)  /* More left on stack */
13217     {
13218         vFAIL("Incomplete expression within '(?[ ])'");
13219     }
13220
13221     /* Here, 'final' is the resultant inversion list from evaluating the
13222      * expression.  Return it if so requested */
13223     if (return_invlist) {
13224         *return_invlist = final;
13225         return END;
13226     }
13227
13228     /* Otherwise generate a resultant node, based on 'final'.  regclass() is
13229      * expecting a string of ranges and individual code points */
13230     invlist_iterinit(final);
13231     result_string = newSVpvs("");
13232     while (invlist_iternext(final, &start, &end)) {
13233         if (start == end) {
13234             Perl_sv_catpvf(aTHX_ result_string, "\\x{%"UVXf"}", start);
13235         }
13236         else {
13237             Perl_sv_catpvf(aTHX_ result_string, "\\x{%"UVXf"}-\\x{%"UVXf"}",
13238                                                      start,          end);
13239         }
13240     }
13241
13242     save_parse = RExC_parse;
13243     RExC_parse = SvPV(result_string, len);
13244     save_end = RExC_end;
13245     RExC_end = RExC_parse + len;
13246
13247     /* We turn off folding around the call, as the class we have constructed
13248      * already has all folding taken into consideration, and we don't want
13249      * regclass() to add to that */
13250     RExC_flags &= ~RXf_PMf_FOLD;
13251     /* regclass() can only return RESTART_UTF8 if multi-char folds are allowed.
13252      */
13253     node = regclass(pRExC_state, flagp,depth+1,
13254                     FALSE, /* means parse the whole char class */
13255                     FALSE, /* don't allow multi-char folds */
13256                     TRUE, /* silence non-portable warnings.  The above may very
13257                              well have generated non-portable code points, but
13258                              they're valid on this machine */
13259                     NULL);
13260     if (!node)
13261         FAIL2("panic: regclass returned NULL to handle_sets, flags=%#"UVxf,
13262                     PTR2UV(flagp));
13263     if (save_fold) {
13264         RExC_flags |= RXf_PMf_FOLD;
13265     }
13266     RExC_parse = save_parse + 1;
13267     RExC_end = save_end;
13268     SvREFCNT_dec_NN(final);
13269     SvREFCNT_dec_NN(result_string);
13270
13271     nextchar(pRExC_state);
13272     Set_Node_Length(node, RExC_parse - oregcomp_parse + 1); /* MJD */
13273     return node;
13274 }
13275 #undef IS_OPERAND
13276
13277 STATIC void
13278 S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invlist)
13279 {
13280     /* This hard-codes the Latin1/above-Latin1 folding rules, so that an
13281      * innocent-looking character class, like /[ks]/i won't have to go out to
13282      * disk to find the possible matches.
13283      *
13284      * This should be called only for a Latin1-range code points, cp, which is
13285      * known to be involved in a simple fold with other code points above
13286      * Latin1.  It would give false results if /aa has been specified.
13287      * Multi-char folds are outside the scope of this, and must be handled
13288      * specially.
13289      *
13290      * XXX It would be better to generate these via regen, in case a new
13291      * version of the Unicode standard adds new mappings, though that is not
13292      * really likely, and may be caught by the default: case of the switch
13293      * below. */
13294
13295     PERL_ARGS_ASSERT_ADD_ABOVE_LATIN1_FOLDS;
13296
13297     assert(HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(cp));
13298
13299     switch (cp) {
13300         case 'k':
13301         case 'K':
13302           *invlist =
13303              add_cp_to_invlist(*invlist, KELVIN_SIGN);
13304             break;
13305         case 's':
13306         case 'S':
13307           *invlist = add_cp_to_invlist(*invlist, LATIN_SMALL_LETTER_LONG_S);
13308             break;
13309         case MICRO_SIGN:
13310           *invlist = add_cp_to_invlist(*invlist, GREEK_CAPITAL_LETTER_MU);
13311           *invlist = add_cp_to_invlist(*invlist, GREEK_SMALL_LETTER_MU);
13312             break;
13313         case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
13314         case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
13315           *invlist = add_cp_to_invlist(*invlist, ANGSTROM_SIGN);
13316             break;
13317         case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
13318           *invlist = add_cp_to_invlist(*invlist,
13319                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
13320             break;
13321         case LATIN_SMALL_LETTER_SHARP_S:
13322           *invlist = add_cp_to_invlist(*invlist, LATIN_CAPITAL_LETTER_SHARP_S);
13323             break;
13324         default:
13325             /* Use deprecated warning to increase the chances of this being
13326              * output */
13327             if (PASS2) {
13328                 ckWARN2reg_d(RExC_parse, "Perl folding rules are not up-to-date for 0x%02X; please use the perlbug utility to report;", cp);
13329             }
13330             break;
13331     }
13332 }
13333
13334 STATIC AV *
13335 S_add_multi_match(pTHX_ AV* multi_char_matches, SV* multi_string, const STRLEN cp_count)
13336 {
13337     /* This adds the string scalar <multi_string> to the array
13338      * <multi_char_matches>.  <multi_string> is known to have exactly
13339      * <cp_count> code points in it.  This is used when constructing a
13340      * bracketed character class and we find something that needs to match more
13341      * than a single character.
13342      *
13343      * <multi_char_matches> is actually an array of arrays.  Each top-level
13344      * element is an array that contains all the strings known so far that are
13345      * the same length.  And that length (in number of code points) is the same
13346      * as the index of the top-level array.  Hence, the [2] element is an
13347      * array, each element thereof is a string containing TWO code points;
13348      * while element [3] is for strings of THREE characters, and so on.  Since
13349      * this is for multi-char strings there can never be a [0] nor [1] element.
13350      *
13351      * When we rewrite the character class below, we will do so such that the
13352      * longest strings are written first, so that it prefers the longest
13353      * matching strings first.  This is done even if it turns out that any
13354      * quantifier is non-greedy, out of this programmer's (khw) laziness.  Tom
13355      * Christiansen has agreed that this is ok.  This makes the test for the
13356      * ligature 'ffi' come before the test for 'ff', for example */
13357
13358     AV* this_array;
13359     AV** this_array_ptr;
13360
13361     PERL_ARGS_ASSERT_ADD_MULTI_MATCH;
13362
13363     if (! multi_char_matches) {
13364         multi_char_matches = newAV();
13365     }
13366
13367     if (av_exists(multi_char_matches, cp_count)) {
13368         this_array_ptr = (AV**) av_fetch(multi_char_matches, cp_count, FALSE);
13369         this_array = *this_array_ptr;
13370     }
13371     else {
13372         this_array = newAV();
13373         av_store(multi_char_matches, cp_count,
13374                  (SV*) this_array);
13375     }
13376     av_push(this_array, multi_string);
13377
13378     return multi_char_matches;
13379 }
13380
13381 /* The names of properties whose definitions are not known at compile time are
13382  * stored in this SV, after a constant heading.  So if the length has been
13383  * changed since initialization, then there is a run-time definition. */
13384 #define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION                            \
13385                                         (SvCUR(listsv) != initial_listsv_len)
13386
13387 STATIC regnode *
13388 S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
13389                  const bool stop_at_1,  /* Just parse the next thing, don't
13390                                            look for a full character class */
13391                  bool allow_multi_folds,
13392                  const bool silence_non_portable,   /* Don't output warnings
13393                                                        about too large
13394                                                        characters */
13395                  SV** ret_invlist)  /* Return an inversion list, not a node */
13396 {
13397     /* parse a bracketed class specification.  Most of these will produce an
13398      * ANYOF node; but something like [a] will produce an EXACT node; [aA], an
13399      * EXACTFish node; [[:ascii:]], a POSIXA node; etc.  It is more complex
13400      * under /i with multi-character folds: it will be rewritten following the
13401      * paradigm of this example, where the <multi-fold>s are characters which
13402      * fold to multiple character sequences:
13403      *      /[abc\x{multi-fold1}def\x{multi-fold2}ghi]/i
13404      * gets effectively rewritten as:
13405      *      /(?:\x{multi-fold1}|\x{multi-fold2}|[abcdefghi]/i
13406      * reg() gets called (recursively) on the rewritten version, and this
13407      * function will return what it constructs.  (Actually the <multi-fold>s
13408      * aren't physically removed from the [abcdefghi], it's just that they are
13409      * ignored in the recursion by means of a flag:
13410      * <RExC_in_multi_char_class>.)
13411      *
13412      * ANYOF nodes contain a bit map for the first NUM_ANYOF_CODE_POINTS
13413      * characters, with the corresponding bit set if that character is in the
13414      * list.  For characters above this, a range list or swash is used.  There
13415      * are extra bits for \w, etc. in locale ANYOFs, as what these match is not
13416      * determinable at compile time
13417      *
13418      * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs
13419      * to be restarted.  This can only happen if ret_invlist is non-NULL.
13420      */
13421
13422     UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE;
13423     IV range = 0;
13424     UV value = OOB_UNICODE, save_value = OOB_UNICODE;
13425     regnode *ret;
13426     STRLEN numlen;
13427     IV namedclass = OOB_NAMEDCLASS;
13428     char *rangebegin = NULL;
13429     bool need_class = 0;
13430     SV *listsv = NULL;
13431     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
13432                                       than just initialized.  */
13433     SV* properties = NULL;    /* Code points that match \p{} \P{} */
13434     SV* posixes = NULL;     /* Code points that match classes like [:word:],
13435                                extended beyond the Latin1 range.  These have to
13436                                be kept separate from other code points for much
13437                                of this function because their handling  is
13438                                different under /i, and for most classes under
13439                                /d as well */
13440     SV* nposixes = NULL;    /* Similarly for [:^word:].  These are kept
13441                                separate for a while from the non-complemented
13442                                versions because of complications with /d
13443                                matching */
13444     UV element_count = 0;   /* Number of distinct elements in the class.
13445                                Optimizations may be possible if this is tiny */
13446     AV * multi_char_matches = NULL; /* Code points that fold to more than one
13447                                        character; used under /i */
13448     UV n;
13449     char * stop_ptr = RExC_end;    /* where to stop parsing */
13450     const bool skip_white = cBOOL(ret_invlist); /* ignore unescaped white
13451                                                    space? */
13452     const bool strict = cBOOL(ret_invlist); /* Apply strict parsing rules? */
13453
13454     /* Unicode properties are stored in a swash; this holds the current one
13455      * being parsed.  If this swash is the only above-latin1 component of the
13456      * character class, an optimization is to pass it directly on to the
13457      * execution engine.  Otherwise, it is set to NULL to indicate that there
13458      * are other things in the class that have to be dealt with at execution
13459      * time */
13460     SV* swash = NULL;           /* Code points that match \p{} \P{} */
13461
13462     /* Set if a component of this character class is user-defined; just passed
13463      * on to the engine */
13464     bool has_user_defined_property = FALSE;
13465
13466     /* inversion list of code points this node matches only when the target
13467      * string is in UTF-8.  (Because is under /d) */
13468     SV* depends_list = NULL;
13469
13470     /* Inversion list of code points this node matches regardless of things
13471      * like locale, folding, utf8ness of the target string */
13472     SV* cp_list = NULL;
13473
13474     /* Like cp_list, but code points on this list need to be checked for things
13475      * that fold to/from them under /i */
13476     SV* cp_foldable_list = NULL;
13477
13478     /* Like cp_list, but code points on this list are valid only when the
13479      * runtime locale is UTF-8 */
13480     SV* only_utf8_locale_list = NULL;
13481
13482 #ifdef EBCDIC
13483     /* In a range, counts how many 0-2 of the ends of it came from literals,
13484      * not escapes.  Thus we can tell if 'A' was input vs \x{C1} */
13485     UV literal_endpoint = 0;
13486 #endif
13487     bool invert = FALSE;    /* Is this class to be complemented */
13488
13489     bool warn_super = ALWAYS_WARN_SUPER;
13490
13491     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
13492         case we need to change the emitted regop to an EXACT. */
13493     const char * orig_parse = RExC_parse;
13494     const SSize_t orig_size = RExC_size;
13495     bool posixl_matches_all = FALSE; /* Does /l class have both e.g. \W,\w ? */
13496     GET_RE_DEBUG_FLAGS_DECL;
13497
13498     PERL_ARGS_ASSERT_REGCLASS;
13499 #ifndef DEBUGGING
13500     PERL_UNUSED_ARG(depth);
13501 #endif
13502
13503     DEBUG_PARSE("clas");
13504
13505     /* Assume we are going to generate an ANYOF node. */
13506     ret = reganode(pRExC_state, ANYOF, 0);
13507
13508     if (SIZE_ONLY) {
13509         RExC_size += ANYOF_SKIP;
13510         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
13511     }
13512     else {
13513         ANYOF_FLAGS(ret) = 0;
13514
13515         RExC_emit += ANYOF_SKIP;
13516         listsv = newSVpvs_flags("# comment\n", SVs_TEMP);
13517         initial_listsv_len = SvCUR(listsv);
13518         SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated.  */
13519     }
13520
13521     if (skip_white) {
13522         RExC_parse = regpatws(pRExC_state, RExC_parse,
13523                               FALSE /* means don't recognize comments */ );
13524     }
13525
13526     if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
13527         RExC_parse++;
13528         invert = TRUE;
13529         allow_multi_folds = FALSE;
13530         RExC_naughty++;
13531         if (skip_white) {
13532             RExC_parse = regpatws(pRExC_state, RExC_parse,
13533                                   FALSE /* means don't recognize comments */ );
13534         }
13535     }
13536
13537     /* Check that they didn't say [:posix:] instead of [[:posix:]] */
13538     if (!SIZE_ONLY && RExC_parse < RExC_end && POSIXCC(UCHARAT(RExC_parse))) {
13539         const char *s = RExC_parse;
13540         const char  c = *s++;
13541
13542         while (isWORDCHAR(*s))
13543             s++;
13544         if (*s && c == *s && s[1] == ']') {
13545             SAVEFREESV(RExC_rx_sv);
13546             ckWARN3reg(s+2,
13547                        "POSIX syntax [%c %c] belongs inside character classes",
13548                        c, c);
13549             (void)ReREFCNT_inc(RExC_rx_sv);
13550         }
13551     }
13552
13553     /* If the caller wants us to just parse a single element, accomplish this
13554      * by faking the loop ending condition */
13555     if (stop_at_1 && RExC_end > RExC_parse) {
13556         stop_ptr = RExC_parse + 1;
13557     }
13558
13559     /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */
13560     if (UCHARAT(RExC_parse) == ']')
13561         goto charclassloop;
13562
13563     while (1) {
13564         if  (RExC_parse >= stop_ptr) {
13565             break;
13566         }
13567
13568         if (skip_white) {
13569             RExC_parse = regpatws(pRExC_state, RExC_parse,
13570                                   FALSE /* means don't recognize comments */ );
13571         }
13572
13573         if  (UCHARAT(RExC_parse) == ']') {
13574             break;
13575         }
13576
13577     charclassloop:
13578
13579         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
13580         save_value = value;
13581         save_prevvalue = prevvalue;
13582
13583         if (!range) {
13584             rangebegin = RExC_parse;
13585             element_count++;
13586         }
13587         if (UTF) {
13588             value = utf8n_to_uvchr((U8*)RExC_parse,
13589                                    RExC_end - RExC_parse,
13590                                    &numlen, UTF8_ALLOW_DEFAULT);
13591             RExC_parse += numlen;
13592         }
13593         else
13594             value = UCHARAT(RExC_parse++);
13595
13596         if (value == '['
13597             && RExC_parse < RExC_end
13598             && POSIXCC(UCHARAT(RExC_parse)))
13599         {
13600             namedclass = regpposixcc(pRExC_state, value, strict);
13601         }
13602         else if (value != '\\') {
13603 #ifdef EBCDIC
13604             literal_endpoint++;
13605 #endif
13606         }
13607         else {
13608             /* Is a backslash; get the code point of the char after it */
13609             if (UTF && ! UTF8_IS_INVARIANT(RExC_parse)) {
13610                 value = utf8n_to_uvchr((U8*)RExC_parse,
13611                                    RExC_end - RExC_parse,
13612                                    &numlen, UTF8_ALLOW_DEFAULT);
13613                 RExC_parse += numlen;
13614             }
13615             else
13616                 value = UCHARAT(RExC_parse++);
13617
13618             /* Some compilers cannot handle switching on 64-bit integer
13619              * values, therefore value cannot be an UV.  Yes, this will
13620              * be a problem later if we want switch on Unicode.
13621              * A similar issue a little bit later when switching on
13622              * namedclass. --jhi */
13623
13624             /* If the \ is escaping white space when white space is being
13625              * skipped, it means that that white space is wanted literally, and
13626              * is already in 'value'.  Otherwise, need to translate the escape
13627              * into what it signifies. */
13628             if (! skip_white || ! is_PATWS_cp(value)) switch ((I32)value) {
13629
13630             case 'w':   namedclass = ANYOF_WORDCHAR;    break;
13631             case 'W':   namedclass = ANYOF_NWORDCHAR;   break;
13632             case 's':   namedclass = ANYOF_SPACE;       break;
13633             case 'S':   namedclass = ANYOF_NSPACE;      break;
13634             case 'd':   namedclass = ANYOF_DIGIT;       break;
13635             case 'D':   namedclass = ANYOF_NDIGIT;      break;
13636             case 'v':   namedclass = ANYOF_VERTWS;      break;
13637             case 'V':   namedclass = ANYOF_NVERTWS;     break;
13638             case 'h':   namedclass = ANYOF_HORIZWS;     break;
13639             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
13640             case 'N':  /* Handle \N{NAME} in class */
13641                 {
13642                     SV *as_text;
13643                     STRLEN cp_count = grok_bslash_N(pRExC_state, NULL, &value,
13644                                                     flagp, depth, &as_text);
13645                     if (*flagp & RESTART_UTF8)
13646                         FAIL("panic: grok_bslash_N set RESTART_UTF8");
13647                     if (cp_count != 1) {    /* The typical case drops through */
13648                         assert(cp_count != (STRLEN) -1);
13649                         if (cp_count == 0) {
13650                             if (strict) {
13651                                 RExC_parse++;   /* Position after the "}" */
13652                                 vFAIL("Zero length \\N{}");
13653                             }
13654                             else if (PASS2) {
13655                                 ckWARNreg(RExC_parse,
13656                                         "Ignoring zero length \\N{} in character class");
13657                             }
13658                         }
13659                         else { /* cp_count > 1 */
13660                             if (! RExC_in_multi_char_class) {
13661                                 if (invert || range || *RExC_parse == '-') {
13662                                     if (strict) {
13663                                         RExC_parse--;
13664                                         vFAIL("\\N{} in inverted character class or as a range end-point is restricted to one character");
13665                                     }
13666                                     else if (PASS2) {
13667                                         ckWARNreg(RExC_parse, "Using just the first character returned by \\N{} in character class");
13668                                     }
13669                                 }
13670                                 else {
13671                                     multi_char_matches
13672                                         = add_multi_match(multi_char_matches,
13673                                                           as_text,
13674                                                           cp_count);
13675                                 }
13676                                 break; /* <value> contains the first code
13677                                           point. Drop out of the switch to
13678                                           process it */
13679                             }
13680                         } /* End of cp_count != 1 */
13681
13682                         /* This element should not be processed further in this
13683                          * class */
13684                         element_count--;
13685                         value = save_value;
13686                         prevvalue = save_prevvalue;
13687                         continue;   /* Back to top of loop to get next char */
13688                     }
13689                     /* Here, is a single code point, and <value> contains it */
13690                 }
13691                 break;
13692             case 'p':
13693             case 'P':
13694                 {
13695                 char *e;
13696
13697                 /* We will handle any undefined properties ourselves */
13698                 U8 swash_init_flags = _CORE_SWASH_INIT_RETURN_IF_UNDEF
13699                                        /* And we actually would prefer to get
13700                                         * the straight inversion list of the
13701                                         * swash, since we will be accessing it
13702                                         * anyway, to save a little time */
13703                                       |_CORE_SWASH_INIT_ACCEPT_INVLIST;
13704
13705                 if (RExC_parse >= RExC_end)
13706                     vFAIL2("Empty \\%c{}", (U8)value);
13707                 if (*RExC_parse == '{') {
13708                     const U8 c = (U8)value;
13709                     e = strchr(RExC_parse++, '}');
13710                     if (!e)
13711                         vFAIL2("Missing right brace on \\%c{}", c);
13712                     while (isSPACE(*RExC_parse))
13713                         RExC_parse++;
13714                     if (e == RExC_parse)
13715                         vFAIL2("Empty \\%c{}", c);
13716                     n = e - RExC_parse;
13717                     while (isSPACE(*(RExC_parse + n - 1)))
13718                         n--;
13719                 }
13720                 else {
13721                     e = RExC_parse;
13722                     n = 1;
13723                 }
13724                 if (!SIZE_ONLY) {
13725                     SV* invlist;
13726                     char* name;
13727
13728                     if (UCHARAT(RExC_parse) == '^') {
13729                          RExC_parse++;
13730                          n--;
13731                          /* toggle.  (The rhs xor gets the single bit that
13732                           * differs between P and p; the other xor inverts just
13733                           * that bit) */
13734                          value ^= 'P' ^ 'p';
13735
13736                          while (isSPACE(*RExC_parse)) {
13737                               RExC_parse++;
13738                               n--;
13739                          }
13740                     }
13741                     /* Try to get the definition of the property into
13742                      * <invlist>.  If /i is in effect, the effective property
13743                      * will have its name be <__NAME_i>.  The design is
13744                      * discussed in commit
13745                      * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
13746                     name = savepv(Perl_form(aTHX_
13747                                           "%s%.*s%s\n",
13748                                           (FOLD) ? "__" : "",
13749                                           (int)n,
13750                                           RExC_parse,
13751                                           (FOLD) ? "_i" : ""
13752                                 ));
13753
13754                     /* Look up the property name, and get its swash and
13755                      * inversion list, if the property is found  */
13756                     if (swash) {
13757                         SvREFCNT_dec_NN(swash);
13758                     }
13759                     swash = _core_swash_init("utf8", name, &PL_sv_undef,
13760                                              1, /* binary */
13761                                              0, /* not tr/// */
13762                                              NULL, /* No inversion list */
13763                                              &swash_init_flags
13764                                             );
13765                     if (! swash || ! (invlist = _get_swash_invlist(swash))) {
13766                         HV* curpkg = (IN_PERL_COMPILETIME)
13767                                       ? PL_curstash
13768                                       : CopSTASH(PL_curcop);
13769                         if (swash) {
13770                             SvREFCNT_dec_NN(swash);
13771                             swash = NULL;
13772                         }
13773
13774                         /* Here didn't find it.  It could be a user-defined
13775                          * property that will be available at run-time.  If we
13776                          * accept only compile-time properties, is an error;
13777                          * otherwise add it to the list for run-time look up */
13778                         if (ret_invlist) {
13779                             RExC_parse = e + 1;
13780                             vFAIL2utf8f(
13781                                 "Property '%"UTF8f"' is unknown",
13782                                 UTF8fARG(UTF, n, name));
13783                         }
13784
13785                         /* If the property name doesn't already have a package
13786                          * name, add the current one to it so that it can be
13787                          * referred to outside it. [perl #121777] */
13788                         if (curpkg && ! instr(name, "::")) {
13789                             char* pkgname = HvNAME(curpkg);
13790                             if (strNE(pkgname, "main")) {
13791                                 char* full_name = Perl_form(aTHX_
13792                                                             "%s::%s",
13793                                                             pkgname,
13794                                                             name);
13795                                 n = strlen(full_name);
13796                                 Safefree(name);
13797                                 name = savepvn(full_name, n);
13798                             }
13799                         }
13800                         Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%"UTF8f"\n",
13801                                         (value == 'p' ? '+' : '!'),
13802                                         UTF8fARG(UTF, n, name));
13803                         has_user_defined_property = TRUE;
13804
13805                         /* We don't know yet, so have to assume that the
13806                          * property could match something in the Latin1 range,
13807                          * hence something that isn't utf8.  Note that this
13808                          * would cause things in <depends_list> to match
13809                          * inappropriately, except that any \p{}, including
13810                          * this one forces Unicode semantics, which means there
13811                          * is no <depends_list> */
13812                         ANYOF_FLAGS(ret)
13813                                       |= ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES;
13814                     }
13815                     else {
13816
13817                         /* Here, did get the swash and its inversion list.  If
13818                          * the swash is from a user-defined property, then this
13819                          * whole character class should be regarded as such */
13820                         if (swash_init_flags
13821                             & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY)
13822                         {
13823                             has_user_defined_property = TRUE;
13824                         }
13825                         else if
13826                             /* We warn on matching an above-Unicode code point
13827                              * if the match would return true, except don't
13828                              * warn for \p{All}, which has exactly one element
13829                              * = 0 */
13830                             (_invlist_contains_cp(invlist, 0x110000)
13831                                 && (! (_invlist_len(invlist) == 1
13832                                        && *invlist_array(invlist) == 0)))
13833                         {
13834                             warn_super = TRUE;
13835                         }
13836
13837
13838                         /* Invert if asking for the complement */
13839                         if (value == 'P') {
13840                             _invlist_union_complement_2nd(properties,
13841                                                           invlist,
13842                                                           &properties);
13843
13844                             /* The swash can't be used as-is, because we've
13845                              * inverted things; delay removing it to here after
13846                              * have copied its invlist above */
13847                             SvREFCNT_dec_NN(swash);
13848                             swash = NULL;
13849                         }
13850                         else {
13851                             _invlist_union(properties, invlist, &properties);
13852                         }
13853                     }
13854                     Safefree(name);
13855                 }
13856                 RExC_parse = e + 1;
13857                 namedclass = ANYOF_UNIPROP;  /* no official name, but it's
13858                                                 named */
13859
13860                 /* \p means they want Unicode semantics */
13861                 RExC_uni_semantics = 1;
13862                 }
13863                 break;
13864             case 'n':   value = '\n';                   break;
13865             case 'r':   value = '\r';                   break;
13866             case 't':   value = '\t';                   break;
13867             case 'f':   value = '\f';                   break;
13868             case 'b':   value = '\b';                   break;
13869             case 'e':   value = ESC_NATIVE;             break;
13870             case 'a':   value = '\a';                   break;
13871             case 'o':
13872                 RExC_parse--;   /* function expects to be pointed at the 'o' */
13873                 {
13874                     const char* error_msg;
13875                     bool valid = grok_bslash_o(&RExC_parse,
13876                                                &value,
13877                                                &error_msg,
13878                                                PASS2,   /* warnings only in
13879                                                            pass 2 */
13880                                                strict,
13881                                                silence_non_portable,
13882                                                UTF);
13883                     if (! valid) {
13884                         vFAIL(error_msg);
13885                     }
13886                 }
13887                 if (PL_encoding && value < 0x100) {
13888                     goto recode_encoding;
13889                 }
13890                 break;
13891             case 'x':
13892                 RExC_parse--;   /* function expects to be pointed at the 'x' */
13893                 {
13894                     const char* error_msg;
13895                     bool valid = grok_bslash_x(&RExC_parse,
13896                                                &value,
13897                                                &error_msg,
13898                                                PASS2, /* Output warnings */
13899                                                strict,
13900                                                silence_non_portable,
13901                                                UTF);
13902                     if (! valid) {
13903                         vFAIL(error_msg);
13904                     }
13905                 }
13906                 if (PL_encoding && value < 0x100)
13907                     goto recode_encoding;
13908                 break;
13909             case 'c':
13910                 value = grok_bslash_c(*RExC_parse++, PASS2);
13911                 break;
13912             case '0': case '1': case '2': case '3': case '4':
13913             case '5': case '6': case '7':
13914                 {
13915                     /* Take 1-3 octal digits */
13916                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
13917                     numlen = (strict) ? 4 : 3;
13918                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
13919                     RExC_parse += numlen;
13920                     if (numlen != 3) {
13921                         if (strict) {
13922                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
13923                             vFAIL("Need exactly 3 octal digits");
13924                         }
13925                         else if (! SIZE_ONLY /* like \08, \178 */
13926                                  && numlen < 3
13927                                  && RExC_parse < RExC_end
13928                                  && isDIGIT(*RExC_parse)
13929                                  && ckWARN(WARN_REGEXP))
13930                         {
13931                             SAVEFREESV(RExC_rx_sv);
13932                             reg_warn_non_literal_string(
13933                                  RExC_parse + 1,
13934                                  form_short_octal_warning(RExC_parse, numlen));
13935                             (void)ReREFCNT_inc(RExC_rx_sv);
13936                         }
13937                     }
13938                     if (PL_encoding && value < 0x100)
13939                         goto recode_encoding;
13940                     break;
13941                 }
13942             recode_encoding:
13943                 if (! RExC_override_recoding) {
13944                     SV* enc = PL_encoding;
13945                     value = reg_recode((const char)(U8)value, &enc);
13946                     if (!enc) {
13947                         if (strict) {
13948                             vFAIL("Invalid escape in the specified encoding");
13949                         }
13950                         else if (PASS2) {
13951                             ckWARNreg(RExC_parse,
13952                                   "Invalid escape in the specified encoding");
13953                         }
13954                     }
13955                     break;
13956                 }
13957             default:
13958                 /* Allow \_ to not give an error */
13959                 if (!SIZE_ONLY && isWORDCHAR(value) && value != '_') {
13960                     if (strict) {
13961                         vFAIL2("Unrecognized escape \\%c in character class",
13962                                (int)value);
13963                     }
13964                     else {
13965                         SAVEFREESV(RExC_rx_sv);
13966                         ckWARN2reg(RExC_parse,
13967                             "Unrecognized escape \\%c in character class passed through",
13968                             (int)value);
13969                         (void)ReREFCNT_inc(RExC_rx_sv);
13970                     }
13971                 }
13972                 break;
13973             }   /* End of switch on char following backslash */
13974         } /* end of handling backslash escape sequences */
13975
13976         /* Here, we have the current token in 'value' */
13977
13978         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
13979             U8 classnum;
13980
13981             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
13982              * literal, as is the character that began the false range, i.e.
13983              * the 'a' in the examples */
13984             if (range) {
13985                 if (!SIZE_ONLY) {
13986                     const int w = (RExC_parse >= rangebegin)
13987                                   ? RExC_parse - rangebegin
13988                                   : 0;
13989                     if (strict) {
13990                         vFAIL2utf8f(
13991                             "False [] range \"%"UTF8f"\"",
13992                             UTF8fARG(UTF, w, rangebegin));
13993                     }
13994                     else {
13995                         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
13996                         ckWARN2reg(RExC_parse,
13997                             "False [] range \"%"UTF8f"\"",
13998                             UTF8fARG(UTF, w, rangebegin));
13999                         (void)ReREFCNT_inc(RExC_rx_sv);
14000                         cp_list = add_cp_to_invlist(cp_list, '-');
14001                         cp_foldable_list = add_cp_to_invlist(cp_foldable_list,
14002                                                              prevvalue);
14003                     }
14004                 }
14005
14006                 range = 0; /* this was not a true range */
14007                 element_count += 2; /* So counts for three values */
14008             }
14009
14010             classnum = namedclass_to_classnum(namedclass);
14011
14012             if (LOC && namedclass < ANYOF_POSIXL_MAX
14013 #ifndef HAS_ISASCII
14014                 && classnum != _CC_ASCII
14015 #endif
14016             ) {
14017                 /* What the Posix classes (like \w, [:space:]) match in locale
14018                  * isn't knowable under locale until actual match time.  Room
14019                  * must be reserved (one time per outer bracketed class) to
14020                  * store such classes.  The space will contain a bit for each
14021                  * named class that is to be matched against.  This isn't
14022                  * needed for \p{} and pseudo-classes, as they are not affected
14023                  * by locale, and hence are dealt with separately */
14024                 if (! need_class) {
14025                     need_class = 1;
14026                     if (SIZE_ONLY) {
14027                         RExC_size += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
14028                     }
14029                     else {
14030                         RExC_emit += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
14031                     }
14032                     ANYOF_FLAGS(ret) |= ANYOF_MATCHES_POSIXL;
14033                     ANYOF_POSIXL_ZERO(ret);
14034                 }
14035
14036                 /* Coverity thinks it is possible for this to be negative; both
14037                  * jhi and khw think it's not, but be safer */
14038                 assert(! (ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
14039                        || (namedclass + ((namedclass % 2) ? -1 : 1)) >= 0);
14040
14041                 /* See if it already matches the complement of this POSIX
14042                  * class */
14043                 if ((ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
14044                     && ANYOF_POSIXL_TEST(ret, namedclass + ((namedclass % 2)
14045                                                             ? -1
14046                                                             : 1)))
14047                 {
14048                     posixl_matches_all = TRUE;
14049                     break;  /* No need to continue.  Since it matches both
14050                                e.g., \w and \W, it matches everything, and the
14051                                bracketed class can be optimized into qr/./s */
14052                 }
14053
14054                 /* Add this class to those that should be checked at runtime */
14055                 ANYOF_POSIXL_SET(ret, namedclass);
14056
14057                 /* The above-Latin1 characters are not subject to locale rules.
14058                  * Just add them, in the second pass, to the
14059                  * unconditionally-matched list */
14060                 if (! SIZE_ONLY) {
14061                     SV* scratch_list = NULL;
14062
14063                     /* Get the list of the above-Latin1 code points this
14064                      * matches */
14065                     _invlist_intersection_maybe_complement_2nd(PL_AboveLatin1,
14066                                           PL_XPosix_ptrs[classnum],
14067
14068                                           /* Odd numbers are complements, like
14069                                            * NDIGIT, NASCII, ... */
14070                                           namedclass % 2 != 0,
14071                                           &scratch_list);
14072                     /* Checking if 'cp_list' is NULL first saves an extra
14073                      * clone.  Its reference count will be decremented at the
14074                      * next union, etc, or if this is the only instance, at the
14075                      * end of the routine */
14076                     if (! cp_list) {
14077                         cp_list = scratch_list;
14078                     }
14079                     else {
14080                         _invlist_union(cp_list, scratch_list, &cp_list);
14081                         SvREFCNT_dec_NN(scratch_list);
14082                     }
14083                     continue;   /* Go get next character */
14084                 }
14085             }
14086             else if (! SIZE_ONLY) {
14087
14088                 /* Here, not in pass1 (in that pass we skip calculating the
14089                  * contents of this class), and is /l, or is a POSIX class for
14090                  * which /l doesn't matter (or is a Unicode property, which is
14091                  * skipped here). */
14092                 if (namedclass >= ANYOF_POSIXL_MAX) {  /* If a special class */
14093                     if (namedclass != ANYOF_UNIPROP) { /* UNIPROP = \p and \P */
14094
14095                         /* Here, should be \h, \H, \v, or \V.  None of /d, /i
14096                          * nor /l make a difference in what these match,
14097                          * therefore we just add what they match to cp_list. */
14098                         if (classnum != _CC_VERTSPACE) {
14099                             assert(   namedclass == ANYOF_HORIZWS
14100                                    || namedclass == ANYOF_NHORIZWS);
14101
14102                             /* It turns out that \h is just a synonym for
14103                              * XPosixBlank */
14104                             classnum = _CC_BLANK;
14105                         }
14106
14107                         _invlist_union_maybe_complement_2nd(
14108                                 cp_list,
14109                                 PL_XPosix_ptrs[classnum],
14110                                 namedclass % 2 != 0,    /* Complement if odd
14111                                                           (NHORIZWS, NVERTWS)
14112                                                         */
14113                                 &cp_list);
14114                     }
14115                 }
14116                 else {  /* Garden variety class.  If is NASCII, NDIGIT, ...
14117                            complement and use nposixes */
14118                     SV** posixes_ptr = namedclass % 2 == 0
14119                                        ? &posixes
14120                                        : &nposixes;
14121                     SV** source_ptr = &PL_XPosix_ptrs[classnum];
14122                     _invlist_union_maybe_complement_2nd(
14123                                                      *posixes_ptr,
14124                                                      *source_ptr,
14125                                                      namedclass % 2 != 0,
14126                                                      posixes_ptr);
14127                 }
14128             }
14129         } /* end of namedclass \blah */
14130
14131         if (skip_white) {
14132             RExC_parse = regpatws(pRExC_state, RExC_parse,
14133                                 FALSE /* means don't recognize comments */ );
14134         }
14135
14136         /* If 'range' is set, 'value' is the ending of a range--check its
14137          * validity.  (If value isn't a single code point in the case of a
14138          * range, we should have figured that out above in the code that
14139          * catches false ranges).  Later, we will handle each individual code
14140          * point in the range.  If 'range' isn't set, this could be the
14141          * beginning of a range, so check for that by looking ahead to see if
14142          * the next real character to be processed is the range indicator--the
14143          * minus sign */
14144
14145         if (range) {
14146             if (prevvalue > value) /* b-a */ {
14147                 const int w = RExC_parse - rangebegin;
14148                 vFAIL2utf8f(
14149                     "Invalid [] range \"%"UTF8f"\"",
14150                     UTF8fARG(UTF, w, rangebegin));
14151                 range = 0; /* not a valid range */
14152             }
14153         }
14154         else {
14155             prevvalue = value; /* save the beginning of the potential range */
14156             if (! stop_at_1     /* Can't be a range if parsing just one thing */
14157                 && *RExC_parse == '-')
14158             {
14159                 char* next_char_ptr = RExC_parse + 1;
14160                 if (skip_white) {   /* Get the next real char after the '-' */
14161                     next_char_ptr = regpatws(pRExC_state,
14162                                              RExC_parse + 1,
14163                                              FALSE); /* means don't recognize
14164                                                         comments */
14165                 }
14166
14167                 /* If the '-' is at the end of the class (just before the ']',
14168                  * it is a literal minus; otherwise it is a range */
14169                 if (next_char_ptr < RExC_end && *next_char_ptr != ']') {
14170                     RExC_parse = next_char_ptr;
14171
14172                     /* a bad range like \w-, [:word:]- ? */
14173                     if (namedclass > OOB_NAMEDCLASS) {
14174                         if (strict || (PASS2 && ckWARN(WARN_REGEXP))) {
14175                             const int w = RExC_parse >= rangebegin
14176                                           ?  RExC_parse - rangebegin
14177                                           : 0;
14178                             if (strict) {
14179                                 vFAIL4("False [] range \"%*.*s\"",
14180                                     w, w, rangebegin);
14181                             }
14182                             else if (PASS2) {
14183                                 vWARN4(RExC_parse,
14184                                     "False [] range \"%*.*s\"",
14185                                     w, w, rangebegin);
14186                             }
14187                         }
14188                         if (!SIZE_ONLY) {
14189                             cp_list = add_cp_to_invlist(cp_list, '-');
14190                         }
14191                         element_count++;
14192                     } else
14193                         range = 1;      /* yeah, it's a range! */
14194                     continue;   /* but do it the next time */
14195                 }
14196             }
14197         }
14198
14199         if (namedclass > OOB_NAMEDCLASS) {
14200             continue;
14201         }
14202
14203         /* Here, we have a single value, and <prevvalue> is the beginning of
14204          * the range, if any; or <value> if not */
14205
14206         /* non-Latin1 code point implies unicode semantics.  Must be set in
14207          * pass1 so is there for the whole of pass 2 */
14208         if (value > 255) {
14209             RExC_uni_semantics = 1;
14210         }
14211
14212         /* Ready to process either the single value, or the completed range.
14213          * For single-valued non-inverted ranges, we consider the possibility
14214          * of multi-char folds.  (We made a conscious decision to not do this
14215          * for the other cases because it can often lead to non-intuitive
14216          * results.  For example, you have the peculiar case that:
14217          *  "s s" =~ /^[^\xDF]+$/i => Y
14218          *  "ss"  =~ /^[^\xDF]+$/i => N
14219          *
14220          * See [perl #89750] */
14221         if (FOLD && allow_multi_folds && value == prevvalue) {
14222             if (value == LATIN_SMALL_LETTER_SHARP_S
14223                 || (value > 255 && _invlist_contains_cp(PL_HasMultiCharFold,
14224                                                         value)))
14225             {
14226                 /* Here <value> is indeed a multi-char fold.  Get what it is */
14227
14228                 U8 foldbuf[UTF8_MAXBYTES_CASE];
14229                 STRLEN foldlen;
14230
14231                 UV folded = _to_uni_fold_flags(
14232                                 value,
14233                                 foldbuf,
14234                                 &foldlen,
14235                                 FOLD_FLAGS_FULL | (ASCII_FOLD_RESTRICTED
14236                                                    ? FOLD_FLAGS_NOMIX_ASCII
14237                                                    : 0)
14238                                 );
14239
14240                 /* Here, <folded> should be the first character of the
14241                  * multi-char fold of <value>, with <foldbuf> containing the
14242                  * whole thing.  But, if this fold is not allowed (because of
14243                  * the flags), <fold> will be the same as <value>, and should
14244                  * be processed like any other character, so skip the special
14245                  * handling */
14246                 if (folded != value) {
14247
14248                     /* Skip if we are recursed, currently parsing the class
14249                      * again.  Otherwise add this character to the list of
14250                      * multi-char folds. */
14251                     if (! RExC_in_multi_char_class) {
14252                         STRLEN cp_count = utf8_length(foldbuf,
14253                                                       foldbuf + foldlen);
14254                         SV* multi_fold = sv_2mortal(newSVpvs(""));
14255
14256                         Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%"UVXf"}", value);
14257
14258                         multi_char_matches
14259                                         = add_multi_match(multi_char_matches,
14260                                                           multi_fold,
14261                                                           cp_count);
14262
14263                     }
14264
14265                     /* This element should not be processed further in this
14266                      * class */
14267                     element_count--;
14268                     value = save_value;
14269                     prevvalue = save_prevvalue;
14270                     continue;
14271                 }
14272             }
14273         }
14274
14275         /* Deal with this element of the class */
14276         if (! SIZE_ONLY) {
14277 #ifndef EBCDIC
14278             cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
14279                                                      prevvalue, value);
14280 #else
14281             SV* this_range = _new_invlist(1);
14282             _append_range_to_invlist(this_range, prevvalue, value);
14283
14284             /* In EBCDIC, the ranges 'A-Z' and 'a-z' are each not contiguous.
14285              * If this range was specified using something like 'i-j', we want
14286              * to include only the 'i' and the 'j', and not anything in
14287              * between, so exclude non-ASCII, non-alphabetics from it.
14288              * However, if the range was specified with something like
14289              * [\x89-\x91] or [\x89-j], all code points within it should be
14290              * included.  literal_endpoint==2 means both ends of the range used
14291              * a literal character, not \x{foo} */
14292             if (literal_endpoint == 2
14293                 && ((prevvalue >= 'a' && value <= 'z')
14294                     || (prevvalue >= 'A' && value <= 'Z')))
14295             {
14296                 _invlist_intersection(this_range, PL_XPosix_ptrs[_CC_ASCII],
14297                                       &this_range);
14298
14299                 /* Since this above only contains ascii, the intersection of it
14300                  * with anything will still yield only ascii */
14301                 _invlist_intersection(this_range, PL_XPosix_ptrs[_CC_ALPHA],
14302                                       &this_range);
14303             }
14304             _invlist_union(cp_foldable_list, this_range, &cp_foldable_list);
14305             literal_endpoint = 0;
14306 #endif
14307         }
14308
14309         range = 0; /* this range (if it was one) is done now */
14310     } /* End of loop through all the text within the brackets */
14311
14312     /* If anything in the class expands to more than one character, we have to
14313      * deal with them by building up a substitute parse string, and recursively
14314      * calling reg() on it, instead of proceeding */
14315     if (multi_char_matches) {
14316         SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
14317         I32 cp_count;
14318         STRLEN len;
14319         char *save_end = RExC_end;
14320         char *save_parse = RExC_parse;
14321         bool first_time = TRUE;     /* First multi-char occurrence doesn't get
14322                                        a "|" */
14323         I32 reg_flags;
14324
14325         assert(! invert);
14326 #if 0   /* Have decided not to deal with multi-char folds in inverted classes,
14327            because too confusing */
14328         if (invert) {
14329             sv_catpv(substitute_parse, "(?:");
14330         }
14331 #endif
14332
14333         /* Look at the longest folds first */
14334         for (cp_count = av_tindex(multi_char_matches); cp_count > 0; cp_count--) {
14335
14336             if (av_exists(multi_char_matches, cp_count)) {
14337                 AV** this_array_ptr;
14338                 SV* this_sequence;
14339
14340                 this_array_ptr = (AV**) av_fetch(multi_char_matches,
14341                                                  cp_count, FALSE);
14342                 while ((this_sequence = av_pop(*this_array_ptr)) !=
14343                                                                 &PL_sv_undef)
14344                 {
14345                     if (! first_time) {
14346                         sv_catpv(substitute_parse, "|");
14347                     }
14348                     first_time = FALSE;
14349
14350                     sv_catpv(substitute_parse, SvPVX(this_sequence));
14351                 }
14352             }
14353         }
14354
14355         /* If the character class contains anything else besides these
14356          * multi-character folds, have to include it in recursive parsing */
14357         if (element_count) {
14358             sv_catpv(substitute_parse, "|[");
14359             sv_catpvn(substitute_parse, orig_parse, RExC_parse - orig_parse);
14360             sv_catpv(substitute_parse, "]");
14361         }
14362
14363         sv_catpv(substitute_parse, ")");
14364 #if 0
14365         if (invert) {
14366             /* This is a way to get the parse to skip forward a whole named
14367              * sequence instead of matching the 2nd character when it fails the
14368              * first */
14369             sv_catpv(substitute_parse, "(*THEN)(*SKIP)(*FAIL)|.)");
14370         }
14371 #endif
14372
14373         RExC_parse = SvPV(substitute_parse, len);
14374         RExC_end = RExC_parse + len;
14375         RExC_in_multi_char_class = 1;
14376         RExC_override_recoding = 1;
14377         RExC_emit = (regnode *)orig_emit;
14378
14379         ret = reg(pRExC_state, 1, &reg_flags, depth+1);
14380
14381         *flagp |= reg_flags&(HASWIDTH|SIMPLE|SPSTART|POSTPONED|RESTART_UTF8);
14382
14383         RExC_parse = save_parse;
14384         RExC_end = save_end;
14385         RExC_in_multi_char_class = 0;
14386         RExC_override_recoding = 0;
14387         SvREFCNT_dec_NN(multi_char_matches);
14388         return ret;
14389     }
14390
14391     /* Here, we've gone through the entire class and dealt with multi-char
14392      * folds.  We are now in a position that we can do some checks to see if we
14393      * can optimize this ANYOF node into a simpler one, even in Pass 1.
14394      * Currently we only do two checks:
14395      * 1) is in the unlikely event that the user has specified both, eg. \w and
14396      *    \W under /l, then the class matches everything.  (This optimization
14397      *    is done only to make the optimizer code run later work.)
14398      * 2) if the character class contains only a single element (including a
14399      *    single range), we see if there is an equivalent node for it.
14400      * Other checks are possible */
14401     if (! ret_invlist   /* Can't optimize if returning the constructed
14402                            inversion list */
14403         && (UNLIKELY(posixl_matches_all) || element_count == 1))
14404     {
14405         U8 op = END;
14406         U8 arg = 0;
14407
14408         if (UNLIKELY(posixl_matches_all)) {
14409             op = SANY;
14410         }
14411         else if (namedclass > OOB_NAMEDCLASS) { /* this is a named class, like
14412                                                    \w or [:digit:] or \p{foo}
14413                                                  */
14414
14415             /* All named classes are mapped into POSIXish nodes, with its FLAG
14416              * argument giving which class it is */
14417             switch ((I32)namedclass) {
14418                 case ANYOF_UNIPROP:
14419                     break;
14420
14421                 /* These don't depend on the charset modifiers.  They always
14422                  * match under /u rules */
14423                 case ANYOF_NHORIZWS:
14424                 case ANYOF_HORIZWS:
14425                     namedclass = ANYOF_BLANK + namedclass - ANYOF_HORIZWS;
14426                     /* FALLTHROUGH */
14427
14428                 case ANYOF_NVERTWS:
14429                 case ANYOF_VERTWS:
14430                     op = POSIXU;
14431                     goto join_posix;
14432
14433                 /* The actual POSIXish node for all the rest depends on the
14434                  * charset modifier.  The ones in the first set depend only on
14435                  * ASCII or, if available on this platform, locale */
14436                 case ANYOF_ASCII:
14437                 case ANYOF_NASCII:
14438 #ifdef HAS_ISASCII
14439                     op = (LOC) ? POSIXL : POSIXA;
14440 #else
14441                     op = POSIXA;
14442 #endif
14443                     goto join_posix;
14444
14445                 case ANYOF_NCASED:
14446                 case ANYOF_LOWER:
14447                 case ANYOF_NLOWER:
14448                 case ANYOF_UPPER:
14449                 case ANYOF_NUPPER:
14450                     /* under /a could be alpha */
14451                     if (FOLD) {
14452                         if (ASCII_RESTRICTED) {
14453                             namedclass = ANYOF_ALPHA + (namedclass % 2);
14454                         }
14455                         else if (! LOC) {
14456                             break;
14457                         }
14458                     }
14459                     /* FALLTHROUGH */
14460
14461                 /* The rest have more possibilities depending on the charset.
14462                  * We take advantage of the enum ordering of the charset
14463                  * modifiers to get the exact node type, */
14464                 default:
14465                     op = POSIXD + get_regex_charset(RExC_flags);
14466                     if (op > POSIXA) { /* /aa is same as /a */
14467                         op = POSIXA;
14468                     }
14469
14470                 join_posix:
14471                     /* The odd numbered ones are the complements of the
14472                      * next-lower even number one */
14473                     if (namedclass % 2 == 1) {
14474                         invert = ! invert;
14475                         namedclass--;
14476                     }
14477                     arg = namedclass_to_classnum(namedclass);
14478                     break;
14479             }
14480         }
14481         else if (value == prevvalue) {
14482
14483             /* Here, the class consists of just a single code point */
14484
14485             if (invert) {
14486                 if (! LOC && value == '\n') {
14487                     op = REG_ANY; /* Optimize [^\n] */
14488                     *flagp |= HASWIDTH|SIMPLE;
14489                     RExC_naughty++;
14490                 }
14491             }
14492             else if (value < 256 || UTF) {
14493
14494                 /* Optimize a single value into an EXACTish node, but not if it
14495                  * would require converting the pattern to UTF-8. */
14496                 op = compute_EXACTish(pRExC_state);
14497             }
14498         } /* Otherwise is a range */
14499         else if (! LOC) {   /* locale could vary these */
14500             if (prevvalue == '0') {
14501                 if (value == '9') {
14502                     arg = _CC_DIGIT;
14503                     op = POSIXA;
14504                 }
14505             }
14506             else if (prevvalue == 'A') {
14507                 if (value == 'Z'
14508 #ifdef EBCDIC
14509                     && literal_endpoint == 2
14510 #endif
14511                 ) {
14512                     arg = (FOLD) ? _CC_ALPHA : _CC_UPPER;
14513                     op = POSIXA;
14514                 }
14515             }
14516             else if (prevvalue == 'a') {
14517                 if (value == 'z'
14518 #ifdef EBCDIC
14519                     && literal_endpoint == 2
14520 #endif
14521                 ) {
14522                     arg = (FOLD) ? _CC_ALPHA : _CC_LOWER;
14523                     op = POSIXA;
14524                 }
14525             }
14526         }
14527
14528         /* Here, we have changed <op> away from its initial value iff we found
14529          * an optimization */
14530         if (op != END) {
14531
14532             /* Throw away this ANYOF regnode, and emit the calculated one,
14533              * which should correspond to the beginning, not current, state of
14534              * the parse */
14535             const char * cur_parse = RExC_parse;
14536             RExC_parse = (char *)orig_parse;
14537             if ( SIZE_ONLY) {
14538                 if (! LOC) {
14539
14540                     /* To get locale nodes to not use the full ANYOF size would
14541                      * require moving the code above that writes the portions
14542                      * of it that aren't in other nodes to after this point.
14543                      * e.g.  ANYOF_POSIXL_SET */
14544                     RExC_size = orig_size;
14545                 }
14546             }
14547             else {
14548                 RExC_emit = (regnode *)orig_emit;
14549                 if (PL_regkind[op] == POSIXD) {
14550                     if (op == POSIXL) {
14551                         RExC_contains_locale = 1;
14552                     }
14553                     if (invert) {
14554                         op += NPOSIXD - POSIXD;
14555                     }
14556                 }
14557             }
14558
14559             ret = reg_node(pRExC_state, op);
14560
14561             if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
14562                 if (! SIZE_ONLY) {
14563                     FLAGS(ret) = arg;
14564                 }
14565                 *flagp |= HASWIDTH|SIMPLE;
14566             }
14567             else if (PL_regkind[op] == EXACT) {
14568                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
14569                                            TRUE /* downgradable to EXACT */
14570                                            );
14571             }
14572
14573             RExC_parse = (char *) cur_parse;
14574
14575             SvREFCNT_dec(posixes);
14576             SvREFCNT_dec(nposixes);
14577             SvREFCNT_dec(cp_list);
14578             SvREFCNT_dec(cp_foldable_list);
14579             return ret;
14580         }
14581     }
14582
14583     if (SIZE_ONLY)
14584         return ret;
14585     /****** !SIZE_ONLY (Pass 2) AFTER HERE *********/
14586
14587     /* If folding, we calculate all characters that could fold to or from the
14588      * ones already on the list */
14589     if (cp_foldable_list) {
14590         if (FOLD) {
14591             UV start, end;      /* End points of code point ranges */
14592
14593             SV* fold_intersection = NULL;
14594             SV** use_list;
14595
14596             /* Our calculated list will be for Unicode rules.  For locale
14597              * matching, we have to keep a separate list that is consulted at
14598              * runtime only when the locale indicates Unicode rules.  For
14599              * non-locale, we just use to the general list */
14600             if (LOC) {
14601                 use_list = &only_utf8_locale_list;
14602             }
14603             else {
14604                 use_list = &cp_list;
14605             }
14606
14607             /* Only the characters in this class that participate in folds need
14608              * be checked.  Get the intersection of this class and all the
14609              * possible characters that are foldable.  This can quickly narrow
14610              * down a large class */
14611             _invlist_intersection(PL_utf8_foldable, cp_foldable_list,
14612                                   &fold_intersection);
14613
14614             /* The folds for all the Latin1 characters are hard-coded into this
14615              * program, but we have to go out to disk to get the others. */
14616             if (invlist_highest(cp_foldable_list) >= 256) {
14617
14618                 /* This is a hash that for a particular fold gives all
14619                  * characters that are involved in it */
14620                 if (! PL_utf8_foldclosures) {
14621                     _load_PL_utf8_foldclosures();
14622                 }
14623             }
14624
14625             /* Now look at the foldable characters in this class individually */
14626             invlist_iterinit(fold_intersection);
14627             while (invlist_iternext(fold_intersection, &start, &end)) {
14628                 UV j;
14629
14630                 /* Look at every character in the range */
14631                 for (j = start; j <= end; j++) {
14632                     U8 foldbuf[UTF8_MAXBYTES_CASE+1];
14633                     STRLEN foldlen;
14634                     SV** listp;
14635
14636                     if (j < 256) {
14637
14638                         if (IS_IN_SOME_FOLD_L1(j)) {
14639
14640                             /* ASCII is always matched; non-ASCII is matched
14641                              * only under Unicode rules (which could happen
14642                              * under /l if the locale is a UTF-8 one */
14643                             if (isASCII(j) || ! DEPENDS_SEMANTICS) {
14644                                 *use_list = add_cp_to_invlist(*use_list,
14645                                                             PL_fold_latin1[j]);
14646                             }
14647                             else {
14648                                 depends_list =
14649                                  add_cp_to_invlist(depends_list,
14650                                                    PL_fold_latin1[j]);
14651                             }
14652                         }
14653
14654                         if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(j)
14655                             && (! isASCII(j) || ! ASCII_FOLD_RESTRICTED))
14656                         {
14657                             add_above_Latin1_folds(pRExC_state,
14658                                                    (U8) j,
14659                                                    use_list);
14660                         }
14661                         continue;
14662                     }
14663
14664                     /* Here is an above Latin1 character.  We don't have the
14665                      * rules hard-coded for it.  First, get its fold.  This is
14666                      * the simple fold, as the multi-character folds have been
14667                      * handled earlier and separated out */
14668                     _to_uni_fold_flags(j, foldbuf, &foldlen,
14669                                                         (ASCII_FOLD_RESTRICTED)
14670                                                         ? FOLD_FLAGS_NOMIX_ASCII
14671                                                         : 0);
14672
14673                     /* Single character fold of above Latin1.  Add everything in
14674                     * its fold closure to the list that this node should match.
14675                     * The fold closures data structure is a hash with the keys
14676                     * being the UTF-8 of every character that is folded to, like
14677                     * 'k', and the values each an array of all code points that
14678                     * fold to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ].
14679                     * Multi-character folds are not included */
14680                     if ((listp = hv_fetch(PL_utf8_foldclosures,
14681                                         (char *) foldbuf, foldlen, FALSE)))
14682                     {
14683                         AV* list = (AV*) *listp;
14684                         IV k;
14685                         for (k = 0; k <= av_tindex(list); k++) {
14686                             SV** c_p = av_fetch(list, k, FALSE);
14687                             UV c;
14688                             assert(c_p);
14689
14690                             c = SvUV(*c_p);
14691
14692                             /* /aa doesn't allow folds between ASCII and non- */
14693                             if ((ASCII_FOLD_RESTRICTED
14694                                 && (isASCII(c) != isASCII(j))))
14695                             {
14696                                 continue;
14697                             }
14698
14699                             /* Folds under /l which cross the 255/256 boundary
14700                              * are added to a separate list.  (These are valid
14701                              * only when the locale is UTF-8.) */
14702                             if (c < 256 && LOC) {
14703                                 *use_list = add_cp_to_invlist(*use_list, c);
14704                                 continue;
14705                             }
14706
14707                             if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS)
14708                             {
14709                                 cp_list = add_cp_to_invlist(cp_list, c);
14710                             }
14711                             else {
14712                                 /* Similarly folds involving non-ascii Latin1
14713                                 * characters under /d are added to their list */
14714                                 depends_list = add_cp_to_invlist(depends_list,
14715                                                                  c);
14716                             }
14717                         }
14718                     }
14719                 }
14720             }
14721             SvREFCNT_dec_NN(fold_intersection);
14722         }
14723
14724         /* Now that we have finished adding all the folds, there is no reason
14725          * to keep the foldable list separate */
14726         _invlist_union(cp_list, cp_foldable_list, &cp_list);
14727         SvREFCNT_dec_NN(cp_foldable_list);
14728     }
14729
14730     /* And combine the result (if any) with any inversion list from posix
14731      * classes.  The lists are kept separate up to now because we don't want to
14732      * fold the classes (folding of those is automatically handled by the swash
14733      * fetching code) */
14734     if (posixes || nposixes) {
14735         if (posixes && AT_LEAST_ASCII_RESTRICTED) {
14736             /* Under /a and /aa, nothing above ASCII matches these */
14737             _invlist_intersection(posixes,
14738                                   PL_XPosix_ptrs[_CC_ASCII],
14739                                   &posixes);
14740         }
14741         if (nposixes) {
14742             if (DEPENDS_SEMANTICS) {
14743                 /* Under /d, everything in the upper half of the Latin1 range
14744                  * matches these complements */
14745                 ANYOF_FLAGS(ret) |= ANYOF_MATCHES_ALL_NON_UTF8_NON_ASCII;
14746             }
14747             else if (AT_LEAST_ASCII_RESTRICTED) {
14748                 /* Under /a and /aa, everything above ASCII matches these
14749                  * complements */
14750                 _invlist_union_complement_2nd(nposixes,
14751                                               PL_XPosix_ptrs[_CC_ASCII],
14752                                               &nposixes);
14753             }
14754             if (posixes) {
14755                 _invlist_union(posixes, nposixes, &posixes);
14756                 SvREFCNT_dec_NN(nposixes);
14757             }
14758             else {
14759                 posixes = nposixes;
14760             }
14761         }
14762         if (! DEPENDS_SEMANTICS) {
14763             if (cp_list) {
14764                 _invlist_union(cp_list, posixes, &cp_list);
14765                 SvREFCNT_dec_NN(posixes);
14766             }
14767             else {
14768                 cp_list = posixes;
14769             }
14770         }
14771         else {
14772             /* Under /d, we put into a separate list the Latin1 things that
14773              * match only when the target string is utf8 */
14774             SV* nonascii_but_latin1_properties = NULL;
14775             _invlist_intersection(posixes, PL_UpperLatin1,
14776                                   &nonascii_but_latin1_properties);
14777             _invlist_subtract(posixes, nonascii_but_latin1_properties,
14778                               &posixes);
14779             if (cp_list) {
14780                 _invlist_union(cp_list, posixes, &cp_list);
14781                 SvREFCNT_dec_NN(posixes);
14782             }
14783             else {
14784                 cp_list = posixes;
14785             }
14786
14787             if (depends_list) {
14788                 _invlist_union(depends_list, nonascii_but_latin1_properties,
14789                                &depends_list);
14790                 SvREFCNT_dec_NN(nonascii_but_latin1_properties);
14791             }
14792             else {
14793                 depends_list = nonascii_but_latin1_properties;
14794             }
14795         }
14796     }
14797
14798     /* And combine the result (if any) with any inversion list from properties.
14799      * The lists are kept separate up to now so that we can distinguish the two
14800      * in regards to matching above-Unicode.  A run-time warning is generated
14801      * if a Unicode property is matched against a non-Unicode code point. But,
14802      * we allow user-defined properties to match anything, without any warning,
14803      * and we also suppress the warning if there is a portion of the character
14804      * class that isn't a Unicode property, and which matches above Unicode, \W
14805      * or [\x{110000}] for example.
14806      * (Note that in this case, unlike the Posix one above, there is no
14807      * <depends_list>, because having a Unicode property forces Unicode
14808      * semantics */
14809     if (properties) {
14810         if (cp_list) {
14811
14812             /* If it matters to the final outcome, see if a non-property
14813              * component of the class matches above Unicode.  If so, the
14814              * warning gets suppressed.  This is true even if just a single
14815              * such code point is specified, as though not strictly correct if
14816              * another such code point is matched against, the fact that they
14817              * are using above-Unicode code points indicates they should know
14818              * the issues involved */
14819             if (warn_super) {
14820                 warn_super = ! (invert
14821                                ^ (invlist_highest(cp_list) > PERL_UNICODE_MAX));
14822             }
14823
14824             _invlist_union(properties, cp_list, &cp_list);
14825             SvREFCNT_dec_NN(properties);
14826         }
14827         else {
14828             cp_list = properties;
14829         }
14830
14831         if (warn_super) {
14832             ANYOF_FLAGS(ret) |= ANYOF_WARN_SUPER;
14833         }
14834     }
14835
14836     /* Here, we have calculated what code points should be in the character
14837      * class.
14838      *
14839      * Now we can see about various optimizations.  Fold calculation (which we
14840      * did above) needs to take place before inversion.  Otherwise /[^k]/i
14841      * would invert to include K, which under /i would match k, which it
14842      * shouldn't.  Therefore we can't invert folded locale now, as it won't be
14843      * folded until runtime */
14844
14845     /* If we didn't do folding, it's because some information isn't available
14846      * until runtime; set the run-time fold flag for these.  (We don't have to
14847      * worry about properties folding, as that is taken care of by the swash
14848      * fetching).  We know to set the flag if we have a non-NULL list for UTF-8
14849      * locales, or the class matches at least one 0-255 range code point */
14850     if (LOC && FOLD) {
14851         if (only_utf8_locale_list) {
14852             ANYOF_FLAGS(ret) |= ANYOF_LOC_FOLD;
14853         }
14854         else if (cp_list) { /* Look to see if there a 0-255 code point is in
14855                                the list */
14856             UV start, end;
14857             invlist_iterinit(cp_list);
14858             if (invlist_iternext(cp_list, &start, &end) && start < 256) {
14859                 ANYOF_FLAGS(ret) |= ANYOF_LOC_FOLD;
14860             }
14861             invlist_iterfinish(cp_list);
14862         }
14863     }
14864
14865     /* Optimize inverted simple patterns (e.g. [^a-z]) when everything is known
14866      * at compile time.  Besides not inverting folded locale now, we can't
14867      * invert if there are things such as \w, which aren't known until runtime
14868      * */
14869     if (cp_list
14870         && invert
14871         && ! (ANYOF_FLAGS(ret) & (ANYOF_LOCALE_FLAGS))
14872         && ! depends_list
14873         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
14874     {
14875         _invlist_invert(cp_list);
14876
14877         /* Any swash can't be used as-is, because we've inverted things */
14878         if (swash) {
14879             SvREFCNT_dec_NN(swash);
14880             swash = NULL;
14881         }
14882
14883         /* Clear the invert flag since have just done it here */
14884         invert = FALSE;
14885     }
14886
14887     if (ret_invlist) {
14888         *ret_invlist = cp_list;
14889         SvREFCNT_dec(swash);
14890
14891         /* Discard the generated node */
14892         if (SIZE_ONLY) {
14893             RExC_size = orig_size;
14894         }
14895         else {
14896             RExC_emit = orig_emit;
14897         }
14898         return orig_emit;
14899     }
14900
14901     /* Some character classes are equivalent to other nodes.  Such nodes take
14902      * up less room and generally fewer operations to execute than ANYOF nodes.
14903      * Above, we checked for and optimized into some such equivalents for
14904      * certain common classes that are easy to test.  Getting to this point in
14905      * the code means that the class didn't get optimized there.  Since this
14906      * code is only executed in Pass 2, it is too late to save space--it has
14907      * been allocated in Pass 1, and currently isn't given back.  But turning
14908      * things into an EXACTish node can allow the optimizer to join it to any
14909      * adjacent such nodes.  And if the class is equivalent to things like /./,
14910      * expensive run-time swashes can be avoided.  Now that we have more
14911      * complete information, we can find things necessarily missed by the
14912      * earlier code.  I (khw) am not sure how much to look for here.  It would
14913      * be easy, but perhaps too slow, to check any candidates against all the
14914      * node types they could possibly match using _invlistEQ(). */
14915
14916     if (cp_list
14917         && ! invert
14918         && ! depends_list
14919         && ! (ANYOF_FLAGS(ret) & (ANYOF_LOCALE_FLAGS))
14920         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
14921
14922            /* We don't optimize if we are supposed to make sure all non-Unicode
14923             * code points raise a warning, as only ANYOF nodes have this check.
14924             * */
14925         && ! ((ANYOF_FLAGS(ret) & ANYOF_WARN_SUPER) && ALWAYS_WARN_SUPER))
14926     {
14927         UV start, end;
14928         U8 op = END;  /* The optimzation node-type */
14929         const char * cur_parse= RExC_parse;
14930
14931         invlist_iterinit(cp_list);
14932         if (! invlist_iternext(cp_list, &start, &end)) {
14933
14934             /* Here, the list is empty.  This happens, for example, when a
14935              * Unicode property is the only thing in the character class, and
14936              * it doesn't match anything.  (perluniprops.pod notes such
14937              * properties) */
14938             op = OPFAIL;
14939             *flagp |= HASWIDTH|SIMPLE;
14940         }
14941         else if (start == end) {    /* The range is a single code point */
14942             if (! invlist_iternext(cp_list, &start, &end)
14943
14944                     /* Don't do this optimization if it would require changing
14945                      * the pattern to UTF-8 */
14946                 && (start < 256 || UTF))
14947             {
14948                 /* Here, the list contains a single code point.  Can optimize
14949                  * into an EXACTish node */
14950
14951                 value = start;
14952
14953                 if (! FOLD) {
14954                     op = EXACT;
14955                 }
14956                 else if (LOC) {
14957
14958                     /* A locale node under folding with one code point can be
14959                      * an EXACTFL, as its fold won't be calculated until
14960                      * runtime */
14961                     op = EXACTFL;
14962                 }
14963                 else {
14964
14965                     /* Here, we are generally folding, but there is only one
14966                      * code point to match.  If we have to, we use an EXACT
14967                      * node, but it would be better for joining with adjacent
14968                      * nodes in the optimization pass if we used the same
14969                      * EXACTFish node that any such are likely to be.  We can
14970                      * do this iff the code point doesn't participate in any
14971                      * folds.  For example, an EXACTF of a colon is the same as
14972                      * an EXACT one, since nothing folds to or from a colon. */
14973                     if (value < 256) {
14974                         if (IS_IN_SOME_FOLD_L1(value)) {
14975                             op = EXACT;
14976                         }
14977                     }
14978                     else {
14979                         if (_invlist_contains_cp(PL_utf8_foldable, value)) {
14980                             op = EXACT;
14981                         }
14982                     }
14983
14984                     /* If we haven't found the node type, above, it means we
14985                      * can use the prevailing one */
14986                     if (op == END) {
14987                         op = compute_EXACTish(pRExC_state);
14988                     }
14989                 }
14990             }
14991         }
14992         else if (start == 0) {
14993             if (end == UV_MAX) {
14994                 op = SANY;
14995                 *flagp |= HASWIDTH|SIMPLE;
14996                 RExC_naughty++;
14997             }
14998             else if (end == '\n' - 1
14999                     && invlist_iternext(cp_list, &start, &end)
15000                     && start == '\n' + 1 && end == UV_MAX)
15001             {
15002                 op = REG_ANY;
15003                 *flagp |= HASWIDTH|SIMPLE;
15004                 RExC_naughty++;
15005             }
15006         }
15007         invlist_iterfinish(cp_list);
15008
15009         if (op != END) {
15010             RExC_parse = (char *)orig_parse;
15011             RExC_emit = (regnode *)orig_emit;
15012
15013             ret = reg_node(pRExC_state, op);
15014
15015             RExC_parse = (char *)cur_parse;
15016
15017             if (PL_regkind[op] == EXACT) {
15018                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
15019                                            TRUE /* downgradable to EXACT */
15020                                           );
15021             }
15022
15023             SvREFCNT_dec_NN(cp_list);
15024             return ret;
15025         }
15026     }
15027
15028     /* Here, <cp_list> contains all the code points we can determine at
15029      * compile time that match under all conditions.  Go through it, and
15030      * for things that belong in the bitmap, put them there, and delete from
15031      * <cp_list>.  While we are at it, see if everything above 255 is in the
15032      * list, and if so, set a flag to speed up execution */
15033
15034     populate_ANYOF_from_invlist(ret, &cp_list);
15035
15036     if (invert) {
15037         ANYOF_FLAGS(ret) |= ANYOF_INVERT;
15038     }
15039
15040     /* Here, the bitmap has been populated with all the Latin1 code points that
15041      * always match.  Can now add to the overall list those that match only
15042      * when the target string is UTF-8 (<depends_list>). */
15043     if (depends_list) {
15044         if (cp_list) {
15045             _invlist_union(cp_list, depends_list, &cp_list);
15046             SvREFCNT_dec_NN(depends_list);
15047         }
15048         else {
15049             cp_list = depends_list;
15050         }
15051         ANYOF_FLAGS(ret) |= ANYOF_HAS_UTF8_NONBITMAP_MATCHES;
15052     }
15053
15054     /* If there is a swash and more than one element, we can't use the swash in
15055      * the optimization below. */
15056     if (swash && element_count > 1) {
15057         SvREFCNT_dec_NN(swash);
15058         swash = NULL;
15059     }
15060
15061     /* Note that the optimization of using 'swash' if it is the only thing in
15062      * the class doesn't have us change swash at all, so it can include things
15063      * that are also in the bitmap; otherwise we have purposely deleted that
15064      * duplicate information */
15065     set_ANYOF_arg(pRExC_state, ret, cp_list,
15066                   (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
15067                    ? listsv : NULL,
15068                   only_utf8_locale_list,
15069                   swash, has_user_defined_property);
15070
15071     *flagp |= HASWIDTH|SIMPLE;
15072
15073     if (ANYOF_FLAGS(ret) & ANYOF_LOCALE_FLAGS) {
15074         RExC_contains_locale = 1;
15075     }
15076
15077     return ret;
15078 }
15079
15080 #undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
15081
15082 STATIC void
15083 S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state,
15084                 regnode* const node,
15085                 SV* const cp_list,
15086                 SV* const runtime_defns,
15087                 SV* const only_utf8_locale_list,
15088                 SV* const swash,
15089                 const bool has_user_defined_property)
15090 {
15091     /* Sets the arg field of an ANYOF-type node 'node', using information about
15092      * the node passed-in.  If there is nothing outside the node's bitmap, the
15093      * arg is set to ANYOF_ONLY_HAS_BITMAP.  Otherwise, it sets the argument to
15094      * the count returned by add_data(), having allocated and stored an array,
15095      * av, that that count references, as follows:
15096      *  av[0] stores the character class description in its textual form.
15097      *        This is used later (regexec.c:Perl_regclass_swash()) to
15098      *        initialize the appropriate swash, and is also useful for dumping
15099      *        the regnode.  This is set to &PL_sv_undef if the textual
15100      *        description is not needed at run-time (as happens if the other
15101      *        elements completely define the class)
15102      *  av[1] if &PL_sv_undef, is a placeholder to later contain the swash
15103      *        computed from av[0].  But if no further computation need be done,
15104      *        the swash is stored here now (and av[0] is &PL_sv_undef).
15105      *  av[2] stores the inversion list of code points that match only if the
15106      *        current locale is UTF-8
15107      *  av[3] stores the cp_list inversion list for use in addition or instead
15108      *        of av[0]; used only if cp_list exists and av[1] is &PL_sv_undef.
15109      *        (Otherwise everything needed is already in av[0] and av[1])
15110      *  av[4] is set if any component of the class is from a user-defined
15111      *        property; used only if av[3] exists */
15112
15113     UV n;
15114
15115     PERL_ARGS_ASSERT_SET_ANYOF_ARG;
15116
15117     if (! cp_list && ! runtime_defns && ! only_utf8_locale_list) {
15118         assert(! (ANYOF_FLAGS(node)
15119                   & (ANYOF_HAS_UTF8_NONBITMAP_MATCHES
15120                      |ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES)));
15121         ARG_SET(node, ANYOF_ONLY_HAS_BITMAP);
15122     }
15123     else {
15124         AV * const av = newAV();
15125         SV *rv;
15126
15127         assert(ANYOF_FLAGS(node)
15128                & (ANYOF_HAS_UTF8_NONBITMAP_MATCHES
15129                   |ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES|ANYOF_LOC_FOLD));
15130
15131         av_store(av, 0, (runtime_defns)
15132                         ? SvREFCNT_inc(runtime_defns) : &PL_sv_undef);
15133         if (swash) {
15134             assert(cp_list);
15135             av_store(av, 1, swash);
15136             SvREFCNT_dec_NN(cp_list);
15137         }
15138         else {
15139             av_store(av, 1, &PL_sv_undef);
15140             if (cp_list) {
15141                 av_store(av, 3, cp_list);
15142                 av_store(av, 4, newSVuv(has_user_defined_property));
15143             }
15144         }
15145
15146         if (only_utf8_locale_list) {
15147             av_store(av, 2, only_utf8_locale_list);
15148         }
15149         else {
15150             av_store(av, 2, &PL_sv_undef);
15151         }
15152
15153         rv = newRV_noinc(MUTABLE_SV(av));
15154         n = add_data(pRExC_state, STR_WITH_LEN("s"));
15155         RExC_rxi->data->data[n] = (void*)rv;
15156         ARG_SET(node, n);
15157     }
15158 }
15159
15160 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
15161 SV *
15162 Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog,
15163                                         const regnode* node,
15164                                         bool doinit,
15165                                         SV** listsvp,
15166                                         SV** only_utf8_locale_ptr,
15167                                         SV*  exclude_list)
15168
15169 {
15170     /* For internal core use only.
15171      * Returns the swash for the input 'node' in the regex 'prog'.
15172      * If <doinit> is 'true', will attempt to create the swash if not already
15173      *    done.
15174      * If <listsvp> is non-null, will return the printable contents of the
15175      *    swash.  This can be used to get debugging information even before the
15176      *    swash exists, by calling this function with 'doinit' set to false, in
15177      *    which case the components that will be used to eventually create the
15178      *    swash are returned  (in a printable form).
15179      * If <exclude_list> is not NULL, it is an inversion list of things to
15180      *    exclude from what's returned in <listsvp>.
15181      * Tied intimately to how S_set_ANYOF_arg sets up the data structure.  Note
15182      * that, in spite of this function's name, the swash it returns may include
15183      * the bitmap data as well */
15184
15185     SV *sw  = NULL;
15186     SV *si  = NULL;         /* Input swash initialization string */
15187     SV*  invlist = NULL;
15188
15189     RXi_GET_DECL(prog,progi);
15190     const struct reg_data * const data = prog ? progi->data : NULL;
15191
15192     PERL_ARGS_ASSERT__GET_REGCLASS_NONBITMAP_DATA;
15193
15194     assert(ANYOF_FLAGS(node)
15195         & (ANYOF_HAS_UTF8_NONBITMAP_MATCHES
15196            |ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES|ANYOF_LOC_FOLD));
15197
15198     if (data && data->count) {
15199         const U32 n = ARG(node);
15200
15201         if (data->what[n] == 's') {
15202             SV * const rv = MUTABLE_SV(data->data[n]);
15203             AV * const av = MUTABLE_AV(SvRV(rv));
15204             SV **const ary = AvARRAY(av);
15205             U8 swash_init_flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
15206
15207             si = *ary;  /* ary[0] = the string to initialize the swash with */
15208
15209             /* Elements 3 and 4 are either both present or both absent. [3] is
15210              * any inversion list generated at compile time; [4] indicates if
15211              * that inversion list has any user-defined properties in it. */
15212             if (av_tindex(av) >= 2) {
15213                 if (only_utf8_locale_ptr
15214                     && ary[2]
15215                     && ary[2] != &PL_sv_undef)
15216                 {
15217                     *only_utf8_locale_ptr = ary[2];
15218                 }
15219                 else {
15220                     assert(only_utf8_locale_ptr);
15221                     *only_utf8_locale_ptr = NULL;
15222                 }
15223
15224                 if (av_tindex(av) >= 3) {
15225                     invlist = ary[3];
15226                     if (SvUV(ary[4])) {
15227                         swash_init_flags |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY;
15228                     }
15229                 }
15230                 else {
15231                     invlist = NULL;
15232                 }
15233             }
15234
15235             /* Element [1] is reserved for the set-up swash.  If already there,
15236              * return it; if not, create it and store it there */
15237             if (ary[1] && SvROK(ary[1])) {
15238                 sw = ary[1];
15239             }
15240             else if (doinit && ((si && si != &PL_sv_undef)
15241                                  || (invlist && invlist != &PL_sv_undef))) {
15242                 assert(si);
15243                 sw = _core_swash_init("utf8", /* the utf8 package */
15244                                       "", /* nameless */
15245                                       si,
15246                                       1, /* binary */
15247                                       0, /* not from tr/// */
15248                                       invlist,
15249                                       &swash_init_flags);
15250                 (void)av_store(av, 1, sw);
15251             }
15252         }
15253     }
15254
15255     /* If requested, return a printable version of what this swash matches */
15256     if (listsvp) {
15257         SV* matches_string = newSVpvs("");
15258
15259         /* The swash should be used, if possible, to get the data, as it
15260          * contains the resolved data.  But this function can be called at
15261          * compile-time, before everything gets resolved, in which case we
15262          * return the currently best available information, which is the string
15263          * that will eventually be used to do that resolving, 'si' */
15264         if ((! sw || (invlist = _get_swash_invlist(sw)) == NULL)
15265             && (si && si != &PL_sv_undef))
15266         {
15267             sv_catsv(matches_string, si);
15268         }
15269
15270         /* Add the inversion list to whatever we have.  This may have come from
15271          * the swash, or from an input parameter */
15272         if (invlist) {
15273             if (exclude_list) {
15274                 SV* clone = invlist_clone(invlist);
15275                 _invlist_subtract(clone, exclude_list, &clone);
15276                 sv_catsv(matches_string, _invlist_contents(clone));
15277                 SvREFCNT_dec_NN(clone);
15278             }
15279             else {
15280                 sv_catsv(matches_string, _invlist_contents(invlist));
15281             }
15282         }
15283         *listsvp = matches_string;
15284     }
15285
15286     return sw;
15287 }
15288 #endif /* !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) */
15289
15290 /* reg_skipcomment()
15291
15292    Absorbs an /x style # comment from the input stream,
15293    returning a pointer to the first character beyond the comment, or if the
15294    comment terminates the pattern without anything following it, this returns
15295    one past the final character of the pattern (in other words, RExC_end) and
15296    sets the REG_RUN_ON_COMMENT_SEEN flag.
15297
15298    Note it's the callers responsibility to ensure that we are
15299    actually in /x mode
15300
15301 */
15302
15303 PERL_STATIC_INLINE char*
15304 S_reg_skipcomment(RExC_state_t *pRExC_state, char* p)
15305 {
15306     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
15307
15308     assert(*p == '#');
15309
15310     while (p < RExC_end) {
15311         if (*(++p) == '\n') {
15312             return p+1;
15313         }
15314     }
15315
15316     /* we ran off the end of the pattern without ending the comment, so we have
15317      * to add an \n when wrapping */
15318     RExC_seen |= REG_RUN_ON_COMMENT_SEEN;
15319     return p;
15320 }
15321
15322 /* nextchar()
15323
15324    Advances the parse position, and optionally absorbs
15325    "whitespace" from the inputstream.
15326
15327    Without /x "whitespace" means (?#...) style comments only,
15328    with /x this means (?#...) and # comments and whitespace proper.
15329
15330    Returns the RExC_parse point from BEFORE the scan occurs.
15331
15332    This is the /x friendly way of saying RExC_parse++.
15333 */
15334
15335 STATIC char*
15336 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
15337 {
15338     char* const retval = RExC_parse++;
15339
15340     PERL_ARGS_ASSERT_NEXTCHAR;
15341
15342     for (;;) {
15343         if (RExC_end - RExC_parse >= 3
15344             && *RExC_parse == '('
15345             && RExC_parse[1] == '?'
15346             && RExC_parse[2] == '#')
15347         {
15348             while (*RExC_parse != ')') {
15349                 if (RExC_parse == RExC_end)
15350                     FAIL("Sequence (?#... not terminated");
15351                 RExC_parse++;
15352             }
15353             RExC_parse++;
15354             continue;
15355         }
15356         if (RExC_flags & RXf_PMf_EXTENDED) {
15357             char * p = regpatws(pRExC_state, RExC_parse,
15358                                           TRUE); /* means recognize comments */
15359             if (p != RExC_parse) {
15360                 RExC_parse = p;
15361                 continue;
15362             }
15363         }
15364         return retval;
15365     }
15366 }
15367
15368 /*
15369 - reg_node - emit a node
15370 */
15371 STATIC regnode *                        /* Location. */
15372 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
15373 {
15374     regnode *ptr;
15375     regnode * const ret = RExC_emit;
15376     GET_RE_DEBUG_FLAGS_DECL;
15377
15378     PERL_ARGS_ASSERT_REG_NODE;
15379
15380     if (SIZE_ONLY) {
15381         SIZE_ALIGN(RExC_size);
15382         RExC_size += 1;
15383         return(ret);
15384     }
15385     if (RExC_emit >= RExC_emit_bound)
15386         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
15387                    op, (void*)RExC_emit, (void*)RExC_emit_bound);
15388
15389     NODE_ALIGN_FILL(ret);
15390     ptr = ret;
15391     FILL_ADVANCE_NODE(ptr, op);
15392 #ifdef RE_TRACK_PATTERN_OFFSETS
15393     if (RExC_offsets) {         /* MJD */
15394         MJD_OFFSET_DEBUG(
15395               ("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n",
15396               "reg_node", __LINE__,
15397               PL_reg_name[op],
15398               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0]
15399                 ? "Overwriting end of array!\n" : "OK",
15400               (UV)(RExC_emit - RExC_emit_start),
15401               (UV)(RExC_parse - RExC_start),
15402               (UV)RExC_offsets[0]));
15403         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
15404     }
15405 #endif
15406     RExC_emit = ptr;
15407     return(ret);
15408 }
15409
15410 /*
15411 - reganode - emit a node with an argument
15412 */
15413 STATIC regnode *                        /* Location. */
15414 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
15415 {
15416     regnode *ptr;
15417     regnode * const ret = RExC_emit;
15418     GET_RE_DEBUG_FLAGS_DECL;
15419
15420     PERL_ARGS_ASSERT_REGANODE;
15421
15422     if (SIZE_ONLY) {
15423         SIZE_ALIGN(RExC_size);
15424         RExC_size += 2;
15425         /*
15426            We can't do this:
15427
15428            assert(2==regarglen[op]+1);
15429
15430            Anything larger than this has to allocate the extra amount.
15431            If we changed this to be:
15432
15433            RExC_size += (1 + regarglen[op]);
15434
15435            then it wouldn't matter. Its not clear what side effect
15436            might come from that so its not done so far.
15437            -- dmq
15438         */
15439         return(ret);
15440     }
15441     if (RExC_emit >= RExC_emit_bound)
15442         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
15443                    op, (void*)RExC_emit, (void*)RExC_emit_bound);
15444
15445     NODE_ALIGN_FILL(ret);
15446     ptr = ret;
15447     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
15448 #ifdef RE_TRACK_PATTERN_OFFSETS
15449     if (RExC_offsets) {         /* MJD */
15450         MJD_OFFSET_DEBUG(
15451               ("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
15452               "reganode",
15453               __LINE__,
15454               PL_reg_name[op],
15455               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ?
15456               "Overwriting end of array!\n" : "OK",
15457               (UV)(RExC_emit - RExC_emit_start),
15458               (UV)(RExC_parse - RExC_start),
15459               (UV)RExC_offsets[0]));
15460         Set_Cur_Node_Offset;
15461     }
15462 #endif
15463     RExC_emit = ptr;
15464     return(ret);
15465 }
15466
15467 /*
15468 - reguni - emit (if appropriate) a Unicode character
15469 */
15470 PERL_STATIC_INLINE STRLEN
15471 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
15472 {
15473     PERL_ARGS_ASSERT_REGUNI;
15474
15475     return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
15476 }
15477
15478 /*
15479 - reginsert - insert an operator in front of already-emitted operand
15480 *
15481 * Means relocating the operand.
15482 */
15483 STATIC void
15484 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
15485 {
15486     regnode *src;
15487     regnode *dst;
15488     regnode *place;
15489     const int offset = regarglen[(U8)op];
15490     const int size = NODE_STEP_REGNODE + offset;
15491     GET_RE_DEBUG_FLAGS_DECL;
15492
15493     PERL_ARGS_ASSERT_REGINSERT;
15494     PERL_UNUSED_CONTEXT;
15495     PERL_UNUSED_ARG(depth);
15496 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
15497     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
15498     if (SIZE_ONLY) {
15499         RExC_size += size;
15500         return;
15501     }
15502
15503     src = RExC_emit;
15504     RExC_emit += size;
15505     dst = RExC_emit;
15506     if (RExC_open_parens) {
15507         int paren;
15508         /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
15509         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
15510             if ( RExC_open_parens[paren] >= opnd ) {
15511                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
15512                 RExC_open_parens[paren] += size;
15513             } else {
15514                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
15515             }
15516             if ( RExC_close_parens[paren] >= opnd ) {
15517                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
15518                 RExC_close_parens[paren] += size;
15519             } else {
15520                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
15521             }
15522         }
15523     }
15524
15525     while (src > opnd) {
15526         StructCopy(--src, --dst, regnode);
15527 #ifdef RE_TRACK_PATTERN_OFFSETS
15528         if (RExC_offsets) {     /* MJD 20010112 */
15529             MJD_OFFSET_DEBUG(
15530                  ("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
15531                   "reg_insert",
15532                   __LINE__,
15533                   PL_reg_name[op],
15534                   (UV)(dst - RExC_emit_start) > RExC_offsets[0]
15535                     ? "Overwriting end of array!\n" : "OK",
15536                   (UV)(src - RExC_emit_start),
15537                   (UV)(dst - RExC_emit_start),
15538                   (UV)RExC_offsets[0]));
15539             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
15540             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
15541         }
15542 #endif
15543     }
15544
15545
15546     place = opnd;               /* Op node, where operand used to be. */
15547 #ifdef RE_TRACK_PATTERN_OFFSETS
15548     if (RExC_offsets) {         /* MJD */
15549         MJD_OFFSET_DEBUG(
15550               ("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
15551               "reginsert",
15552               __LINE__,
15553               PL_reg_name[op],
15554               (UV)(place - RExC_emit_start) > RExC_offsets[0]
15555               ? "Overwriting end of array!\n" : "OK",
15556               (UV)(place - RExC_emit_start),
15557               (UV)(RExC_parse - RExC_start),
15558               (UV)RExC_offsets[0]));
15559         Set_Node_Offset(place, RExC_parse);
15560         Set_Node_Length(place, 1);
15561     }
15562 #endif
15563     src = NEXTOPER(place);
15564     FILL_ADVANCE_NODE(place, op);
15565     Zero(src, offset, regnode);
15566 }
15567
15568 /*
15569 - regtail - set the next-pointer at the end of a node chain of p to val.
15570 - SEE ALSO: regtail_study
15571 */
15572 /* TODO: All three parms should be const */
15573 STATIC void
15574 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p,
15575                 const regnode *val,U32 depth)
15576 {
15577     regnode *scan;
15578     GET_RE_DEBUG_FLAGS_DECL;
15579
15580     PERL_ARGS_ASSERT_REGTAIL;
15581 #ifndef DEBUGGING
15582     PERL_UNUSED_ARG(depth);
15583 #endif
15584
15585     if (SIZE_ONLY)
15586         return;
15587
15588     /* Find last node. */
15589     scan = p;
15590     for (;;) {
15591         regnode * const temp = regnext(scan);
15592         DEBUG_PARSE_r({
15593             SV * const mysv=sv_newmortal();
15594             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
15595             regprop(RExC_rx, mysv, scan, NULL);
15596             PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
15597                 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
15598                     (temp == NULL ? "->" : ""),
15599                     (temp == NULL ? PL_reg_name[OP(val)] : "")
15600             );
15601         });
15602         if (temp == NULL)
15603             break;
15604         scan = temp;
15605     }
15606
15607     if (reg_off_by_arg[OP(scan)]) {
15608         ARG_SET(scan, val - scan);
15609     }
15610     else {
15611         NEXT_OFF(scan) = val - scan;
15612     }
15613 }
15614
15615 #ifdef DEBUGGING
15616 /*
15617 - regtail_study - set the next-pointer at the end of a node chain of p to val.
15618 - Look for optimizable sequences at the same time.
15619 - currently only looks for EXACT chains.
15620
15621 This is experimental code. The idea is to use this routine to perform
15622 in place optimizations on branches and groups as they are constructed,
15623 with the long term intention of removing optimization from study_chunk so
15624 that it is purely analytical.
15625
15626 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
15627 to control which is which.
15628
15629 */
15630 /* TODO: All four parms should be const */
15631
15632 STATIC U8
15633 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p,
15634                       const regnode *val,U32 depth)
15635 {
15636     regnode *scan;
15637     U8 exact = PSEUDO;
15638 #ifdef EXPERIMENTAL_INPLACESCAN
15639     I32 min = 0;
15640 #endif
15641     GET_RE_DEBUG_FLAGS_DECL;
15642
15643     PERL_ARGS_ASSERT_REGTAIL_STUDY;
15644
15645
15646     if (SIZE_ONLY)
15647         return exact;
15648
15649     /* Find last node. */
15650
15651     scan = p;
15652     for (;;) {
15653         regnode * const temp = regnext(scan);
15654 #ifdef EXPERIMENTAL_INPLACESCAN
15655         if (PL_regkind[OP(scan)] == EXACT) {
15656             bool unfolded_multi_char;   /* Unexamined in this routine */
15657             if (join_exact(pRExC_state, scan, &min,
15658                            &unfolded_multi_char, 1, val, depth+1))
15659                 return EXACT;
15660         }
15661 #endif
15662         if ( exact ) {
15663             switch (OP(scan)) {
15664                 case EXACT:
15665                 case EXACTF:
15666                 case EXACTFA_NO_TRIE:
15667                 case EXACTFA:
15668                 case EXACTFU:
15669                 case EXACTFU_SS:
15670                 case EXACTFL:
15671                         if( exact == PSEUDO )
15672                             exact= OP(scan);
15673                         else if ( exact != OP(scan) )
15674                             exact= 0;
15675                 case NOTHING:
15676                     break;
15677                 default:
15678                     exact= 0;
15679             }
15680         }
15681         DEBUG_PARSE_r({
15682             SV * const mysv=sv_newmortal();
15683             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
15684             regprop(RExC_rx, mysv, scan, NULL);
15685             PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
15686                 SvPV_nolen_const(mysv),
15687                 REG_NODE_NUM(scan),
15688                 PL_reg_name[exact]);
15689         });
15690         if (temp == NULL)
15691             break;
15692         scan = temp;
15693     }
15694     DEBUG_PARSE_r({
15695         SV * const mysv_val=sv_newmortal();
15696         DEBUG_PARSE_MSG("");
15697         regprop(RExC_rx, mysv_val, val, NULL);
15698         PerlIO_printf(Perl_debug_log,
15699                       "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
15700                       SvPV_nolen_const(mysv_val),
15701                       (IV)REG_NODE_NUM(val),
15702                       (IV)(val - scan)
15703         );
15704     });
15705     if (reg_off_by_arg[OP(scan)]) {
15706         ARG_SET(scan, val - scan);
15707     }
15708     else {
15709         NEXT_OFF(scan) = val - scan;
15710     }
15711
15712     return exact;
15713 }
15714 #endif
15715
15716 /*
15717  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
15718  */
15719 #ifdef DEBUGGING
15720
15721 static void
15722 S_regdump_intflags(pTHX_ const char *lead, const U32 flags)
15723 {
15724     int bit;
15725     int set=0;
15726
15727     ASSUME(REG_INTFLAGS_NAME_SIZE <= sizeof(flags)*8);
15728
15729     for (bit=0; bit<REG_INTFLAGS_NAME_SIZE; bit++) {
15730         if (flags & (1<<bit)) {
15731             if (!set++ && lead)
15732                 PerlIO_printf(Perl_debug_log, "%s",lead);
15733             PerlIO_printf(Perl_debug_log, "%s ",PL_reg_intflags_name[bit]);
15734         }
15735     }
15736     if (lead)  {
15737         if (set)
15738             PerlIO_printf(Perl_debug_log, "\n");
15739         else
15740             PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
15741     }
15742 }
15743
15744 static void
15745 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
15746 {
15747     int bit;
15748     int set=0;
15749     regex_charset cs;
15750
15751     ASSUME(REG_EXTFLAGS_NAME_SIZE <= sizeof(flags)*8);
15752
15753     for (bit=0; bit<REG_EXTFLAGS_NAME_SIZE; bit++) {
15754         if (flags & (1<<bit)) {
15755             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
15756                 continue;
15757             }
15758             if (!set++ && lead)
15759                 PerlIO_printf(Perl_debug_log, "%s",lead);
15760             PerlIO_printf(Perl_debug_log, "%s ",PL_reg_extflags_name[bit]);
15761         }
15762     }
15763     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
15764             if (!set++ && lead) {
15765                 PerlIO_printf(Perl_debug_log, "%s",lead);
15766             }
15767             switch (cs) {
15768                 case REGEX_UNICODE_CHARSET:
15769                     PerlIO_printf(Perl_debug_log, "UNICODE");
15770                     break;
15771                 case REGEX_LOCALE_CHARSET:
15772                     PerlIO_printf(Perl_debug_log, "LOCALE");
15773                     break;
15774                 case REGEX_ASCII_RESTRICTED_CHARSET:
15775                     PerlIO_printf(Perl_debug_log, "ASCII-RESTRICTED");
15776                     break;
15777                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
15778                     PerlIO_printf(Perl_debug_log, "ASCII-MORE_RESTRICTED");
15779                     break;
15780                 default:
15781                     PerlIO_printf(Perl_debug_log, "UNKNOWN CHARACTER SET");
15782                     break;
15783             }
15784     }
15785     if (lead)  {
15786         if (set)
15787             PerlIO_printf(Perl_debug_log, "\n");
15788         else
15789             PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
15790     }
15791 }
15792 #endif
15793
15794 void
15795 Perl_regdump(pTHX_ const regexp *r)
15796 {
15797 #ifdef DEBUGGING
15798     SV * const sv = sv_newmortal();
15799     SV *dsv= sv_newmortal();
15800     RXi_GET_DECL(r,ri);
15801     GET_RE_DEBUG_FLAGS_DECL;
15802
15803     PERL_ARGS_ASSERT_REGDUMP;
15804
15805     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
15806
15807     /* Header fields of interest. */
15808     if (r->anchored_substr) {
15809         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr),
15810             RE_SV_DUMPLEN(r->anchored_substr), 30);
15811         PerlIO_printf(Perl_debug_log,
15812                       "anchored %s%s at %"IVdf" ",
15813                       s, RE_SV_TAIL(r->anchored_substr),
15814                       (IV)r->anchored_offset);
15815     } else if (r->anchored_utf8) {
15816         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8),
15817             RE_SV_DUMPLEN(r->anchored_utf8), 30);
15818         PerlIO_printf(Perl_debug_log,
15819                       "anchored utf8 %s%s at %"IVdf" ",
15820                       s, RE_SV_TAIL(r->anchored_utf8),
15821                       (IV)r->anchored_offset);
15822     }
15823     if (r->float_substr) {
15824         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr),
15825             RE_SV_DUMPLEN(r->float_substr), 30);
15826         PerlIO_printf(Perl_debug_log,
15827                       "floating %s%s at %"IVdf"..%"UVuf" ",
15828                       s, RE_SV_TAIL(r->float_substr),
15829                       (IV)r->float_min_offset, (UV)r->float_max_offset);
15830     } else if (r->float_utf8) {
15831         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8),
15832             RE_SV_DUMPLEN(r->float_utf8), 30);
15833         PerlIO_printf(Perl_debug_log,
15834                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
15835                       s, RE_SV_TAIL(r->float_utf8),
15836                       (IV)r->float_min_offset, (UV)r->float_max_offset);
15837     }
15838     if (r->check_substr || r->check_utf8)
15839         PerlIO_printf(Perl_debug_log,
15840                       (const char *)
15841                       (r->check_substr == r->float_substr
15842                        && r->check_utf8 == r->float_utf8
15843                        ? "(checking floating" : "(checking anchored"));
15844     if (r->intflags & PREGf_NOSCAN)
15845         PerlIO_printf(Perl_debug_log, " noscan");
15846     if (r->extflags & RXf_CHECK_ALL)
15847         PerlIO_printf(Perl_debug_log, " isall");
15848     if (r->check_substr || r->check_utf8)
15849         PerlIO_printf(Perl_debug_log, ") ");
15850
15851     if (ri->regstclass) {
15852         regprop(r, sv, ri->regstclass, NULL);
15853         PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
15854     }
15855     if (r->intflags & PREGf_ANCH) {
15856         PerlIO_printf(Perl_debug_log, "anchored");
15857         if (r->intflags & PREGf_ANCH_MBOL)
15858             PerlIO_printf(Perl_debug_log, "(MBOL)");
15859         if (r->intflags & PREGf_ANCH_SBOL)
15860             PerlIO_printf(Perl_debug_log, "(SBOL)");
15861         if (r->intflags & PREGf_ANCH_GPOS)
15862             PerlIO_printf(Perl_debug_log, "(GPOS)");
15863         PerlIO_putc(Perl_debug_log, ' ');
15864     }
15865     if (r->intflags & PREGf_GPOS_SEEN)
15866         PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
15867     if (r->intflags & PREGf_SKIP)
15868         PerlIO_printf(Perl_debug_log, "plus ");
15869     if (r->intflags & PREGf_IMPLICIT)
15870         PerlIO_printf(Perl_debug_log, "implicit ");
15871     PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
15872     if (r->extflags & RXf_EVAL_SEEN)
15873         PerlIO_printf(Perl_debug_log, "with eval ");
15874     PerlIO_printf(Perl_debug_log, "\n");
15875     DEBUG_FLAGS_r({
15876         regdump_extflags("r->extflags: ",r->extflags);
15877         regdump_intflags("r->intflags: ",r->intflags);
15878     });
15879 #else
15880     PERL_ARGS_ASSERT_REGDUMP;
15881     PERL_UNUSED_CONTEXT;
15882     PERL_UNUSED_ARG(r);
15883 #endif  /* DEBUGGING */
15884 }
15885
15886 /*
15887 - regprop - printable representation of opcode, with run time support
15888 */
15889
15890 void
15891 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_info *reginfo)
15892 {
15893 #ifdef DEBUGGING
15894     int k;
15895
15896     /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
15897     static const char * const anyofs[] = {
15898 #if _CC_WORDCHAR != 0 || _CC_DIGIT != 1 || _CC_ALPHA != 2 || _CC_LOWER != 3 \
15899     || _CC_UPPER != 4 || _CC_PUNCT != 5 || _CC_PRINT != 6                   \
15900     || _CC_ALPHANUMERIC != 7 || _CC_GRAPH != 8 || _CC_CASED != 9            \
15901     || _CC_SPACE != 10 || _CC_BLANK != 11 || _CC_XDIGIT != 12               \
15902     || _CC_PSXSPC != 13 || _CC_CNTRL != 14 || _CC_ASCII != 15               \
15903     || _CC_VERTSPACE != 16
15904   #error Need to adjust order of anyofs[]
15905 #endif
15906         "\\w",
15907         "\\W",
15908         "\\d",
15909         "\\D",
15910         "[:alpha:]",
15911         "[:^alpha:]",
15912         "[:lower:]",
15913         "[:^lower:]",
15914         "[:upper:]",
15915         "[:^upper:]",
15916         "[:punct:]",
15917         "[:^punct:]",
15918         "[:print:]",
15919         "[:^print:]",
15920         "[:alnum:]",
15921         "[:^alnum:]",
15922         "[:graph:]",
15923         "[:^graph:]",
15924         "[:cased:]",
15925         "[:^cased:]",
15926         "\\s",
15927         "\\S",
15928         "[:blank:]",
15929         "[:^blank:]",
15930         "[:xdigit:]",
15931         "[:^xdigit:]",
15932         "[:space:]",
15933         "[:^space:]",
15934         "[:cntrl:]",
15935         "[:^cntrl:]",
15936         "[:ascii:]",
15937         "[:^ascii:]",
15938         "\\v",
15939         "\\V"
15940     };
15941     RXi_GET_DECL(prog,progi);
15942     GET_RE_DEBUG_FLAGS_DECL;
15943
15944     PERL_ARGS_ASSERT_REGPROP;
15945
15946     sv_setpvs(sv, "");
15947
15948     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
15949         /* It would be nice to FAIL() here, but this may be called from
15950            regexec.c, and it would be hard to supply pRExC_state. */
15951         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
15952                                               (int)OP(o), (int)REGNODE_MAX);
15953     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
15954
15955     k = PL_regkind[OP(o)];
15956
15957     if (k == EXACT) {
15958         sv_catpvs(sv, " ");
15959         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
15960          * is a crude hack but it may be the best for now since
15961          * we have no flag "this EXACTish node was UTF-8"
15962          * --jhi */
15963         pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
15964                   PERL_PV_ESCAPE_UNI_DETECT |
15965                   PERL_PV_ESCAPE_NONASCII   |
15966                   PERL_PV_PRETTY_ELLIPSES   |
15967                   PERL_PV_PRETTY_LTGT       |
15968                   PERL_PV_PRETTY_NOCLEAR
15969                   );
15970     } else if (k == TRIE) {
15971         /* print the details of the trie in dumpuntil instead, as
15972          * progi->data isn't available here */
15973         const char op = OP(o);
15974         const U32 n = ARG(o);
15975         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
15976                (reg_ac_data *)progi->data->data[n] :
15977                NULL;
15978         const reg_trie_data * const trie
15979             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
15980
15981         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
15982         DEBUG_TRIE_COMPILE_r(
15983           Perl_sv_catpvf(aTHX_ sv,
15984             "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
15985             (UV)trie->startstate,
15986             (IV)trie->statecount-1, /* -1 because of the unused 0 element */
15987             (UV)trie->wordcount,
15988             (UV)trie->minlen,
15989             (UV)trie->maxlen,
15990             (UV)TRIE_CHARCOUNT(trie),
15991             (UV)trie->uniquecharcount
15992           );
15993         );
15994         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
15995             sv_catpvs(sv, "[");
15996             (void) put_charclass_bitmap_innards(sv,
15997                                                 (IS_ANYOF_TRIE(op))
15998                                                  ? ANYOF_BITMAP(o)
15999                                                  : TRIE_BITMAP(trie),
16000                                                 NULL);
16001             sv_catpvs(sv, "]");
16002         }
16003
16004     } else if (k == CURLY) {
16005         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
16006             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
16007         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
16008     }
16009     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
16010         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
16011     else if (k == REF || k == OPEN || k == CLOSE
16012              || k == GROUPP || OP(o)==ACCEPT)
16013     {
16014         Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
16015         if ( RXp_PAREN_NAMES(prog) ) {
16016             if ( k != REF || (OP(o) < NREF)) {
16017                 AV *list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
16018                 SV **name= av_fetch(list, ARG(o), 0 );
16019                 if (name)
16020                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
16021             }
16022             else {
16023                 AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]);
16024                 SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]);
16025                 I32 *nums=(I32*)SvPVX(sv_dat);
16026                 SV **name= av_fetch(list, nums[0], 0 );
16027                 I32 n;
16028                 if (name) {
16029                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
16030                         Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
16031                                     (n ? "," : ""), (IV)nums[n]);
16032                     }
16033                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
16034                 }
16035             }
16036         }
16037         if ( k == REF && reginfo) {
16038             U32 n = ARG(o);  /* which paren pair */
16039             I32 ln = prog->offs[n].start;
16040             if (prog->lastparen < n || ln == -1)
16041                 Perl_sv_catpvf(aTHX_ sv, ": FAIL");
16042             else if (ln == prog->offs[n].end)
16043                 Perl_sv_catpvf(aTHX_ sv, ": ACCEPT - EMPTY STRING");
16044             else {
16045                 const char *s = reginfo->strbeg + ln;
16046                 Perl_sv_catpvf(aTHX_ sv, ": ");
16047                 Perl_pv_pretty( aTHX_ sv, s, prog->offs[n].end - prog->offs[n].start, 32, 0, 0,
16048                     PERL_PV_ESCAPE_UNI_DETECT|PERL_PV_PRETTY_NOCLEAR|PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE );
16049             }
16050         }
16051     } else if (k == GOSUB)
16052         /* Paren and offset */
16053         Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o));
16054     else if (k == VERB) {
16055         if (!o->flags)
16056             Perl_sv_catpvf(aTHX_ sv, ":%"SVf,
16057                            SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
16058     } else if (k == LOGICAL)
16059         /* 2: embedded, otherwise 1 */
16060         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);
16061     else if (k == ANYOF) {
16062         const U8 flags = ANYOF_FLAGS(o);
16063         int do_sep = 0;
16064         SV* bitmap_invlist;  /* Will hold what the bit map contains */
16065
16066
16067         if (flags & ANYOF_LOCALE_FLAGS)
16068             sv_catpvs(sv, "{loc}");
16069         if (flags & ANYOF_LOC_FOLD)
16070             sv_catpvs(sv, "{i}");
16071         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
16072         if (flags & ANYOF_INVERT)
16073             sv_catpvs(sv, "^");
16074
16075         /* output what the standard cp 0-NUM_ANYOF_CODE_POINTS-1 bitmap matches
16076          * */
16077         do_sep = put_charclass_bitmap_innards(sv, ANYOF_BITMAP(o),
16078                                                             &bitmap_invlist);
16079
16080         /* output any special charclass tests (used entirely under use
16081          * locale) * */
16082         if (ANYOF_POSIXL_TEST_ANY_SET(o)) {
16083             int i;
16084             for (i = 0; i < ANYOF_POSIXL_MAX; i++) {
16085                 if (ANYOF_POSIXL_TEST(o,i)) {
16086                     sv_catpv(sv, anyofs[i]);
16087                     do_sep = 1;
16088                 }
16089             }
16090         }
16091
16092         if ((flags & (ANYOF_MATCHES_ALL_ABOVE_BITMAP
16093                       |ANYOF_HAS_UTF8_NONBITMAP_MATCHES
16094                       |ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES
16095                       |ANYOF_LOC_FOLD)))
16096         {
16097             if (do_sep) {
16098                 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]);
16099                 if (flags & ANYOF_INVERT)
16100                     /*make sure the invert info is in each */
16101                     sv_catpvs(sv, "^");
16102             }
16103
16104             if (flags & ANYOF_MATCHES_ALL_NON_UTF8_NON_ASCII) {
16105                 sv_catpvs(sv, "{non-utf8-latin1-all}");
16106             }
16107
16108             /* output information about the unicode matching */
16109             if (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP)
16110                 sv_catpvs(sv, "{above_bitmap_all}");
16111             else if (ARG(o) != ANYOF_ONLY_HAS_BITMAP) {
16112                 SV *lv; /* Set if there is something outside the bit map. */
16113                 bool byte_output = FALSE;   /* If something in the bitmap has
16114                                                been output */
16115                 SV *only_utf8_locale;
16116
16117                 /* Get the stuff that wasn't in the bitmap.  'bitmap_invlist'
16118                  * is used to guarantee that nothing in the bitmap gets
16119                  * returned */
16120                 (void) _get_regclass_nonbitmap_data(prog, o, FALSE,
16121                                                     &lv, &only_utf8_locale,
16122                                                     bitmap_invlist);
16123                 if (lv && lv != &PL_sv_undef) {
16124                     char *s = savesvpv(lv);
16125                     char * const origs = s;
16126
16127                     while (*s && *s != '\n')
16128                         s++;
16129
16130                     if (*s == '\n') {
16131                         const char * const t = ++s;
16132
16133                         if (flags & ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES) {
16134                             sv_catpvs(sv, "{outside bitmap}");
16135                         }
16136                         else {
16137                             sv_catpvs(sv, "{utf8}");
16138                         }
16139
16140                         if (byte_output) {
16141                             sv_catpvs(sv, " ");
16142                         }
16143
16144                         while (*s) {
16145                             if (*s == '\n') {
16146
16147                                 /* Truncate very long output */
16148                                 if (s - origs > 256) {
16149                                     Perl_sv_catpvf(aTHX_ sv,
16150                                                 "%.*s...",
16151                                                 (int) (s - origs - 1),
16152                                                 t);
16153                                     goto out_dump;
16154                                 }
16155                                 *s = ' ';
16156                             }
16157                             else if (*s == '\t') {
16158                                 *s = '-';
16159                             }
16160                             s++;
16161                         }
16162                         if (s[-1] == ' ')
16163                             s[-1] = 0;
16164
16165                         sv_catpv(sv, t);
16166                     }
16167
16168                 out_dump:
16169
16170                     Safefree(origs);
16171                     SvREFCNT_dec_NN(lv);
16172                 }
16173
16174                 if ((flags & ANYOF_LOC_FOLD)
16175                      && only_utf8_locale
16176                      && only_utf8_locale != &PL_sv_undef)
16177                 {
16178                     UV start, end;
16179                     int max_entries = 256;
16180
16181                     sv_catpvs(sv, "{utf8 locale}");
16182                     invlist_iterinit(only_utf8_locale);
16183                     while (invlist_iternext(only_utf8_locale,
16184                                             &start, &end)) {
16185                         put_range(sv, start, end, FALSE);
16186                         max_entries --;
16187                         if (max_entries < 0) {
16188                             sv_catpvs(sv, "...");
16189                             break;
16190                         }
16191                     }
16192                     invlist_iterfinish(only_utf8_locale);
16193                 }
16194             }
16195         }
16196         SvREFCNT_dec(bitmap_invlist);
16197
16198
16199         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
16200     }
16201     else if (k == POSIXD || k == NPOSIXD) {
16202         U8 index = FLAGS(o) * 2;
16203         if (index < C_ARRAY_LENGTH(anyofs)) {
16204             if (*anyofs[index] != '[')  {
16205                 sv_catpv(sv, "[");
16206             }
16207             sv_catpv(sv, anyofs[index]);
16208             if (*anyofs[index] != '[')  {
16209                 sv_catpv(sv, "]");
16210             }
16211         }
16212         else {
16213             Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
16214         }
16215     }
16216     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
16217         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
16218     else if (OP(o) == SBOL)
16219         Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^");
16220 #else
16221     PERL_UNUSED_CONTEXT;
16222     PERL_UNUSED_ARG(sv);
16223     PERL_UNUSED_ARG(o);
16224     PERL_UNUSED_ARG(prog);
16225     PERL_UNUSED_ARG(reginfo);
16226 #endif  /* DEBUGGING */
16227 }
16228
16229
16230
16231 SV *
16232 Perl_re_intuit_string(pTHX_ REGEXP * const r)
16233 {                               /* Assume that RE_INTUIT is set */
16234     struct regexp *const prog = ReANY(r);
16235     GET_RE_DEBUG_FLAGS_DECL;
16236
16237     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
16238     PERL_UNUSED_CONTEXT;
16239
16240     DEBUG_COMPILE_r(
16241         {
16242             const char * const s = SvPV_nolen_const(prog->check_substr
16243                       ? prog->check_substr : prog->check_utf8);
16244
16245             if (!PL_colorset) reginitcolors();
16246             PerlIO_printf(Perl_debug_log,
16247                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
16248                       PL_colors[4],
16249                       prog->check_substr ? "" : "utf8 ",
16250                       PL_colors[5],PL_colors[0],
16251                       s,
16252                       PL_colors[1],
16253                       (strlen(s) > 60 ? "..." : ""));
16254         } );
16255
16256     return prog->check_substr ? prog->check_substr : prog->check_utf8;
16257 }
16258
16259 /*
16260    pregfree()
16261
16262    handles refcounting and freeing the perl core regexp structure. When
16263    it is necessary to actually free the structure the first thing it
16264    does is call the 'free' method of the regexp_engine associated to
16265    the regexp, allowing the handling of the void *pprivate; member
16266    first. (This routine is not overridable by extensions, which is why
16267    the extensions free is called first.)
16268
16269    See regdupe and regdupe_internal if you change anything here.
16270 */
16271 #ifndef PERL_IN_XSUB_RE
16272 void
16273 Perl_pregfree(pTHX_ REGEXP *r)
16274 {
16275     SvREFCNT_dec(r);
16276 }
16277
16278 void
16279 Perl_pregfree2(pTHX_ REGEXP *rx)
16280 {
16281     struct regexp *const r = ReANY(rx);
16282     GET_RE_DEBUG_FLAGS_DECL;
16283
16284     PERL_ARGS_ASSERT_PREGFREE2;
16285
16286     if (r->mother_re) {
16287         ReREFCNT_dec(r->mother_re);
16288     } else {
16289         CALLREGFREE_PVT(rx); /* free the private data */
16290         SvREFCNT_dec(RXp_PAREN_NAMES(r));
16291         Safefree(r->xpv_len_u.xpvlenu_pv);
16292     }
16293     if (r->substrs) {
16294         SvREFCNT_dec(r->anchored_substr);
16295         SvREFCNT_dec(r->anchored_utf8);
16296         SvREFCNT_dec(r->float_substr);
16297         SvREFCNT_dec(r->float_utf8);
16298         Safefree(r->substrs);
16299     }
16300     RX_MATCH_COPY_FREE(rx);
16301 #ifdef PERL_ANY_COW
16302     SvREFCNT_dec(r->saved_copy);
16303 #endif
16304     Safefree(r->offs);
16305     SvREFCNT_dec(r->qr_anoncv);
16306     rx->sv_u.svu_rx = 0;
16307 }
16308
16309 /*  reg_temp_copy()
16310
16311     This is a hacky workaround to the structural issue of match results
16312     being stored in the regexp structure which is in turn stored in
16313     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
16314     could be PL_curpm in multiple contexts, and could require multiple
16315     result sets being associated with the pattern simultaneously, such
16316     as when doing a recursive match with (??{$qr})
16317
16318     The solution is to make a lightweight copy of the regexp structure
16319     when a qr// is returned from the code executed by (??{$qr}) this
16320     lightweight copy doesn't actually own any of its data except for
16321     the starp/end and the actual regexp structure itself.
16322
16323 */
16324
16325
16326 REGEXP *
16327 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
16328 {
16329     struct regexp *ret;
16330     struct regexp *const r = ReANY(rx);
16331     const bool islv = ret_x && SvTYPE(ret_x) == SVt_PVLV;
16332
16333     PERL_ARGS_ASSERT_REG_TEMP_COPY;
16334
16335     if (!ret_x)
16336         ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
16337     else {
16338         SvOK_off((SV *)ret_x);
16339         if (islv) {
16340             /* For PVLVs, SvANY points to the xpvlv body while sv_u points
16341                to the regexp.  (For SVt_REGEXPs, sv_upgrade has already
16342                made both spots point to the same regexp body.) */
16343             REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
16344             assert(!SvPVX(ret_x));
16345             ret_x->sv_u.svu_rx = temp->sv_any;
16346             temp->sv_any = NULL;
16347             SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
16348             SvREFCNT_dec_NN(temp);
16349             /* SvCUR still resides in the xpvlv struct, so the regexp copy-
16350                ing below will not set it. */
16351             SvCUR_set(ret_x, SvCUR(rx));
16352         }
16353     }
16354     /* This ensures that SvTHINKFIRST(sv) is true, and hence that
16355        sv_force_normal(sv) is called.  */
16356     SvFAKE_on(ret_x);
16357     ret = ReANY(ret_x);
16358
16359     SvFLAGS(ret_x) |= SvUTF8(rx);
16360     /* We share the same string buffer as the original regexp, on which we
16361        hold a reference count, incremented when mother_re is set below.
16362        The string pointer is copied here, being part of the regexp struct.
16363      */
16364     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
16365            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
16366     if (r->offs) {
16367         const I32 npar = r->nparens+1;
16368         Newx(ret->offs, npar, regexp_paren_pair);
16369         Copy(r->offs, ret->offs, npar, regexp_paren_pair);
16370     }
16371     if (r->substrs) {
16372         Newx(ret->substrs, 1, struct reg_substr_data);
16373         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
16374
16375         SvREFCNT_inc_void(ret->anchored_substr);
16376         SvREFCNT_inc_void(ret->anchored_utf8);
16377         SvREFCNT_inc_void(ret->float_substr);
16378         SvREFCNT_inc_void(ret->float_utf8);
16379
16380         /* check_substr and check_utf8, if non-NULL, point to either their
16381            anchored or float namesakes, and don't hold a second reference.  */
16382     }
16383     RX_MATCH_COPIED_off(ret_x);
16384 #ifdef PERL_ANY_COW
16385     ret->saved_copy = NULL;
16386 #endif
16387     ret->mother_re = ReREFCNT_inc(r->mother_re ? r->mother_re : rx);
16388     SvREFCNT_inc_void(ret->qr_anoncv);
16389
16390     return ret_x;
16391 }
16392 #endif
16393
16394 /* regfree_internal()
16395
16396    Free the private data in a regexp. This is overloadable by
16397    extensions. Perl takes care of the regexp structure in pregfree(),
16398    this covers the *pprivate pointer which technically perl doesn't
16399    know about, however of course we have to handle the
16400    regexp_internal structure when no extension is in use.
16401
16402    Note this is called before freeing anything in the regexp
16403    structure.
16404  */
16405
16406 void
16407 Perl_regfree_internal(pTHX_ REGEXP * const rx)
16408 {
16409     struct regexp *const r = ReANY(rx);
16410     RXi_GET_DECL(r,ri);
16411     GET_RE_DEBUG_FLAGS_DECL;
16412
16413     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
16414
16415     DEBUG_COMPILE_r({
16416         if (!PL_colorset)
16417             reginitcolors();
16418         {
16419             SV *dsv= sv_newmortal();
16420             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
16421                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
16422             PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n",
16423                 PL_colors[4],PL_colors[5],s);
16424         }
16425     });
16426 #ifdef RE_TRACK_PATTERN_OFFSETS
16427     if (ri->u.offsets)
16428         Safefree(ri->u.offsets);             /* 20010421 MJD */
16429 #endif
16430     if (ri->code_blocks) {
16431         int n;
16432         for (n = 0; n < ri->num_code_blocks; n++)
16433             SvREFCNT_dec(ri->code_blocks[n].src_regex);
16434         Safefree(ri->code_blocks);
16435     }
16436
16437     if (ri->data) {
16438         int n = ri->data->count;
16439
16440         while (--n >= 0) {
16441           /* If you add a ->what type here, update the comment in regcomp.h */
16442             switch (ri->data->what[n]) {
16443             case 'a':
16444             case 'r':
16445             case 's':
16446             case 'S':
16447             case 'u':
16448                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
16449                 break;
16450             case 'f':
16451                 Safefree(ri->data->data[n]);
16452                 break;
16453             case 'l':
16454             case 'L':
16455                 break;
16456             case 'T':
16457                 { /* Aho Corasick add-on structure for a trie node.
16458                      Used in stclass optimization only */
16459                     U32 refcount;
16460                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
16461 #ifdef USE_ITHREADS
16462                     dVAR;
16463 #endif
16464                     OP_REFCNT_LOCK;
16465                     refcount = --aho->refcount;
16466                     OP_REFCNT_UNLOCK;
16467                     if ( !refcount ) {
16468                         PerlMemShared_free(aho->states);
16469                         PerlMemShared_free(aho->fail);
16470                          /* do this last!!!! */
16471                         PerlMemShared_free(ri->data->data[n]);
16472                         /* we should only ever get called once, so
16473                          * assert as much, and also guard the free
16474                          * which /might/ happen twice. At the least
16475                          * it will make code anlyzers happy and it
16476                          * doesn't cost much. - Yves */
16477                         assert(ri->regstclass);
16478                         if (ri->regstclass) {
16479                             PerlMemShared_free(ri->regstclass);
16480                             ri->regstclass = 0;
16481                         }
16482                     }
16483                 }
16484                 break;
16485             case 't':
16486                 {
16487                     /* trie structure. */
16488                     U32 refcount;
16489                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
16490 #ifdef USE_ITHREADS
16491                     dVAR;
16492 #endif
16493                     OP_REFCNT_LOCK;
16494                     refcount = --trie->refcount;
16495                     OP_REFCNT_UNLOCK;
16496                     if ( !refcount ) {
16497                         PerlMemShared_free(trie->charmap);
16498                         PerlMemShared_free(trie->states);
16499                         PerlMemShared_free(trie->trans);
16500                         if (trie->bitmap)
16501                             PerlMemShared_free(trie->bitmap);
16502                         if (trie->jump)
16503                             PerlMemShared_free(trie->jump);
16504                         PerlMemShared_free(trie->wordinfo);
16505                         /* do this last!!!! */
16506                         PerlMemShared_free(ri->data->data[n]);
16507                     }
16508                 }
16509                 break;
16510             default:
16511                 Perl_croak(aTHX_ "panic: regfree data code '%c'",
16512                                                     ri->data->what[n]);
16513             }
16514         }
16515         Safefree(ri->data->what);
16516         Safefree(ri->data);
16517     }
16518
16519     Safefree(ri);
16520 }
16521
16522 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
16523 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
16524 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
16525
16526 /*
16527    re_dup - duplicate a regexp.
16528
16529    This routine is expected to clone a given regexp structure. It is only
16530    compiled under USE_ITHREADS.
16531
16532    After all of the core data stored in struct regexp is duplicated
16533    the regexp_engine.dupe method is used to copy any private data
16534    stored in the *pprivate pointer. This allows extensions to handle
16535    any duplication it needs to do.
16536
16537    See pregfree() and regfree_internal() if you change anything here.
16538 */
16539 #if defined(USE_ITHREADS)
16540 #ifndef PERL_IN_XSUB_RE
16541 void
16542 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
16543 {
16544     dVAR;
16545     I32 npar;
16546     const struct regexp *r = ReANY(sstr);
16547     struct regexp *ret = ReANY(dstr);
16548
16549     PERL_ARGS_ASSERT_RE_DUP_GUTS;
16550
16551     npar = r->nparens+1;
16552     Newx(ret->offs, npar, regexp_paren_pair);
16553     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
16554
16555     if (ret->substrs) {
16556         /* Do it this way to avoid reading from *r after the StructCopy().
16557            That way, if any of the sv_dup_inc()s dislodge *r from the L1
16558            cache, it doesn't matter.  */
16559         const bool anchored = r->check_substr
16560             ? r->check_substr == r->anchored_substr
16561             : r->check_utf8 == r->anchored_utf8;
16562         Newx(ret->substrs, 1, struct reg_substr_data);
16563         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
16564
16565         ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
16566         ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
16567         ret->float_substr = sv_dup_inc(ret->float_substr, param);
16568         ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
16569
16570         /* check_substr and check_utf8, if non-NULL, point to either their
16571            anchored or float namesakes, and don't hold a second reference.  */
16572
16573         if (ret->check_substr) {
16574             if (anchored) {
16575                 assert(r->check_utf8 == r->anchored_utf8);
16576                 ret->check_substr = ret->anchored_substr;
16577                 ret->check_utf8 = ret->anchored_utf8;
16578             } else {
16579                 assert(r->check_substr == r->float_substr);
16580                 assert(r->check_utf8 == r->float_utf8);
16581                 ret->check_substr = ret->float_substr;
16582                 ret->check_utf8 = ret->float_utf8;
16583             }
16584         } else if (ret->check_utf8) {
16585             if (anchored) {
16586                 ret->check_utf8 = ret->anchored_utf8;
16587             } else {
16588                 ret->check_utf8 = ret->float_utf8;
16589             }
16590         }
16591     }
16592
16593     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
16594     ret->qr_anoncv = MUTABLE_CV(sv_dup_inc((const SV *)ret->qr_anoncv, param));
16595
16596     if (ret->pprivate)
16597         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
16598
16599     if (RX_MATCH_COPIED(dstr))
16600         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
16601     else
16602         ret->subbeg = NULL;
16603 #ifdef PERL_ANY_COW
16604     ret->saved_copy = NULL;
16605 #endif
16606
16607     /* Whether mother_re be set or no, we need to copy the string.  We
16608        cannot refrain from copying it when the storage points directly to
16609        our mother regexp, because that's
16610                1: a buffer in a different thread
16611                2: something we no longer hold a reference on
16612                so we need to copy it locally.  */
16613     RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED(sstr), SvCUR(sstr)+1);
16614     ret->mother_re   = NULL;
16615 }
16616 #endif /* PERL_IN_XSUB_RE */
16617
16618 /*
16619    regdupe_internal()
16620
16621    This is the internal complement to regdupe() which is used to copy
16622    the structure pointed to by the *pprivate pointer in the regexp.
16623    This is the core version of the extension overridable cloning hook.
16624    The regexp structure being duplicated will be copied by perl prior
16625    to this and will be provided as the regexp *r argument, however
16626    with the /old/ structures pprivate pointer value. Thus this routine
16627    may override any copying normally done by perl.
16628
16629    It returns a pointer to the new regexp_internal structure.
16630 */
16631
16632 void *
16633 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
16634 {
16635     dVAR;
16636     struct regexp *const r = ReANY(rx);
16637     regexp_internal *reti;
16638     int len;
16639     RXi_GET_DECL(r,ri);
16640
16641     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
16642
16643     len = ProgLen(ri);
16644
16645     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode),
16646           char, regexp_internal);
16647     Copy(ri->program, reti->program, len+1, regnode);
16648
16649     reti->num_code_blocks = ri->num_code_blocks;
16650     if (ri->code_blocks) {
16651         int n;
16652         Newxc(reti->code_blocks, ri->num_code_blocks, struct reg_code_block,
16653                 struct reg_code_block);
16654         Copy(ri->code_blocks, reti->code_blocks, ri->num_code_blocks,
16655                 struct reg_code_block);
16656         for (n = 0; n < ri->num_code_blocks; n++)
16657              reti->code_blocks[n].src_regex = (REGEXP*)
16658                     sv_dup_inc((SV*)(ri->code_blocks[n].src_regex), param);
16659     }
16660     else
16661         reti->code_blocks = NULL;
16662
16663     reti->regstclass = NULL;
16664
16665     if (ri->data) {
16666         struct reg_data *d;
16667         const int count = ri->data->count;
16668         int i;
16669
16670         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
16671                 char, struct reg_data);
16672         Newx(d->what, count, U8);
16673
16674         d->count = count;
16675         for (i = 0; i < count; i++) {
16676             d->what[i] = ri->data->what[i];
16677             switch (d->what[i]) {
16678                 /* see also regcomp.h and regfree_internal() */
16679             case 'a': /* actually an AV, but the dup function is identical.  */
16680             case 'r':
16681             case 's':
16682             case 'S':
16683             case 'u': /* actually an HV, but the dup function is identical.  */
16684                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
16685                 break;
16686             case 'f':
16687                 /* This is cheating. */
16688                 Newx(d->data[i], 1, regnode_ssc);
16689                 StructCopy(ri->data->data[i], d->data[i], regnode_ssc);
16690                 reti->regstclass = (regnode*)d->data[i];
16691                 break;
16692             case 'T':
16693                 /* Trie stclasses are readonly and can thus be shared
16694                  * without duplication. We free the stclass in pregfree
16695                  * when the corresponding reg_ac_data struct is freed.
16696                  */
16697                 reti->regstclass= ri->regstclass;
16698                 /* FALLTHROUGH */
16699             case 't':
16700                 OP_REFCNT_LOCK;
16701                 ((reg_trie_data*)ri->data->data[i])->refcount++;
16702                 OP_REFCNT_UNLOCK;
16703                 /* FALLTHROUGH */
16704             case 'l':
16705             case 'L':
16706                 d->data[i] = ri->data->data[i];
16707                 break;
16708             default:
16709                 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'",
16710                                                            ri->data->what[i]);
16711             }
16712         }
16713
16714         reti->data = d;
16715     }
16716     else
16717         reti->data = NULL;
16718
16719     reti->name_list_idx = ri->name_list_idx;
16720
16721 #ifdef RE_TRACK_PATTERN_OFFSETS
16722     if (ri->u.offsets) {
16723         Newx(reti->u.offsets, 2*len+1, U32);
16724         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
16725     }
16726 #else
16727     SetProgLen(reti,len);
16728 #endif
16729
16730     return (void*)reti;
16731 }
16732
16733 #endif    /* USE_ITHREADS */
16734
16735 #ifndef PERL_IN_XSUB_RE
16736
16737 /*
16738  - regnext - dig the "next" pointer out of a node
16739  */
16740 regnode *
16741 Perl_regnext(pTHX_ regnode *p)
16742 {
16743     I32 offset;
16744
16745     if (!p)
16746         return(NULL);
16747
16748     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
16749         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
16750                                                 (int)OP(p), (int)REGNODE_MAX);
16751     }
16752
16753     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
16754     if (offset == 0)
16755         return(NULL);
16756
16757     return(p+offset);
16758 }
16759 #endif
16760
16761 STATIC void
16762 S_re_croak2(pTHX_ bool utf8, const char* pat1,const char* pat2,...)
16763 {
16764     va_list args;
16765     STRLEN l1 = strlen(pat1);
16766     STRLEN l2 = strlen(pat2);
16767     char buf[512];
16768     SV *msv;
16769     const char *message;
16770
16771     PERL_ARGS_ASSERT_RE_CROAK2;
16772
16773     if (l1 > 510)
16774         l1 = 510;
16775     if (l1 + l2 > 510)
16776         l2 = 510 - l1;
16777     Copy(pat1, buf, l1 , char);
16778     Copy(pat2, buf + l1, l2 , char);
16779     buf[l1 + l2] = '\n';
16780     buf[l1 + l2 + 1] = '\0';
16781     va_start(args, pat2);
16782     msv = vmess(buf, &args);
16783     va_end(args);
16784     message = SvPV_const(msv,l1);
16785     if (l1 > 512)
16786         l1 = 512;
16787     Copy(message, buf, l1 , char);
16788     /* l1-1 to avoid \n */
16789     Perl_croak(aTHX_ "%"UTF8f, UTF8fARG(utf8, l1-1, buf));
16790 }
16791
16792 #ifdef DEBUGGING
16793 /* Certain characters are output as a sequence with the first being a
16794  * backslash. */
16795 #define isBACKSLASHED_PUNCT(c)                                              \
16796                     ((c) == '-' || (c) == ']' || (c) == '\\' || (c) == '^')
16797
16798 STATIC void
16799 S_put_code_point(pTHX_ SV *sv, UV c)
16800 {
16801     PERL_ARGS_ASSERT_PUT_CODE_POINT;
16802
16803     if (c > 255) {
16804         Perl_sv_catpvf(aTHX_ sv, "\\x{%04"UVXf"}", c);
16805     }
16806     else if (isPRINT(c)) {
16807         const char string = (char) c;
16808         if (isBACKSLASHED_PUNCT(c))
16809             sv_catpvs(sv, "\\");
16810         sv_catpvn(sv, &string, 1);
16811     }
16812     else {
16813         const char * const mnemonic = cntrl_to_mnemonic((char) c);
16814         if (mnemonic) {
16815             Perl_sv_catpvf(aTHX_ sv, "%s", mnemonic);
16816         }
16817         else {
16818             Perl_sv_catpvf(aTHX_ sv, "\\x{%02X}", (U8) c);
16819         }
16820     }
16821 }
16822
16823 #define MAX_PRINT_A MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C
16824
16825 #ifndef MIN
16826 #define MIN(a,b) ((a) < (b) ? (a) : (b))
16827 #endif
16828
16829 STATIC void
16830 S_put_range(pTHX_ SV *sv, UV start, const UV end, const bool allow_literals)
16831 {
16832     /* Appends to 'sv' a displayable version of the range of code points from
16833      * 'start' to 'end'.  It assumes that only ASCII printables are displayable
16834      * as-is (though some of these will be escaped by put_code_point()). */
16835
16836     const unsigned int min_range_count = 3;
16837
16838     assert(start <= end);
16839
16840     PERL_ARGS_ASSERT_PUT_RANGE;
16841
16842     while (start <= end) {
16843         UV this_end;
16844         const char * format;
16845
16846         if (end - start < min_range_count) {
16847
16848             /* Individual chars in short ranges */
16849             for (; start <= end; start++) {
16850                 put_code_point(sv, start);
16851             }
16852             break;
16853         }
16854
16855         /* If permitted by the input options, and there is a possibility that
16856          * this range contains a printable literal, look to see if there is
16857          * one.  */
16858         if (allow_literals && start <= MAX_PRINT_A) {
16859
16860             /* If the range begin isn't an ASCII printable, effectively split
16861              * the range into two parts:
16862              *  1) the portion before the first such printable,
16863              *  2) the rest
16864              * and output them separately. */
16865             if (! isPRINT_A(start)) {
16866                 UV temp_end = start + 1;
16867
16868                 /* There is no point looking beyond the final possible
16869                  * printable, in MAX_PRINT_A */
16870                 UV max = MIN(end, MAX_PRINT_A);
16871
16872                 while (temp_end <= max && ! isPRINT_A(temp_end)) {
16873                     temp_end++;
16874                 }
16875
16876                 /* Here, temp_end points to one beyond the first printable if
16877                  * found, or to one beyond 'max' if not.  If none found, make
16878                  * sure that we use the entire range */
16879                 if (temp_end > MAX_PRINT_A) {
16880                     temp_end = end + 1;
16881                 }
16882
16883                 /* Output the first part of the split range, the part that
16884                  * doesn't have printables, with no looking for literals
16885                  * (otherwise we would infinitely recurse) */
16886                 put_range(sv, start, temp_end - 1, FALSE);
16887
16888                 /* The 2nd part of the range (if any) starts here. */
16889                 start = temp_end;
16890
16891                 /* We continue instead of dropping down because even if the 2nd
16892                  * part is non-empty, it could be so short that we want to
16893                  * output it specially, as tested for at the top of this loop.
16894                  * */
16895                 continue;
16896             }
16897
16898             /* Here, 'start' is a printable ASCII.  If it is an alphanumeric,
16899              * output a sub-range of just the digits or letters, then process
16900              * the remaining portion as usual. */
16901             if (isALPHANUMERIC_A(start)) {
16902                 UV mask = (isDIGIT_A(start))
16903                            ? _CC_DIGIT
16904                              : isUPPER_A(start)
16905                                ? _CC_UPPER
16906                                : _CC_LOWER;
16907                 UV temp_end = start + 1;
16908
16909                 /* Find the end of the sub-range that includes just the
16910                  * characters in the same class as the first character in it */
16911                 while (temp_end <= end && _generic_isCC_A(temp_end, mask)) {
16912                     temp_end++;
16913                 }
16914                 temp_end--;
16915
16916                 /* For short ranges, don't duplicate the code above to output
16917                  * them; just call recursively */
16918                 if (temp_end - start < min_range_count) {
16919                     put_range(sv, start, temp_end, FALSE);
16920                 }
16921                 else {  /* Output as a range */
16922                     put_code_point(sv, start);
16923                     sv_catpvs(sv, "-");
16924                     put_code_point(sv, temp_end);
16925                 }
16926                 start = temp_end + 1;
16927                 continue;
16928             }
16929
16930             /* We output any other printables as individual characters */
16931             if (isPUNCT_A(start) || isSPACE_A(start)) {
16932                 while (start <= end && (isPUNCT_A(start)
16933                                         || isSPACE_A(start)))
16934                 {
16935                     put_code_point(sv, start);
16936                     start++;
16937                 }
16938                 continue;
16939             }
16940         } /* End of looking for literals */
16941
16942         /* Here is not to output as a literal.  Some control characters have
16943          * mnemonic names.  Split off any of those at the beginning and end of
16944          * the range to print mnemonically.  It isn't possible for many of
16945          * these to be in a row, so this won't overwhelm with output */
16946         while (isMNEMONIC_CNTRL(start) && start <= end) {
16947             put_code_point(sv, start);
16948             start++;
16949         }
16950         if (start < end && isMNEMONIC_CNTRL(end)) {
16951
16952             /* Here, the final character in the range has a mnemonic name.
16953              * Work backwards from the end to find the final non-mnemonic */
16954             UV temp_end = end - 1;
16955             while (isMNEMONIC_CNTRL(temp_end)) {
16956                 temp_end--;
16957             }
16958
16959             /* And separately output the range that doesn't have mnemonics */
16960             put_range(sv, start, temp_end, FALSE);
16961
16962             /* Then output the mnemonic trailing controls */
16963             start = temp_end + 1;
16964             while (start <= end) {
16965                 put_code_point(sv, start);
16966                 start++;
16967             }
16968             break;
16969         }
16970
16971         /* As a final resort, output the range or subrange as hex. */
16972
16973         this_end = (end < NUM_ANYOF_CODE_POINTS)
16974                     ? end
16975                     : NUM_ANYOF_CODE_POINTS - 1;
16976         format = (this_end < 256)
16977                  ? "\\x{%02"UVXf"}-\\x{%02"UVXf"}"
16978                  : "\\x{%04"UVXf"}-\\x{%04"UVXf"}";
16979         Perl_sv_catpvf(aTHX_ sv, format, start, this_end);
16980         break;
16981     }
16982 }
16983
16984 STATIC bool
16985 S_put_charclass_bitmap_innards(pTHX_ SV *sv, char *bitmap, SV** bitmap_invlist)
16986 {
16987     /* Appends to 'sv' a displayable version of the innards of the bracketed
16988      * character class whose bitmap is 'bitmap';  Returns 'TRUE' if it actually
16989      * output anything, and bitmap_invlist, if not NULL, will point to an
16990      * inversion list of what is in the bit map */
16991
16992     int i;
16993     UV start, end;
16994     unsigned int punct_count = 0;
16995     SV* invlist = NULL;
16996     SV** invlist_ptr;   /* Temporary, in case bitmap_invlist is NULL */
16997     bool allow_literals = TRUE;
16998
16999     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS;
17000
17001     invlist_ptr = (bitmap_invlist) ? bitmap_invlist : &invlist;
17002
17003     /* Worst case is exactly every-other code point is in the list */
17004     *invlist_ptr = _new_invlist(NUM_ANYOF_CODE_POINTS / 2);
17005
17006     /* Convert the bit map to an inversion list, keeping track of how many
17007      * ASCII puncts are set, including an extra amount for the backslashed
17008      * ones.  */
17009     for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
17010         if (BITMAP_TEST(bitmap, i)) {
17011             *invlist_ptr = add_cp_to_invlist(*invlist_ptr, i);
17012             if (isPUNCT_A(i)) {
17013                 punct_count++;
17014                 if isBACKSLASHED_PUNCT(i) {
17015                     punct_count++;
17016                 }
17017             }
17018         }
17019     }
17020
17021     /* Nothing to output */
17022     if (_invlist_len(*invlist_ptr) == 0) {
17023         SvREFCNT_dec(invlist);
17024         return FALSE;
17025     }
17026
17027     /* Generally, it is more readable if printable characters are output as
17028      * literals, but if a range (nearly) spans all of them, it's best to output
17029      * it as a single range.  This code will use a single range if all but 2
17030      * printables are in it */
17031     invlist_iterinit(*invlist_ptr);
17032     while (invlist_iternext(*invlist_ptr, &start, &end)) {
17033
17034         /* If range starts beyond final printable, it doesn't have any in it */
17035         if (start > MAX_PRINT_A) {
17036             break;
17037         }
17038
17039         /* In both ASCII and EBCDIC, a SPACE is the lowest printable.  To span
17040          * all but two, the range must start and end no later than 2 from
17041          * either end */
17042         if (start < ' ' + 2 && end > MAX_PRINT_A - 2) {
17043             if (end > MAX_PRINT_A) {
17044                 end = MAX_PRINT_A;
17045             }
17046             if (start < ' ') {
17047                 start = ' ';
17048             }
17049             if (end - start >= MAX_PRINT_A - ' ' - 2) {
17050                 allow_literals = FALSE;
17051             }
17052             break;
17053         }
17054     }
17055     invlist_iterfinish(*invlist_ptr);
17056
17057     /* The legibility of the output depends mostly on how many punctuation
17058      * characters are output.  There are 32 possible ASCII ones, and some have
17059      * an additional backslash, bringing it to currently 36, so if any more
17060      * than 18 are to be output, we can instead output it as its complement,
17061      * yielding fewer puncts, and making it more legible.  But give some weight
17062      * to the fact that outputting it as a complement is less legible than a
17063      * straight output, so don't complement unless we are somewhat over the 18
17064      * mark */
17065     if (allow_literals && punct_count > 22) {
17066         sv_catpvs(sv, "^");
17067
17068         /* Add everything remaining to the list, so when we invert it just
17069          * below, it will be excluded */
17070         _invlist_union_complement_2nd(*invlist_ptr, PL_InBitmap, invlist_ptr);
17071         _invlist_invert(*invlist_ptr);
17072     }
17073
17074     /* Here we have figured things out.  Output each range */
17075     invlist_iterinit(*invlist_ptr);
17076     while (invlist_iternext(*invlist_ptr, &start, &end)) {
17077         if (start >= NUM_ANYOF_CODE_POINTS) {
17078             break;
17079         }
17080         put_range(sv, start, end, allow_literals);
17081     }
17082     invlist_iterfinish(*invlist_ptr);
17083
17084     return TRUE;
17085 }
17086
17087 #define CLEAR_OPTSTART \
17088     if (optstart) STMT_START {                                               \
17089         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,                       \
17090                               " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
17091         optstart=NULL;                                                       \
17092     } STMT_END
17093
17094 #define DUMPUNTIL(b,e)                                                       \
17095                     CLEAR_OPTSTART;                                          \
17096                     node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
17097
17098 STATIC const regnode *
17099 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
17100             const regnode *last, const regnode *plast,
17101             SV* sv, I32 indent, U32 depth)
17102 {
17103     U8 op = PSEUDO;     /* Arbitrary non-END op. */
17104     const regnode *next;
17105     const regnode *optstart= NULL;
17106
17107     RXi_GET_DECL(r,ri);
17108     GET_RE_DEBUG_FLAGS_DECL;
17109
17110     PERL_ARGS_ASSERT_DUMPUNTIL;
17111
17112 #ifdef DEBUG_DUMPUNTIL
17113     PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
17114         last ? last-start : 0,plast ? plast-start : 0);
17115 #endif
17116
17117     if (plast && plast < last)
17118         last= plast;
17119
17120     while (PL_regkind[op] != END && (!last || node < last)) {
17121         assert(node);
17122         /* While that wasn't END last time... */
17123         NODE_ALIGN(node);
17124         op = OP(node);
17125         if (op == CLOSE || op == WHILEM)
17126             indent--;
17127         next = regnext((regnode *)node);
17128
17129         /* Where, what. */
17130         if (OP(node) == OPTIMIZED) {
17131             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
17132                 optstart = node;
17133             else
17134                 goto after_print;
17135         } else
17136             CLEAR_OPTSTART;
17137
17138         regprop(r, sv, node, NULL);
17139         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
17140                       (int)(2*indent + 1), "", SvPVX_const(sv));
17141
17142         if (OP(node) != OPTIMIZED) {
17143             if (next == NULL)           /* Next ptr. */
17144                 PerlIO_printf(Perl_debug_log, " (0)");
17145             else if (PL_regkind[(U8)op] == BRANCH
17146                      && PL_regkind[OP(next)] != BRANCH )
17147                 PerlIO_printf(Perl_debug_log, " (FAIL)");
17148             else
17149                 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
17150             (void)PerlIO_putc(Perl_debug_log, '\n');
17151         }
17152
17153       after_print:
17154         if (PL_regkind[(U8)op] == BRANCHJ) {
17155             assert(next);
17156             {
17157                 const regnode *nnode = (OP(next) == LONGJMP
17158                                        ? regnext((regnode *)next)
17159                                        : next);
17160                 if (last && nnode > last)
17161                     nnode = last;
17162                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
17163             }
17164         }
17165         else if (PL_regkind[(U8)op] == BRANCH) {
17166             assert(next);
17167             DUMPUNTIL(NEXTOPER(node), next);
17168         }
17169         else if ( PL_regkind[(U8)op]  == TRIE ) {
17170             const regnode *this_trie = node;
17171             const char op = OP(node);
17172             const U32 n = ARG(node);
17173             const reg_ac_data * const ac = op>=AHOCORASICK ?
17174                (reg_ac_data *)ri->data->data[n] :
17175                NULL;
17176             const reg_trie_data * const trie =
17177                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
17178 #ifdef DEBUGGING
17179             AV *const trie_words
17180                            = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
17181 #endif
17182             const regnode *nextbranch= NULL;
17183             I32 word_idx;
17184             sv_setpvs(sv, "");
17185             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
17186                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
17187
17188                 PerlIO_printf(Perl_debug_log, "%*s%s ",
17189                    (int)(2*(indent+3)), "",
17190                     elem_ptr
17191                     ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr),
17192                                 SvCUR(*elem_ptr), 60,
17193                                 PL_colors[0], PL_colors[1],
17194                                 (SvUTF8(*elem_ptr)
17195                                  ? PERL_PV_ESCAPE_UNI
17196                                  : 0)
17197                                 | PERL_PV_PRETTY_ELLIPSES
17198                                 | PERL_PV_PRETTY_LTGT
17199                             )
17200                     : "???"
17201                 );
17202                 if (trie->jump) {
17203                     U16 dist= trie->jump[word_idx+1];
17204                     PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
17205                                (UV)((dist ? this_trie + dist : next) - start));
17206                     if (dist) {
17207                         if (!nextbranch)
17208                             nextbranch= this_trie + trie->jump[0];
17209                         DUMPUNTIL(this_trie + dist, nextbranch);
17210                     }
17211                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
17212                         nextbranch= regnext((regnode *)nextbranch);
17213                 } else {
17214                     PerlIO_printf(Perl_debug_log, "\n");
17215                 }
17216             }
17217             if (last && next > last)
17218                 node= last;
17219             else
17220                 node= next;
17221         }
17222         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
17223             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
17224                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
17225         }
17226         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
17227             assert(next);
17228             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
17229         }
17230         else if ( op == PLUS || op == STAR) {
17231             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
17232         }
17233         else if (PL_regkind[(U8)op] == ANYOF) {
17234             /* arglen 1 + class block */
17235             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_MATCHES_POSIXL)
17236                           ? ANYOF_POSIXL_SKIP
17237                           : ANYOF_SKIP);
17238             node = NEXTOPER(node);
17239         }
17240         else if (PL_regkind[(U8)op] == EXACT) {
17241             /* Literal string, where present. */
17242             node += NODE_SZ_STR(node) - 1;
17243             node = NEXTOPER(node);
17244         }
17245         else {
17246             node = NEXTOPER(node);
17247             node += regarglen[(U8)op];
17248         }
17249         if (op == CURLYX || op == OPEN)
17250             indent++;
17251     }
17252     CLEAR_OPTSTART;
17253 #ifdef DEBUG_DUMPUNTIL
17254     PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
17255 #endif
17256     return node;
17257 }
17258
17259 #endif  /* DEBUGGING */
17260
17261 /*
17262  * Local variables:
17263  * c-indentation-style: bsd
17264  * c-basic-offset: 4
17265  * indent-tabs-mode: nil
17266  * End:
17267  *
17268  * ex: set ts=8 sts=4 sw=4 et:
17269  */