]> git.vpit.fr Git - perl/modules/re-engine-Hooks.git/blob - src/5018000/orig/regcomp.c
Add support for perl 5.23.[01]
[perl/modules/re-engine-Hooks.git] / src / 5018000 / orig / 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 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) _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
95 #define IS_NON_FINAL_FOLD(c) _IS_NON_FINAL_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
96 #define IS_IN_SOME_FOLD_L1(c) _IS_IN_SOME_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
97
98 #ifdef op
99 #undef op
100 #endif /* op */
101
102 #ifdef MSDOS
103 #  if defined(BUGGY_MSC6)
104  /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
105 #    pragma optimize("a",off)
106  /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
107 #    pragma optimize("w",on )
108 #  endif /* BUGGY_MSC6 */
109 #endif /* MSDOS */
110
111 #ifndef STATIC
112 #define STATIC  static
113 #endif
114
115
116 typedef struct RExC_state_t {
117     U32         flags;                  /* RXf_* are we folding, multilining? */
118     U32         pm_flags;               /* PMf_* stuff from the calling PMOP */
119     char        *precomp;               /* uncompiled string. */
120     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
121     regexp      *rx;                    /* perl core regexp structure */
122     regexp_internal     *rxi;           /* internal data for regexp object pprivate field */        
123     char        *start;                 /* Start of input for compile */
124     char        *end;                   /* End of input for compile */
125     char        *parse;                 /* Input-scan pointer. */
126     I32         whilem_seen;            /* number of WHILEM in this expr */
127     regnode     *emit_start;            /* Start of emitted-code area */
128     regnode     *emit_bound;            /* First regnode outside of the allocated space */
129     regnode     *emit;                  /* Code-emit pointer; &regdummy = don't = compiling */
130     I32         naughty;                /* How bad is this pattern? */
131     I32         sawback;                /* Did we see \1, ...? */
132     U32         seen;
133     I32         size;                   /* Code size. */
134     I32         npar;                   /* Capture buffer count, (OPEN). */
135     I32         cpar;                   /* Capture buffer count, (CLOSE). */
136     I32         nestroot;               /* root parens we are in - used by accept */
137     I32         extralen;
138     I32         seen_zerolen;
139     regnode     **open_parens;          /* pointers to open parens */
140     regnode     **close_parens;         /* pointers to close parens */
141     regnode     *opend;                 /* END node in program */
142     I32         utf8;           /* whether the pattern is utf8 or not */
143     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
144                                 /* XXX use this for future optimisation of case
145                                  * where pattern must be upgraded to utf8. */
146     I32         uni_semantics;  /* If a d charset modifier should use unicode
147                                    rules, even if the pattern is not in
148                                    utf8 */
149     HV          *paren_names;           /* Paren names */
150     
151     regnode     **recurse;              /* Recurse regops */
152     I32         recurse_count;          /* Number of recurse regops */
153     I32         in_lookbehind;
154     I32         contains_locale;
155     I32         override_recoding;
156     I32         in_multi_char_class;
157     struct reg_code_block *code_blocks; /* positions of literal (?{})
158                                             within pattern */
159     int         num_code_blocks;        /* size of code_blocks[] */
160     int         code_index;             /* next code_blocks[] slot */
161 #if ADD_TO_REGEXEC
162     char        *starttry;              /* -Dr: where regtry was called. */
163 #define RExC_starttry   (pRExC_state->starttry)
164 #endif
165     SV          *runtime_code_qr;       /* qr with the runtime code blocks */
166 #ifdef DEBUGGING
167     const char  *lastparse;
168     I32         lastnum;
169     AV          *paren_name_list;       /* idx -> name */
170 #define RExC_lastparse  (pRExC_state->lastparse)
171 #define RExC_lastnum    (pRExC_state->lastnum)
172 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
173 #endif
174 } RExC_state_t;
175
176 #define RExC_flags      (pRExC_state->flags)
177 #define RExC_pm_flags   (pRExC_state->pm_flags)
178 #define RExC_precomp    (pRExC_state->precomp)
179 #define RExC_rx_sv      (pRExC_state->rx_sv)
180 #define RExC_rx         (pRExC_state->rx)
181 #define RExC_rxi        (pRExC_state->rxi)
182 #define RExC_start      (pRExC_state->start)
183 #define RExC_end        (pRExC_state->end)
184 #define RExC_parse      (pRExC_state->parse)
185 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
186 #ifdef RE_TRACK_PATTERN_OFFSETS
187 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the others */
188 #endif
189 #define RExC_emit       (pRExC_state->emit)
190 #define RExC_emit_start (pRExC_state->emit_start)
191 #define RExC_emit_bound (pRExC_state->emit_bound)
192 #define RExC_naughty    (pRExC_state->naughty)
193 #define RExC_sawback    (pRExC_state->sawback)
194 #define RExC_seen       (pRExC_state->seen)
195 #define RExC_size       (pRExC_state->size)
196 #define RExC_npar       (pRExC_state->npar)
197 #define RExC_nestroot   (pRExC_state->nestroot)
198 #define RExC_extralen   (pRExC_state->extralen)
199 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
200 #define RExC_utf8       (pRExC_state->utf8)
201 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
202 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
203 #define RExC_open_parens        (pRExC_state->open_parens)
204 #define RExC_close_parens       (pRExC_state->close_parens)
205 #define RExC_opend      (pRExC_state->opend)
206 #define RExC_paren_names        (pRExC_state->paren_names)
207 #define RExC_recurse    (pRExC_state->recurse)
208 #define RExC_recurse_count      (pRExC_state->recurse_count)
209 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
210 #define RExC_contains_locale    (pRExC_state->contains_locale)
211 #define RExC_override_recoding (pRExC_state->override_recoding)
212 #define RExC_in_multi_char_class (pRExC_state->in_multi_char_class)
213
214
215 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
216 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
217         ((*s) == '{' && regcurly(s, FALSE)))
218
219 #ifdef SPSTART
220 #undef SPSTART          /* dratted cpp namespace... */
221 #endif
222 /*
223  * Flags to be passed up and down.
224  */
225 #define WORST           0       /* Worst case. */
226 #define HASWIDTH        0x01    /* Known to match non-null strings. */
227
228 /* Simple enough to be STAR/PLUS operand; in an EXACTish node must be a single
229  * character.  (There needs to be a case: in the switch statement in regexec.c
230  * for any node marked SIMPLE.)  Note that this is not the same thing as
231  * REGNODE_SIMPLE */
232 #define SIMPLE          0x02
233 #define SPSTART         0x04    /* Starts with * or + */
234 #define POSTPONED       0x08    /* (?1),(?&name), (??{...}) or similar */
235 #define TRYAGAIN        0x10    /* Weeded out a declaration. */
236 #define RESTART_UTF8    0x20    /* Restart, need to calcuate sizes as UTF-8 */
237
238 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
239
240 /* whether trie related optimizations are enabled */
241 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
242 #define TRIE_STUDY_OPT
243 #define FULL_TRIE_STUDY
244 #define TRIE_STCLASS
245 #endif
246
247
248
249 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
250 #define PBITVAL(paren) (1 << ((paren) & 7))
251 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
252 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
253 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
254
255 #define REQUIRE_UTF8    STMT_START {                                       \
256                                      if (!UTF) {                           \
257                                          *flagp = RESTART_UTF8;            \
258                                          return NULL;                      \
259                                      }                                     \
260                         } STMT_END
261
262 /* This converts the named class defined in regcomp.h to its equivalent class
263  * number defined in handy.h. */
264 #define namedclass_to_classnum(class)  ((int) ((class) / 2))
265 #define classnum_to_namedclass(classnum)  ((classnum) * 2)
266
267 /* About scan_data_t.
268
269   During optimisation we recurse through the regexp program performing
270   various inplace (keyhole style) optimisations. In addition study_chunk
271   and scan_commit populate this data structure with information about
272   what strings MUST appear in the pattern. We look for the longest 
273   string that must appear at a fixed location, and we look for the
274   longest string that may appear at a floating location. So for instance
275   in the pattern:
276   
277     /FOO[xX]A.*B[xX]BAR/
278     
279   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
280   strings (because they follow a .* construct). study_chunk will identify
281   both FOO and BAR as being the longest fixed and floating strings respectively.
282   
283   The strings can be composites, for instance
284   
285      /(f)(o)(o)/
286      
287   will result in a composite fixed substring 'foo'.
288   
289   For each string some basic information is maintained:
290   
291   - offset or min_offset
292     This is the position the string must appear at, or not before.
293     It also implicitly (when combined with minlenp) tells us how many
294     characters must match before the string we are searching for.
295     Likewise when combined with minlenp and the length of the string it
296     tells us how many characters must appear after the string we have 
297     found.
298   
299   - max_offset
300     Only used for floating strings. This is the rightmost point that
301     the string can appear at. If set to I32 max it indicates that the
302     string can occur infinitely far to the right.
303   
304   - minlenp
305     A pointer to the minimum number of characters of the pattern that the
306     string was found inside. This is important as in the case of positive
307     lookahead or positive lookbehind we can have multiple patterns 
308     involved. Consider
309     
310     /(?=FOO).*F/
311     
312     The minimum length of the pattern overall is 3, the minimum length
313     of the lookahead part is 3, but the minimum length of the part that
314     will actually match is 1. So 'FOO's minimum length is 3, but the 
315     minimum length for the F is 1. This is important as the minimum length
316     is used to determine offsets in front of and behind the string being 
317     looked for.  Since strings can be composites this is the length of the
318     pattern at the time it was committed with a scan_commit. Note that
319     the length is calculated by study_chunk, so that the minimum lengths
320     are not known until the full pattern has been compiled, thus the 
321     pointer to the value.
322   
323   - lookbehind
324   
325     In the case of lookbehind the string being searched for can be
326     offset past the start point of the final matching string. 
327     If this value was just blithely removed from the min_offset it would
328     invalidate some of the calculations for how many chars must match
329     before or after (as they are derived from min_offset and minlen and
330     the length of the string being searched for). 
331     When the final pattern is compiled and the data is moved from the
332     scan_data_t structure into the regexp structure the information
333     about lookbehind is factored in, with the information that would 
334     have been lost precalculated in the end_shift field for the 
335     associated string.
336
337   The fields pos_min and pos_delta are used to store the minimum offset
338   and the delta to the maximum offset at the current point in the pattern.    
339
340 */
341
342 typedef struct scan_data_t {
343     /*I32 len_min;      unused */
344     /*I32 len_delta;    unused */
345     I32 pos_min;
346     I32 pos_delta;
347     SV *last_found;
348     I32 last_end;           /* min value, <0 unless valid. */
349     I32 last_start_min;
350     I32 last_start_max;
351     SV **longest;           /* Either &l_fixed, or &l_float. */
352     SV *longest_fixed;      /* longest fixed string found in pattern */
353     I32 offset_fixed;       /* offset where it starts */
354     I32 *minlen_fixed;      /* pointer to the minlen relevant to the string */
355     I32 lookbehind_fixed;   /* is the position of the string modfied by LB */
356     SV *longest_float;      /* longest floating string found in pattern */
357     I32 offset_float_min;   /* earliest point in string it can appear */
358     I32 offset_float_max;   /* latest point in string it can appear */
359     I32 *minlen_float;      /* pointer to the minlen relevant to the string */
360     I32 lookbehind_float;   /* is the position of the string modified by LB */
361     I32 flags;
362     I32 whilem_c;
363     I32 *last_closep;
364     struct regnode_charclass_class *start_class;
365 } scan_data_t;
366
367 /*
368  * Forward declarations for pregcomp()'s friends.
369  */
370
371 static const scan_data_t zero_scan_data =
372   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
373
374 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
375 #define SF_BEFORE_SEOL          0x0001
376 #define SF_BEFORE_MEOL          0x0002
377 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
378 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
379
380 #ifdef NO_UNARY_PLUS
381 #  define SF_FIX_SHIFT_EOL      (0+2)
382 #  define SF_FL_SHIFT_EOL               (0+4)
383 #else
384 #  define SF_FIX_SHIFT_EOL      (+2)
385 #  define SF_FL_SHIFT_EOL               (+4)
386 #endif
387
388 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
389 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
390
391 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
392 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
393 #define SF_IS_INF               0x0040
394 #define SF_HAS_PAR              0x0080
395 #define SF_IN_PAR               0x0100
396 #define SF_HAS_EVAL             0x0200
397 #define SCF_DO_SUBSTR           0x0400
398 #define SCF_DO_STCLASS_AND      0x0800
399 #define SCF_DO_STCLASS_OR       0x1000
400 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
401 #define SCF_WHILEM_VISITED_POS  0x2000
402
403 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
404 #define SCF_SEEN_ACCEPT         0x8000 
405
406 #define UTF cBOOL(RExC_utf8)
407
408 /* The enums for all these are ordered so things work out correctly */
409 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
410 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_DEPENDS_CHARSET)
411 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
412 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags) >= REGEX_UNICODE_CHARSET)
413 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_RESTRICTED_CHARSET)
414 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags) >= REGEX_ASCII_RESTRICTED_CHARSET)
415 #define ASCII_FOLD_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
416
417 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
418
419 #define OOB_NAMEDCLASS          -1
420
421 /* There is no code point that is out-of-bounds, so this is problematic.  But
422  * its only current use is to initialize a variable that is always set before
423  * looked at. */
424 #define OOB_UNICODE             0xDEADBEEF
425
426 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
427 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
428
429
430 /* length of regex to show in messages that don't mark a position within */
431 #define RegexLengthToShowInErrorMessages 127
432
433 /*
434  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
435  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
436  * op/pragma/warn/regcomp.
437  */
438 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
439 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
440
441 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
442
443 /*
444  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
445  * arg. Show regex, up to a maximum length. If it's too long, chop and add
446  * "...".
447  */
448 #define _FAIL(code) STMT_START {                                        \
449     const char *ellipses = "";                                          \
450     IV len = RExC_end - RExC_precomp;                                   \
451                                                                         \
452     if (!SIZE_ONLY)                                                     \
453         SAVEFREESV(RExC_rx_sv);                                         \
454     if (len > RegexLengthToShowInErrorMessages) {                       \
455         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
456         len = RegexLengthToShowInErrorMessages - 10;                    \
457         ellipses = "...";                                               \
458     }                                                                   \
459     code;                                                               \
460 } STMT_END
461
462 #define FAIL(msg) _FAIL(                            \
463     Perl_croak(aTHX_ "%s in regex m/%.*s%s/",       \
464             msg, (int)len, RExC_precomp, ellipses))
465
466 #define FAIL2(msg,arg) _FAIL(                       \
467     Perl_croak(aTHX_ msg " in regex m/%.*s%s/",     \
468             arg, (int)len, RExC_precomp, ellipses))
469
470 /*
471  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
472  */
473 #define Simple_vFAIL(m) STMT_START {                                    \
474     const IV offset = RExC_parse - RExC_precomp;                        \
475     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
476             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
477 } STMT_END
478
479 /*
480  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
481  */
482 #define vFAIL(m) STMT_START {                           \
483     if (!SIZE_ONLY)                                     \
484         SAVEFREESV(RExC_rx_sv);                         \
485     Simple_vFAIL(m);                                    \
486 } STMT_END
487
488 /*
489  * Like Simple_vFAIL(), but accepts two arguments.
490  */
491 #define Simple_vFAIL2(m,a1) STMT_START {                        \
492     const IV offset = RExC_parse - RExC_precomp;                        \
493     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1,                   \
494             (int)offset, RExC_precomp, RExC_precomp + offset);  \
495 } STMT_END
496
497 /*
498  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
499  */
500 #define vFAIL2(m,a1) STMT_START {                       \
501     if (!SIZE_ONLY)                                     \
502         SAVEFREESV(RExC_rx_sv);                         \
503     Simple_vFAIL2(m, a1);                               \
504 } STMT_END
505
506
507 /*
508  * Like Simple_vFAIL(), but accepts three arguments.
509  */
510 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
511     const IV offset = RExC_parse - RExC_precomp;                \
512     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2,               \
513             (int)offset, RExC_precomp, RExC_precomp + offset);  \
514 } STMT_END
515
516 /*
517  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
518  */
519 #define vFAIL3(m,a1,a2) STMT_START {                    \
520     if (!SIZE_ONLY)                                     \
521         SAVEFREESV(RExC_rx_sv);                         \
522     Simple_vFAIL3(m, a1, a2);                           \
523 } STMT_END
524
525 /*
526  * Like Simple_vFAIL(), but accepts four arguments.
527  */
528 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
529     const IV offset = RExC_parse - RExC_precomp;                \
530     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3,           \
531             (int)offset, RExC_precomp, RExC_precomp + offset);  \
532 } STMT_END
533
534 #define vFAIL4(m,a1,a2,a3) STMT_START {                 \
535     if (!SIZE_ONLY)                                     \
536         SAVEFREESV(RExC_rx_sv);                         \
537     Simple_vFAIL4(m, a1, a2, a3);                       \
538 } STMT_END
539
540 /* m is not necessarily a "literal string", in this macro */
541 #define reg_warn_non_literal_string(loc, m) STMT_START {                \
542     const IV offset = loc - RExC_precomp;                               \
543     Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s" REPORT_LOCATION,      \
544             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
545 } STMT_END
546
547 #define ckWARNreg(loc,m) STMT_START {                                   \
548     const IV offset = loc - RExC_precomp;                               \
549     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
550             (int)offset, RExC_precomp, RExC_precomp + offset);          \
551 } STMT_END
552
553 #define vWARN_dep(loc, m) STMT_START {                                  \
554     const IV offset = loc - RExC_precomp;                               \
555     Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), m REPORT_LOCATION,     \
556             (int)offset, RExC_precomp, RExC_precomp + offset);          \
557 } STMT_END
558
559 #define ckWARNdep(loc,m) STMT_START {                                   \
560     const IV offset = loc - RExC_precomp;                               \
561     Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),                   \
562             m REPORT_LOCATION,                                          \
563             (int)offset, RExC_precomp, RExC_precomp + offset);          \
564 } STMT_END
565
566 #define ckWARNregdep(loc,m) STMT_START {                                \
567     const IV offset = loc - RExC_precomp;                               \
568     Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),     \
569             m REPORT_LOCATION,                                          \
570             (int)offset, RExC_precomp, RExC_precomp + offset);          \
571 } STMT_END
572
573 #define ckWARN2regdep(loc,m, a1) STMT_START {                           \
574     const IV offset = loc - RExC_precomp;                               \
575     Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),     \
576             m REPORT_LOCATION,                                          \
577             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
578 } STMT_END
579
580 #define ckWARN2reg(loc, m, a1) STMT_START {                             \
581     const IV offset = loc - RExC_precomp;                               \
582     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
583             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
584 } STMT_END
585
586 #define vWARN3(loc, m, a1, a2) STMT_START {                             \
587     const IV offset = loc - RExC_precomp;                               \
588     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
589             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
590 } STMT_END
591
592 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                         \
593     const IV offset = loc - RExC_precomp;                               \
594     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
595             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
596 } STMT_END
597
598 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
599     const IV offset = loc - RExC_precomp;                               \
600     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
601             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
602 } STMT_END
603
604 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
605     const IV offset = loc - RExC_precomp;                               \
606     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
607             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
608 } STMT_END
609
610 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
611     const IV offset = loc - RExC_precomp;                               \
612     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
613             a1, a2, a3, a4, (int)offset, RExC_precomp, RExC_precomp + offset); \
614 } STMT_END
615
616
617 /* Allow for side effects in s */
618 #define REGC(c,s) STMT_START {                  \
619     if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
620 } STMT_END
621
622 /* Macros for recording node offsets.   20001227 mjd@plover.com 
623  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
624  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
625  * Element 0 holds the number n.
626  * Position is 1 indexed.
627  */
628 #ifndef RE_TRACK_PATTERN_OFFSETS
629 #define Set_Node_Offset_To_R(node,byte)
630 #define Set_Node_Offset(node,byte)
631 #define Set_Cur_Node_Offset
632 #define Set_Node_Length_To_R(node,len)
633 #define Set_Node_Length(node,len)
634 #define Set_Node_Cur_Length(node)
635 #define Node_Offset(n) 
636 #define Node_Length(n) 
637 #define Set_Node_Offset_Length(node,offset,len)
638 #define ProgLen(ri) ri->u.proglen
639 #define SetProgLen(ri,x) ri->u.proglen = x
640 #else
641 #define ProgLen(ri) ri->u.offsets[0]
642 #define SetProgLen(ri,x) ri->u.offsets[0] = x
643 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
644     if (! SIZE_ONLY) {                                                  \
645         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
646                     __LINE__, (int)(node), (int)(byte)));               \
647         if((node) < 0) {                                                \
648             Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \
649         } else {                                                        \
650             RExC_offsets[2*(node)-1] = (byte);                          \
651         }                                                               \
652     }                                                                   \
653 } STMT_END
654
655 #define Set_Node_Offset(node,byte) \
656     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
657 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
658
659 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
660     if (! SIZE_ONLY) {                                                  \
661         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
662                 __LINE__, (int)(node), (int)(len)));                    \
663         if((node) < 0) {                                                \
664             Perl_croak(aTHX_ "value of node is %d in Length macro", (int)(node)); \
665         } else {                                                        \
666             RExC_offsets[2*(node)] = (len);                             \
667         }                                                               \
668     }                                                                   \
669 } STMT_END
670
671 #define Set_Node_Length(node,len) \
672     Set_Node_Length_To_R((node)-RExC_emit_start, len)
673 #define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
674 #define Set_Node_Cur_Length(node) \
675     Set_Node_Length(node, RExC_parse - parse_start)
676
677 /* Get offsets and lengths */
678 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
679 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
680
681 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
682     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
683     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
684 } STMT_END
685 #endif
686
687 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
688 #define EXPERIMENTAL_INPLACESCAN
689 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
690
691 #define DEBUG_STUDYDATA(str,data,depth)                              \
692 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
693     PerlIO_printf(Perl_debug_log,                                    \
694         "%*s" str "Pos:%"IVdf"/%"IVdf                                \
695         " Flags: 0x%"UVXf" Whilem_c: %"IVdf" Lcp: %"IVdf" %s",       \
696         (int)(depth)*2, "",                                          \
697         (IV)((data)->pos_min),                                       \
698         (IV)((data)->pos_delta),                                     \
699         (UV)((data)->flags),                                         \
700         (IV)((data)->whilem_c),                                      \
701         (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
702         is_inf ? "INF " : ""                                         \
703     );                                                               \
704     if ((data)->last_found)                                          \
705         PerlIO_printf(Perl_debug_log,                                \
706             "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
707             " %sFloat: '%s' @ %"IVdf"/%"IVdf"",                      \
708             SvPVX_const((data)->last_found),                         \
709             (IV)((data)->last_end),                                  \
710             (IV)((data)->last_start_min),                            \
711             (IV)((data)->last_start_max),                            \
712             ((data)->longest &&                                      \
713              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
714             SvPVX_const((data)->longest_fixed),                      \
715             (IV)((data)->offset_fixed),                              \
716             ((data)->longest &&                                      \
717              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
718             SvPVX_const((data)->longest_float),                      \
719             (IV)((data)->offset_float_min),                          \
720             (IV)((data)->offset_float_max)                           \
721         );                                                           \
722     PerlIO_printf(Perl_debug_log,"\n");                              \
723 });
724
725 /* Mark that we cannot extend a found fixed substring at this point.
726    Update the longest found anchored substring and the longest found
727    floating substrings if needed. */
728
729 STATIC void
730 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp, int is_inf)
731 {
732     const STRLEN l = CHR_SVLEN(data->last_found);
733     const STRLEN old_l = CHR_SVLEN(*data->longest);
734     GET_RE_DEBUG_FLAGS_DECL;
735
736     PERL_ARGS_ASSERT_SCAN_COMMIT;
737
738     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
739         SvSetMagicSV(*data->longest, data->last_found);
740         if (*data->longest == data->longest_fixed) {
741             data->offset_fixed = l ? data->last_start_min : data->pos_min;
742             if (data->flags & SF_BEFORE_EOL)
743                 data->flags
744                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
745             else
746                 data->flags &= ~SF_FIX_BEFORE_EOL;
747             data->minlen_fixed=minlenp;
748             data->lookbehind_fixed=0;
749         }
750         else { /* *data->longest == data->longest_float */
751             data->offset_float_min = l ? data->last_start_min : data->pos_min;
752             data->offset_float_max = (l
753                                       ? data->last_start_max
754                                       : (data->pos_delta == I32_MAX ? I32_MAX : data->pos_min + data->pos_delta));
755             if (is_inf || (U32)data->offset_float_max > (U32)I32_MAX)
756                 data->offset_float_max = I32_MAX;
757             if (data->flags & SF_BEFORE_EOL)
758                 data->flags
759                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
760             else
761                 data->flags &= ~SF_FL_BEFORE_EOL;
762             data->minlen_float=minlenp;
763             data->lookbehind_float=0;
764         }
765     }
766     SvCUR_set(data->last_found, 0);
767     {
768         SV * const sv = data->last_found;
769         if (SvUTF8(sv) && SvMAGICAL(sv)) {
770             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
771             if (mg)
772                 mg->mg_len = 0;
773         }
774     }
775     data->last_end = -1;
776     data->flags &= ~SF_BEFORE_EOL;
777     DEBUG_STUDYDATA("commit: ",data,0);
778 }
779
780 /* These macros set, clear and test whether the synthetic start class ('ssc',
781  * given by the parameter) matches an empty string (EOS).  This uses the
782  * 'next_off' field in the node, to save a bit in the flags field.  The ssc
783  * stands alone, so there is never a next_off, so this field is otherwise
784  * unused.  The EOS information is used only for compilation, but theoretically
785  * it could be passed on to the execution code.  This could be used to store
786  * more than one bit of information, but only this one is currently used. */
787 #define SET_SSC_EOS(node)   STMT_START { (node)->next_off = TRUE; } STMT_END
788 #define CLEAR_SSC_EOS(node) STMT_START { (node)->next_off = FALSE; } STMT_END
789 #define TEST_SSC_EOS(node)  cBOOL((node)->next_off)
790
791 /* Can match anything (initialization) */
792 STATIC void
793 S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
794 {
795     PERL_ARGS_ASSERT_CL_ANYTHING;
796
797     ANYOF_BITMAP_SETALL(cl);
798     cl->flags = ANYOF_UNICODE_ALL;
799     SET_SSC_EOS(cl);
800
801     /* If any portion of the regex is to operate under locale rules,
802      * initialization includes it.  The reason this isn't done for all regexes
803      * is that the optimizer was written under the assumption that locale was
804      * all-or-nothing.  Given the complexity and lack of documentation in the
805      * optimizer, and that there are inadequate test cases for locale, so many
806      * parts of it may not work properly, it is safest to avoid locale unless
807      * necessary. */
808     if (RExC_contains_locale) {
809         ANYOF_CLASS_SETALL(cl);     /* /l uses class */
810         cl->flags |= ANYOF_LOCALE|ANYOF_CLASS|ANYOF_LOC_FOLD;
811     }
812     else {
813         ANYOF_CLASS_ZERO(cl);       /* Only /l uses class now */
814     }
815 }
816
817 /* Can match anything (initialization) */
818 STATIC int
819 S_cl_is_anything(const struct regnode_charclass_class *cl)
820 {
821     int value;
822
823     PERL_ARGS_ASSERT_CL_IS_ANYTHING;
824
825     for (value = 0; value < ANYOF_MAX; value += 2)
826         if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
827             return 1;
828     if (!(cl->flags & ANYOF_UNICODE_ALL))
829         return 0;
830     if (!ANYOF_BITMAP_TESTALLSET((const void*)cl))
831         return 0;
832     return 1;
833 }
834
835 /* Can match anything (initialization) */
836 STATIC void
837 S_cl_init(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
838 {
839     PERL_ARGS_ASSERT_CL_INIT;
840
841     Zero(cl, 1, struct regnode_charclass_class);
842     cl->type = ANYOF;
843     cl_anything(pRExC_state, cl);
844     ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
845 }
846
847 /* These two functions currently do the exact same thing */
848 #define cl_init_zero            S_cl_init
849
850 /* 'AND' a given class with another one.  Can create false positives.  'cl'
851  * should not be inverted.  'and_with->flags & ANYOF_CLASS' should be 0 if
852  * 'and_with' is a regnode_charclass instead of a regnode_charclass_class. */
853 STATIC void
854 S_cl_and(struct regnode_charclass_class *cl,
855         const struct regnode_charclass_class *and_with)
856 {
857     PERL_ARGS_ASSERT_CL_AND;
858
859     assert(PL_regkind[and_with->type] == ANYOF);
860
861     /* I (khw) am not sure all these restrictions are necessary XXX */
862     if (!(ANYOF_CLASS_TEST_ANY_SET(and_with))
863         && !(ANYOF_CLASS_TEST_ANY_SET(cl))
864         && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
865         && !(and_with->flags & ANYOF_LOC_FOLD)
866         && !(cl->flags & ANYOF_LOC_FOLD)) {
867         int i;
868
869         if (and_with->flags & ANYOF_INVERT)
870             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
871                 cl->bitmap[i] &= ~and_with->bitmap[i];
872         else
873             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
874                 cl->bitmap[i] &= and_with->bitmap[i];
875     } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
876
877     if (and_with->flags & ANYOF_INVERT) {
878
879         /* Here, the and'ed node is inverted.  Get the AND of the flags that
880          * aren't affected by the inversion.  Those that are affected are
881          * handled individually below */
882         U8 affected_flags = cl->flags & ~INVERSION_UNAFFECTED_FLAGS;
883         cl->flags &= (and_with->flags & INVERSION_UNAFFECTED_FLAGS);
884         cl->flags |= affected_flags;
885
886         /* We currently don't know how to deal with things that aren't in the
887          * bitmap, but we know that the intersection is no greater than what
888          * is already in cl, so let there be false positives that get sorted
889          * out after the synthetic start class succeeds, and the node is
890          * matched for real. */
891
892         /* The inversion of these two flags indicate that the resulting
893          * intersection doesn't have them */
894         if (and_with->flags & ANYOF_UNICODE_ALL) {
895             cl->flags &= ~ANYOF_UNICODE_ALL;
896         }
897         if (and_with->flags & ANYOF_NON_UTF8_LATIN1_ALL) {
898             cl->flags &= ~ANYOF_NON_UTF8_LATIN1_ALL;
899         }
900     }
901     else {   /* and'd node is not inverted */
902         U8 outside_bitmap_but_not_utf8; /* Temp variable */
903
904         if (! ANYOF_NONBITMAP(and_with)) {
905
906             /* Here 'and_with' doesn't match anything outside the bitmap
907              * (except possibly ANYOF_UNICODE_ALL), which means the
908              * intersection can't either, except for ANYOF_UNICODE_ALL, in
909              * which case we don't know what the intersection is, but it's no
910              * greater than what cl already has, so can just leave it alone,
911              * with possible false positives */
912             if (! (and_with->flags & ANYOF_UNICODE_ALL)) {
913                 ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
914                 cl->flags &= ~ANYOF_NONBITMAP_NON_UTF8;
915             }
916         }
917         else if (! ANYOF_NONBITMAP(cl)) {
918
919             /* Here, 'and_with' does match something outside the bitmap, and cl
920              * doesn't have a list of things to match outside the bitmap.  If
921              * cl can match all code points above 255, the intersection will
922              * be those above-255 code points that 'and_with' matches.  If cl
923              * can't match all Unicode code points, it means that it can't
924              * match anything outside the bitmap (since the 'if' that got us
925              * into this block tested for that), so we leave the bitmap empty.
926              */
927             if (cl->flags & ANYOF_UNICODE_ALL) {
928                 ARG_SET(cl, ARG(and_with));
929
930                 /* and_with's ARG may match things that don't require UTF8.
931                  * And now cl's will too, in spite of this being an 'and'.  See
932                  * the comments below about the kludge */
933                 cl->flags |= and_with->flags & ANYOF_NONBITMAP_NON_UTF8;
934             }
935         }
936         else {
937             /* Here, both 'and_with' and cl match something outside the
938              * bitmap.  Currently we do not do the intersection, so just match
939              * whatever cl had at the beginning.  */
940         }
941
942
943         /* Take the intersection of the two sets of flags.  However, the
944          * ANYOF_NONBITMAP_NON_UTF8 flag is treated as an 'or'.  This is a
945          * kludge around the fact that this flag is not treated like the others
946          * which are initialized in cl_anything().  The way the optimizer works
947          * is that the synthetic start class (SSC) is initialized to match
948          * anything, and then the first time a real node is encountered, its
949          * values are AND'd with the SSC's with the result being the values of
950          * the real node.  However, there are paths through the optimizer where
951          * the AND never gets called, so those initialized bits are set
952          * inappropriately, which is not usually a big deal, as they just cause
953          * false positives in the SSC, which will just mean a probably
954          * imperceptible slow down in execution.  However this bit has a
955          * higher false positive consequence in that it can cause utf8.pm,
956          * utf8_heavy.pl ... to be loaded when not necessary, which is a much
957          * bigger slowdown and also causes significant extra memory to be used.
958          * In order to prevent this, the code now takes a different tack.  The
959          * bit isn't set unless some part of the regular expression needs it,
960          * but once set it won't get cleared.  This means that these extra
961          * modules won't get loaded unless there was some path through the
962          * pattern that would have required them anyway, and  so any false
963          * positives that occur by not ANDing them out when they could be
964          * aren't as severe as they would be if we treated this bit like all
965          * the others */
966         outside_bitmap_but_not_utf8 = (cl->flags | and_with->flags)
967                                       & ANYOF_NONBITMAP_NON_UTF8;
968         cl->flags &= and_with->flags;
969         cl->flags |= outside_bitmap_but_not_utf8;
970     }
971 }
972
973 /* 'OR' a given class with another one.  Can create false positives.  'cl'
974  * should not be inverted.  'or_with->flags & ANYOF_CLASS' should be 0 if
975  * 'or_with' is a regnode_charclass instead of a regnode_charclass_class. */
976 STATIC void
977 S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
978 {
979     PERL_ARGS_ASSERT_CL_OR;
980
981     if (or_with->flags & ANYOF_INVERT) {
982
983         /* Here, the or'd node is to be inverted.  This means we take the
984          * complement of everything not in the bitmap, but currently we don't
985          * know what that is, so give up and match anything */
986         if (ANYOF_NONBITMAP(or_with)) {
987             cl_anything(pRExC_state, cl);
988         }
989         /* We do not use
990          * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
991          *   <= (B1 | !B2) | (CL1 | !CL2)
992          * which is wasteful if CL2 is small, but we ignore CL2:
993          *   (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
994          * XXXX Can we handle case-fold?  Unclear:
995          *   (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
996          *   (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
997          */
998         else if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
999              && !(or_with->flags & ANYOF_LOC_FOLD)
1000              && !(cl->flags & ANYOF_LOC_FOLD) ) {
1001             int i;
1002
1003             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
1004                 cl->bitmap[i] |= ~or_with->bitmap[i];
1005         } /* XXXX: logic is complicated otherwise */
1006         else {
1007             cl_anything(pRExC_state, cl);
1008         }
1009
1010         /* And, we can just take the union of the flags that aren't affected
1011          * by the inversion */
1012         cl->flags |= or_with->flags & INVERSION_UNAFFECTED_FLAGS;
1013
1014         /* For the remaining flags:
1015             ANYOF_UNICODE_ALL and inverted means to not match anything above
1016                     255, which means that the union with cl should just be
1017                     what cl has in it, so can ignore this flag
1018             ANYOF_NON_UTF8_LATIN1_ALL and inverted means if not utf8 and ord
1019                     is 127-255 to match them, but then invert that, so the
1020                     union with cl should just be what cl has in it, so can
1021                     ignore this flag
1022          */
1023     } else {    /* 'or_with' is not inverted */
1024         /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
1025         if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
1026              && (!(or_with->flags & ANYOF_LOC_FOLD)
1027                  || (cl->flags & ANYOF_LOC_FOLD)) ) {
1028             int i;
1029
1030             /* OR char bitmap and class bitmap separately */
1031             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
1032                 cl->bitmap[i] |= or_with->bitmap[i];
1033             if (or_with->flags & ANYOF_CLASS) {
1034                 ANYOF_CLASS_OR(or_with, cl);
1035             }
1036         }
1037         else { /* XXXX: logic is complicated, leave it along for a moment. */
1038             cl_anything(pRExC_state, cl);
1039         }
1040
1041         if (ANYOF_NONBITMAP(or_with)) {
1042
1043             /* Use the added node's outside-the-bit-map match if there isn't a
1044              * conflict.  If there is a conflict (both nodes match something
1045              * outside the bitmap, but what they match outside is not the same
1046              * pointer, and hence not easily compared until XXX we extend
1047              * inversion lists this far), give up and allow the start class to
1048              * match everything outside the bitmap.  If that stuff is all above
1049              * 255, can just set UNICODE_ALL, otherwise caould be anything. */
1050             if (! ANYOF_NONBITMAP(cl)) {
1051                 ARG_SET(cl, ARG(or_with));
1052             }
1053             else if (ARG(cl) != ARG(or_with)) {
1054
1055                 if ((or_with->flags & ANYOF_NONBITMAP_NON_UTF8)) {
1056                     cl_anything(pRExC_state, cl);
1057                 }
1058                 else {
1059                     cl->flags |= ANYOF_UNICODE_ALL;
1060                 }
1061             }
1062         }
1063
1064         /* Take the union */
1065         cl->flags |= or_with->flags;
1066     }
1067 }
1068
1069 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1070 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
1071 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1072 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list ? (TRIE_LIST_CUR( idx ) - 1) : 0 )
1073
1074
1075 #ifdef DEBUGGING
1076 /*
1077    dump_trie(trie,widecharmap,revcharmap)
1078    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1079    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1080
1081    These routines dump out a trie in a somewhat readable format.
1082    The _interim_ variants are used for debugging the interim
1083    tables that are used to generate the final compressed
1084    representation which is what dump_trie expects.
1085
1086    Part of the reason for their existence is to provide a form
1087    of documentation as to how the different representations function.
1088
1089 */
1090
1091 /*
1092   Dumps the final compressed table form of the trie to Perl_debug_log.
1093   Used for debugging make_trie().
1094 */
1095
1096 STATIC void
1097 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1098             AV *revcharmap, U32 depth)
1099 {
1100     U32 state;
1101     SV *sv=sv_newmortal();
1102     int colwidth= widecharmap ? 6 : 4;
1103     U16 word;
1104     GET_RE_DEBUG_FLAGS_DECL;
1105
1106     PERL_ARGS_ASSERT_DUMP_TRIE;
1107
1108     PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
1109         (int)depth * 2 + 2,"",
1110         "Match","Base","Ofs" );
1111
1112     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1113         SV ** const tmp = av_fetch( revcharmap, state, 0);
1114         if ( tmp ) {
1115             PerlIO_printf( Perl_debug_log, "%*s", 
1116                 colwidth,
1117                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1118                             PL_colors[0], PL_colors[1],
1119                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1120                             PERL_PV_ESCAPE_FIRSTCHAR 
1121                 ) 
1122             );
1123         }
1124     }
1125     PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
1126         (int)depth * 2 + 2,"");
1127
1128     for( state = 0 ; state < trie->uniquecharcount ; state++ )
1129         PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
1130     PerlIO_printf( Perl_debug_log, "\n");
1131
1132     for( state = 1 ; state < trie->statecount ; state++ ) {
1133         const U32 base = trie->states[ state ].trans.base;
1134
1135         PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state);
1136
1137         if ( trie->states[ state ].wordnum ) {
1138             PerlIO_printf( Perl_debug_log, " W%4X", trie->states[ state ].wordnum );
1139         } else {
1140             PerlIO_printf( Perl_debug_log, "%6s", "" );
1141         }
1142
1143         PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
1144
1145         if ( base ) {
1146             U32 ofs = 0;
1147
1148             while( ( base + ofs  < trie->uniquecharcount ) ||
1149                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
1150                      && trie->trans[ base + ofs - trie->uniquecharcount ].check != state))
1151                     ofs++;
1152
1153             PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
1154
1155             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
1156                 if ( ( base + ofs >= trie->uniquecharcount ) &&
1157                      ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
1158                      trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
1159                 {
1160                    PerlIO_printf( Perl_debug_log, "%*"UVXf,
1161                     colwidth,
1162                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
1163                 } else {
1164                     PerlIO_printf( Perl_debug_log, "%*s",colwidth,"   ." );
1165                 }
1166             }
1167
1168             PerlIO_printf( Perl_debug_log, "]");
1169
1170         }
1171         PerlIO_printf( Perl_debug_log, "\n" );
1172     }
1173     PerlIO_printf(Perl_debug_log, "%*sword_info N:(prev,len)=", (int)depth*2, "");
1174     for (word=1; word <= trie->wordcount; word++) {
1175         PerlIO_printf(Perl_debug_log, " %d:(%d,%d)",
1176             (int)word, (int)(trie->wordinfo[word].prev),
1177             (int)(trie->wordinfo[word].len));
1178     }
1179     PerlIO_printf(Perl_debug_log, "\n" );
1180 }    
1181 /*
1182   Dumps a fully constructed but uncompressed trie in list form.
1183   List tries normally only are used for construction when the number of 
1184   possible chars (trie->uniquecharcount) is very high.
1185   Used for debugging make_trie().
1186 */
1187 STATIC void
1188 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
1189                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
1190                          U32 depth)
1191 {
1192     U32 state;
1193     SV *sv=sv_newmortal();
1194     int colwidth= widecharmap ? 6 : 4;
1195     GET_RE_DEBUG_FLAGS_DECL;
1196
1197     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
1198
1199     /* print out the table precompression.  */
1200     PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
1201         (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
1202         "------:-----+-----------------\n" );
1203     
1204     for( state=1 ; state < next_alloc ; state ++ ) {
1205         U16 charid;
1206     
1207         PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
1208             (int)depth * 2 + 2,"", (UV)state  );
1209         if ( ! trie->states[ state ].wordnum ) {
1210             PerlIO_printf( Perl_debug_log, "%5s| ","");
1211         } else {
1212             PerlIO_printf( Perl_debug_log, "W%4x| ",
1213                 trie->states[ state ].wordnum
1214             );
1215         }
1216         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
1217             SV ** const tmp = av_fetch( revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
1218             if ( tmp ) {
1219                 PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
1220                     colwidth,
1221                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1222                             PL_colors[0], PL_colors[1],
1223                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1224                             PERL_PV_ESCAPE_FIRSTCHAR 
1225                     ) ,
1226                     TRIE_LIST_ITEM(state,charid).forid,
1227                     (UV)TRIE_LIST_ITEM(state,charid).newstate
1228                 );
1229                 if (!(charid % 10)) 
1230                     PerlIO_printf(Perl_debug_log, "\n%*s| ",
1231                         (int)((depth * 2) + 14), "");
1232             }
1233         }
1234         PerlIO_printf( Perl_debug_log, "\n");
1235     }
1236 }    
1237
1238 /*
1239   Dumps a fully constructed but uncompressed trie in table form.
1240   This is the normal DFA style state transition table, with a few 
1241   twists to facilitate compression later. 
1242   Used for debugging make_trie().
1243 */
1244 STATIC void
1245 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
1246                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
1247                           U32 depth)
1248 {
1249     U32 state;
1250     U16 charid;
1251     SV *sv=sv_newmortal();
1252     int colwidth= widecharmap ? 6 : 4;
1253     GET_RE_DEBUG_FLAGS_DECL;
1254
1255     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
1256     
1257     /*
1258        print out the table precompression so that we can do a visual check
1259        that they are identical.
1260      */
1261     
1262     PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
1263
1264     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1265         SV ** const tmp = av_fetch( revcharmap, charid, 0);
1266         if ( tmp ) {
1267             PerlIO_printf( Perl_debug_log, "%*s", 
1268                 colwidth,
1269                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1270                             PL_colors[0], PL_colors[1],
1271                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1272                             PERL_PV_ESCAPE_FIRSTCHAR 
1273                 ) 
1274             );
1275         }
1276     }
1277
1278     PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
1279
1280     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
1281         PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
1282     }
1283
1284     PerlIO_printf( Perl_debug_log, "\n" );
1285
1286     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
1287
1288         PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ", 
1289             (int)depth * 2 + 2,"",
1290             (UV)TRIE_NODENUM( state ) );
1291
1292         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1293             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
1294             if (v)
1295                 PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
1296             else
1297                 PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
1298         }
1299         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1300             PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check );
1301         } else {
1302             PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n", (UV)trie->trans[ state ].check,
1303             trie->states[ TRIE_NODENUM( state ) ].wordnum );
1304         }
1305     }
1306 }
1307
1308 #endif
1309
1310
1311 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
1312   startbranch: the first branch in the whole branch sequence
1313   first      : start branch of sequence of branch-exact nodes.
1314                May be the same as startbranch
1315   last       : Thing following the last branch.
1316                May be the same as tail.
1317   tail       : item following the branch sequence
1318   count      : words in the sequence
1319   flags      : currently the OP() type we will be building one of /EXACT(|F|Fl)/
1320   depth      : indent depth
1321
1322 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
1323
1324 A trie is an N'ary tree where the branches are determined by digital
1325 decomposition of the key. IE, at the root node you look up the 1st character and
1326 follow that branch repeat until you find the end of the branches. Nodes can be
1327 marked as "accepting" meaning they represent a complete word. Eg:
1328
1329   /he|she|his|hers/
1330
1331 would convert into the following structure. Numbers represent states, letters
1332 following numbers represent valid transitions on the letter from that state, if
1333 the number is in square brackets it represents an accepting state, otherwise it
1334 will be in parenthesis.
1335
1336       +-h->+-e->[3]-+-r->(8)-+-s->[9]
1337       |    |
1338       |   (2)
1339       |    |
1340      (1)   +-i->(6)-+-s->[7]
1341       |
1342       +-s->(3)-+-h->(4)-+-e->[5]
1343
1344       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
1345
1346 This shows that when matching against the string 'hers' we will begin at state 1
1347 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
1348 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
1349 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
1350 single traverse. We store a mapping from accepting to state to which word was
1351 matched, and then when we have multiple possibilities we try to complete the
1352 rest of the regex in the order in which they occured in the alternation.
1353
1354 The only prior NFA like behaviour that would be changed by the TRIE support is
1355 the silent ignoring of duplicate alternations which are of the form:
1356
1357  / (DUPE|DUPE) X? (?{ ... }) Y /x
1358
1359 Thus EVAL blocks following a trie may be called a different number of times with
1360 and without the optimisation. With the optimisations dupes will be silently
1361 ignored. This inconsistent behaviour of EVAL type nodes is well established as
1362 the following demonstrates:
1363
1364  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
1365
1366 which prints out 'word' three times, but
1367
1368  'words'=~/(word|word|word)(?{ print $1 })S/
1369
1370 which doesnt print it out at all. This is due to other optimisations kicking in.
1371
1372 Example of what happens on a structural level:
1373
1374 The regexp /(ac|ad|ab)+/ will produce the following debug output:
1375
1376    1: CURLYM[1] {1,32767}(18)
1377    5:   BRANCH(8)
1378    6:     EXACT <ac>(16)
1379    8:   BRANCH(11)
1380    9:     EXACT <ad>(16)
1381   11:   BRANCH(14)
1382   12:     EXACT <ab>(16)
1383   16:   SUCCEED(0)
1384   17:   NOTHING(18)
1385   18: END(0)
1386
1387 This would be optimizable with startbranch=5, first=5, last=16, tail=16
1388 and should turn into:
1389
1390    1: CURLYM[1] {1,32767}(18)
1391    5:   TRIE(16)
1392         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
1393           <ac>
1394           <ad>
1395           <ab>
1396   16:   SUCCEED(0)
1397   17:   NOTHING(18)
1398   18: END(0)
1399
1400 Cases where tail != last would be like /(?foo|bar)baz/:
1401
1402    1: BRANCH(4)
1403    2:   EXACT <foo>(8)
1404    4: BRANCH(7)
1405    5:   EXACT <bar>(8)
1406    7: TAIL(8)
1407    8: EXACT <baz>(10)
1408   10: END(0)
1409
1410 which would be optimizable with startbranch=1, first=1, last=7, tail=8
1411 and would end up looking like:
1412
1413     1: TRIE(8)
1414       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
1415         <foo>
1416         <bar>
1417    7: TAIL(8)
1418    8: EXACT <baz>(10)
1419   10: END(0)
1420
1421     d = uvuni_to_utf8_flags(d, uv, 0);
1422
1423 is the recommended Unicode-aware way of saying
1424
1425     *(d++) = uv;
1426 */
1427
1428 #define TRIE_STORE_REVCHAR(val)                                            \
1429     STMT_START {                                                           \
1430         if (UTF) {                                                         \
1431             SV *zlopp = newSV(7); /* XXX: optimize me */                   \
1432             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
1433             unsigned const char *const kapow = uvuni_to_utf8(flrbbbbb, val); \
1434             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
1435             SvPOK_on(zlopp);                                               \
1436             SvUTF8_on(zlopp);                                              \
1437             av_push(revcharmap, zlopp);                                    \
1438         } else {                                                           \
1439             char ooooff = (char)val;                                           \
1440             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
1441         }                                                                  \
1442         } STMT_END
1443
1444 #define TRIE_READ_CHAR STMT_START {                                                     \
1445     wordlen++;                                                                          \
1446     if ( UTF ) {                                                                        \
1447         /* if it is UTF then it is either already folded, or does not need folding */   \
1448         uvc = utf8n_to_uvuni( (const U8*) uc, UTF8_MAXLEN, &len, uniflags);             \
1449     }                                                                                   \
1450     else if (folder == PL_fold_latin1) {                                                \
1451         /* if we use this folder we have to obey unicode rules on latin-1 data */       \
1452         if ( foldlen > 0 ) {                                                            \
1453            uvc = utf8n_to_uvuni( (const U8*) scan, UTF8_MAXLEN, &len, uniflags );       \
1454            foldlen -= len;                                                              \
1455            scan += len;                                                                 \
1456            len = 0;                                                                     \
1457         } else {                                                                        \
1458             len = 1;                                                                    \
1459             uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, 1);                     \
1460             skiplen = UNISKIP(uvc);                                                     \
1461             foldlen -= skiplen;                                                         \
1462             scan = foldbuf + skiplen;                                                   \
1463         }                                                                               \
1464     } else {                                                                            \
1465         /* raw data, will be folded later if needed */                                  \
1466         uvc = (U32)*uc;                                                                 \
1467         len = 1;                                                                        \
1468     }                                                                                   \
1469 } STMT_END
1470
1471
1472
1473 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
1474     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
1475         U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
1476         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
1477     }                                                           \
1478     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
1479     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
1480     TRIE_LIST_CUR( state )++;                                   \
1481 } STMT_END
1482
1483 #define TRIE_LIST_NEW(state) STMT_START {                       \
1484     Newxz( trie->states[ state ].trans.list,               \
1485         4, reg_trie_trans_le );                                 \
1486      TRIE_LIST_CUR( state ) = 1;                                \
1487      TRIE_LIST_LEN( state ) = 4;                                \
1488 } STMT_END
1489
1490 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
1491     U16 dupe= trie->states[ state ].wordnum;                    \
1492     regnode * const noper_next = regnext( noper );              \
1493                                                                 \
1494     DEBUG_r({                                                   \
1495         /* store the word for dumping */                        \
1496         SV* tmp;                                                \
1497         if (OP(noper) != NOTHING)                               \
1498             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
1499         else                                                    \
1500             tmp = newSVpvn_utf8( "", 0, UTF );                  \
1501         av_push( trie_words, tmp );                             \
1502     });                                                         \
1503                                                                 \
1504     curword++;                                                  \
1505     trie->wordinfo[curword].prev   = 0;                         \
1506     trie->wordinfo[curword].len    = wordlen;                   \
1507     trie->wordinfo[curword].accept = state;                     \
1508                                                                 \
1509     if ( noper_next < tail ) {                                  \
1510         if (!trie->jump)                                        \
1511             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, sizeof(U16) ); \
1512         trie->jump[curword] = (U16)(noper_next - convert);      \
1513         if (!jumper)                                            \
1514             jumper = noper_next;                                \
1515         if (!nextbranch)                                        \
1516             nextbranch= regnext(cur);                           \
1517     }                                                           \
1518                                                                 \
1519     if ( dupe ) {                                               \
1520         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
1521         /* chain, so that when the bits of chain are later    */\
1522         /* linked together, the dups appear in the chain      */\
1523         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
1524         trie->wordinfo[dupe].prev = curword;                    \
1525     } else {                                                    \
1526         /* we haven't inserted this word yet.                */ \
1527         trie->states[ state ].wordnum = curword;                \
1528     }                                                           \
1529 } STMT_END
1530
1531
1532 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
1533      ( ( base + charid >=  ucharcount                                   \
1534          && base + charid < ubound                                      \
1535          && state == trie->trans[ base - ucharcount + charid ].check    \
1536          && trie->trans[ base - ucharcount + charid ].next )            \
1537            ? trie->trans[ base - ucharcount + charid ].next             \
1538            : ( state==1 ? special : 0 )                                 \
1539       )
1540
1541 #define MADE_TRIE       1
1542 #define MADE_JUMP_TRIE  2
1543 #define MADE_EXACT_TRIE 4
1544
1545 STATIC I32
1546 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth)
1547 {
1548     dVAR;
1549     /* first pass, loop through and scan words */
1550     reg_trie_data *trie;
1551     HV *widecharmap = NULL;
1552     AV *revcharmap = newAV();
1553     regnode *cur;
1554     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1555     STRLEN len = 0;
1556     UV uvc = 0;
1557     U16 curword = 0;
1558     U32 next_alloc = 0;
1559     regnode *jumper = NULL;
1560     regnode *nextbranch = NULL;
1561     regnode *convert = NULL;
1562     U32 *prev_states; /* temp array mapping each state to previous one */
1563     /* we just use folder as a flag in utf8 */
1564     const U8 * folder = NULL;
1565
1566 #ifdef DEBUGGING
1567     const U32 data_slot = add_data( pRExC_state, 4, "tuuu" );
1568     AV *trie_words = NULL;
1569     /* along with revcharmap, this only used during construction but both are
1570      * useful during debugging so we store them in the struct when debugging.
1571      */
1572 #else
1573     const U32 data_slot = add_data( pRExC_state, 2, "tu" );
1574     STRLEN trie_charcount=0;
1575 #endif
1576     SV *re_trie_maxbuff;
1577     GET_RE_DEBUG_FLAGS_DECL;
1578
1579     PERL_ARGS_ASSERT_MAKE_TRIE;
1580 #ifndef DEBUGGING
1581     PERL_UNUSED_ARG(depth);
1582 #endif
1583
1584     switch (flags) {
1585         case EXACT: break;
1586         case EXACTFA:
1587         case EXACTFU_SS:
1588         case EXACTFU_TRICKYFOLD:
1589         case EXACTFU: folder = PL_fold_latin1; break;
1590         case EXACTF:  folder = PL_fold; break;
1591         case EXACTFL: folder = PL_fold_locale; break;
1592         default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
1593     }
1594
1595     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
1596     trie->refcount = 1;
1597     trie->startstate = 1;
1598     trie->wordcount = word_count;
1599     RExC_rxi->data->data[ data_slot ] = (void*)trie;
1600     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
1601     if (flags == EXACT)
1602         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
1603     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
1604                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
1605
1606     DEBUG_r({
1607         trie_words = newAV();
1608     });
1609
1610     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
1611     if (!SvIOK(re_trie_maxbuff)) {
1612         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
1613     }
1614     DEBUG_TRIE_COMPILE_r({
1615                 PerlIO_printf( Perl_debug_log,
1616                   "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
1617                   (int)depth * 2 + 2, "", 
1618                   REG_NODE_NUM(startbranch),REG_NODE_NUM(first), 
1619                   REG_NODE_NUM(last), REG_NODE_NUM(tail),
1620                   (int)depth);
1621     });
1622    
1623    /* Find the node we are going to overwrite */
1624     if ( first == startbranch && OP( last ) != BRANCH ) {
1625         /* whole branch chain */
1626         convert = first;
1627     } else {
1628         /* branch sub-chain */
1629         convert = NEXTOPER( first );
1630     }
1631         
1632     /*  -- First loop and Setup --
1633
1634        We first traverse the branches and scan each word to determine if it
1635        contains widechars, and how many unique chars there are, this is
1636        important as we have to build a table with at least as many columns as we
1637        have unique chars.
1638
1639        We use an array of integers to represent the character codes 0..255
1640        (trie->charmap) and we use a an HV* to store Unicode characters. We use the
1641        native representation of the character value as the key and IV's for the
1642        coded index.
1643
1644        *TODO* If we keep track of how many times each character is used we can
1645        remap the columns so that the table compression later on is more
1646        efficient in terms of memory by ensuring the most common value is in the
1647        middle and the least common are on the outside.  IMO this would be better
1648        than a most to least common mapping as theres a decent chance the most
1649        common letter will share a node with the least common, meaning the node
1650        will not be compressible. With a middle is most common approach the worst
1651        case is when we have the least common nodes twice.
1652
1653      */
1654
1655     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1656         regnode *noper = NEXTOPER( cur );
1657         const U8 *uc = (U8*)STRING( noper );
1658         const U8 *e  = uc + STR_LEN( noper );
1659         STRLEN foldlen = 0;
1660         U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1661         STRLEN skiplen = 0;
1662         const U8 *scan = (U8*)NULL;
1663         U32 wordlen      = 0;         /* required init */
1664         STRLEN chars = 0;
1665         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the bitmap?*/
1666
1667         if (OP(noper) == NOTHING) {
1668             regnode *noper_next= regnext(noper);
1669             if (noper_next != tail && OP(noper_next) == flags) {
1670                 noper = noper_next;
1671                 uc= (U8*)STRING(noper);
1672                 e= uc + STR_LEN(noper);
1673                 trie->minlen= STR_LEN(noper);
1674             } else {
1675                 trie->minlen= 0;
1676                 continue;
1677             }
1678         }
1679
1680         if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
1681             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
1682                                           regardless of encoding */
1683             if (OP( noper ) == EXACTFU_SS) {
1684                 /* false positives are ok, so just set this */
1685                 TRIE_BITMAP_SET(trie,0xDF);
1686             }
1687         }
1688         for ( ; uc < e ; uc += len ) {
1689             TRIE_CHARCOUNT(trie)++;
1690             TRIE_READ_CHAR;
1691             chars++;
1692             if ( uvc < 256 ) {
1693                 if ( folder ) {
1694                     U8 folded= folder[ (U8) uvc ];
1695                     if ( !trie->charmap[ folded ] ) {
1696                         trie->charmap[ folded ]=( ++trie->uniquecharcount );
1697                         TRIE_STORE_REVCHAR( folded );
1698                     }
1699                 }
1700                 if ( !trie->charmap[ uvc ] ) {
1701                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
1702                     TRIE_STORE_REVCHAR( uvc );
1703                 }
1704                 if ( set_bit ) {
1705                     /* store the codepoint in the bitmap, and its folded
1706                      * equivalent. */
1707                     TRIE_BITMAP_SET(trie, uvc);
1708
1709                     /* store the folded codepoint */
1710                     if ( folder ) TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);
1711
1712                     if ( !UTF ) {
1713                         /* store first byte of utf8 representation of
1714                            variant codepoints */
1715                         if (! UNI_IS_INVARIANT(uvc)) {
1716                             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));
1717                         }
1718                     }
1719                     set_bit = 0; /* We've done our bit :-) */
1720                 }
1721             } else {
1722                 SV** svpp;
1723                 if ( !widecharmap )
1724                     widecharmap = newHV();
1725
1726                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
1727
1728                 if ( !svpp )
1729                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
1730
1731                 if ( !SvTRUE( *svpp ) ) {
1732                     sv_setiv( *svpp, ++trie->uniquecharcount );
1733                     TRIE_STORE_REVCHAR(uvc);
1734                 }
1735             }
1736         }
1737         if( cur == first ) {
1738             trie->minlen = chars;
1739             trie->maxlen = chars;
1740         } else if (chars < trie->minlen) {
1741             trie->minlen = chars;
1742         } else if (chars > trie->maxlen) {
1743             trie->maxlen = chars;
1744         }
1745         if (OP( noper ) == EXACTFU_SS) {
1746             /* XXX: workaround - 'ss' could match "\x{DF}" so minlen could be 1 and not 2*/
1747             if (trie->minlen > 1)
1748                 trie->minlen= 1;
1749         }
1750         if (OP( noper ) == EXACTFU_TRICKYFOLD) {
1751             /* XXX: workround - things like "\x{1FBE}\x{0308}\x{0301}" can match "\x{0390}" 
1752              *                - We assume that any such sequence might match a 2 byte string */
1753             if (trie->minlen > 2 )
1754                 trie->minlen= 2;
1755         }
1756
1757     } /* end first pass */
1758     DEBUG_TRIE_COMPILE_r(
1759         PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
1760                 (int)depth * 2 + 2,"",
1761                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
1762                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
1763                 (int)trie->minlen, (int)trie->maxlen )
1764     );
1765
1766     /*
1767         We now know what we are dealing with in terms of unique chars and
1768         string sizes so we can calculate how much memory a naive
1769         representation using a flat table  will take. If it's over a reasonable
1770         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
1771         conservative but potentially much slower representation using an array
1772         of lists.
1773
1774         At the end we convert both representations into the same compressed
1775         form that will be used in regexec.c for matching with. The latter
1776         is a form that cannot be used to construct with but has memory
1777         properties similar to the list form and access properties similar
1778         to the table form making it both suitable for fast searches and
1779         small enough that its feasable to store for the duration of a program.
1780
1781         See the comment in the code where the compressed table is produced
1782         inplace from the flat tabe representation for an explanation of how
1783         the compression works.
1784
1785     */
1786
1787
1788     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
1789     prev_states[1] = 0;
1790
1791     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1) > SvIV(re_trie_maxbuff) ) {
1792         /*
1793             Second Pass -- Array Of Lists Representation
1794
1795             Each state will be represented by a list of charid:state records
1796             (reg_trie_trans_le) the first such element holds the CUR and LEN
1797             points of the allocated array. (See defines above).
1798
1799             We build the initial structure using the lists, and then convert
1800             it into the compressed table form which allows faster lookups
1801             (but cant be modified once converted).
1802         */
1803
1804         STRLEN transcount = 1;
1805
1806         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
1807             "%*sCompiling trie using list compiler\n",
1808             (int)depth * 2 + 2, ""));
1809
1810         trie->states = (reg_trie_state *)
1811             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1812                                   sizeof(reg_trie_state) );
1813         TRIE_LIST_NEW(1);
1814         next_alloc = 2;
1815
1816         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1817
1818             regnode *noper   = NEXTOPER( cur );
1819             U8 *uc           = (U8*)STRING( noper );
1820             const U8 *e      = uc + STR_LEN( noper );
1821             U32 state        = 1;         /* required init */
1822             U16 charid       = 0;         /* sanity init */
1823             U8 *scan         = (U8*)NULL; /* sanity init */
1824             STRLEN foldlen   = 0;         /* required init */
1825             U32 wordlen      = 0;         /* required init */
1826             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1827             STRLEN skiplen   = 0;
1828
1829             if (OP(noper) == NOTHING) {
1830                 regnode *noper_next= regnext(noper);
1831                 if (noper_next != tail && OP(noper_next) == flags) {
1832                     noper = noper_next;
1833                     uc= (U8*)STRING(noper);
1834                     e= uc + STR_LEN(noper);
1835                 }
1836             }
1837
1838             if (OP(noper) != NOTHING) {
1839                 for ( ; uc < e ; uc += len ) {
1840
1841                     TRIE_READ_CHAR;
1842
1843                     if ( uvc < 256 ) {
1844                         charid = trie->charmap[ uvc ];
1845                     } else {
1846                         SV** const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1847                         if ( !svpp ) {
1848                             charid = 0;
1849                         } else {
1850                             charid=(U16)SvIV( *svpp );
1851                         }
1852                     }
1853                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
1854                     if ( charid ) {
1855
1856                         U16 check;
1857                         U32 newstate = 0;
1858
1859                         charid--;
1860                         if ( !trie->states[ state ].trans.list ) {
1861                             TRIE_LIST_NEW( state );
1862                         }
1863                         for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) {
1864                             if ( TRIE_LIST_ITEM( state, check ).forid == charid ) {
1865                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
1866                                 break;
1867                             }
1868                         }
1869                         if ( ! newstate ) {
1870                             newstate = next_alloc++;
1871                             prev_states[newstate] = state;
1872                             TRIE_LIST_PUSH( state, charid, newstate );
1873                             transcount++;
1874                         }
1875                         state = newstate;
1876                     } else {
1877                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1878                     }
1879                 }
1880             }
1881             TRIE_HANDLE_WORD(state);
1882
1883         } /* end second pass */
1884
1885         /* next alloc is the NEXT state to be allocated */
1886         trie->statecount = next_alloc; 
1887         trie->states = (reg_trie_state *)
1888             PerlMemShared_realloc( trie->states,
1889                                    next_alloc
1890                                    * sizeof(reg_trie_state) );
1891
1892         /* and now dump it out before we compress it */
1893         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
1894                                                          revcharmap, next_alloc,
1895                                                          depth+1)
1896         );
1897
1898         trie->trans = (reg_trie_trans *)
1899             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
1900         {
1901             U32 state;
1902             U32 tp = 0;
1903             U32 zp = 0;
1904
1905
1906             for( state=1 ; state < next_alloc ; state ++ ) {
1907                 U32 base=0;
1908
1909                 /*
1910                 DEBUG_TRIE_COMPILE_MORE_r(
1911                     PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
1912                 );
1913                 */
1914
1915                 if (trie->states[state].trans.list) {
1916                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
1917                     U16 maxid=minid;
1918                     U16 idx;
1919
1920                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1921                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
1922                         if ( forid < minid ) {
1923                             minid=forid;
1924                         } else if ( forid > maxid ) {
1925                             maxid=forid;
1926                         }
1927                     }
1928                     if ( transcount < tp + maxid - minid + 1) {
1929                         transcount *= 2;
1930                         trie->trans = (reg_trie_trans *)
1931                             PerlMemShared_realloc( trie->trans,
1932                                                      transcount
1933                                                      * sizeof(reg_trie_trans) );
1934                         Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans );
1935                     }
1936                     base = trie->uniquecharcount + tp - minid;
1937                     if ( maxid == minid ) {
1938                         U32 set = 0;
1939                         for ( ; zp < tp ; zp++ ) {
1940                             if ( ! trie->trans[ zp ].next ) {
1941                                 base = trie->uniquecharcount + zp - minid;
1942                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1943                                 trie->trans[ zp ].check = state;
1944                                 set = 1;
1945                                 break;
1946                             }
1947                         }
1948                         if ( !set ) {
1949                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1950                             trie->trans[ tp ].check = state;
1951                             tp++;
1952                             zp = tp;
1953                         }
1954                     } else {
1955                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1956                             const U32 tid = base -  trie->uniquecharcount + TRIE_LIST_ITEM( state, idx ).forid;
1957                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state, idx ).newstate;
1958                             trie->trans[ tid ].check = state;
1959                         }
1960                         tp += ( maxid - minid + 1 );
1961                     }
1962                     Safefree(trie->states[ state ].trans.list);
1963                 }
1964                 /*
1965                 DEBUG_TRIE_COMPILE_MORE_r(
1966                     PerlIO_printf( Perl_debug_log, " base: %d\n",base);
1967                 );
1968                 */
1969                 trie->states[ state ].trans.base=base;
1970             }
1971             trie->lasttrans = tp + 1;
1972         }
1973     } else {
1974         /*
1975            Second Pass -- Flat Table Representation.
1976
1977            we dont use the 0 slot of either trans[] or states[] so we add 1 to each.
1978            We know that we will need Charcount+1 trans at most to store the data
1979            (one row per char at worst case) So we preallocate both structures
1980            assuming worst case.
1981
1982            We then construct the trie using only the .next slots of the entry
1983            structs.
1984
1985            We use the .check field of the first entry of the node temporarily to
1986            make compression both faster and easier by keeping track of how many non
1987            zero fields are in the node.
1988
1989            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
1990            transition.
1991
1992            There are two terms at use here: state as a TRIE_NODEIDX() which is a
1993            number representing the first entry of the node, and state as a
1994            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1) and
1995            TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3) if there
1996            are 2 entrys per node. eg:
1997
1998              A B       A B
1999           1. 2 4    1. 3 7
2000           2. 0 3    3. 0 5
2001           3. 0 0    5. 0 0
2002           4. 0 0    7. 0 0
2003
2004            The table is internally in the right hand, idx form. However as we also
2005            have to deal with the states array which is indexed by nodenum we have to
2006            use TRIE_NODENUM() to convert.
2007
2008         */
2009         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
2010             "%*sCompiling trie using table compiler\n",
2011             (int)depth * 2 + 2, ""));
2012
2013         trie->trans = (reg_trie_trans *)
2014             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
2015                                   * trie->uniquecharcount + 1,
2016                                   sizeof(reg_trie_trans) );
2017         trie->states = (reg_trie_state *)
2018             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2019                                   sizeof(reg_trie_state) );
2020         next_alloc = trie->uniquecharcount + 1;
2021
2022
2023         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2024
2025             regnode *noper   = NEXTOPER( cur );
2026             const U8 *uc     = (U8*)STRING( noper );
2027             const U8 *e      = uc + STR_LEN( noper );
2028
2029             U32 state        = 1;         /* required init */
2030
2031             U16 charid       = 0;         /* sanity init */
2032             U32 accept_state = 0;         /* sanity init */
2033             U8 *scan         = (U8*)NULL; /* sanity init */
2034
2035             STRLEN foldlen   = 0;         /* required init */
2036             U32 wordlen      = 0;         /* required init */
2037             STRLEN skiplen   = 0;
2038             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2039
2040             if (OP(noper) == NOTHING) {
2041                 regnode *noper_next= regnext(noper);
2042                 if (noper_next != tail && OP(noper_next) == flags) {
2043                     noper = noper_next;
2044                     uc= (U8*)STRING(noper);
2045                     e= uc + STR_LEN(noper);
2046                 }
2047             }
2048
2049             if ( OP(noper) != NOTHING ) {
2050                 for ( ; uc < e ; uc += len ) {
2051
2052                     TRIE_READ_CHAR;
2053
2054                     if ( uvc < 256 ) {
2055                         charid = trie->charmap[ uvc ];
2056                     } else {
2057                         SV* const * const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
2058                         charid = svpp ? (U16)SvIV(*svpp) : 0;
2059                     }
2060                     if ( charid ) {
2061                         charid--;
2062                         if ( !trie->trans[ state + charid ].next ) {
2063                             trie->trans[ state + charid ].next = next_alloc;
2064                             trie->trans[ state ].check++;
2065                             prev_states[TRIE_NODENUM(next_alloc)]
2066                                     = TRIE_NODENUM(state);
2067                             next_alloc += trie->uniquecharcount;
2068                         }
2069                         state = trie->trans[ state + charid ].next;
2070                     } else {
2071                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
2072                     }
2073                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
2074                 }
2075             }
2076             accept_state = TRIE_NODENUM( state );
2077             TRIE_HANDLE_WORD(accept_state);
2078
2079         } /* end second pass */
2080
2081         /* and now dump it out before we compress it */
2082         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
2083                                                           revcharmap,
2084                                                           next_alloc, depth+1));
2085
2086         {
2087         /*
2088            * Inplace compress the table.*
2089
2090            For sparse data sets the table constructed by the trie algorithm will
2091            be mostly 0/FAIL transitions or to put it another way mostly empty.
2092            (Note that leaf nodes will not contain any transitions.)
2093
2094            This algorithm compresses the tables by eliminating most such
2095            transitions, at the cost of a modest bit of extra work during lookup:
2096
2097            - Each states[] entry contains a .base field which indicates the
2098            index in the state[] array wheres its transition data is stored.
2099
2100            - If .base is 0 there are no valid transitions from that node.
2101
2102            - If .base is nonzero then charid is added to it to find an entry in
2103            the trans array.
2104
2105            -If trans[states[state].base+charid].check!=state then the
2106            transition is taken to be a 0/Fail transition. Thus if there are fail
2107            transitions at the front of the node then the .base offset will point
2108            somewhere inside the previous nodes data (or maybe even into a node
2109            even earlier), but the .check field determines if the transition is
2110            valid.
2111
2112            XXX - wrong maybe?
2113            The following process inplace converts the table to the compressed
2114            table: We first do not compress the root node 1,and mark all its
2115            .check pointers as 1 and set its .base pointer as 1 as well. This
2116            allows us to do a DFA construction from the compressed table later,
2117            and ensures that any .base pointers we calculate later are greater
2118            than 0.
2119
2120            - We set 'pos' to indicate the first entry of the second node.
2121
2122            - We then iterate over the columns of the node, finding the first and
2123            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
2124            and set the .check pointers accordingly, and advance pos
2125            appropriately and repreat for the next node. Note that when we copy
2126            the next pointers we have to convert them from the original
2127            NODEIDX form to NODENUM form as the former is not valid post
2128            compression.
2129
2130            - If a node has no transitions used we mark its base as 0 and do not
2131            advance the pos pointer.
2132
2133            - If a node only has one transition we use a second pointer into the
2134            structure to fill in allocated fail transitions from other states.
2135            This pointer is independent of the main pointer and scans forward
2136            looking for null transitions that are allocated to a state. When it
2137            finds one it writes the single transition into the "hole".  If the
2138            pointer doesnt find one the single transition is appended as normal.
2139
2140            - Once compressed we can Renew/realloc the structures to release the
2141            excess space.
2142
2143            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
2144            specifically Fig 3.47 and the associated pseudocode.
2145
2146            demq
2147         */
2148         const U32 laststate = TRIE_NODENUM( next_alloc );
2149         U32 state, charid;
2150         U32 pos = 0, zp=0;
2151         trie->statecount = laststate;
2152
2153         for ( state = 1 ; state < laststate ; state++ ) {
2154             U8 flag = 0;
2155             const U32 stateidx = TRIE_NODEIDX( state );
2156             const U32 o_used = trie->trans[ stateidx ].check;
2157             U32 used = trie->trans[ stateidx ].check;
2158             trie->trans[ stateidx ].check = 0;
2159
2160             for ( charid = 0 ; used && charid < trie->uniquecharcount ; charid++ ) {
2161                 if ( flag || trie->trans[ stateidx + charid ].next ) {
2162                     if ( trie->trans[ stateidx + charid ].next ) {
2163                         if (o_used == 1) {
2164                             for ( ; zp < pos ; zp++ ) {
2165                                 if ( ! trie->trans[ zp ].next ) {
2166                                     break;
2167                                 }
2168                             }
2169                             trie->states[ state ].trans.base = zp + trie->uniquecharcount - charid ;
2170                             trie->trans[ zp ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2171                             trie->trans[ zp ].check = state;
2172                             if ( ++zp > pos ) pos = zp;
2173                             break;
2174                         }
2175                         used--;
2176                     }
2177                     if ( !flag ) {
2178                         flag = 1;
2179                         trie->states[ state ].trans.base = pos + trie->uniquecharcount - charid ;
2180                     }
2181                     trie->trans[ pos ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2182                     trie->trans[ pos ].check = state;
2183                     pos++;
2184                 }
2185             }
2186         }
2187         trie->lasttrans = pos + 1;
2188         trie->states = (reg_trie_state *)
2189             PerlMemShared_realloc( trie->states, laststate
2190                                    * sizeof(reg_trie_state) );
2191         DEBUG_TRIE_COMPILE_MORE_r(
2192                 PerlIO_printf( Perl_debug_log,
2193                     "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
2194                     (int)depth * 2 + 2,"",
2195                     (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1 ),
2196                     (IV)next_alloc,
2197                     (IV)pos,
2198                     ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
2199             );
2200
2201         } /* end table compress */
2202     }
2203     DEBUG_TRIE_COMPILE_MORE_r(
2204             PerlIO_printf(Perl_debug_log, "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
2205                 (int)depth * 2 + 2, "",
2206                 (UV)trie->statecount,
2207                 (UV)trie->lasttrans)
2208     );
2209     /* resize the trans array to remove unused space */
2210     trie->trans = (reg_trie_trans *)
2211         PerlMemShared_realloc( trie->trans, trie->lasttrans
2212                                * sizeof(reg_trie_trans) );
2213
2214     {   /* Modify the program and insert the new TRIE node */ 
2215         U8 nodetype =(U8)(flags & 0xFF);
2216         char *str=NULL;
2217         
2218 #ifdef DEBUGGING
2219         regnode *optimize = NULL;
2220 #ifdef RE_TRACK_PATTERN_OFFSETS
2221
2222         U32 mjd_offset = 0;
2223         U32 mjd_nodelen = 0;
2224 #endif /* RE_TRACK_PATTERN_OFFSETS */
2225 #endif /* DEBUGGING */
2226         /*
2227            This means we convert either the first branch or the first Exact,
2228            depending on whether the thing following (in 'last') is a branch
2229            or not and whther first is the startbranch (ie is it a sub part of
2230            the alternation or is it the whole thing.)
2231            Assuming its a sub part we convert the EXACT otherwise we convert
2232            the whole branch sequence, including the first.
2233          */
2234         /* Find the node we are going to overwrite */
2235         if ( first != startbranch || OP( last ) == BRANCH ) {
2236             /* branch sub-chain */
2237             NEXT_OFF( first ) = (U16)(last - first);
2238 #ifdef RE_TRACK_PATTERN_OFFSETS
2239             DEBUG_r({
2240                 mjd_offset= Node_Offset((convert));
2241                 mjd_nodelen= Node_Length((convert));
2242             });
2243 #endif
2244             /* whole branch chain */
2245         }
2246 #ifdef RE_TRACK_PATTERN_OFFSETS
2247         else {
2248             DEBUG_r({
2249                 const  regnode *nop = NEXTOPER( convert );
2250                 mjd_offset= Node_Offset((nop));
2251                 mjd_nodelen= Node_Length((nop));
2252             });
2253         }
2254         DEBUG_OPTIMISE_r(
2255             PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
2256                 (int)depth * 2 + 2, "",
2257                 (UV)mjd_offset, (UV)mjd_nodelen)
2258         );
2259 #endif
2260         /* But first we check to see if there is a common prefix we can 
2261            split out as an EXACT and put in front of the TRIE node.  */
2262         trie->startstate= 1;
2263         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
2264             U32 state;
2265             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
2266                 U32 ofs = 0;
2267                 I32 idx = -1;
2268                 U32 count = 0;
2269                 const U32 base = trie->states[ state ].trans.base;
2270
2271                 if ( trie->states[state].wordnum )
2272                         count = 1;
2273
2274                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2275                     if ( ( base + ofs >= trie->uniquecharcount ) &&
2276                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
2277                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
2278                     {
2279                         if ( ++count > 1 ) {
2280                             SV **tmp = av_fetch( revcharmap, ofs, 0);
2281                             const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
2282                             if ( state == 1 ) break;
2283                             if ( count == 2 ) {
2284                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
2285                                 DEBUG_OPTIMISE_r(
2286                                     PerlIO_printf(Perl_debug_log,
2287                                         "%*sNew Start State=%"UVuf" Class: [",
2288                                         (int)depth * 2 + 2, "",
2289                                         (UV)state));
2290                                 if (idx >= 0) {
2291                                     SV ** const tmp = av_fetch( revcharmap, idx, 0);
2292                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
2293
2294                                     TRIE_BITMAP_SET(trie,*ch);
2295                                     if ( folder )
2296                                         TRIE_BITMAP_SET(trie, folder[ *ch ]);
2297                                     DEBUG_OPTIMISE_r(
2298                                         PerlIO_printf(Perl_debug_log, "%s", (char*)ch)
2299                                     );
2300                                 }
2301                             }
2302                             TRIE_BITMAP_SET(trie,*ch);
2303                             if ( folder )
2304                                 TRIE_BITMAP_SET(trie,folder[ *ch ]);
2305                             DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
2306                         }
2307                         idx = ofs;
2308                     }
2309                 }
2310                 if ( count == 1 ) {
2311                     SV **tmp = av_fetch( revcharmap, idx, 0);
2312                     STRLEN len;
2313                     char *ch = SvPV( *tmp, len );
2314                     DEBUG_OPTIMISE_r({
2315                         SV *sv=sv_newmortal();
2316                         PerlIO_printf( Perl_debug_log,
2317                             "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
2318                             (int)depth * 2 + 2, "",
2319                             (UV)state, (UV)idx, 
2320                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6, 
2321                                 PL_colors[0], PL_colors[1],
2322                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2323                                 PERL_PV_ESCAPE_FIRSTCHAR 
2324                             )
2325                         );
2326                     });
2327                     if ( state==1 ) {
2328                         OP( convert ) = nodetype;
2329                         str=STRING(convert);
2330                         STR_LEN(convert)=0;
2331                     }
2332                     STR_LEN(convert) += len;
2333                     while (len--)
2334                         *str++ = *ch++;
2335                 } else {
2336 #ifdef DEBUGGING            
2337                     if (state>1)
2338                         DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
2339 #endif
2340                     break;
2341                 }
2342             }
2343             trie->prefixlen = (state-1);
2344             if (str) {
2345                 regnode *n = convert+NODE_SZ_STR(convert);
2346                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
2347                 trie->startstate = state;
2348                 trie->minlen -= (state - 1);
2349                 trie->maxlen -= (state - 1);
2350 #ifdef DEBUGGING
2351                /* At least the UNICOS C compiler choked on this
2352                 * being argument to DEBUG_r(), so let's just have
2353                 * it right here. */
2354                if (
2355 #ifdef PERL_EXT_RE_BUILD
2356                    1
2357 #else
2358                    DEBUG_r_TEST
2359 #endif
2360                    ) {
2361                    regnode *fix = convert;
2362                    U32 word = trie->wordcount;
2363                    mjd_nodelen++;
2364                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
2365                    while( ++fix < n ) {
2366                        Set_Node_Offset_Length(fix, 0, 0);
2367                    }
2368                    while (word--) {
2369                        SV ** const tmp = av_fetch( trie_words, word, 0 );
2370                        if (tmp) {
2371                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
2372                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
2373                            else
2374                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
2375                        }
2376                    }
2377                }
2378 #endif
2379                 if (trie->maxlen) {
2380                     convert = n;
2381                 } else {
2382                     NEXT_OFF(convert) = (U16)(tail - convert);
2383                     DEBUG_r(optimize= n);
2384                 }
2385             }
2386         }
2387         if (!jumper) 
2388             jumper = last; 
2389         if ( trie->maxlen ) {
2390             NEXT_OFF( convert ) = (U16)(tail - convert);
2391             ARG_SET( convert, data_slot );
2392             /* Store the offset to the first unabsorbed branch in 
2393                jump[0], which is otherwise unused by the jump logic. 
2394                We use this when dumping a trie and during optimisation. */
2395             if (trie->jump) 
2396                 trie->jump[0] = (U16)(nextbranch - convert);
2397             
2398             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
2399              *   and there is a bitmap
2400              *   and the first "jump target" node we found leaves enough room
2401              * then convert the TRIE node into a TRIEC node, with the bitmap
2402              * embedded inline in the opcode - this is hypothetically faster.
2403              */
2404             if ( !trie->states[trie->startstate].wordnum
2405                  && trie->bitmap
2406                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
2407             {
2408                 OP( convert ) = TRIEC;
2409                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
2410                 PerlMemShared_free(trie->bitmap);
2411                 trie->bitmap= NULL;
2412             } else 
2413                 OP( convert ) = TRIE;
2414
2415             /* store the type in the flags */
2416             convert->flags = nodetype;
2417             DEBUG_r({
2418             optimize = convert 
2419                       + NODE_STEP_REGNODE 
2420                       + regarglen[ OP( convert ) ];
2421             });
2422             /* XXX We really should free up the resource in trie now, 
2423                    as we won't use them - (which resources?) dmq */
2424         }
2425         /* needed for dumping*/
2426         DEBUG_r(if (optimize) {
2427             regnode *opt = convert;
2428
2429             while ( ++opt < optimize) {
2430                 Set_Node_Offset_Length(opt,0,0);
2431             }
2432             /* 
2433                 Try to clean up some of the debris left after the 
2434                 optimisation.
2435              */
2436             while( optimize < jumper ) {
2437                 mjd_nodelen += Node_Length((optimize));
2438                 OP( optimize ) = OPTIMIZED;
2439                 Set_Node_Offset_Length(optimize,0,0);
2440                 optimize++;
2441             }
2442             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
2443         });
2444     } /* end node insert */
2445
2446     /*  Finish populating the prev field of the wordinfo array.  Walk back
2447      *  from each accept state until we find another accept state, and if
2448      *  so, point the first word's .prev field at the second word. If the
2449      *  second already has a .prev field set, stop now. This will be the
2450      *  case either if we've already processed that word's accept state,
2451      *  or that state had multiple words, and the overspill words were
2452      *  already linked up earlier.
2453      */
2454     {
2455         U16 word;
2456         U32 state;
2457         U16 prev;
2458
2459         for (word=1; word <= trie->wordcount; word++) {
2460             prev = 0;
2461             if (trie->wordinfo[word].prev)
2462                 continue;
2463             state = trie->wordinfo[word].accept;
2464             while (state) {
2465                 state = prev_states[state];
2466                 if (!state)
2467                     break;
2468                 prev = trie->states[state].wordnum;
2469                 if (prev)
2470                     break;
2471             }
2472             trie->wordinfo[word].prev = prev;
2473         }
2474         Safefree(prev_states);
2475     }
2476
2477
2478     /* and now dump out the compressed format */
2479     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
2480
2481     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
2482 #ifdef DEBUGGING
2483     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
2484     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
2485 #else
2486     SvREFCNT_dec_NN(revcharmap);
2487 #endif
2488     return trie->jump 
2489            ? MADE_JUMP_TRIE 
2490            : trie->startstate>1 
2491              ? MADE_EXACT_TRIE 
2492              : MADE_TRIE;
2493 }
2494
2495 STATIC void
2496 S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source,  regnode *stclass, U32 depth)
2497 {
2498 /* The Trie is constructed and compressed now so we can build a fail array if it's needed
2499
2500    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
2501    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
2502    ISBN 0-201-10088-6
2503
2504    We find the fail state for each state in the trie, this state is the longest proper
2505    suffix of the current state's 'word' that is also a proper prefix of another word in our
2506    trie. State 1 represents the word '' and is thus the default fail state. This allows
2507    the DFA not to have to restart after its tried and failed a word at a given point, it
2508    simply continues as though it had been matching the other word in the first place.
2509    Consider
2510       'abcdgu'=~/abcdefg|cdgu/
2511    When we get to 'd' we are still matching the first word, we would encounter 'g' which would
2512    fail, which would bring us to the state representing 'd' in the second word where we would
2513    try 'g' and succeed, proceeding to match 'cdgu'.
2514  */
2515  /* add a fail transition */
2516     const U32 trie_offset = ARG(source);
2517     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
2518     U32 *q;
2519     const U32 ucharcount = trie->uniquecharcount;
2520     const U32 numstates = trie->statecount;
2521     const U32 ubound = trie->lasttrans + ucharcount;
2522     U32 q_read = 0;
2523     U32 q_write = 0;
2524     U32 charid;
2525     U32 base = trie->states[ 1 ].trans.base;
2526     U32 *fail;
2527     reg_ac_data *aho;
2528     const U32 data_slot = add_data( pRExC_state, 1, "T" );
2529     GET_RE_DEBUG_FLAGS_DECL;
2530
2531     PERL_ARGS_ASSERT_MAKE_TRIE_FAILTABLE;
2532 #ifndef DEBUGGING
2533     PERL_UNUSED_ARG(depth);
2534 #endif
2535
2536
2537     ARG_SET( stclass, data_slot );
2538     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
2539     RExC_rxi->data->data[ data_slot ] = (void*)aho;
2540     aho->trie=trie_offset;
2541     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
2542     Copy( trie->states, aho->states, numstates, reg_trie_state );
2543     Newxz( q, numstates, U32);
2544     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
2545     aho->refcount = 1;
2546     fail = aho->fail;
2547     /* initialize fail[0..1] to be 1 so that we always have
2548        a valid final fail state */
2549     fail[ 0 ] = fail[ 1 ] = 1;
2550
2551     for ( charid = 0; charid < ucharcount ; charid++ ) {
2552         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
2553         if ( newstate ) {
2554             q[ q_write ] = newstate;
2555             /* set to point at the root */
2556             fail[ q[ q_write++ ] ]=1;
2557         }
2558     }
2559     while ( q_read < q_write) {
2560         const U32 cur = q[ q_read++ % numstates ];
2561         base = trie->states[ cur ].trans.base;
2562
2563         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
2564             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
2565             if (ch_state) {
2566                 U32 fail_state = cur;
2567                 U32 fail_base;
2568                 do {
2569                     fail_state = fail[ fail_state ];
2570                     fail_base = aho->states[ fail_state ].trans.base;
2571                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
2572
2573                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
2574                 fail[ ch_state ] = fail_state;
2575                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
2576                 {
2577                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
2578                 }
2579                 q[ q_write++ % numstates] = ch_state;
2580             }
2581         }
2582     }
2583     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
2584        when we fail in state 1, this allows us to use the
2585        charclass scan to find a valid start char. This is based on the principle
2586        that theres a good chance the string being searched contains lots of stuff
2587        that cant be a start char.
2588      */
2589     fail[ 0 ] = fail[ 1 ] = 0;
2590     DEBUG_TRIE_COMPILE_r({
2591         PerlIO_printf(Perl_debug_log,
2592                       "%*sStclass Failtable (%"UVuf" states): 0", 
2593                       (int)(depth * 2), "", (UV)numstates
2594         );
2595         for( q_read=1; q_read<numstates; q_read++ ) {
2596             PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
2597         }
2598         PerlIO_printf(Perl_debug_log, "\n");
2599     });
2600     Safefree(q);
2601     /*RExC_seen |= REG_SEEN_TRIEDFA;*/
2602 }
2603
2604
2605 /*
2606  * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2607  * These need to be revisited when a newer toolchain becomes available.
2608  */
2609 #if defined(__sparc64__) && defined(__GNUC__)
2610 #   if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2611 #       undef  SPARC64_GCC_WORKAROUND
2612 #       define SPARC64_GCC_WORKAROUND 1
2613 #   endif
2614 #endif
2615
2616 #define DEBUG_PEEP(str,scan,depth) \
2617     DEBUG_OPTIMISE_r({if (scan){ \
2618        SV * const mysv=sv_newmortal(); \
2619        regnode *Next = regnext(scan); \
2620        regprop(RExC_rx, mysv, scan); \
2621        PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
2622        (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
2623        Next ? (REG_NODE_NUM(Next)) : 0 ); \
2624    }});
2625
2626
2627 /* The below joins as many adjacent EXACTish nodes as possible into a single
2628  * one.  The regop may be changed if the node(s) contain certain sequences that
2629  * require special handling.  The joining is only done if:
2630  * 1) there is room in the current conglomerated node to entirely contain the
2631  *    next one.
2632  * 2) they are the exact same node type
2633  *
2634  * The adjacent nodes actually may be separated by NOTHING-kind nodes, and
2635  * these get optimized out
2636  *
2637  * If a node is to match under /i (folded), the number of characters it matches
2638  * can be different than its character length if it contains a multi-character
2639  * fold.  *min_subtract is set to the total delta of the input nodes.
2640  *
2641  * And *has_exactf_sharp_s is set to indicate whether or not the node is EXACTF
2642  * and contains LATIN SMALL LETTER SHARP S
2643  *
2644  * This is as good a place as any to discuss the design of handling these
2645  * multi-character fold sequences.  It's been wrong in Perl for a very long
2646  * time.  There are three code points in Unicode whose multi-character folds
2647  * were long ago discovered to mess things up.  The previous designs for
2648  * dealing with these involved assigning a special node for them.  This
2649  * approach doesn't work, as evidenced by this example:
2650  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
2651  * Both these fold to "sss", but if the pattern is parsed to create a node that
2652  * would match just the \xDF, it won't be able to handle the case where a
2653  * successful match would have to cross the node's boundary.  The new approach
2654  * that hopefully generally solves the problem generates an EXACTFU_SS node
2655  * that is "sss".
2656  *
2657  * It turns out that there are problems with all multi-character folds, and not
2658  * just these three.  Now the code is general, for all such cases, but the
2659  * three still have some special handling.  The approach taken is:
2660  * 1)   This routine examines each EXACTFish node that could contain multi-
2661  *      character fold sequences.  It returns in *min_subtract how much to
2662  *      subtract from the the actual length of the string to get a real minimum
2663  *      match length; it is 0 if there are no multi-char folds.  This delta is
2664  *      used by the caller to adjust the min length of the match, and the delta
2665  *      between min and max, so that the optimizer doesn't reject these
2666  *      possibilities based on size constraints.
2667  * 2)   Certain of these sequences require special handling by the trie code,
2668  *      so, if found, this code changes the joined node type to special ops:
2669  *      EXACTFU_TRICKYFOLD and EXACTFU_SS.
2670  * 3)   For the sequence involving the Sharp s (\xDF), the node type EXACTFU_SS
2671  *      is used for an EXACTFU node that contains at least one "ss" sequence in
2672  *      it.  For non-UTF-8 patterns and strings, this is the only case where
2673  *      there is a possible fold length change.  That means that a regular
2674  *      EXACTFU node without UTF-8 involvement doesn't have to concern itself
2675  *      with length changes, and so can be processed faster.  regexec.c takes
2676  *      advantage of this.  Generally, an EXACTFish node that is in UTF-8 is
2677  *      pre-folded by regcomp.c.  This saves effort in regex matching.
2678  *      However, the pre-folding isn't done for non-UTF8 patterns because the
2679  *      fold of the MICRO SIGN requires UTF-8, and we don't want to slow things
2680  *      down by forcing the pattern into UTF8 unless necessary.  Also what
2681  *      EXACTF and EXACTFL nodes fold to isn't known until runtime.  The fold
2682  *      possibilities for the non-UTF8 patterns are quite simple, except for
2683  *      the sharp s.  All the ones that don't involve a UTF-8 target string are
2684  *      members of a fold-pair, and arrays are set up for all of them so that
2685  *      the other member of the pair can be found quickly.  Code elsewhere in
2686  *      this file makes sure that in EXACTFU nodes, the sharp s gets folded to
2687  *      'ss', even if the pattern isn't UTF-8.  This avoids the issues
2688  *      described in the next item.
2689  * 4)   A problem remains for the sharp s in EXACTF nodes.  Whether it matches
2690  *      'ss' or not is not knowable at compile time.  It will match iff the
2691  *      target string is in UTF-8, unlike the EXACTFU nodes, where it always
2692  *      matches; and the EXACTFL and EXACTFA nodes where it never does.  Thus
2693  *      it can't be folded to "ss" at compile time, unlike EXACTFU does (as
2694  *      described in item 3).  An assumption that the optimizer part of
2695  *      regexec.c (probably unwittingly) makes is that a character in the
2696  *      pattern corresponds to at most a single character in the target string.
2697  *      (And I do mean character, and not byte here, unlike other parts of the
2698  *      documentation that have never been updated to account for multibyte
2699  *      Unicode.)  This assumption is wrong only in this case, as all other
2700  *      cases are either 1-1 folds when no UTF-8 is involved; or is true by
2701  *      virtue of having this file pre-fold UTF-8 patterns.   I'm
2702  *      reluctant to try to change this assumption, so instead the code punts.
2703  *      This routine examines EXACTF nodes for the sharp s, and returns a
2704  *      boolean indicating whether or not the node is an EXACTF node that
2705  *      contains a sharp s.  When it is true, the caller sets a flag that later
2706  *      causes the optimizer in this file to not set values for the floating
2707  *      and fixed string lengths, and thus avoids the optimizer code in
2708  *      regexec.c that makes the invalid assumption.  Thus, there is no
2709  *      optimization based on string lengths for EXACTF nodes that contain the
2710  *      sharp s.  This only happens for /id rules (which means the pattern
2711  *      isn't in UTF-8).
2712  */
2713
2714 #define JOIN_EXACT(scan,min_subtract,has_exactf_sharp_s, flags) \
2715     if (PL_regkind[OP(scan)] == EXACT) \
2716         join_exact(pRExC_state,(scan),(min_subtract),has_exactf_sharp_s, (flags),NULL,depth+1)
2717
2718 STATIC U32
2719 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, UV *min_subtract, bool *has_exactf_sharp_s, U32 flags,regnode *val, U32 depth) {
2720     /* Merge several consecutive EXACTish nodes into one. */
2721     regnode *n = regnext(scan);
2722     U32 stringok = 1;
2723     regnode *next = scan + NODE_SZ_STR(scan);
2724     U32 merged = 0;
2725     U32 stopnow = 0;
2726 #ifdef DEBUGGING
2727     regnode *stop = scan;
2728     GET_RE_DEBUG_FLAGS_DECL;
2729 #else
2730     PERL_UNUSED_ARG(depth);
2731 #endif
2732
2733     PERL_ARGS_ASSERT_JOIN_EXACT;
2734 #ifndef EXPERIMENTAL_INPLACESCAN
2735     PERL_UNUSED_ARG(flags);
2736     PERL_UNUSED_ARG(val);
2737 #endif
2738     DEBUG_PEEP("join",scan,depth);
2739
2740     /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
2741      * EXACT ones that are mergeable to the current one. */
2742     while (n
2743            && (PL_regkind[OP(n)] == NOTHING
2744                || (stringok && OP(n) == OP(scan)))
2745            && NEXT_OFF(n)
2746            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
2747     {
2748         
2749         if (OP(n) == TAIL || n > next)
2750             stringok = 0;
2751         if (PL_regkind[OP(n)] == NOTHING) {
2752             DEBUG_PEEP("skip:",n,depth);
2753             NEXT_OFF(scan) += NEXT_OFF(n);
2754             next = n + NODE_STEP_REGNODE;
2755 #ifdef DEBUGGING
2756             if (stringok)
2757                 stop = n;
2758 #endif
2759             n = regnext(n);
2760         }
2761         else if (stringok) {
2762             const unsigned int oldl = STR_LEN(scan);
2763             regnode * const nnext = regnext(n);
2764
2765             /* XXX I (khw) kind of doubt that this works on platforms where
2766              * U8_MAX is above 255 because of lots of other assumptions */
2767             /* Don't join if the sum can't fit into a single node */
2768             if (oldl + STR_LEN(n) > U8_MAX)
2769                 break;
2770             
2771             DEBUG_PEEP("merg",n,depth);
2772             merged++;
2773
2774             NEXT_OFF(scan) += NEXT_OFF(n);
2775             STR_LEN(scan) += STR_LEN(n);
2776             next = n + NODE_SZ_STR(n);
2777             /* Now we can overwrite *n : */
2778             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
2779 #ifdef DEBUGGING
2780             stop = next - 1;
2781 #endif
2782             n = nnext;
2783             if (stopnow) break;
2784         }
2785
2786 #ifdef EXPERIMENTAL_INPLACESCAN
2787         if (flags && !NEXT_OFF(n)) {
2788             DEBUG_PEEP("atch", val, depth);
2789             if (reg_off_by_arg[OP(n)]) {
2790                 ARG_SET(n, val - n);
2791             }
2792             else {
2793                 NEXT_OFF(n) = val - n;
2794             }
2795             stopnow = 1;
2796         }
2797 #endif
2798     }
2799
2800     *min_subtract = 0;
2801     *has_exactf_sharp_s = FALSE;
2802
2803     /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
2804      * can now analyze for sequences of problematic code points.  (Prior to
2805      * this final joining, sequences could have been split over boundaries, and
2806      * hence missed).  The sequences only happen in folding, hence for any
2807      * non-EXACT EXACTish node */
2808     if (OP(scan) != EXACT) {
2809         const U8 * const s0 = (U8*) STRING(scan);
2810         const U8 * s = s0;
2811         const U8 * const s_end = s0 + STR_LEN(scan);
2812
2813         /* One pass is made over the node's string looking for all the
2814          * possibilities.  to avoid some tests in the loop, there are two main
2815          * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
2816          * non-UTF-8 */
2817         if (UTF) {
2818
2819             /* Examine the string for a multi-character fold sequence.  UTF-8
2820              * patterns have all characters pre-folded by the time this code is
2821              * executed */
2822             while (s < s_end - 1) /* Can stop 1 before the end, as minimum
2823                                      length sequence we are looking for is 2 */
2824             {
2825                 int count = 0;
2826                 int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
2827                 if (! len) {    /* Not a multi-char fold: get next char */
2828                     s += UTF8SKIP(s);
2829                     continue;
2830                 }
2831
2832                 /* Nodes with 'ss' require special handling, except for EXACTFL
2833                  * and EXACTFA for which there is no multi-char fold to this */
2834                 if (len == 2 && *s == 's' && *(s+1) == 's'
2835                     && OP(scan) != EXACTFL && OP(scan) != EXACTFA)
2836                 {
2837                     count = 2;
2838                     OP(scan) = EXACTFU_SS;
2839                     s += 2;
2840                 }
2841                 else if (len == 6   /* len is the same in both ASCII and EBCDIC for these */
2842                          && (memEQ(s, GREEK_SMALL_LETTER_IOTA_UTF8
2843                                       COMBINING_DIAERESIS_UTF8
2844                                       COMBINING_ACUTE_ACCENT_UTF8,
2845                                    6)
2846                              || memEQ(s, GREEK_SMALL_LETTER_UPSILON_UTF8
2847                                          COMBINING_DIAERESIS_UTF8
2848                                          COMBINING_ACUTE_ACCENT_UTF8,
2849                                      6)))
2850                 {
2851                     count = 3;
2852
2853                     /* These two folds require special handling by trie's, so
2854                      * change the node type to indicate this.  If EXACTFA and
2855                      * EXACTFL were ever to be handled by trie's, this would
2856                      * have to be changed.  If this node has already been
2857                      * changed to EXACTFU_SS in this loop, leave it as is.  (I
2858                      * (khw) think it doesn't matter in regexec.c for UTF
2859                      * patterns, but no need to change it */
2860                     if (OP(scan) == EXACTFU) {
2861                         OP(scan) = EXACTFU_TRICKYFOLD;
2862                     }
2863                     s += 6;
2864                 }
2865                 else { /* Here is a generic multi-char fold. */
2866                     const U8* multi_end  = s + len;
2867
2868                     /* Count how many characters in it.  In the case of /l and
2869                      * /aa, no folds which contain ASCII code points are
2870                      * allowed, so check for those, and skip if found.  (In
2871                      * EXACTFL, no folds are allowed to any Latin1 code point,
2872                      * not just ASCII.  But there aren't any of these
2873                      * currently, nor ever likely, so don't take the time to
2874                      * test for them.  The code that generates the
2875                      * is_MULTI_foo() macros croaks should one actually get put
2876                      * into Unicode .) */
2877                     if (OP(scan) != EXACTFL && OP(scan) != EXACTFA) {
2878                         count = utf8_length(s, multi_end);
2879                         s = multi_end;
2880                     }
2881                     else {
2882                         while (s < multi_end) {
2883                             if (isASCII(*s)) {
2884                                 s++;
2885                                 goto next_iteration;
2886                             }
2887                             else {
2888                                 s += UTF8SKIP(s);
2889                             }
2890                             count++;
2891                         }
2892                     }
2893                 }
2894
2895                 /* The delta is how long the sequence is minus 1 (1 is how long
2896                  * the character that folds to the sequence is) */
2897                 *min_subtract += count - 1;
2898             next_iteration: ;
2899             }
2900         }
2901         else if (OP(scan) != EXACTFL && OP(scan) != EXACTFA) {
2902
2903             /* Here, the pattern is not UTF-8.  Look for the multi-char folds
2904              * that are all ASCII.  As in the above case, EXACTFL and EXACTFA
2905              * nodes can't have multi-char folds to this range (and there are
2906              * no existing ones in the upper latin1 range).  In the EXACTF
2907              * case we look also for the sharp s, which can be in the final
2908              * position.  Otherwise we can stop looking 1 byte earlier because
2909              * have to find at least two characters for a multi-fold */
2910             const U8* upper = (OP(scan) == EXACTF) ? s_end : s_end -1;
2911
2912             /* The below is perhaps overboard, but this allows us to save a
2913              * test each time through the loop at the expense of a mask.  This
2914              * is because on both EBCDIC and ASCII machines, 'S' and 's' differ
2915              * by a single bit.  On ASCII they are 32 apart; on EBCDIC, they
2916              * are 64.  This uses an exclusive 'or' to find that bit and then
2917              * inverts it to form a mask, with just a single 0, in the bit
2918              * position where 'S' and 's' differ. */
2919             const U8 S_or_s_mask = (U8) ~ ('S' ^ 's');
2920             const U8 s_masked = 's' & S_or_s_mask;
2921
2922             while (s < upper) {
2923                 int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end);
2924                 if (! len) {    /* Not a multi-char fold. */
2925                     if (*s == LATIN_SMALL_LETTER_SHARP_S && OP(scan) == EXACTF)
2926                     {
2927                         *has_exactf_sharp_s = TRUE;
2928                     }
2929                     s++;
2930                     continue;
2931                 }
2932
2933                 if (len == 2
2934                     && ((*s & S_or_s_mask) == s_masked)
2935                     && ((*(s+1) & S_or_s_mask) == s_masked))
2936                 {
2937
2938                     /* EXACTF nodes need to know that the minimum length
2939                      * changed so that a sharp s in the string can match this
2940                      * ss in the pattern, but they remain EXACTF nodes, as they
2941                      * won't match this unless the target string is is UTF-8,
2942                      * which we don't know until runtime */
2943                     if (OP(scan) != EXACTF) {
2944                         OP(scan) = EXACTFU_SS;
2945                     }
2946                 }
2947
2948                 *min_subtract += len - 1;
2949                 s += len;
2950             }
2951         }
2952     }
2953
2954 #ifdef DEBUGGING
2955     /* Allow dumping but overwriting the collection of skipped
2956      * ops and/or strings with fake optimized ops */
2957     n = scan + NODE_SZ_STR(scan);
2958     while (n <= stop) {
2959         OP(n) = OPTIMIZED;
2960         FLAGS(n) = 0;
2961         NEXT_OFF(n) = 0;
2962         n++;
2963     }
2964 #endif
2965     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
2966     return stopnow;
2967 }
2968
2969 /* REx optimizer.  Converts nodes into quicker variants "in place".
2970    Finds fixed substrings.  */
2971
2972 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
2973    to the position after last scanned or to NULL. */
2974
2975 #define INIT_AND_WITHP \
2976     assert(!and_withp); \
2977     Newx(and_withp,1,struct regnode_charclass_class); \
2978     SAVEFREEPV(and_withp)
2979
2980 /* this is a chain of data about sub patterns we are processing that
2981    need to be handled separately/specially in study_chunk. Its so
2982    we can simulate recursion without losing state.  */
2983 struct scan_frame;
2984 typedef struct scan_frame {
2985     regnode *last;  /* last node to process in this frame */
2986     regnode *next;  /* next node to process when last is reached */
2987     struct scan_frame *prev; /*previous frame*/
2988     I32 stop; /* what stopparen do we use */
2989 } scan_frame;
2990
2991
2992 #define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf)
2993
2994 STATIC I32
2995 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
2996                         I32 *minlenp, I32 *deltap,
2997                         regnode *last,
2998                         scan_data_t *data,
2999                         I32 stopparen,
3000                         U8* recursed,
3001                         struct regnode_charclass_class *and_withp,
3002                         U32 flags, U32 depth)
3003                         /* scanp: Start here (read-write). */
3004                         /* deltap: Write maxlen-minlen here. */
3005                         /* last: Stop before this one. */
3006                         /* data: string data about the pattern */
3007                         /* stopparen: treat close N as END */
3008                         /* recursed: which subroutines have we recursed into */
3009                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
3010 {
3011     dVAR;
3012     I32 min = 0;    /* There must be at least this number of characters to match */
3013     I32 pars = 0, code;
3014     regnode *scan = *scanp, *next;
3015     I32 delta = 0;
3016     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
3017     int is_inf_internal = 0;            /* The studied chunk is infinite */
3018     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
3019     scan_data_t data_fake;
3020     SV *re_trie_maxbuff = NULL;
3021     regnode *first_non_open = scan;
3022     I32 stopmin = I32_MAX;
3023     scan_frame *frame = NULL;
3024     GET_RE_DEBUG_FLAGS_DECL;
3025
3026     PERL_ARGS_ASSERT_STUDY_CHUNK;
3027
3028 #ifdef DEBUGGING
3029     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
3030 #endif
3031
3032     if ( depth == 0 ) {
3033         while (first_non_open && OP(first_non_open) == OPEN)
3034             first_non_open=regnext(first_non_open);
3035     }
3036
3037
3038   fake_study_recurse:
3039     while ( scan && OP(scan) != END && scan < last ){
3040         UV min_subtract = 0;    /* How mmany chars to subtract from the minimum
3041                                    node length to get a real minimum (because
3042                                    the folded version may be shorter) */
3043         bool has_exactf_sharp_s = FALSE;
3044         /* Peephole optimizer: */
3045         DEBUG_STUDYDATA("Peep:", data,depth);
3046         DEBUG_PEEP("Peep",scan,depth);
3047
3048         /* Its not clear to khw or hv why this is done here, and not in the
3049          * clauses that deal with EXACT nodes.  khw's guess is that it's
3050          * because of a previous design */
3051         JOIN_EXACT(scan,&min_subtract, &has_exactf_sharp_s, 0);
3052
3053         /* Follow the next-chain of the current node and optimize
3054            away all the NOTHINGs from it.  */
3055         if (OP(scan) != CURLYX) {
3056             const int max = (reg_off_by_arg[OP(scan)]
3057                        ? I32_MAX
3058                        /* I32 may be smaller than U16 on CRAYs! */
3059                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
3060             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
3061             int noff;
3062             regnode *n = scan;
3063
3064             /* Skip NOTHING and LONGJMP. */
3065             while ((n = regnext(n))
3066                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
3067                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
3068                    && off + noff < max)
3069                 off += noff;
3070             if (reg_off_by_arg[OP(scan)])
3071                 ARG(scan) = off;
3072             else
3073                 NEXT_OFF(scan) = off;
3074         }
3075
3076
3077
3078         /* The principal pseudo-switch.  Cannot be a switch, since we
3079            look into several different things.  */
3080         if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
3081                    || OP(scan) == IFTHEN) {
3082             next = regnext(scan);
3083             code = OP(scan);
3084             /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
3085
3086             if (OP(next) == code || code == IFTHEN) {
3087                 /* NOTE - There is similar code to this block below for handling
3088                    TRIE nodes on a re-study.  If you change stuff here check there
3089                    too. */
3090                 I32 max1 = 0, min1 = I32_MAX, num = 0;
3091                 struct regnode_charclass_class accum;
3092                 regnode * const startbranch=scan;
3093
3094                 if (flags & SCF_DO_SUBSTR)
3095                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
3096                 if (flags & SCF_DO_STCLASS)
3097                     cl_init_zero(pRExC_state, &accum);
3098
3099                 while (OP(scan) == code) {
3100                     I32 deltanext, minnext, f = 0, fake;
3101                     struct regnode_charclass_class this_class;
3102
3103                     num++;
3104                     data_fake.flags = 0;
3105                     if (data) {
3106                         data_fake.whilem_c = data->whilem_c;
3107                         data_fake.last_closep = data->last_closep;
3108                     }
3109                     else
3110                         data_fake.last_closep = &fake;
3111
3112                     data_fake.pos_delta = delta;
3113                     next = regnext(scan);
3114                     scan = NEXTOPER(scan);
3115                     if (code != BRANCH)
3116                         scan = NEXTOPER(scan);
3117                     if (flags & SCF_DO_STCLASS) {
3118                         cl_init(pRExC_state, &this_class);
3119                         data_fake.start_class = &this_class;
3120                         f = SCF_DO_STCLASS_AND;
3121                     }
3122                     if (flags & SCF_WHILEM_VISITED_POS)
3123                         f |= SCF_WHILEM_VISITED_POS;
3124
3125                     /* we suppose the run is continuous, last=next...*/
3126                     minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
3127                                           next, &data_fake,
3128                                           stopparen, recursed, NULL, f,depth+1);
3129                     if (min1 > minnext)
3130                         min1 = minnext;
3131                     if (deltanext == I32_MAX) {
3132                         is_inf = is_inf_internal = 1;
3133                         max1 = I32_MAX;
3134                     } else if (max1 < minnext + deltanext)
3135                         max1 = minnext + deltanext;
3136                     scan = next;
3137                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3138                         pars++;
3139                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
3140                         if ( stopmin > minnext) 
3141                             stopmin = min + min1;
3142                         flags &= ~SCF_DO_SUBSTR;
3143                         if (data)
3144                             data->flags |= SCF_SEEN_ACCEPT;
3145                     }
3146                     if (data) {
3147                         if (data_fake.flags & SF_HAS_EVAL)
3148                             data->flags |= SF_HAS_EVAL;
3149                         data->whilem_c = data_fake.whilem_c;
3150                     }
3151                     if (flags & SCF_DO_STCLASS)
3152                         cl_or(pRExC_state, &accum, &this_class);
3153                 }
3154                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
3155                     min1 = 0;
3156                 if (flags & SCF_DO_SUBSTR) {
3157                     data->pos_min += min1;
3158                     if (data->pos_delta >= I32_MAX - (max1 - min1))
3159                         data->pos_delta = I32_MAX;
3160                     else
3161                         data->pos_delta += max1 - min1;
3162                     if (max1 != min1 || is_inf)
3163                         data->longest = &(data->longest_float);
3164                 }
3165                 min += min1;
3166                 if (delta == I32_MAX || I32_MAX - delta - (max1 - min1) < 0)
3167                     delta = I32_MAX;
3168                 else
3169                     delta += max1 - min1;
3170                 if (flags & SCF_DO_STCLASS_OR) {
3171                     cl_or(pRExC_state, data->start_class, &accum);
3172                     if (min1) {
3173                         cl_and(data->start_class, and_withp);
3174                         flags &= ~SCF_DO_STCLASS;
3175                     }
3176                 }
3177                 else if (flags & SCF_DO_STCLASS_AND) {
3178                     if (min1) {
3179                         cl_and(data->start_class, &accum);
3180                         flags &= ~SCF_DO_STCLASS;
3181                     }
3182                     else {
3183                         /* Switch to OR mode: cache the old value of
3184                          * data->start_class */
3185                         INIT_AND_WITHP;
3186                         StructCopy(data->start_class, and_withp,
3187                                    struct regnode_charclass_class);
3188                         flags &= ~SCF_DO_STCLASS_AND;
3189                         StructCopy(&accum, data->start_class,
3190                                    struct regnode_charclass_class);
3191                         flags |= SCF_DO_STCLASS_OR;
3192                         SET_SSC_EOS(data->start_class);
3193                     }
3194                 }
3195
3196                 if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) == BRANCH ) {
3197                 /* demq.
3198
3199                    Assuming this was/is a branch we are dealing with: 'scan' now
3200                    points at the item that follows the branch sequence, whatever
3201                    it is. We now start at the beginning of the sequence and look
3202                    for subsequences of
3203
3204                    BRANCH->EXACT=>x1
3205                    BRANCH->EXACT=>x2
3206                    tail
3207
3208                    which would be constructed from a pattern like /A|LIST|OF|WORDS/
3209
3210                    If we can find such a subsequence we need to turn the first
3211                    element into a trie and then add the subsequent branch exact
3212                    strings to the trie.
3213
3214                    We have two cases
3215
3216                      1. patterns where the whole set of branches can be converted. 
3217
3218                      2. patterns where only a subset can be converted.
3219
3220                    In case 1 we can replace the whole set with a single regop
3221                    for the trie. In case 2 we need to keep the start and end
3222                    branches so
3223
3224                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
3225                      becomes BRANCH TRIE; BRANCH X;
3226
3227                   There is an additional case, that being where there is a 
3228                   common prefix, which gets split out into an EXACT like node
3229                   preceding the TRIE node.
3230
3231                   If x(1..n)==tail then we can do a simple trie, if not we make
3232                   a "jump" trie, such that when we match the appropriate word
3233                   we "jump" to the appropriate tail node. Essentially we turn
3234                   a nested if into a case structure of sorts.
3235
3236                 */
3237
3238                     int made=0;
3239                     if (!re_trie_maxbuff) {
3240                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
3241                         if (!SvIOK(re_trie_maxbuff))
3242                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
3243                     }
3244                     if ( SvIV(re_trie_maxbuff)>=0  ) {
3245                         regnode *cur;
3246                         regnode *first = (regnode *)NULL;
3247                         regnode *last = (regnode *)NULL;
3248                         regnode *tail = scan;
3249                         U8 trietype = 0;
3250                         U32 count=0;
3251
3252 #ifdef DEBUGGING
3253                         SV * const mysv = sv_newmortal();       /* for dumping */
3254 #endif
3255                         /* var tail is used because there may be a TAIL
3256                            regop in the way. Ie, the exacts will point to the
3257                            thing following the TAIL, but the last branch will
3258                            point at the TAIL. So we advance tail. If we
3259                            have nested (?:) we may have to move through several
3260                            tails.
3261                          */
3262
3263                         while ( OP( tail ) == TAIL ) {
3264                             /* this is the TAIL generated by (?:) */
3265                             tail = regnext( tail );
3266                         }
3267
3268                         
3269                         DEBUG_TRIE_COMPILE_r({
3270                             regprop(RExC_rx, mysv, tail );
3271                             PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
3272                                 (int)depth * 2 + 2, "", 
3273                                 "Looking for TRIE'able sequences. Tail node is: ", 
3274                                 SvPV_nolen_const( mysv )
3275                             );
3276                         });
3277                         
3278                         /*
3279
3280                             Step through the branches
3281                                 cur represents each branch,
3282                                 noper is the first thing to be matched as part of that branch
3283                                 noper_next is the regnext() of that node.
3284
3285                             We normally handle a case like this /FOO[xyz]|BAR[pqr]/
3286                             via a "jump trie" but we also support building with NOJUMPTRIE,
3287                             which restricts the trie logic to structures like /FOO|BAR/.
3288
3289                             If noper is a trieable nodetype then the branch is a possible optimization
3290                             target. If we are building under NOJUMPTRIE then we require that noper_next
3291                             is the same as scan (our current position in the regex program).
3292
3293                             Once we have two or more consecutive such branches we can create a
3294                             trie of the EXACT's contents and stitch it in place into the program.
3295
3296                             If the sequence represents all of the branches in the alternation we
3297                             replace the entire thing with a single TRIE node.
3298
3299                             Otherwise when it is a subsequence we need to stitch it in place and
3300                             replace only the relevant branches. This means the first branch has
3301                             to remain as it is used by the alternation logic, and its next pointer,
3302                             and needs to be repointed at the item on the branch chain following
3303                             the last branch we have optimized away.
3304
3305                             This could be either a BRANCH, in which case the subsequence is internal,
3306                             or it could be the item following the branch sequence in which case the
3307                             subsequence is at the end (which does not necessarily mean the first node
3308                             is the start of the alternation).
3309
3310                             TRIE_TYPE(X) is a define which maps the optype to a trietype.
3311
3312                                 optype          |  trietype
3313                                 ----------------+-----------
3314                                 NOTHING         | NOTHING
3315                                 EXACT           | EXACT
3316                                 EXACTFU         | EXACTFU
3317                                 EXACTFU_SS      | EXACTFU
3318                                 EXACTFU_TRICKYFOLD | EXACTFU
3319                                 EXACTFA         | 0
3320
3321
3322                         */
3323 #define TRIE_TYPE(X) ( ( NOTHING == (X) ) ? NOTHING :   \
3324                        ( EXACT == (X) )   ? EXACT :        \
3325                        ( EXACTFU == (X) || EXACTFU_SS == (X) || EXACTFU_TRICKYFOLD == (X) ) ? EXACTFU :        \
3326                        0 )
3327
3328                         /* dont use tail as the end marker for this traverse */
3329                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
3330                             regnode * const noper = NEXTOPER( cur );
3331                             U8 noper_type = OP( noper );
3332                             U8 noper_trietype = TRIE_TYPE( noper_type );
3333 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
3334                             regnode * const noper_next = regnext( noper );
3335                             U8 noper_next_type = (noper_next && noper_next != tail) ? OP(noper_next) : 0;
3336                             U8 noper_next_trietype = (noper_next && noper_next != tail) ? TRIE_TYPE( noper_next_type ) :0;
3337 #endif
3338
3339                             DEBUG_TRIE_COMPILE_r({
3340                                 regprop(RExC_rx, mysv, cur);
3341                                 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
3342                                    (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
3343
3344                                 regprop(RExC_rx, mysv, noper);
3345                                 PerlIO_printf( Perl_debug_log, " -> %s",
3346                                     SvPV_nolen_const(mysv));
3347
3348                                 if ( noper_next ) {
3349                                   regprop(RExC_rx, mysv, noper_next );
3350                                   PerlIO_printf( Perl_debug_log,"\t=> %s\t",
3351                                     SvPV_nolen_const(mysv));
3352                                 }
3353                                 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d,tt==%s,nt==%s,nnt==%s)\n",
3354                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
3355                                    PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype] 
3356                                 );
3357                             });
3358
3359                             /* Is noper a trieable nodetype that can be merged with the
3360                              * current trie (if there is one)? */
3361                             if ( noper_trietype
3362                                   &&
3363                                   (
3364                                         ( noper_trietype == NOTHING)
3365                                         || ( trietype == NOTHING )
3366                                         || ( trietype == noper_trietype )
3367                                   )
3368 #ifdef NOJUMPTRIE
3369                                   && noper_next == tail
3370 #endif
3371                                   && count < U16_MAX)
3372                             {
3373                                 /* Handle mergable triable node
3374                                  * Either we are the first node in a new trieable sequence,
3375                                  * in which case we do some bookkeeping, otherwise we update
3376                                  * the end pointer. */
3377                                 if ( !first ) {
3378                                     first = cur;
3379                                     if ( noper_trietype == NOTHING ) {
3380 #if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
3381                                         regnode * const noper_next = regnext( noper );
3382                                         U8 noper_next_type = (noper_next && noper_next!=tail) ? OP(noper_next) : 0;
3383                                         U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
3384 #endif
3385
3386                                         if ( noper_next_trietype ) {
3387                                             trietype = noper_next_trietype;
3388                                         } else if (noper_next_type)  {
3389                                             /* a NOTHING regop is 1 regop wide. We need at least two
3390                                              * for a trie so we can't merge this in */
3391                                             first = NULL;
3392                                         }
3393                                     } else {
3394                                         trietype = noper_trietype;
3395                                     }
3396                                 } else {
3397                                     if ( trietype == NOTHING )
3398                                         trietype = noper_trietype;
3399                                     last = cur;
3400                                 }
3401                                 if (first)
3402                                     count++;
3403                             } /* end handle mergable triable node */
3404                             else {
3405                                 /* handle unmergable node -
3406                                  * noper may either be a triable node which can not be tried
3407                                  * together with the current trie, or a non triable node */
3408                                 if ( last ) {
3409                                     /* If last is set and trietype is not NOTHING then we have found
3410                                      * at least two triable branch sequences in a row of a similar
3411                                      * trietype so we can turn them into a trie. If/when we
3412                                      * allow NOTHING to start a trie sequence this condition will be
3413                                      * required, and it isn't expensive so we leave it in for now. */
3414                                     if ( trietype && trietype != NOTHING )
3415                                         make_trie( pRExC_state,
3416                                                 startbranch, first, cur, tail, count,
3417                                                 trietype, depth+1 );
3418                                     last = NULL; /* note: we clear/update first, trietype etc below, so we dont do it here */
3419                                 }
3420                                 if ( noper_trietype
3421 #ifdef NOJUMPTRIE
3422                                      && noper_next == tail
3423 #endif
3424                                 ){
3425                                     /* noper is triable, so we can start a new trie sequence */
3426                                     count = 1;
3427                                     first = cur;
3428                                     trietype = noper_trietype;
3429                                 } else if (first) {
3430                                     /* if we already saw a first but the current node is not triable then we have
3431                                      * to reset the first information. */
3432                                     count = 0;
3433                                     first = NULL;
3434                                     trietype = 0;
3435                                 }
3436                             } /* end handle unmergable node */
3437                         } /* loop over branches */
3438                         DEBUG_TRIE_COMPILE_r({
3439                             regprop(RExC_rx, mysv, cur);
3440                             PerlIO_printf( Perl_debug_log,
3441                               "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
3442                               "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3443
3444                         });
3445                         if ( last && trietype ) {
3446                             if ( trietype != NOTHING ) {
3447                                 /* the last branch of the sequence was part of a trie,
3448                                  * so we have to construct it here outside of the loop
3449                                  */
3450                                 made= make_trie( pRExC_state, startbranch, first, scan, tail, count, trietype, depth+1 );
3451 #ifdef TRIE_STUDY_OPT
3452                                 if ( ((made == MADE_EXACT_TRIE &&
3453                                      startbranch == first)
3454                                      || ( first_non_open == first )) &&
3455                                      depth==0 ) {
3456                                     flags |= SCF_TRIE_RESTUDY;
3457                                     if ( startbranch == first
3458                                          && scan == tail )
3459                                     {
3460                                         RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
3461                                     }
3462                                 }
3463 #endif
3464                             } else {
3465                                 /* at this point we know whatever we have is a NOTHING sequence/branch
3466                                  * AND if 'startbranch' is 'first' then we can turn the whole thing into a NOTHING
3467                                  */
3468                                 if ( startbranch == first ) {
3469                                     regnode *opt;
3470                                     /* the entire thing is a NOTHING sequence, something like this:
3471                                      * (?:|) So we can turn it into a plain NOTHING op. */
3472                                     DEBUG_TRIE_COMPILE_r({
3473                                         regprop(RExC_rx, mysv, cur);
3474                                         PerlIO_printf( Perl_debug_log,
3475                                           "%*s- %s (%d) <NOTHING BRANCH SEQUENCE>\n", (int)depth * 2 + 2,
3476                                           "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3477
3478                                     });
3479                                     OP(startbranch)= NOTHING;
3480                                     NEXT_OFF(startbranch)= tail - startbranch;
3481                                     for ( opt= startbranch + 1; opt < tail ; opt++ )
3482                                         OP(opt)= OPTIMIZED;
3483                                 }
3484                             }
3485                         } /* end if ( last) */
3486                     } /* TRIE_MAXBUF is non zero */
3487                     
3488                 } /* do trie */
3489                 
3490             }
3491             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
3492                 scan = NEXTOPER(NEXTOPER(scan));
3493             } else                      /* single branch is optimized. */
3494                 scan = NEXTOPER(scan);
3495             continue;
3496         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
3497             scan_frame *newframe = NULL;
3498             I32 paren;
3499             regnode *start;
3500             regnode *end;
3501
3502             if (OP(scan) != SUSPEND) {
3503             /* set the pointer */
3504                 if (OP(scan) == GOSUB) {
3505                     paren = ARG(scan);
3506                     RExC_recurse[ARG2L(scan)] = scan;
3507                     start = RExC_open_parens[paren-1];
3508                     end   = RExC_close_parens[paren-1];
3509                 } else {
3510                     paren = 0;
3511                     start = RExC_rxi->program + 1;
3512                     end   = RExC_opend;
3513                 }
3514                 if (!recursed) {
3515                     Newxz(recursed, (((RExC_npar)>>3) +1), U8);
3516                     SAVEFREEPV(recursed);
3517                 }
3518                 if (!PAREN_TEST(recursed,paren+1)) {
3519                     PAREN_SET(recursed,paren+1);
3520                     Newx(newframe,1,scan_frame);
3521                 } else {
3522                     if (flags & SCF_DO_SUBSTR) {
3523                         SCAN_COMMIT(pRExC_state,data,minlenp);
3524                         data->longest = &(data->longest_float);
3525                     }
3526                     is_inf = is_inf_internal = 1;
3527                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3528                         cl_anything(pRExC_state, data->start_class);
3529                     flags &= ~SCF_DO_STCLASS;
3530                 }
3531             } else {
3532                 Newx(newframe,1,scan_frame);
3533                 paren = stopparen;
3534                 start = scan+2;
3535                 end = regnext(scan);
3536             }
3537             if (newframe) {
3538                 assert(start);
3539                 assert(end);
3540                 SAVEFREEPV(newframe);
3541                 newframe->next = regnext(scan);
3542                 newframe->last = last;
3543                 newframe->stop = stopparen;
3544                 newframe->prev = frame;
3545
3546                 frame = newframe;
3547                 scan =  start;
3548                 stopparen = paren;
3549                 last = end;
3550
3551                 continue;
3552             }
3553         }
3554         else if (OP(scan) == EXACT) {
3555             I32 l = STR_LEN(scan);
3556             UV uc;
3557             if (UTF) {
3558                 const U8 * const s = (U8*)STRING(scan);
3559                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
3560                 l = utf8_length(s, s + l);
3561             } else {
3562                 uc = *((U8*)STRING(scan));
3563             }
3564             min += l;
3565             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
3566                 /* The code below prefers earlier match for fixed
3567                    offset, later match for variable offset.  */
3568                 if (data->last_end == -1) { /* Update the start info. */
3569                     data->last_start_min = data->pos_min;
3570                     data->last_start_max = is_inf
3571                         ? I32_MAX : data->pos_min + data->pos_delta;
3572                 }
3573                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
3574                 if (UTF)
3575                     SvUTF8_on(data->last_found);
3576                 {
3577                     SV * const sv = data->last_found;
3578                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3579                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
3580                     if (mg && mg->mg_len >= 0)
3581                         mg->mg_len += utf8_length((U8*)STRING(scan),
3582                                                   (U8*)STRING(scan)+STR_LEN(scan));
3583                 }
3584                 data->last_end = data->pos_min + l;
3585                 data->pos_min += l; /* As in the first entry. */
3586                 data->flags &= ~SF_BEFORE_EOL;
3587             }
3588             if (flags & SCF_DO_STCLASS_AND) {
3589                 /* Check whether it is compatible with what we know already! */
3590                 int compat = 1;
3591
3592
3593                 /* If compatible, we or it in below.  It is compatible if is
3594                  * in the bitmp and either 1) its bit or its fold is set, or 2)
3595                  * it's for a locale.  Even if there isn't unicode semantics
3596                  * here, at runtime there may be because of matching against a
3597                  * utf8 string, so accept a possible false positive for
3598                  * latin1-range folds */
3599                 if (uc >= 0x100 ||
3600                     (!(data->start_class->flags & ANYOF_LOCALE)
3601                     && !ANYOF_BITMAP_TEST(data->start_class, uc)
3602                     && (!(data->start_class->flags & ANYOF_LOC_FOLD)
3603                         || !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3604                     )
3605                 {
3606                     compat = 0;
3607                 }
3608                 ANYOF_CLASS_ZERO(data->start_class);
3609                 ANYOF_BITMAP_ZERO(data->start_class);
3610                 if (compat)
3611                     ANYOF_BITMAP_SET(data->start_class, uc);
3612                 else if (uc >= 0x100) {
3613                     int i;
3614
3615                     /* Some Unicode code points fold to the Latin1 range; as
3616                      * XXX temporary code, instead of figuring out if this is
3617                      * one, just assume it is and set all the start class bits
3618                      * that could be some such above 255 code point's fold
3619                      * which will generate fals positives.  As the code
3620                      * elsewhere that does compute the fold settles down, it
3621                      * can be extracted out and re-used here */
3622                     for (i = 0; i < 256; i++){
3623                         if (HAS_NONLATIN1_FOLD_CLOSURE(i)) {
3624                             ANYOF_BITMAP_SET(data->start_class, i);
3625                         }
3626                     }
3627                 }
3628                 CLEAR_SSC_EOS(data->start_class);
3629                 if (uc < 0x100)
3630                   data->start_class->flags &= ~ANYOF_UNICODE_ALL;
3631             }
3632             else if (flags & SCF_DO_STCLASS_OR) {
3633                 /* false positive possible if the class is case-folded */
3634                 if (uc < 0x100)
3635                     ANYOF_BITMAP_SET(data->start_class, uc);
3636                 else
3637                     data->start_class->flags |= ANYOF_UNICODE_ALL;
3638                 CLEAR_SSC_EOS(data->start_class);
3639                 cl_and(data->start_class, and_withp);
3640             }
3641             flags &= ~SCF_DO_STCLASS;
3642         }
3643         else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
3644             I32 l = STR_LEN(scan);
3645             UV uc = *((U8*)STRING(scan));
3646
3647             /* Search for fixed substrings supports EXACT only. */
3648             if (flags & SCF_DO_SUBSTR) {
3649                 assert(data);
3650                 SCAN_COMMIT(pRExC_state, data, minlenp);
3651             }
3652             if (UTF) {
3653                 const U8 * const s = (U8 *)STRING(scan);
3654                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
3655                 l = utf8_length(s, s + l);
3656             }
3657             if (has_exactf_sharp_s) {
3658                 RExC_seen |= REG_SEEN_EXACTF_SHARP_S;
3659             }
3660             min += l - min_subtract;
3661             assert (min >= 0);
3662             delta += min_subtract;
3663             if (flags & SCF_DO_SUBSTR) {
3664                 data->pos_min += l - min_subtract;
3665                 if (data->pos_min < 0) {
3666                     data->pos_min = 0;
3667                 }
3668                 data->pos_delta += min_subtract;
3669                 if (min_subtract) {
3670                     data->longest = &(data->longest_float);
3671                 }
3672             }
3673             if (flags & SCF_DO_STCLASS_AND) {
3674                 /* Check whether it is compatible with what we know already! */
3675                 int compat = 1;
3676                 if (uc >= 0x100 ||
3677                  (!(data->start_class->flags & ANYOF_LOCALE)
3678                   && !ANYOF_BITMAP_TEST(data->start_class, uc)
3679                   && !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3680                 {
3681                     compat = 0;
3682                 }
3683                 ANYOF_CLASS_ZERO(data->start_class);
3684                 ANYOF_BITMAP_ZERO(data->start_class);
3685                 if (compat) {
3686                     ANYOF_BITMAP_SET(data->start_class, uc);
3687                     CLEAR_SSC_EOS(data->start_class);
3688                     if (OP(scan) == EXACTFL) {
3689                         /* XXX This set is probably no longer necessary, and
3690                          * probably wrong as LOCALE now is on in the initial
3691                          * state */
3692                         data->start_class->flags |= ANYOF_LOCALE|ANYOF_LOC_FOLD;
3693                     }
3694                     else {
3695
3696                         /* Also set the other member of the fold pair.  In case
3697                          * that unicode semantics is called for at runtime, use
3698                          * the full latin1 fold.  (Can't do this for locale,
3699                          * because not known until runtime) */
3700                         ANYOF_BITMAP_SET(data->start_class, PL_fold_latin1[uc]);
3701
3702                         /* All other (EXACTFL handled above) folds except under
3703                          * /iaa that include s, S, and sharp_s also may include
3704                          * the others */
3705                         if (OP(scan) != EXACTFA) {
3706                             if (uc == 's' || uc == 'S') {
3707                                 ANYOF_BITMAP_SET(data->start_class,
3708                                                  LATIN_SMALL_LETTER_SHARP_S);
3709                             }
3710                             else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3711                                 ANYOF_BITMAP_SET(data->start_class, 's');
3712                                 ANYOF_BITMAP_SET(data->start_class, 'S');
3713                             }
3714                         }
3715                     }
3716                 }
3717                 else if (uc >= 0x100) {
3718                     int i;
3719                     for (i = 0; i < 256; i++){
3720                         if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3721                             ANYOF_BITMAP_SET(data->start_class, i);
3722                         }
3723                     }
3724                 }
3725             }
3726             else if (flags & SCF_DO_STCLASS_OR) {
3727                 if (data->start_class->flags & ANYOF_LOC_FOLD) {
3728                     /* false positive possible if the class is case-folded.
3729                        Assume that the locale settings are the same... */
3730                     if (uc < 0x100) {
3731                         ANYOF_BITMAP_SET(data->start_class, uc);
3732                         if (OP(scan) != EXACTFL) {
3733
3734                             /* And set the other member of the fold pair, but
3735                              * can't do that in locale because not known until
3736                              * run-time */
3737                             ANYOF_BITMAP_SET(data->start_class,
3738                                              PL_fold_latin1[uc]);
3739
3740                             /* All folds except under /iaa that include s, S,
3741                              * and sharp_s also may include the others */
3742                             if (OP(scan) != EXACTFA) {
3743                                 if (uc == 's' || uc == 'S') {
3744                                     ANYOF_BITMAP_SET(data->start_class,
3745                                                    LATIN_SMALL_LETTER_SHARP_S);
3746                                 }
3747                                 else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3748                                     ANYOF_BITMAP_SET(data->start_class, 's');
3749                                     ANYOF_BITMAP_SET(data->start_class, 'S');
3750                                 }
3751                             }
3752                         }
3753                     }
3754                     CLEAR_SSC_EOS(data->start_class);
3755                 }
3756                 cl_and(data->start_class, and_withp);
3757             }
3758             flags &= ~SCF_DO_STCLASS;
3759         }
3760         else if (REGNODE_VARIES(OP(scan))) {
3761             I32 mincount, maxcount, minnext, deltanext, fl = 0;
3762             I32 f = flags, pos_before = 0;
3763             regnode * const oscan = scan;
3764             struct regnode_charclass_class this_class;
3765             struct regnode_charclass_class *oclass = NULL;
3766             I32 next_is_eval = 0;
3767
3768             switch (PL_regkind[OP(scan)]) {
3769             case WHILEM:                /* End of (?:...)* . */
3770                 scan = NEXTOPER(scan);
3771                 goto finish;
3772             case PLUS:
3773                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
3774                     next = NEXTOPER(scan);
3775                     if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
3776                         mincount = 1;
3777                         maxcount = REG_INFTY;
3778                         next = regnext(scan);
3779                         scan = NEXTOPER(scan);
3780                         goto do_curly;
3781                     }
3782                 }
3783                 if (flags & SCF_DO_SUBSTR)
3784                     data->pos_min++;
3785                 min++;
3786                 /* Fall through. */
3787             case STAR:
3788                 if (flags & SCF_DO_STCLASS) {
3789                     mincount = 0;
3790                     maxcount = REG_INFTY;
3791                     next = regnext(scan);
3792                     scan = NEXTOPER(scan);
3793                     goto do_curly;
3794                 }
3795                 is_inf = is_inf_internal = 1;
3796                 scan = regnext(scan);
3797                 if (flags & SCF_DO_SUBSTR) {
3798                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
3799                     data->longest = &(data->longest_float);
3800                 }
3801                 goto optimize_curly_tail;
3802             case CURLY:
3803                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
3804                     && (scan->flags == stopparen))
3805                 {
3806                     mincount = 1;
3807                     maxcount = 1;
3808                 } else {
3809                     mincount = ARG1(scan);
3810                     maxcount = ARG2(scan);
3811                 }
3812                 next = regnext(scan);
3813                 if (OP(scan) == CURLYX) {
3814                     I32 lp = (data ? *(data->last_closep) : 0);
3815                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
3816                 }
3817                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3818                 next_is_eval = (OP(scan) == EVAL);
3819               do_curly:
3820                 if (flags & SCF_DO_SUBSTR) {
3821                     if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
3822                     pos_before = data->pos_min;
3823                 }
3824                 if (data) {
3825                     fl = data->flags;
3826                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
3827                     if (is_inf)
3828                         data->flags |= SF_IS_INF;
3829                 }
3830                 if (flags & SCF_DO_STCLASS) {
3831                     cl_init(pRExC_state, &this_class);
3832                     oclass = data->start_class;
3833                     data->start_class = &this_class;
3834                     f |= SCF_DO_STCLASS_AND;
3835                     f &= ~SCF_DO_STCLASS_OR;
3836                 }
3837                 /* Exclude from super-linear cache processing any {n,m}
3838                    regops for which the combination of input pos and regex
3839                    pos is not enough information to determine if a match
3840                    will be possible.
3841
3842                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
3843                    regex pos at the \s*, the prospects for a match depend not
3844                    only on the input position but also on how many (bar\s*)
3845                    repeats into the {4,8} we are. */
3846                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
3847                     f &= ~SCF_WHILEM_VISITED_POS;
3848
3849                 /* This will finish on WHILEM, setting scan, or on NULL: */
3850                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, 
3851                                       last, data, stopparen, recursed, NULL,
3852                                       (mincount == 0
3853                                         ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
3854
3855                 if (flags & SCF_DO_STCLASS)
3856                     data->start_class = oclass;
3857                 if (mincount == 0 || minnext == 0) {
3858                     if (flags & SCF_DO_STCLASS_OR) {
3859                         cl_or(pRExC_state, data->start_class, &this_class);
3860                     }
3861                     else if (flags & SCF_DO_STCLASS_AND) {
3862                         /* Switch to OR mode: cache the old value of
3863                          * data->start_class */
3864                         INIT_AND_WITHP;
3865                         StructCopy(data->start_class, and_withp,
3866                                    struct regnode_charclass_class);
3867                         flags &= ~SCF_DO_STCLASS_AND;
3868                         StructCopy(&this_class, data->start_class,
3869                                    struct regnode_charclass_class);
3870                         flags |= SCF_DO_STCLASS_OR;
3871                         SET_SSC_EOS(data->start_class);
3872                     }
3873                 } else {                /* Non-zero len */
3874                     if (flags & SCF_DO_STCLASS_OR) {
3875                         cl_or(pRExC_state, data->start_class, &this_class);
3876                         cl_and(data->start_class, and_withp);
3877                     }
3878                     else if (flags & SCF_DO_STCLASS_AND)
3879                         cl_and(data->start_class, &this_class);
3880                     flags &= ~SCF_DO_STCLASS;
3881                 }
3882                 if (!scan)              /* It was not CURLYX, but CURLY. */
3883                     scan = next;
3884                 if ( /* ? quantifier ok, except for (?{ ... }) */
3885                     (next_is_eval || !(mincount == 0 && maxcount == 1))
3886                     && (minnext == 0) && (deltanext == 0)
3887                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
3888                     && maxcount <= REG_INFTY/3) /* Complement check for big count */
3889                 {
3890                     /* Fatal warnings may leak the regexp without this: */
3891                     SAVEFREESV(RExC_rx_sv);
3892                     ckWARNreg(RExC_parse,
3893                               "Quantifier unexpected on zero-length expression");
3894                     (void)ReREFCNT_inc(RExC_rx_sv);
3895                 }
3896
3897                 min += minnext * mincount;
3898                 is_inf_internal |= deltanext == I32_MAX
3899                                      || (maxcount == REG_INFTY && minnext + deltanext > 0);
3900                 is_inf |= is_inf_internal;
3901                 if (is_inf)
3902                     delta = I32_MAX;
3903                 else
3904                     delta += (minnext + deltanext) * maxcount - minnext * mincount;
3905
3906                 /* Try powerful optimization CURLYX => CURLYN. */
3907                 if (  OP(oscan) == CURLYX && data
3908                       && data->flags & SF_IN_PAR
3909                       && !(data->flags & SF_HAS_EVAL)
3910                       && !deltanext && minnext == 1 ) {
3911                     /* Try to optimize to CURLYN.  */
3912                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
3913                     regnode * const nxt1 = nxt;
3914 #ifdef DEBUGGING
3915                     regnode *nxt2;
3916 #endif
3917
3918                     /* Skip open. */
3919                     nxt = regnext(nxt);
3920                     if (!REGNODE_SIMPLE(OP(nxt))
3921                         && !(PL_regkind[OP(nxt)] == EXACT
3922                              && STR_LEN(nxt) == 1))
3923                         goto nogo;
3924 #ifdef DEBUGGING
3925                     nxt2 = nxt;
3926 #endif
3927                     nxt = regnext(nxt);
3928                     if (OP(nxt) != CLOSE)
3929                         goto nogo;
3930                     if (RExC_open_parens) {
3931                         RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3932                         RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
3933                     }
3934                     /* Now we know that nxt2 is the only contents: */
3935                     oscan->flags = (U8)ARG(nxt);
3936                     OP(oscan) = CURLYN;
3937                     OP(nxt1) = NOTHING; /* was OPEN. */
3938
3939 #ifdef DEBUGGING
3940                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3941                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
3942                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
3943                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
3944                     OP(nxt + 1) = OPTIMIZED; /* was count. */
3945                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
3946 #endif
3947                 }
3948               nogo:
3949
3950                 /* Try optimization CURLYX => CURLYM. */
3951                 if (  OP(oscan) == CURLYX && data
3952                       && !(data->flags & SF_HAS_PAR)
3953                       && !(data->flags & SF_HAS_EVAL)
3954                       && !deltanext     /* atom is fixed width */
3955                       && minnext != 0   /* CURLYM can't handle zero width */
3956                       && ! (RExC_seen & REG_SEEN_EXACTF_SHARP_S) /* Nor \xDF */
3957                 ) {
3958                     /* XXXX How to optimize if data == 0? */
3959                     /* Optimize to a simpler form.  */
3960                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
3961                     regnode *nxt2;
3962
3963                     OP(oscan) = CURLYM;
3964                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
3965                             && (OP(nxt2) != WHILEM))
3966                         nxt = nxt2;
3967                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
3968                     /* Need to optimize away parenths. */
3969                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
3970                         /* Set the parenth number.  */
3971                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
3972
3973                         oscan->flags = (U8)ARG(nxt);
3974                         if (RExC_open_parens) {
3975                             RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3976                             RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
3977                         }
3978                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
3979                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
3980
3981 #ifdef DEBUGGING
3982                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3983                         OP(nxt + 1) = OPTIMIZED; /* was count. */
3984                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
3985                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
3986 #endif
3987 #if 0
3988                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
3989                             regnode *nnxt = regnext(nxt1);
3990                             if (nnxt == nxt) {
3991                                 if (reg_off_by_arg[OP(nxt1)])
3992                                     ARG_SET(nxt1, nxt2 - nxt1);
3993                                 else if (nxt2 - nxt1 < U16_MAX)
3994                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
3995                                 else
3996                                     OP(nxt) = NOTHING;  /* Cannot beautify */
3997                             }
3998                             nxt1 = nnxt;
3999                         }
4000 #endif
4001                         /* Optimize again: */
4002                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
4003                                     NULL, stopparen, recursed, NULL, 0,depth+1);
4004                     }
4005                     else
4006                         oscan->flags = 0;
4007                 }
4008                 else if ((OP(oscan) == CURLYX)
4009                          && (flags & SCF_WHILEM_VISITED_POS)
4010                          /* See the comment on a similar expression above.
4011                             However, this time it's not a subexpression
4012                             we care about, but the expression itself. */
4013                          && (maxcount == REG_INFTY)
4014                          && data && ++data->whilem_c < 16) {
4015                     /* This stays as CURLYX, we can put the count/of pair. */
4016                     /* Find WHILEM (as in regexec.c) */
4017                     regnode *nxt = oscan + NEXT_OFF(oscan);
4018
4019                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
4020                         nxt += ARG(nxt);
4021                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
4022                         | (RExC_whilem_seen << 4)); /* On WHILEM */
4023                 }
4024                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
4025                     pars++;
4026                 if (flags & SCF_DO_SUBSTR) {
4027                     SV *last_str = NULL;
4028                     int counted = mincount != 0;
4029
4030                     if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
4031 #if defined(SPARC64_GCC_WORKAROUND)
4032                         I32 b = 0;
4033                         STRLEN l = 0;
4034                         const char *s = NULL;
4035                         I32 old = 0;
4036
4037                         if (pos_before >= data->last_start_min)
4038                             b = pos_before;
4039                         else
4040                             b = data->last_start_min;
4041
4042                         l = 0;
4043                         s = SvPV_const(data->last_found, l);
4044                         old = b - data->last_start_min;
4045
4046 #else
4047                         I32 b = pos_before >= data->last_start_min
4048                             ? pos_before : data->last_start_min;
4049                         STRLEN l;
4050                         const char * const s = SvPV_const(data->last_found, l);
4051                         I32 old = b - data->last_start_min;
4052 #endif
4053
4054                         if (UTF)
4055                             old = utf8_hop((U8*)s, old) - (U8*)s;
4056                         l -= old;
4057                         /* Get the added string: */
4058                         last_str = newSVpvn_utf8(s  + old, l, UTF);
4059                         if (deltanext == 0 && pos_before == b) {
4060                             /* What was added is a constant string */
4061                             if (mincount > 1) {
4062                                 SvGROW(last_str, (mincount * l) + 1);
4063                                 repeatcpy(SvPVX(last_str) + l,
4064                                           SvPVX_const(last_str), l, mincount - 1);
4065                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
4066                                 /* Add additional parts. */
4067                                 SvCUR_set(data->last_found,
4068                                           SvCUR(data->last_found) - l);
4069                                 sv_catsv(data->last_found, last_str);
4070                                 {
4071                                     SV * sv = data->last_found;
4072                                     MAGIC *mg =
4073                                         SvUTF8(sv) && SvMAGICAL(sv) ?
4074                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
4075                                     if (mg && mg->mg_len >= 0)
4076                                         mg->mg_len += CHR_SVLEN(last_str) - l;
4077                                 }
4078                                 data->last_end += l * (mincount - 1);
4079                             }
4080                         } else {
4081                             /* start offset must point into the last copy */
4082                             data->last_start_min += minnext * (mincount - 1);
4083                             data->last_start_max += is_inf ? I32_MAX
4084                                 : (maxcount - 1) * (minnext + data->pos_delta);
4085                         }
4086                     }
4087                     /* It is counted once already... */
4088                     data->pos_min += minnext * (mincount - counted);
4089 #if 0
4090 PerlIO_printf(Perl_debug_log, "counted=%d deltanext=%d I32_MAX=%d minnext=%d maxcount=%d mincount=%d\n",
4091     counted, deltanext, I32_MAX, minnext, maxcount, mincount);
4092 if (deltanext != I32_MAX)
4093 PerlIO_printf(Perl_debug_log, "LHS=%d RHS=%d\n", -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount, I32_MAX - data->pos_delta);
4094 #endif
4095                     if (deltanext == I32_MAX || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= I32_MAX - data->pos_delta)
4096                         data->pos_delta = I32_MAX;
4097                     else
4098                         data->pos_delta += - counted * deltanext +
4099                         (minnext + deltanext) * maxcount - minnext * mincount;
4100                     if (mincount != maxcount) {
4101                          /* Cannot extend fixed substrings found inside
4102                             the group.  */
4103                         SCAN_COMMIT(pRExC_state,data,minlenp);
4104                         if (mincount && last_str) {
4105                             SV * const sv = data->last_found;
4106                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4107                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
4108
4109                             if (mg)
4110                                 mg->mg_len = -1;
4111                             sv_setsv(sv, last_str);
4112                             data->last_end = data->pos_min;
4113                             data->last_start_min =
4114                                 data->pos_min - CHR_SVLEN(last_str);
4115                             data->last_start_max = is_inf
4116                                 ? I32_MAX
4117                                 : data->pos_min + data->pos_delta
4118                                 - CHR_SVLEN(last_str);
4119                         }
4120                         data->longest = &(data->longest_float);
4121                     }
4122                     SvREFCNT_dec(last_str);
4123                 }
4124                 if (data && (fl & SF_HAS_EVAL))
4125                     data->flags |= SF_HAS_EVAL;
4126               optimize_curly_tail:
4127                 if (OP(oscan) != CURLYX) {
4128                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
4129                            && NEXT_OFF(next))
4130                         NEXT_OFF(oscan) += NEXT_OFF(next);
4131                 }
4132                 continue;
4133             default:                    /* REF, and CLUMP only? */
4134                 if (flags & SCF_DO_SUBSTR) {
4135                     SCAN_COMMIT(pRExC_state,data,minlenp);      /* Cannot expect anything... */
4136                     data->longest = &(data->longest_float);
4137                 }
4138                 is_inf = is_inf_internal = 1;
4139                 if (flags & SCF_DO_STCLASS_OR)
4140                     cl_anything(pRExC_state, data->start_class);
4141                 flags &= ~SCF_DO_STCLASS;
4142                 break;
4143             }
4144         }
4145         else if (OP(scan) == LNBREAK) {
4146             if (flags & SCF_DO_STCLASS) {
4147                 int value = 0;
4148                 CLEAR_SSC_EOS(data->start_class); /* No match on empty */
4149                 if (flags & SCF_DO_STCLASS_AND) {
4150                     for (value = 0; value < 256; value++)
4151                         if (!is_VERTWS_cp(value))
4152                             ANYOF_BITMAP_CLEAR(data->start_class, value);
4153                 }
4154                 else {
4155                     for (value = 0; value < 256; value++)
4156                         if (is_VERTWS_cp(value))
4157                             ANYOF_BITMAP_SET(data->start_class, value);
4158                 }
4159                 if (flags & SCF_DO_STCLASS_OR)
4160                     cl_and(data->start_class, and_withp);
4161                 flags &= ~SCF_DO_STCLASS;
4162             }
4163             min++;
4164             delta++;    /* Because of the 2 char string cr-lf */
4165             if (flags & SCF_DO_SUBSTR) {
4166                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
4167                 data->pos_min += 1;
4168                 data->pos_delta += 1;
4169                 data->longest = &(data->longest_float);
4170             }
4171         }
4172         else if (REGNODE_SIMPLE(OP(scan))) {
4173             int value = 0;
4174
4175             if (flags & SCF_DO_SUBSTR) {
4176                 SCAN_COMMIT(pRExC_state,data,minlenp);
4177                 data->pos_min++;
4178             }
4179             min++;
4180             if (flags & SCF_DO_STCLASS) {
4181                 int loop_max = 256;
4182                 CLEAR_SSC_EOS(data->start_class); /* No match on empty */
4183
4184                 /* Some of the logic below assumes that switching
4185                    locale on will only add false positives. */
4186                 switch (PL_regkind[OP(scan)]) {
4187                     U8 classnum;
4188
4189                 case SANY:
4190                 default:
4191 #ifdef DEBUGGING
4192                    Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan));
4193 #endif
4194                  do_default:
4195                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4196                         cl_anything(pRExC_state, data->start_class);
4197                     break;
4198                 case REG_ANY:
4199                     if (OP(scan) == SANY)
4200                         goto do_default;
4201                     if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
4202                         value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
4203                                 || ANYOF_CLASS_TEST_ANY_SET(data->start_class));
4204                         cl_anything(pRExC_state, data->start_class);
4205                     }
4206                     if (flags & SCF_DO_STCLASS_AND || !value)
4207                         ANYOF_BITMAP_CLEAR(data->start_class,'\n');
4208                     break;
4209                 case ANYOF:
4210                     if (flags & SCF_DO_STCLASS_AND)
4211                         cl_and(data->start_class,
4212                                (struct regnode_charclass_class*)scan);
4213                     else
4214                         cl_or(pRExC_state, data->start_class,
4215                               (struct regnode_charclass_class*)scan);
4216                     break;
4217                 case POSIXA:
4218                     loop_max = 128;
4219                     /* FALL THROUGH */
4220                 case POSIXL:
4221                 case POSIXD:
4222                 case POSIXU:
4223                     classnum = FLAGS(scan);
4224                     if (flags & SCF_DO_STCLASS_AND) {
4225                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
4226                             ANYOF_CLASS_CLEAR(data->start_class, classnum_to_namedclass(classnum) + 1);
4227                             for (value = 0; value < loop_max; value++) {
4228                                 if (! _generic_isCC(UNI_TO_NATIVE(value), classnum)) {
4229                                     ANYOF_BITMAP_CLEAR(data->start_class, UNI_TO_NATIVE(value));
4230                                 }
4231                             }
4232                         }
4233                     }
4234                     else {
4235                         if (data->start_class->flags & ANYOF_LOCALE) {
4236                             ANYOF_CLASS_SET(data->start_class, classnum_to_namedclass(classnum));
4237                         }
4238                         else {
4239
4240                         /* Even if under locale, set the bits for non-locale
4241                          * in case it isn't a true locale-node.  This will
4242                          * create false positives if it truly is locale */
4243                         for (value = 0; value < loop_max; value++) {
4244                             if (_generic_isCC(UNI_TO_NATIVE(value), classnum)) {
4245                                 ANYOF_BITMAP_SET(data->start_class, UNI_TO_NATIVE(value));
4246                             }
4247                         }
4248                         }
4249                     }
4250                     break;
4251                 case NPOSIXA:
4252                     loop_max = 128;
4253                     /* FALL THROUGH */
4254                 case NPOSIXL:
4255                 case NPOSIXU:
4256                 case NPOSIXD:
4257                     classnum = FLAGS(scan);
4258                     if (flags & SCF_DO_STCLASS_AND) {
4259                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
4260                             ANYOF_CLASS_CLEAR(data->start_class, classnum_to_namedclass(classnum));
4261                             for (value = 0; value < loop_max; value++) {
4262                                 if (_generic_isCC(UNI_TO_NATIVE(value), classnum)) {
4263                                     ANYOF_BITMAP_CLEAR(data->start_class, UNI_TO_NATIVE(value));
4264                                 }
4265                             }
4266                         }
4267                     }
4268                     else {
4269                         if (data->start_class->flags & ANYOF_LOCALE) {
4270                             ANYOF_CLASS_SET(data->start_class, classnum_to_namedclass(classnum) + 1);
4271                         }
4272                         else {
4273
4274                         /* Even if under locale, set the bits for non-locale in
4275                          * case it isn't a true locale-node.  This will create
4276                          * false positives if it truly is locale */
4277                         for (value = 0; value < loop_max; value++) {
4278                             if (! _generic_isCC(UNI_TO_NATIVE(value), classnum)) {
4279                                 ANYOF_BITMAP_SET(data->start_class, UNI_TO_NATIVE(value));
4280                             }
4281                         }
4282                         if (PL_regkind[OP(scan)] == NPOSIXD) {
4283                             data->start_class->flags |= ANYOF_NON_UTF8_LATIN1_ALL;
4284                         }
4285                         }
4286                     }
4287                     break;
4288                 }
4289                 if (flags & SCF_DO_STCLASS_OR)
4290                     cl_and(data->start_class, and_withp);
4291                 flags &= ~SCF_DO_STCLASS;
4292             }
4293         }
4294         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
4295             data->flags |= (OP(scan) == MEOL
4296                             ? SF_BEFORE_MEOL
4297                             : SF_BEFORE_SEOL);
4298             SCAN_COMMIT(pRExC_state, data, minlenp);
4299
4300         }
4301         else if (  PL_regkind[OP(scan)] == BRANCHJ
4302                  /* Lookbehind, or need to calculate parens/evals/stclass: */
4303                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
4304                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
4305             if ( OP(scan) == UNLESSM &&
4306                  scan->flags == 0 &&
4307                  OP(NEXTOPER(NEXTOPER(scan))) == NOTHING &&
4308                  OP(regnext(NEXTOPER(NEXTOPER(scan)))) == SUCCEED
4309             ) {
4310                 regnode *opt;
4311                 regnode *upto= regnext(scan);
4312                 DEBUG_PARSE_r({
4313                     SV * const mysv_val=sv_newmortal();
4314                     DEBUG_STUDYDATA("OPFAIL",data,depth);
4315
4316                     /*DEBUG_PARSE_MSG("opfail");*/
4317                     regprop(RExC_rx, mysv_val, upto);
4318                     PerlIO_printf(Perl_debug_log, "~ replace with OPFAIL pointed at %s (%"IVdf") offset %"IVdf"\n",
4319                                   SvPV_nolen_const(mysv_val),
4320                                   (IV)REG_NODE_NUM(upto),
4321                                   (IV)(upto - scan)
4322                     );
4323                 });
4324                 OP(scan) = OPFAIL;
4325                 NEXT_OFF(scan) = upto - scan;
4326                 for (opt= scan + 1; opt < upto ; opt++)
4327                     OP(opt) = OPTIMIZED;
4328                 scan= upto;
4329                 continue;
4330             }
4331             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY 
4332                 || OP(scan) == UNLESSM )
4333             {
4334                 /* Negative Lookahead/lookbehind
4335                    In this case we can't do fixed string optimisation.
4336                 */
4337
4338                 I32 deltanext, minnext, fake = 0;
4339                 regnode *nscan;
4340                 struct regnode_charclass_class intrnl;
4341                 int f = 0;
4342
4343                 data_fake.flags = 0;
4344                 if (data) {
4345                     data_fake.whilem_c = data->whilem_c;
4346                     data_fake.last_closep = data->last_closep;
4347                 }
4348                 else
4349                     data_fake.last_closep = &fake;
4350                 data_fake.pos_delta = delta;
4351                 if ( flags & SCF_DO_STCLASS && !scan->flags
4352                      && OP(scan) == IFMATCH ) { /* Lookahead */
4353                     cl_init(pRExC_state, &intrnl);
4354                     data_fake.start_class = &intrnl;
4355                     f |= SCF_DO_STCLASS_AND;
4356                 }
4357                 if (flags & SCF_WHILEM_VISITED_POS)
4358                     f |= SCF_WHILEM_VISITED_POS;
4359                 next = regnext(scan);
4360                 nscan = NEXTOPER(NEXTOPER(scan));
4361                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext, 
4362                     last, &data_fake, stopparen, recursed, NULL, f, depth+1);
4363                 if (scan->flags) {
4364                     if (deltanext) {
4365                         FAIL("Variable length lookbehind not implemented");
4366                     }
4367                     else if (minnext > (I32)U8_MAX) {
4368                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4369                     }
4370                     scan->flags = (U8)minnext;
4371                 }
4372                 if (data) {
4373                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4374                         pars++;
4375                     if (data_fake.flags & SF_HAS_EVAL)
4376                         data->flags |= SF_HAS_EVAL;
4377                     data->whilem_c = data_fake.whilem_c;
4378                 }
4379                 if (f & SCF_DO_STCLASS_AND) {
4380                     if (flags & SCF_DO_STCLASS_OR) {
4381                         /* OR before, AND after: ideally we would recurse with
4382                          * data_fake to get the AND applied by study of the
4383                          * remainder of the pattern, and then derecurse;
4384                          * *** HACK *** for now just treat as "no information".
4385                          * See [perl #56690].
4386                          */
4387                         cl_init(pRExC_state, data->start_class);
4388                     }  else {
4389                         /* AND before and after: combine and continue */
4390                         const int was = TEST_SSC_EOS(data->start_class);
4391
4392                         cl_and(data->start_class, &intrnl);
4393                         if (was)
4394                             SET_SSC_EOS(data->start_class);
4395                     }
4396                 }
4397             }
4398 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
4399             else {
4400                 /* Positive Lookahead/lookbehind
4401                    In this case we can do fixed string optimisation,
4402                    but we must be careful about it. Note in the case of
4403                    lookbehind the positions will be offset by the minimum
4404                    length of the pattern, something we won't know about
4405                    until after the recurse.
4406                 */
4407                 I32 deltanext, fake = 0;
4408                 regnode *nscan;
4409                 struct regnode_charclass_class intrnl;
4410                 int f = 0;
4411                 /* We use SAVEFREEPV so that when the full compile 
4412                     is finished perl will clean up the allocated 
4413                     minlens when it's all done. This way we don't
4414                     have to worry about freeing them when we know
4415                     they wont be used, which would be a pain.
4416                  */
4417                 I32 *minnextp;
4418                 Newx( minnextp, 1, I32 );
4419                 SAVEFREEPV(minnextp);
4420
4421                 if (data) {
4422                     StructCopy(data, &data_fake, scan_data_t);
4423                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
4424                         f |= SCF_DO_SUBSTR;
4425                         if (scan->flags) 
4426                             SCAN_COMMIT(pRExC_state, &data_fake,minlenp);
4427                         data_fake.last_found=newSVsv(data->last_found);
4428                     }
4429                 }
4430                 else
4431                     data_fake.last_closep = &fake;
4432                 data_fake.flags = 0;
4433                 data_fake.pos_delta = delta;
4434                 if (is_inf)
4435                     data_fake.flags |= SF_IS_INF;
4436                 if ( flags & SCF_DO_STCLASS && !scan->flags
4437                      && OP(scan) == IFMATCH ) { /* Lookahead */
4438                     cl_init(pRExC_state, &intrnl);
4439                     data_fake.start_class = &intrnl;
4440                     f |= SCF_DO_STCLASS_AND;
4441                 }
4442                 if (flags & SCF_WHILEM_VISITED_POS)
4443                     f |= SCF_WHILEM_VISITED_POS;
4444                 next = regnext(scan);
4445                 nscan = NEXTOPER(NEXTOPER(scan));
4446
4447                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext, 
4448                     last, &data_fake, stopparen, recursed, NULL, f,depth+1);
4449                 if (scan->flags) {
4450                     if (deltanext) {
4451                         FAIL("Variable length lookbehind not implemented");
4452                     }
4453                     else if (*minnextp > (I32)U8_MAX) {
4454                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4455                     }
4456                     scan->flags = (U8)*minnextp;
4457                 }
4458
4459                 *minnextp += min;
4460
4461                 if (f & SCF_DO_STCLASS_AND) {
4462                     const int was = TEST_SSC_EOS(data.start_class);
4463
4464                     cl_and(data->start_class, &intrnl);
4465                     if (was)
4466                         SET_SSC_EOS(data->start_class);
4467                 }
4468                 if (data) {
4469                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4470                         pars++;
4471                     if (data_fake.flags & SF_HAS_EVAL)
4472                         data->flags |= SF_HAS_EVAL;
4473                     data->whilem_c = data_fake.whilem_c;
4474                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
4475                         if (RExC_rx->minlen<*minnextp)
4476                             RExC_rx->minlen=*minnextp;
4477                         SCAN_COMMIT(pRExC_state, &data_fake, minnextp);
4478                         SvREFCNT_dec_NN(data_fake.last_found);
4479                         
4480                         if ( data_fake.minlen_fixed != minlenp ) 
4481                         {
4482                             data->offset_fixed= data_fake.offset_fixed;
4483                             data->minlen_fixed= data_fake.minlen_fixed;
4484                             data->lookbehind_fixed+= scan->flags;
4485                         }
4486                         if ( data_fake.minlen_float != minlenp )
4487                         {
4488                             data->minlen_float= data_fake.minlen_float;
4489                             data->offset_float_min=data_fake.offset_float_min;
4490                             data->offset_float_max=data_fake.offset_float_max;
4491                             data->lookbehind_float+= scan->flags;
4492                         }
4493                     }
4494                 }
4495             }
4496 #endif
4497         }
4498         else if (OP(scan) == OPEN) {
4499             if (stopparen != (I32)ARG(scan))
4500                 pars++;
4501         }
4502         else if (OP(scan) == CLOSE) {
4503             if (stopparen == (I32)ARG(scan)) {
4504                 break;
4505             }
4506             if ((I32)ARG(scan) == is_par) {
4507                 next = regnext(scan);
4508
4509                 if ( next && (OP(next) != WHILEM) && next < last)
4510                     is_par = 0;         /* Disable optimization */
4511             }
4512             if (data)
4513                 *(data->last_closep) = ARG(scan);
4514         }
4515         else if (OP(scan) == EVAL) {
4516                 if (data)
4517                     data->flags |= SF_HAS_EVAL;
4518         }
4519         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
4520             if (flags & SCF_DO_SUBSTR) {
4521                 SCAN_COMMIT(pRExC_state,data,minlenp);
4522                 flags &= ~SCF_DO_SUBSTR;
4523             }
4524             if (data && OP(scan)==ACCEPT) {
4525                 data->flags |= SCF_SEEN_ACCEPT;
4526                 if (stopmin > min)
4527                     stopmin = min;
4528             }
4529         }
4530         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
4531         {
4532                 if (flags & SCF_DO_SUBSTR) {
4533                     SCAN_COMMIT(pRExC_state,data,minlenp);
4534                     data->longest = &(data->longest_float);
4535                 }
4536                 is_inf = is_inf_internal = 1;
4537                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4538                     cl_anything(pRExC_state, data->start_class);
4539                 flags &= ~SCF_DO_STCLASS;
4540         }
4541         else if (OP(scan) == GPOS) {
4542             if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) &&
4543                 !(delta || is_inf || (data && data->pos_delta))) 
4544             {
4545                 if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR))
4546                     RExC_rx->extflags |= RXf_ANCH_GPOS;
4547                 if (RExC_rx->gofs < (U32)min)
4548                     RExC_rx->gofs = min;
4549             } else {
4550                 RExC_rx->extflags |= RXf_GPOS_FLOAT;
4551                 RExC_rx->gofs = 0;
4552             }       
4553         }
4554 #ifdef TRIE_STUDY_OPT
4555 #ifdef FULL_TRIE_STUDY
4556         else if (PL_regkind[OP(scan)] == TRIE) {
4557             /* NOTE - There is similar code to this block above for handling
4558                BRANCH nodes on the initial study.  If you change stuff here
4559                check there too. */
4560             regnode *trie_node= scan;
4561             regnode *tail= regnext(scan);
4562             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4563             I32 max1 = 0, min1 = I32_MAX;
4564             struct regnode_charclass_class accum;
4565
4566             if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
4567                 SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
4568             if (flags & SCF_DO_STCLASS)
4569                 cl_init_zero(pRExC_state, &accum);
4570                 
4571             if (!trie->jump) {
4572                 min1= trie->minlen;
4573                 max1= trie->maxlen;
4574             } else {
4575                 const regnode *nextbranch= NULL;
4576                 U32 word;
4577                 
4578                 for ( word=1 ; word <= trie->wordcount ; word++) 
4579                 {
4580                     I32 deltanext=0, minnext=0, f = 0, fake;
4581                     struct regnode_charclass_class this_class;
4582                     
4583                     data_fake.flags = 0;
4584                     if (data) {
4585                         data_fake.whilem_c = data->whilem_c;
4586                         data_fake.last_closep = data->last_closep;
4587                     }
4588                     else
4589                         data_fake.last_closep = &fake;
4590                     data_fake.pos_delta = delta;
4591                     if (flags & SCF_DO_STCLASS) {
4592                         cl_init(pRExC_state, &this_class);
4593                         data_fake.start_class = &this_class;
4594                         f = SCF_DO_STCLASS_AND;
4595                     }
4596                     if (flags & SCF_WHILEM_VISITED_POS)
4597                         f |= SCF_WHILEM_VISITED_POS;
4598     
4599                     if (trie->jump[word]) {
4600                         if (!nextbranch)
4601                             nextbranch = trie_node + trie->jump[0];
4602                         scan= trie_node + trie->jump[word];
4603                         /* We go from the jump point to the branch that follows
4604                            it. Note this means we need the vestigal unused branches
4605                            even though they arent otherwise used.
4606                          */
4607                         minnext = study_chunk(pRExC_state, &scan, minlenp, 
4608                             &deltanext, (regnode *)nextbranch, &data_fake, 
4609                             stopparen, recursed, NULL, f,depth+1);
4610                     }
4611                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
4612                         nextbranch= regnext((regnode*)nextbranch);
4613                     
4614                     if (min1 > (I32)(minnext + trie->minlen))
4615                         min1 = minnext + trie->minlen;
4616                     if (deltanext == I32_MAX) {
4617                         is_inf = is_inf_internal = 1;
4618                         max1 = I32_MAX;
4619                     } else if (max1 < (I32)(minnext + deltanext + trie->maxlen))
4620                         max1 = minnext + deltanext + trie->maxlen;
4621                     
4622                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4623                         pars++;
4624                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4625                         if ( stopmin > min + min1) 
4626                             stopmin = min + min1;
4627                         flags &= ~SCF_DO_SUBSTR;
4628                         if (data)
4629                             data->flags |= SCF_SEEN_ACCEPT;
4630                     }
4631                     if (data) {
4632                         if (data_fake.flags & SF_HAS_EVAL)
4633                             data->flags |= SF_HAS_EVAL;
4634                         data->whilem_c = data_fake.whilem_c;
4635                     }
4636                     if (flags & SCF_DO_STCLASS)
4637                         cl_or(pRExC_state, &accum, &this_class);
4638                 }
4639             }
4640             if (flags & SCF_DO_SUBSTR) {
4641                 data->pos_min += min1;
4642                 data->pos_delta += max1 - min1;
4643                 if (max1 != min1 || is_inf)
4644                     data->longest = &(data->longest_float);
4645             }
4646             min += min1;
4647             delta += max1 - min1;
4648             if (flags & SCF_DO_STCLASS_OR) {
4649                 cl_or(pRExC_state, data->start_class, &accum);
4650                 if (min1) {
4651                     cl_and(data->start_class, and_withp);
4652                     flags &= ~SCF_DO_STCLASS;
4653                 }
4654             }
4655             else if (flags & SCF_DO_STCLASS_AND) {
4656                 if (min1) {
4657                     cl_and(data->start_class, &accum);
4658                     flags &= ~SCF_DO_STCLASS;
4659                 }
4660                 else {
4661                     /* Switch to OR mode: cache the old value of
4662                      * data->start_class */
4663                     INIT_AND_WITHP;
4664                     StructCopy(data->start_class, and_withp,
4665                                struct regnode_charclass_class);
4666                     flags &= ~SCF_DO_STCLASS_AND;
4667                     StructCopy(&accum, data->start_class,
4668                                struct regnode_charclass_class);
4669                     flags |= SCF_DO_STCLASS_OR;
4670                     SET_SSC_EOS(data->start_class);
4671                 }
4672             }
4673             scan= tail;
4674             continue;
4675         }
4676 #else
4677         else if (PL_regkind[OP(scan)] == TRIE) {
4678             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4679             U8*bang=NULL;
4680             
4681             min += trie->minlen;
4682             delta += (trie->maxlen - trie->minlen);
4683             flags &= ~SCF_DO_STCLASS; /* xxx */
4684             if (flags & SCF_DO_SUBSTR) {
4685                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
4686                 data->pos_min += trie->minlen;
4687                 data->pos_delta += (trie->maxlen - trie->minlen);
4688                 if (trie->maxlen != trie->minlen)
4689                     data->longest = &(data->longest_float);
4690             }
4691             if (trie->jump) /* no more substrings -- for now /grr*/
4692                 flags &= ~SCF_DO_SUBSTR; 
4693         }
4694 #endif /* old or new */
4695 #endif /* TRIE_STUDY_OPT */
4696
4697         /* Else: zero-length, ignore. */
4698         scan = regnext(scan);
4699     }
4700     if (frame) {
4701         last = frame->last;
4702         scan = frame->next;
4703         stopparen = frame->stop;
4704         frame = frame->prev;
4705         goto fake_study_recurse;
4706     }
4707
4708   finish:
4709     assert(!frame);
4710     DEBUG_STUDYDATA("pre-fin:",data,depth);
4711
4712     *scanp = scan;
4713     *deltap = is_inf_internal ? I32_MAX : delta;
4714     if (flags & SCF_DO_SUBSTR && is_inf)
4715         data->pos_delta = I32_MAX - data->pos_min;
4716     if (is_par > (I32)U8_MAX)
4717         is_par = 0;
4718     if (is_par && pars==1 && data) {
4719         data->flags |= SF_IN_PAR;
4720         data->flags &= ~SF_HAS_PAR;
4721     }
4722     else if (pars && data) {
4723         data->flags |= SF_HAS_PAR;
4724         data->flags &= ~SF_IN_PAR;
4725     }
4726     if (flags & SCF_DO_STCLASS_OR)
4727         cl_and(data->start_class, and_withp);
4728     if (flags & SCF_TRIE_RESTUDY)
4729         data->flags |=  SCF_TRIE_RESTUDY;
4730     
4731     DEBUG_STUDYDATA("post-fin:",data,depth);
4732     
4733     return min < stopmin ? min : stopmin;
4734 }
4735
4736 STATIC U32
4737 S_add_data(RExC_state_t *pRExC_state, U32 n, const char *s)
4738 {
4739     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
4740
4741     PERL_ARGS_ASSERT_ADD_DATA;
4742
4743     Renewc(RExC_rxi->data,
4744            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
4745            char, struct reg_data);
4746     if(count)
4747         Renew(RExC_rxi->data->what, count + n, U8);
4748     else
4749         Newx(RExC_rxi->data->what, n, U8);
4750     RExC_rxi->data->count = count + n;
4751     Copy(s, RExC_rxi->data->what + count, n, U8);
4752     return count;
4753 }
4754
4755 /*XXX: todo make this not included in a non debugging perl */
4756 #ifndef PERL_IN_XSUB_RE
4757 void
4758 Perl_reginitcolors(pTHX)
4759 {
4760     dVAR;
4761     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
4762     if (s) {
4763         char *t = savepv(s);
4764         int i = 0;
4765         PL_colors[0] = t;
4766         while (++i < 6) {
4767             t = strchr(t, '\t');
4768             if (t) {
4769                 *t = '\0';
4770                 PL_colors[i] = ++t;
4771             }
4772             else
4773                 PL_colors[i] = t = (char *)"";
4774         }
4775     } else {
4776         int i = 0;
4777         while (i < 6)
4778             PL_colors[i++] = (char *)"";
4779     }
4780     PL_colorset = 1;
4781 }
4782 #endif
4783
4784
4785 #ifdef TRIE_STUDY_OPT
4786 #define CHECK_RESTUDY_GOTO_butfirst(dOsomething)            \
4787     STMT_START {                                            \
4788         if (                                                \
4789               (data.flags & SCF_TRIE_RESTUDY)               \
4790               && ! restudied++                              \
4791         ) {                                                 \
4792             dOsomething;                                    \
4793             goto reStudy;                                   \
4794         }                                                   \
4795     } STMT_END
4796 #else
4797 #define CHECK_RESTUDY_GOTO_butfirst
4798 #endif        
4799
4800 /*
4801  * pregcomp - compile a regular expression into internal code
4802  *
4803  * Decides which engine's compiler to call based on the hint currently in
4804  * scope
4805  */
4806
4807 #ifndef PERL_IN_XSUB_RE 
4808
4809 /* return the currently in-scope regex engine (or the default if none)  */
4810
4811 regexp_engine const *
4812 Perl_current_re_engine(pTHX)
4813 {
4814     dVAR;
4815
4816     if (IN_PERL_COMPILETIME) {
4817         HV * const table = GvHV(PL_hintgv);
4818         SV **ptr;
4819
4820         if (!table)
4821             return &PL_core_reg_engine;
4822         ptr = hv_fetchs(table, "regcomp", FALSE);
4823         if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
4824             return &PL_core_reg_engine;
4825         return INT2PTR(regexp_engine*,SvIV(*ptr));
4826     }
4827     else {
4828         SV *ptr;
4829         if (!PL_curcop->cop_hints_hash)
4830             return &PL_core_reg_engine;
4831         ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
4832         if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
4833             return &PL_core_reg_engine;
4834         return INT2PTR(regexp_engine*,SvIV(ptr));
4835     }
4836 }
4837
4838
4839 REGEXP *
4840 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
4841 {
4842     dVAR;
4843     regexp_engine const *eng = current_re_engine();
4844     GET_RE_DEBUG_FLAGS_DECL;
4845
4846     PERL_ARGS_ASSERT_PREGCOMP;
4847
4848     /* Dispatch a request to compile a regexp to correct regexp engine. */
4849     DEBUG_COMPILE_r({
4850         PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
4851                         PTR2UV(eng));
4852     });
4853     return CALLREGCOMP_ENG(eng, pattern, flags);
4854 }
4855 #endif
4856
4857 /* public(ish) entry point for the perl core's own regex compiling code.
4858  * It's actually a wrapper for Perl_re_op_compile that only takes an SV
4859  * pattern rather than a list of OPs, and uses the internal engine rather
4860  * than the current one */
4861
4862 REGEXP *
4863 Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
4864 {
4865     SV *pat = pattern; /* defeat constness! */
4866     PERL_ARGS_ASSERT_RE_COMPILE;
4867     return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
4868 #ifdef PERL_IN_XSUB_RE
4869                                 &my_reg_engine,
4870 #else
4871                                 &PL_core_reg_engine,
4872 #endif
4873                                 NULL, NULL, rx_flags, 0);
4874 }
4875
4876
4877 /* upgrade pattern pat_p of length plen_p to UTF8, and if there are code
4878  * blocks, recalculate the indices. Update pat_p and plen_p in-place to
4879  * point to the realloced string and length.
4880  *
4881  * This is essentially a copy of Perl_bytes_to_utf8() with the code index
4882  * stuff added */
4883
4884 static void
4885 S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state,
4886                     char **pat_p, STRLEN *plen_p, int num_code_blocks)
4887 {
4888     U8 *const src = (U8*)*pat_p;
4889     U8 *dst;
4890     int n=0;
4891     STRLEN s = 0, d = 0;
4892     bool do_end = 0;
4893     GET_RE_DEBUG_FLAGS_DECL;
4894
4895     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
4896         "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
4897
4898     Newx(dst, *plen_p * 2 + 1, U8);
4899
4900     while (s < *plen_p) {
4901         const UV uv = NATIVE_TO_ASCII(src[s]);
4902         if (UNI_IS_INVARIANT(uv))
4903             dst[d]   = (U8)UTF_TO_NATIVE(uv);
4904         else {
4905             dst[d++] = (U8)UTF8_EIGHT_BIT_HI(uv);
4906             dst[d]   = (U8)UTF8_EIGHT_BIT_LO(uv);
4907         }
4908         if (n < num_code_blocks) {
4909             if (!do_end && pRExC_state->code_blocks[n].start == s) {
4910                 pRExC_state->code_blocks[n].start = d;
4911                 assert(dst[d] == '(');
4912                 do_end = 1;
4913             }
4914             else if (do_end && pRExC_state->code_blocks[n].end == s) {
4915                 pRExC_state->code_blocks[n].end = d;
4916                 assert(dst[d] == ')');
4917                 do_end = 0;
4918                 n++;
4919             }
4920         }
4921         s++;
4922         d++;
4923     }
4924     dst[d] = '\0';
4925     *plen_p = d;
4926     *pat_p = (char*) dst;
4927     SAVEFREEPV(*pat_p);
4928     RExC_orig_utf8 = RExC_utf8 = 1;
4929 }
4930
4931
4932
4933 /* S_concat_pat(): concatenate a list of args to the pattern string pat,
4934  * while recording any code block indices, and handling overloading,
4935  * nested qr// objects etc.  If pat is null, it will allocate a new
4936  * string, or just return the first arg, if there's only one.
4937  *
4938  * Returns the malloced/updated pat.
4939  * patternp and pat_count is the array of SVs to be concatted;
4940  * oplist is the optional list of ops that generated the SVs;
4941  * recompile_p is a pointer to a boolean that will be set if
4942  *   the regex will need to be recompiled.
4943  * delim, if non-null is an SV that will be inserted between each element
4944  */
4945
4946 static SV*
4947 S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
4948                 SV *pat, SV ** const patternp, int pat_count,
4949                 OP *oplist, bool *recompile_p, SV *delim)
4950 {
4951     SV **svp;
4952     int n = 0;
4953     bool use_delim = FALSE;
4954     bool alloced = FALSE;
4955
4956     /* if we know we have at least two args, create an empty string,
4957      * then concatenate args to that. For no args, return an empty string */
4958     if (!pat && pat_count != 1) {
4959         pat = newSVpvn("", 0);
4960         SAVEFREESV(pat);
4961         alloced = TRUE;
4962     }
4963
4964     for (svp = patternp; svp < patternp + pat_count; svp++) {
4965         SV *sv;
4966         SV *rx  = NULL;
4967         STRLEN orig_patlen = 0;
4968         bool code = 0;
4969         SV *msv = use_delim ? delim : *svp;
4970
4971         /* if we've got a delimiter, we go round the loop twice for each
4972          * svp slot (except the last), using the delimiter the second
4973          * time round */
4974         if (use_delim) {
4975             svp--;
4976             use_delim = FALSE;
4977         }
4978         else if (delim)
4979             use_delim = TRUE;
4980
4981         if (SvTYPE(msv) == SVt_PVAV) {
4982             /* we've encountered an interpolated array within
4983              * the pattern, e.g. /...@a..../. Expand the list of elements,
4984              * then recursively append elements.
4985              * The code in this block is based on S_pushav() */
4986
4987             AV *const av = (AV*)msv;
4988             const I32 maxarg = AvFILL(av) + 1;
4989             SV **array;
4990
4991             if (oplist) {
4992                 assert(oplist->op_type == OP_PADAV
4993                     || oplist->op_type == OP_RV2AV); 
4994                 oplist = oplist->op_sibling;;
4995             }
4996
4997             if (SvRMAGICAL(av)) {
4998                 U32 i;
4999
5000                 Newx(array, maxarg, SV*);
5001                 SAVEFREEPV(array);
5002                 for (i=0; i < (U32)maxarg; i++) {
5003                     SV ** const svp = av_fetch(av, i, FALSE);
5004                     array[i] = svp ? *svp : &PL_sv_undef;
5005                 }
5006             }
5007             else
5008                 array = AvARRAY(av);
5009
5010             pat = S_concat_pat(aTHX_ pRExC_state, pat,
5011                                 array, maxarg, NULL, recompile_p,
5012                                 /* $" */
5013                                 GvSV((gv_fetchpvs("\"", GV_ADDMULTI, SVt_PV))));
5014
5015             continue;
5016         }
5017
5018
5019         /* we make the assumption here that each op in the list of
5020          * op_siblings maps to one SV pushed onto the stack,
5021          * except for code blocks, with have both an OP_NULL and
5022          * and OP_CONST.
5023          * This allows us to match up the list of SVs against the
5024          * list of OPs to find the next code block.
5025          *
5026          * Note that       PUSHMARK PADSV PADSV ..
5027          * is optimised to
5028          *                 PADRANGE PADSV  PADSV  ..
5029          * so the alignment still works. */
5030
5031         if (oplist) {
5032             if (oplist->op_type == OP_NULL
5033                 && (oplist->op_flags & OPf_SPECIAL))
5034             {
5035                 assert(n < pRExC_state->num_code_blocks);
5036                 pRExC_state->code_blocks[n].start = pat ? SvCUR(pat) : 0;
5037                 pRExC_state->code_blocks[n].block = oplist;
5038                 pRExC_state->code_blocks[n].src_regex = NULL;
5039                 n++;
5040                 code = 1;
5041                 oplist = oplist->op_sibling; /* skip CONST */
5042                 assert(oplist);
5043             }
5044             oplist = oplist->op_sibling;;
5045         }
5046
5047         /* apply magic and QR overloading to arg */
5048
5049         SvGETMAGIC(msv);
5050         if (SvROK(msv) && SvAMAGIC(msv)) {
5051             SV *sv = AMG_CALLunary(msv, regexp_amg);
5052             if (sv) {
5053                 if (SvROK(sv))
5054                     sv = SvRV(sv);
5055                 if (SvTYPE(sv) != SVt_REGEXP)
5056                     Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
5057                 msv = sv;
5058             }
5059         }
5060
5061         /* try concatenation overload ... */
5062         if (pat && (SvAMAGIC(pat) || SvAMAGIC(msv)) &&
5063                 (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
5064         {
5065             sv_setsv(pat, sv);
5066             /* overloading involved: all bets are off over literal
5067              * code. Pretend we haven't seen it */
5068             pRExC_state->num_code_blocks -= n;
5069             n = 0;
5070         }
5071         else  {
5072             /* ... or failing that, try "" overload */
5073             while (SvAMAGIC(msv)
5074                     && (sv = AMG_CALLunary(msv, string_amg))
5075                     && sv != msv
5076                     &&  !(   SvROK(msv)
5077                           && SvROK(sv)
5078                           && SvRV(msv) == SvRV(sv))
5079             ) {
5080                 msv = sv;
5081                 SvGETMAGIC(msv);
5082             }
5083             if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
5084                 msv = SvRV(msv);
5085
5086             if (pat) {
5087                 /* this is a partially unrolled
5088                  *     sv_catsv_nomg(pat, msv);
5089                  * that allows us to adjust code block indices if
5090                  * needed */
5091                 STRLEN slen, dlen;
5092                 char *dst = SvPV_force_nomg(pat, dlen);
5093                 const char *src = SvPV_flags_const(msv, slen, 0);
5094                 orig_patlen = dlen;
5095                 if (SvUTF8(msv) && !SvUTF8(pat)) {
5096                     S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &dst, &dlen, n);
5097                     sv_setpvn(pat, dst, dlen);
5098                     SvUTF8_on(pat);
5099                 }
5100                 sv_catpvn_nomg(pat, src, slen);
5101                 rx = msv;
5102             }
5103             else
5104                 pat = msv;
5105
5106             if (code)
5107                 pRExC_state->code_blocks[n-1].end = SvCUR(pat)-1;
5108         }
5109
5110         /* extract any code blocks within any embedded qr//'s */
5111         if (rx && SvTYPE(rx) == SVt_REGEXP
5112             && RX_ENGINE((REGEXP*)rx)->op_comp)
5113         {
5114
5115             RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
5116             if (ri->num_code_blocks) {
5117                 int i;
5118                 /* the presence of an embedded qr// with code means
5119                  * we should always recompile: the text of the
5120                  * qr// may not have changed, but it may be a
5121                  * different closure than last time */
5122                 *recompile_p = 1;
5123                 Renew(pRExC_state->code_blocks,
5124                     pRExC_state->num_code_blocks + ri->num_code_blocks,
5125                     struct reg_code_block);
5126                 pRExC_state->num_code_blocks += ri->num_code_blocks;
5127
5128                 for (i=0; i < ri->num_code_blocks; i++) {
5129                     struct reg_code_block *src, *dst;
5130                     STRLEN offset =  orig_patlen
5131                         + ReANY((REGEXP *)rx)->pre_prefix;
5132                     assert(n < pRExC_state->num_code_blocks);
5133                     src = &ri->code_blocks[i];
5134                     dst = &pRExC_state->code_blocks[n];
5135                     dst->start      = src->start + offset;
5136                     dst->end        = src->end   + offset;
5137                     dst->block      = src->block;
5138                     dst->src_regex  = (REGEXP*) SvREFCNT_inc( (SV*)
5139                                             src->src_regex
5140                                                 ? src->src_regex
5141                                                 : (REGEXP*)rx);
5142                     n++;
5143                 }
5144             }
5145         }
5146     }
5147     /* avoid calling magic multiple times on a single element e.g. =~ $qr */
5148     if (alloced)
5149         SvSETMAGIC(pat);
5150
5151     return pat;
5152 }
5153
5154
5155
5156 /* see if there are any run-time code blocks in the pattern.
5157  * False positives are allowed */
5158
5159 static bool
5160 S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
5161                     char *pat, STRLEN plen)
5162 {
5163     int n = 0;
5164     STRLEN s;
5165
5166     for (s = 0; s < plen; s++) {
5167         if (n < pRExC_state->num_code_blocks
5168             && s == pRExC_state->code_blocks[n].start)
5169         {
5170             s = pRExC_state->code_blocks[n].end;
5171             n++;
5172             continue;
5173         }
5174         /* TODO ideally should handle [..], (#..), /#.../x to reduce false
5175          * positives here */
5176         if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' &&
5177             (pat[s+2] == '{'
5178                 || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{'))
5179         )
5180             return 1;
5181     }
5182     return 0;
5183 }
5184
5185 /* Handle run-time code blocks. We will already have compiled any direct
5186  * or indirect literal code blocks. Now, take the pattern 'pat' and make a
5187  * copy of it, but with any literal code blocks blanked out and
5188  * appropriate chars escaped; then feed it into
5189  *
5190  *    eval "qr'modified_pattern'"
5191  *
5192  * For example,
5193  *
5194  *       a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
5195  *
5196  * becomes
5197  *
5198  *    qr'a\\bc_______________________def\'ghi\\\\jkl(?{"this is runtime"})mno'
5199  *
5200  * After eval_sv()-ing that, grab any new code blocks from the returned qr
5201  * and merge them with any code blocks of the original regexp.
5202  *
5203  * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
5204  * instead, just save the qr and return FALSE; this tells our caller that
5205  * the original pattern needs upgrading to utf8.
5206  */
5207
5208 static bool
5209 S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
5210     char *pat, STRLEN plen)
5211 {
5212     SV *qr;
5213
5214     GET_RE_DEBUG_FLAGS_DECL;
5215
5216     if (pRExC_state->runtime_code_qr) {
5217         /* this is the second time we've been called; this should
5218          * only happen if the main pattern got upgraded to utf8
5219          * during compilation; re-use the qr we compiled first time
5220          * round (which should be utf8 too)
5221          */
5222         qr = pRExC_state->runtime_code_qr;
5223         pRExC_state->runtime_code_qr = NULL;
5224         assert(RExC_utf8 && SvUTF8(qr));
5225     }
5226     else {
5227         int n = 0;
5228         STRLEN s;
5229         char *p, *newpat;
5230         int newlen = plen + 6; /* allow for "qr''x\0" extra chars */
5231         SV *sv, *qr_ref;
5232         dSP;
5233
5234         /* determine how many extra chars we need for ' and \ escaping */
5235         for (s = 0; s < plen; s++) {
5236             if (pat[s] == '\'' || pat[s] == '\\')
5237                 newlen++;
5238         }
5239
5240         Newx(newpat, newlen, char);
5241         p = newpat;
5242         *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
5243
5244         for (s = 0; s < plen; s++) {
5245             if (n < pRExC_state->num_code_blocks
5246                 && s == pRExC_state->code_blocks[n].start)
5247             {
5248                 /* blank out literal code block */
5249                 assert(pat[s] == '(');
5250                 while (s <= pRExC_state->code_blocks[n].end) {
5251                     *p++ = '_';
5252                     s++;
5253                 }
5254                 s--;
5255                 n++;
5256                 continue;
5257             }
5258             if (pat[s] == '\'' || pat[s] == '\\')
5259                 *p++ = '\\';
5260             *p++ = pat[s];
5261         }
5262         *p++ = '\'';
5263         if (pRExC_state->pm_flags & RXf_PMf_EXTENDED)
5264             *p++ = 'x';
5265         *p++ = '\0';
5266         DEBUG_COMPILE_r({
5267             PerlIO_printf(Perl_debug_log,
5268                 "%sre-parsing pattern for runtime code:%s %s\n",
5269                 PL_colors[4],PL_colors[5],newpat);
5270         });
5271
5272         sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
5273         Safefree(newpat);
5274
5275         ENTER;
5276         SAVETMPS;
5277         save_re_context();
5278         PUSHSTACKi(PERLSI_REQUIRE);
5279         /* G_RE_REPARSING causes the toker to collapse \\ into \ when
5280          * parsing qr''; normally only q'' does this. It also alters
5281          * hints handling */
5282         eval_sv(sv, G_SCALAR|G_RE_REPARSING);
5283         SvREFCNT_dec_NN(sv);
5284         SPAGAIN;
5285         qr_ref = POPs;
5286         PUTBACK;
5287         {
5288             SV * const errsv = ERRSV;
5289             if (SvTRUE_NN(errsv))
5290             {
5291                 Safefree(pRExC_state->code_blocks);
5292                 /* use croak_sv ? */
5293                 Perl_croak_nocontext("%s", SvPV_nolen_const(errsv));
5294             }
5295         }
5296         assert(SvROK(qr_ref));
5297         qr = SvRV(qr_ref);
5298         assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
5299         /* the leaving below frees the tmp qr_ref.
5300          * Give qr a life of its own */
5301         SvREFCNT_inc(qr);
5302         POPSTACK;
5303         FREETMPS;
5304         LEAVE;
5305
5306     }
5307
5308     if (!RExC_utf8 && SvUTF8(qr)) {
5309         /* first time through; the pattern got upgraded; save the
5310          * qr for the next time through */
5311         assert(!pRExC_state->runtime_code_qr);
5312         pRExC_state->runtime_code_qr = qr;
5313         return 0;
5314     }
5315
5316
5317     /* extract any code blocks within the returned qr//  */
5318
5319
5320     /* merge the main (r1) and run-time (r2) code blocks into one */
5321     {
5322         RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
5323         struct reg_code_block *new_block, *dst;
5324         RExC_state_t * const r1 = pRExC_state; /* convenient alias */
5325         int i1 = 0, i2 = 0;
5326
5327         if (!r2->num_code_blocks) /* we guessed wrong */
5328         {
5329             SvREFCNT_dec_NN(qr);
5330             return 1;
5331         }
5332
5333         Newx(new_block,
5334             r1->num_code_blocks + r2->num_code_blocks,
5335             struct reg_code_block);
5336         dst = new_block;
5337
5338         while (    i1 < r1->num_code_blocks
5339                 || i2 < r2->num_code_blocks)
5340         {
5341             struct reg_code_block *src;
5342             bool is_qr = 0;
5343
5344             if (i1 == r1->num_code_blocks) {
5345                 src = &r2->code_blocks[i2++];
5346                 is_qr = 1;
5347             }
5348             else if (i2 == r2->num_code_blocks)
5349                 src = &r1->code_blocks[i1++];
5350             else if (  r1->code_blocks[i1].start
5351                      < r2->code_blocks[i2].start)
5352             {
5353                 src = &r1->code_blocks[i1++];
5354                 assert(src->end < r2->code_blocks[i2].start);
5355             }
5356             else {
5357                 assert(  r1->code_blocks[i1].start
5358                        > r2->code_blocks[i2].start);
5359                 src = &r2->code_blocks[i2++];
5360                 is_qr = 1;
5361                 assert(src->end < r1->code_blocks[i1].start);
5362             }
5363
5364             assert(pat[src->start] == '(');
5365             assert(pat[src->end]   == ')');
5366             dst->start      = src->start;
5367             dst->end        = src->end;
5368             dst->block      = src->block;
5369             dst->src_regex  = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
5370                                     : src->src_regex;
5371             dst++;
5372         }
5373         r1->num_code_blocks += r2->num_code_blocks;
5374         Safefree(r1->code_blocks);
5375         r1->code_blocks = new_block;
5376     }
5377
5378     SvREFCNT_dec_NN(qr);
5379     return 1;
5380 }
5381
5382
5383 STATIC bool
5384 S_setup_longest(pTHX_ RExC_state_t *pRExC_state, SV* sv_longest, SV** rx_utf8, SV** rx_substr, I32* rx_end_shift, I32 lookbehind, I32 offset, I32 *minlen, STRLEN longest_length, bool eol, bool meol)
5385 {
5386     /* This is the common code for setting up the floating and fixed length
5387      * string data extracted from Perl_re_op_compile() below.  Returns a boolean
5388      * as to whether succeeded or not */
5389
5390     I32 t,ml;
5391
5392     if (! (longest_length
5393            || (eol /* Can't have SEOL and MULTI */
5394                && (! meol || (RExC_flags & RXf_PMf_MULTILINE)))
5395           )
5396             /* See comments for join_exact for why REG_SEEN_EXACTF_SHARP_S */
5397         || (RExC_seen & REG_SEEN_EXACTF_SHARP_S))
5398     {
5399         return FALSE;
5400     }
5401
5402     /* copy the information about the longest from the reg_scan_data
5403         over to the program. */
5404     if (SvUTF8(sv_longest)) {
5405         *rx_utf8 = sv_longest;
5406         *rx_substr = NULL;
5407     } else {
5408         *rx_substr = sv_longest;
5409         *rx_utf8 = NULL;
5410     }
5411     /* end_shift is how many chars that must be matched that
5412         follow this item. We calculate it ahead of time as once the
5413         lookbehind offset is added in we lose the ability to correctly
5414         calculate it.*/
5415     ml = minlen ? *(minlen) : (I32)longest_length;
5416     *rx_end_shift = ml - offset
5417         - longest_length + (SvTAIL(sv_longest) != 0)
5418         + lookbehind;
5419
5420     t = (eol/* Can't have SEOL and MULTI */
5421          && (! meol || (RExC_flags & RXf_PMf_MULTILINE)));
5422     fbm_compile(sv_longest, t ? FBMcf_TAIL : 0);
5423
5424     return TRUE;
5425 }
5426
5427 /*
5428  * Perl_re_op_compile - the perl internal RE engine's function to compile a
5429  * regular expression into internal code.
5430  * The pattern may be passed either as:
5431  *    a list of SVs (patternp plus pat_count)
5432  *    a list of OPs (expr)
5433  * If both are passed, the SV list is used, but the OP list indicates
5434  * which SVs are actually pre-compiled code blocks
5435  *
5436  * The SVs in the list have magic and qr overloading applied to them (and
5437  * the list may be modified in-place with replacement SVs in the latter
5438  * case).
5439  *
5440  * If the pattern hasn't changed from old_re, then old_re will be
5441  * returned.
5442  *
5443  * eng is the current engine. If that engine has an op_comp method, then
5444  * handle directly (i.e. we assume that op_comp was us); otherwise, just
5445  * do the initial concatenation of arguments and pass on to the external
5446  * engine.
5447  *
5448  * If is_bare_re is not null, set it to a boolean indicating whether the
5449  * arg list reduced (after overloading) to a single bare regex which has
5450  * been returned (i.e. /$qr/).
5451  *
5452  * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
5453  *
5454  * pm_flags contains the PMf_* flags, typically based on those from the
5455  * pm_flags field of the related PMOP. Currently we're only interested in
5456  * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL.
5457  *
5458  * We can't allocate space until we know how big the compiled form will be,
5459  * but we can't compile it (and thus know how big it is) until we've got a
5460  * place to put the code.  So we cheat:  we compile it twice, once with code
5461  * generation turned off and size counting turned on, and once "for real".
5462  * This also means that we don't allocate space until we are sure that the
5463  * thing really will compile successfully, and we never have to move the
5464  * code and thus invalidate pointers into it.  (Note that it has to be in
5465  * one piece because free() must be able to free it all.) [NB: not true in perl]
5466  *
5467  * Beware that the optimization-preparation code in here knows about some
5468  * of the structure of the compiled regexp.  [I'll say.]
5469  */
5470
5471 REGEXP *
5472 Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
5473                     OP *expr, const regexp_engine* eng, REGEXP *old_re,
5474                      bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags)
5475 {
5476     dVAR;
5477     REGEXP *rx;
5478     struct regexp *r;
5479     regexp_internal *ri;
5480     STRLEN plen;
5481     char *exp;
5482     regnode *scan;
5483     I32 flags;
5484     I32 minlen = 0;
5485     U32 rx_flags;
5486     SV *pat;
5487     SV *code_blocksv = NULL;
5488     SV** new_patternp = patternp;
5489
5490     /* these are all flags - maybe they should be turned
5491      * into a single int with different bit masks */
5492     I32 sawlookahead = 0;
5493     I32 sawplus = 0;
5494     I32 sawopen = 0;
5495     regex_charset initial_charset = get_regex_charset(orig_rx_flags);
5496     bool recompile = 0;
5497     bool runtime_code = 0;
5498     scan_data_t data;
5499     RExC_state_t RExC_state;
5500     RExC_state_t * const pRExC_state = &RExC_state;
5501 #ifdef TRIE_STUDY_OPT    
5502     int restudied = 0;
5503     RExC_state_t copyRExC_state;
5504 #endif    
5505     GET_RE_DEBUG_FLAGS_DECL;
5506
5507     PERL_ARGS_ASSERT_RE_OP_COMPILE;
5508
5509     DEBUG_r(if (!PL_colorset) reginitcolors());
5510
5511 #ifndef PERL_IN_XSUB_RE
5512     /* Initialize these here instead of as-needed, as is quick and avoids
5513      * having to test them each time otherwise */
5514     if (! PL_AboveLatin1) {
5515         PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
5516         PL_ASCII = _new_invlist_C_array(ASCII_invlist);
5517         PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
5518
5519         PL_L1Posix_ptrs[_CC_ALPHANUMERIC]
5520                                 = _new_invlist_C_array(L1PosixAlnum_invlist);
5521         PL_Posix_ptrs[_CC_ALPHANUMERIC]
5522                                 = _new_invlist_C_array(PosixAlnum_invlist);
5523
5524         PL_L1Posix_ptrs[_CC_ALPHA]
5525                                 = _new_invlist_C_array(L1PosixAlpha_invlist);
5526         PL_Posix_ptrs[_CC_ALPHA] = _new_invlist_C_array(PosixAlpha_invlist);
5527
5528         PL_Posix_ptrs[_CC_BLANK] = _new_invlist_C_array(PosixBlank_invlist);
5529         PL_XPosix_ptrs[_CC_BLANK] = _new_invlist_C_array(XPosixBlank_invlist);
5530
5531         /* Cased is the same as Alpha in the ASCII range */
5532         PL_L1Posix_ptrs[_CC_CASED] =  _new_invlist_C_array(L1Cased_invlist);
5533         PL_Posix_ptrs[_CC_CASED] =  _new_invlist_C_array(PosixAlpha_invlist);
5534
5535         PL_Posix_ptrs[_CC_CNTRL] = _new_invlist_C_array(PosixCntrl_invlist);
5536         PL_XPosix_ptrs[_CC_CNTRL] = _new_invlist_C_array(XPosixCntrl_invlist);
5537
5538         PL_Posix_ptrs[_CC_DIGIT] = _new_invlist_C_array(PosixDigit_invlist);
5539         PL_L1Posix_ptrs[_CC_DIGIT] = _new_invlist_C_array(PosixDigit_invlist);
5540
5541         PL_L1Posix_ptrs[_CC_GRAPH] = _new_invlist_C_array(L1PosixGraph_invlist);
5542         PL_Posix_ptrs[_CC_GRAPH] = _new_invlist_C_array(PosixGraph_invlist);
5543
5544         PL_L1Posix_ptrs[_CC_LOWER] = _new_invlist_C_array(L1PosixLower_invlist);
5545         PL_Posix_ptrs[_CC_LOWER] = _new_invlist_C_array(PosixLower_invlist);
5546
5547         PL_L1Posix_ptrs[_CC_PRINT] = _new_invlist_C_array(L1PosixPrint_invlist);
5548         PL_Posix_ptrs[_CC_PRINT] = _new_invlist_C_array(PosixPrint_invlist);
5549
5550         PL_L1Posix_ptrs[_CC_PUNCT] = _new_invlist_C_array(L1PosixPunct_invlist);
5551         PL_Posix_ptrs[_CC_PUNCT] = _new_invlist_C_array(PosixPunct_invlist);
5552
5553         PL_Posix_ptrs[_CC_SPACE] = _new_invlist_C_array(PerlSpace_invlist);
5554         PL_XPosix_ptrs[_CC_SPACE] = _new_invlist_C_array(XPerlSpace_invlist);
5555         PL_Posix_ptrs[_CC_PSXSPC] = _new_invlist_C_array(PosixSpace_invlist);
5556         PL_XPosix_ptrs[_CC_PSXSPC] = _new_invlist_C_array(XPosixSpace_invlist);
5557
5558         PL_L1Posix_ptrs[_CC_UPPER] = _new_invlist_C_array(L1PosixUpper_invlist);
5559         PL_Posix_ptrs[_CC_UPPER] = _new_invlist_C_array(PosixUpper_invlist);
5560
5561         PL_XPosix_ptrs[_CC_VERTSPACE] = _new_invlist_C_array(VertSpace_invlist);
5562
5563         PL_Posix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(PosixWord_invlist);
5564         PL_L1Posix_ptrs[_CC_WORDCHAR]
5565                                 = _new_invlist_C_array(L1PosixWord_invlist);
5566
5567         PL_Posix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(PosixXDigit_invlist);
5568         PL_XPosix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(XPosixXDigit_invlist);
5569
5570         PL_HasMultiCharFold = _new_invlist_C_array(_Perl_Multi_Char_Folds_invlist);
5571     }
5572 #endif
5573
5574     pRExC_state->code_blocks = NULL;
5575     pRExC_state->num_code_blocks = 0;
5576
5577     if (is_bare_re)
5578         *is_bare_re = FALSE;
5579
5580     if (expr && (expr->op_type == OP_LIST ||
5581                 (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
5582         /* allocate code_blocks if needed */
5583         OP *o;
5584         int ncode = 0;
5585
5586         for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling)
5587             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
5588                 ncode++; /* count of DO blocks */
5589         if (ncode) {
5590             pRExC_state->num_code_blocks = ncode;
5591             Newx(pRExC_state->code_blocks, ncode, struct reg_code_block);
5592         }
5593     }
5594
5595     if (!pat_count) {
5596         /* compile-time pattern with just OP_CONSTs and DO blocks */
5597
5598         int n;
5599         OP *o;
5600
5601         /* find how many CONSTs there are */
5602         assert(expr);
5603         n = 0;
5604         if (expr->op_type == OP_CONST)
5605             n = 1;
5606         else
5607             for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
5608                 if (o->op_type == OP_CONST)
5609                     n++;
5610             }
5611
5612         /* fake up an SV array */
5613
5614         assert(!new_patternp);
5615         Newx(new_patternp, n, SV*);
5616         SAVEFREEPV(new_patternp);
5617         pat_count = n;
5618
5619         n = 0;
5620         if (expr->op_type == OP_CONST)
5621             new_patternp[n] = cSVOPx_sv(expr);
5622         else
5623             for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
5624                 if (o->op_type == OP_CONST)
5625                     new_patternp[n++] = cSVOPo_sv;
5626             }
5627
5628     }
5629
5630     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
5631         "Assembling pattern from %d elements%s\n", pat_count,
5632             orig_rx_flags & RXf_SPLIT ? " for split" : ""));
5633
5634     /* set expr to the first arg op */
5635
5636     if (pRExC_state->num_code_blocks
5637          && expr->op_type != OP_CONST)
5638     {
5639             expr = cLISTOPx(expr)->op_first;
5640             assert(   expr->op_type == OP_PUSHMARK
5641                    || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK)
5642                    || expr->op_type == OP_PADRANGE);
5643             expr = expr->op_sibling;
5644     }
5645
5646     pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count,
5647                         expr, &recompile, NULL);
5648
5649     /* handle bare (possibly after overloading) regex: foo =~ $re */
5650     {
5651         SV *re = pat;
5652         if (SvROK(re))
5653             re = SvRV(re);
5654         if (SvTYPE(re) == SVt_REGEXP) {
5655             if (is_bare_re)
5656                 *is_bare_re = TRUE;
5657             SvREFCNT_inc(re);
5658             Safefree(pRExC_state->code_blocks);
5659             DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
5660                 "Precompiled pattern%s\n",
5661                     orig_rx_flags & RXf_SPLIT ? " for split" : ""));
5662
5663             return (REGEXP*)re;
5664         }
5665     }
5666
5667     exp = SvPV_nomg(pat, plen);
5668
5669     if (!eng->op_comp) {
5670         if ((SvUTF8(pat) && IN_BYTES)
5671                 || SvGMAGICAL(pat) || SvAMAGIC(pat))
5672         {
5673             /* make a temporary copy; either to convert to bytes,
5674              * or to avoid repeating get-magic / overloaded stringify */
5675             pat = newSVpvn_flags(exp, plen, SVs_TEMP |
5676                                         (IN_BYTES ? 0 : SvUTF8(pat)));
5677         }
5678         Safefree(pRExC_state->code_blocks);
5679         return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
5680     }
5681
5682     /* ignore the utf8ness if the pattern is 0 length */
5683     RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
5684     RExC_uni_semantics = 0;
5685     RExC_contains_locale = 0;
5686     pRExC_state->runtime_code_qr = NULL;
5687
5688     DEBUG_COMPILE_r({
5689             SV *dsv= sv_newmortal();
5690             RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, 60);
5691             PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
5692                           PL_colors[4],PL_colors[5],s);
5693         });
5694
5695   redo_first_pass:
5696     /* we jump here if we upgrade the pattern to utf8 and have to
5697      * recompile */
5698
5699     if ((pm_flags & PMf_USE_RE_EVAL)
5700                 /* this second condition covers the non-regex literal case,
5701                  * i.e.  $foo =~ '(?{})'. */
5702                 || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
5703     )
5704         runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen);
5705
5706     /* return old regex if pattern hasn't changed */
5707     /* XXX: note in the below we have to check the flags as well as the pattern.
5708      *
5709      * Things get a touch tricky as we have to compare the utf8 flag independently
5710      * from the compile flags.
5711      */
5712
5713     if (   old_re
5714         && !recompile
5715         && !!RX_UTF8(old_re) == !!RExC_utf8
5716         && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) )
5717         && RX_PRECOMP(old_re)
5718         && RX_PRELEN(old_re) == plen
5719         && memEQ(RX_PRECOMP(old_re), exp, plen)
5720         && !runtime_code /* with runtime code, always recompile */ )
5721     {
5722         Safefree(pRExC_state->code_blocks);
5723         return old_re;
5724     }
5725
5726     rx_flags = orig_rx_flags;
5727
5728     if (initial_charset == REGEX_LOCALE_CHARSET) {
5729         RExC_contains_locale = 1;
5730     }
5731     else if (RExC_utf8 && initial_charset == REGEX_DEPENDS_CHARSET) {
5732
5733         /* Set to use unicode semantics if the pattern is in utf8 and has the
5734          * 'depends' charset specified, as it means unicode when utf8  */
5735         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
5736     }
5737
5738     RExC_precomp = exp;
5739     RExC_flags = rx_flags;
5740     RExC_pm_flags = pm_flags;
5741
5742     if (runtime_code) {
5743         if (TAINTING_get && TAINT_get)
5744             Perl_croak(aTHX_ "Eval-group in insecure regular expression");
5745
5746         if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
5747             /* whoops, we have a non-utf8 pattern, whilst run-time code
5748              * got compiled as utf8. Try again with a utf8 pattern */
5749             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
5750                                     pRExC_state->num_code_blocks);
5751             goto redo_first_pass;
5752         }
5753     }
5754     assert(!pRExC_state->runtime_code_qr);
5755
5756     RExC_sawback = 0;
5757
5758     RExC_seen = 0;
5759     RExC_in_lookbehind = 0;
5760     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
5761     RExC_extralen = 0;
5762     RExC_override_recoding = 0;
5763     RExC_in_multi_char_class = 0;
5764
5765     /* First pass: determine size, legality. */
5766     RExC_parse = exp;
5767     RExC_start = exp;
5768     RExC_end = exp + plen;
5769     RExC_naughty = 0;
5770     RExC_npar = 1;
5771     RExC_nestroot = 0;
5772     RExC_size = 0L;
5773     RExC_emit = &PL_regdummy;
5774     RExC_whilem_seen = 0;
5775     RExC_open_parens = NULL;
5776     RExC_close_parens = NULL;
5777     RExC_opend = NULL;
5778     RExC_paren_names = NULL;
5779 #ifdef DEBUGGING
5780     RExC_paren_name_list = NULL;
5781 #endif
5782     RExC_recurse = NULL;
5783     RExC_recurse_count = 0;
5784     pRExC_state->code_index = 0;
5785
5786 #if 0 /* REGC() is (currently) a NOP at the first pass.
5787        * Clever compilers notice this and complain. --jhi */
5788     REGC((U8)REG_MAGIC, (char*)RExC_emit);
5789 #endif
5790     DEBUG_PARSE_r(
5791         PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n");
5792         RExC_lastnum=0;
5793         RExC_lastparse=NULL;
5794     );
5795     /* reg may croak on us, not giving us a chance to free
5796        pRExC_state->code_blocks.  We cannot SAVEFREEPV it now, as we may
5797        need it to survive as long as the regexp (qr/(?{})/).
5798        We must check that code_blocksv is not already set, because we may
5799        have jumped back to restart the sizing pass. */
5800     if (pRExC_state->code_blocks && !code_blocksv) {
5801         code_blocksv = newSV_type(SVt_PV);
5802         SAVEFREESV(code_blocksv);
5803         SvPV_set(code_blocksv, (char *)pRExC_state->code_blocks);
5804         SvLEN_set(code_blocksv, 1); /*sufficient to make sv_clear free it*/
5805     }
5806     if (reg(pRExC_state, 0, &flags,1) == NULL) {
5807         /* It's possible to write a regexp in ascii that represents Unicode
5808         codepoints outside of the byte range, such as via \x{100}. If we
5809         detect such a sequence we have to convert the entire pattern to utf8
5810         and then recompile, as our sizing calculation will have been based
5811         on 1 byte == 1 character, but we will need to use utf8 to encode
5812         at least some part of the pattern, and therefore must convert the whole
5813         thing.
5814         -- dmq */
5815         if (flags & RESTART_UTF8) {
5816             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
5817                                     pRExC_state->num_code_blocks);
5818             goto redo_first_pass;
5819         }
5820         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for sizing pass, flags=%#X", flags);
5821     }
5822     if (code_blocksv)
5823         SvLEN_set(code_blocksv,0); /* no you can't have it, sv_clear */
5824
5825     DEBUG_PARSE_r({
5826         PerlIO_printf(Perl_debug_log, 
5827             "Required size %"IVdf" nodes\n"
5828             "Starting second pass (creation)\n", 
5829             (IV)RExC_size);
5830         RExC_lastnum=0; 
5831         RExC_lastparse=NULL; 
5832     });
5833
5834     /* The first pass could have found things that force Unicode semantics */
5835     if ((RExC_utf8 || RExC_uni_semantics)
5836          && get_regex_charset(rx_flags) == REGEX_DEPENDS_CHARSET)
5837     {
5838         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
5839     }
5840
5841     /* Small enough for pointer-storage convention?
5842        If extralen==0, this means that we will not need long jumps. */
5843     if (RExC_size >= 0x10000L && RExC_extralen)
5844         RExC_size += RExC_extralen;
5845     else
5846         RExC_extralen = 0;
5847     if (RExC_whilem_seen > 15)
5848         RExC_whilem_seen = 15;
5849
5850     /* Allocate space and zero-initialize. Note, the two step process 
5851        of zeroing when in debug mode, thus anything assigned has to 
5852        happen after that */
5853     rx = (REGEXP*) newSV_type(SVt_REGEXP);
5854     r = ReANY(rx);
5855     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
5856          char, regexp_internal);
5857     if ( r == NULL || ri == NULL )
5858         FAIL("Regexp out of space");
5859 #ifdef DEBUGGING
5860     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
5861     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char);
5862 #else 
5863     /* bulk initialize base fields with 0. */
5864     Zero(ri, sizeof(regexp_internal), char);        
5865 #endif
5866
5867     /* non-zero initialization begins here */
5868     RXi_SET( r, ri );
5869     r->engine= eng;
5870     r->extflags = rx_flags;
5871     RXp_COMPFLAGS(r) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK;
5872
5873     if (pm_flags & PMf_IS_QR) {
5874         ri->code_blocks = pRExC_state->code_blocks;
5875         ri->num_code_blocks = pRExC_state->num_code_blocks;
5876     }
5877     else
5878     {
5879         int n;
5880         for (n = 0; n < pRExC_state->num_code_blocks; n++)
5881             if (pRExC_state->code_blocks[n].src_regex)
5882                 SAVEFREESV(pRExC_state->code_blocks[n].src_regex);
5883         SAVEFREEPV(pRExC_state->code_blocks);
5884     }
5885
5886     {
5887         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
5888         bool has_charset = (get_regex_charset(r->extflags) != REGEX_DEPENDS_CHARSET);
5889
5890         /* The caret is output if there are any defaults: if not all the STD
5891          * flags are set, or if no character set specifier is needed */
5892         bool has_default =
5893                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
5894                     || ! has_charset);
5895         bool has_runon = ((RExC_seen & REG_SEEN_RUN_ON_COMMENT)==REG_SEEN_RUN_ON_COMMENT);
5896         U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD)
5897                             >> RXf_PMf_STD_PMMOD_SHIFT);
5898         const char *fptr = STD_PAT_MODS;        /*"msix"*/
5899         char *p;
5900         /* Allocate for the worst case, which is all the std flags are turned
5901          * on.  If more precision is desired, we could do a population count of
5902          * the flags set.  This could be done with a small lookup table, or by
5903          * shifting, masking and adding, or even, when available, assembly
5904          * language for a machine-language population count.
5905          * We never output a minus, as all those are defaults, so are
5906          * covered by the caret */
5907         const STRLEN wraplen = plen + has_p + has_runon
5908             + has_default       /* If needs a caret */
5909
5910                 /* If needs a character set specifier */
5911             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
5912             + (sizeof(STD_PAT_MODS) - 1)
5913             + (sizeof("(?:)") - 1);
5914
5915         Newx(p, wraplen + 1, char); /* +1 for the ending NUL */
5916         r->xpv_len_u.xpvlenu_pv = p;
5917         if (RExC_utf8)
5918             SvFLAGS(rx) |= SVf_UTF8;
5919         *p++='('; *p++='?';
5920
5921         /* If a default, cover it using the caret */
5922         if (has_default) {
5923             *p++= DEFAULT_PAT_MOD;
5924         }
5925         if (has_charset) {
5926             STRLEN len;
5927             const char* const name = get_regex_charset_name(r->extflags, &len);
5928             Copy(name, p, len, char);
5929             p += len;
5930         }
5931         if (has_p)
5932             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
5933         {
5934             char ch;
5935             while((ch = *fptr++)) {
5936                 if(reganch & 1)
5937                     *p++ = ch;
5938                 reganch >>= 1;
5939             }
5940         }
5941
5942         *p++ = ':';
5943         Copy(RExC_precomp, p, plen, char);
5944         assert ((RX_WRAPPED(rx) - p) < 16);
5945         r->pre_prefix = p - RX_WRAPPED(rx);
5946         p += plen;
5947         if (has_runon)
5948             *p++ = '\n';
5949         *p++ = ')';
5950         *p = 0;
5951         SvCUR_set(rx, p - RX_WRAPPED(rx));
5952     }
5953
5954     r->intflags = 0;
5955     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
5956     
5957     if (RExC_seen & REG_SEEN_RECURSE) {
5958         Newxz(RExC_open_parens, RExC_npar,regnode *);
5959         SAVEFREEPV(RExC_open_parens);
5960         Newxz(RExC_close_parens,RExC_npar,regnode *);
5961         SAVEFREEPV(RExC_close_parens);
5962     }
5963
5964     /* Useful during FAIL. */
5965 #ifdef RE_TRACK_PATTERN_OFFSETS
5966     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
5967     DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
5968                           "%s %"UVuf" bytes for offset annotations.\n",
5969                           ri->u.offsets ? "Got" : "Couldn't get",
5970                           (UV)((2*RExC_size+1) * sizeof(U32))));
5971 #endif
5972     SetProgLen(ri,RExC_size);
5973     RExC_rx_sv = rx;
5974     RExC_rx = r;
5975     RExC_rxi = ri;
5976
5977     /* Second pass: emit code. */
5978     RExC_flags = rx_flags;      /* don't let top level (?i) bleed */
5979     RExC_pm_flags = pm_flags;
5980     RExC_parse = exp;
5981     RExC_end = exp + plen;
5982     RExC_naughty = 0;
5983     RExC_npar = 1;
5984     RExC_emit_start = ri->program;
5985     RExC_emit = ri->program;
5986     RExC_emit_bound = ri->program + RExC_size + 1;
5987     pRExC_state->code_index = 0;
5988
5989     REGC((U8)REG_MAGIC, (char*) RExC_emit++);
5990     if (reg(pRExC_state, 0, &flags,1) == NULL) {
5991         ReREFCNT_dec(rx);   
5992         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for generation pass, flags=%#X", flags);
5993     }
5994     /* XXXX To minimize changes to RE engine we always allocate
5995        3-units-long substrs field. */
5996     Newx(r->substrs, 1, struct reg_substr_data);
5997     if (RExC_recurse_count) {
5998         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
5999         SAVEFREEPV(RExC_recurse);
6000     }
6001
6002 reStudy:
6003     r->minlen = minlen = sawlookahead = sawplus = sawopen = 0;
6004     Zero(r->substrs, 1, struct reg_substr_data);
6005
6006 #ifdef TRIE_STUDY_OPT
6007     if (!restudied) {
6008         StructCopy(&zero_scan_data, &data, scan_data_t);
6009         copyRExC_state = RExC_state;
6010     } else {
6011         U32 seen=RExC_seen;
6012         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
6013         
6014         RExC_state = copyRExC_state;
6015         if (seen & REG_TOP_LEVEL_BRANCHES) 
6016             RExC_seen |= REG_TOP_LEVEL_BRANCHES;
6017         else
6018             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES;
6019         StructCopy(&zero_scan_data, &data, scan_data_t);
6020     }
6021 #else
6022     StructCopy(&zero_scan_data, &data, scan_data_t);
6023 #endif    
6024
6025     /* Dig out information for optimizations. */
6026     r->extflags = RExC_flags; /* was pm_op */
6027     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
6028  
6029     if (UTF)
6030         SvUTF8_on(rx);  /* Unicode in it? */
6031     ri->regstclass = NULL;
6032     if (RExC_naughty >= 10)     /* Probably an expensive pattern. */
6033         r->intflags |= PREGf_NAUGHTY;
6034     scan = ri->program + 1;             /* First BRANCH. */
6035
6036     /* testing for BRANCH here tells us whether there is "must appear"
6037        data in the pattern. If there is then we can use it for optimisations */
6038     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /*  Only one top-level choice. */
6039         I32 fake;
6040         STRLEN longest_float_length, longest_fixed_length;
6041         struct regnode_charclass_class ch_class; /* pointed to by data */
6042         int stclass_flag;
6043         I32 last_close = 0; /* pointed to by data */
6044         regnode *first= scan;
6045         regnode *first_next= regnext(first);
6046         /*
6047          * Skip introductions and multiplicators >= 1
6048          * so that we can extract the 'meat' of the pattern that must 
6049          * match in the large if() sequence following.
6050          * NOTE that EXACT is NOT covered here, as it is normally
6051          * picked up by the optimiser separately. 
6052          *
6053          * This is unfortunate as the optimiser isnt handling lookahead
6054          * properly currently.
6055          *
6056          */
6057         while ((OP(first) == OPEN && (sawopen = 1)) ||
6058                /* An OR of *one* alternative - should not happen now. */
6059             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
6060             /* for now we can't handle lookbehind IFMATCH*/
6061             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
6062             (OP(first) == PLUS) ||
6063             (OP(first) == MINMOD) ||
6064                /* An {n,m} with n>0 */
6065             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
6066             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
6067         {
6068                 /* 
6069                  * the only op that could be a regnode is PLUS, all the rest
6070                  * will be regnode_1 or regnode_2.
6071                  *
6072                  */
6073                 if (OP(first) == PLUS)
6074                     sawplus = 1;
6075                 else
6076                     first += regarglen[OP(first)];
6077
6078                 first = NEXTOPER(first);
6079                 first_next= regnext(first);
6080         }
6081
6082         /* Starting-point info. */
6083       again:
6084         DEBUG_PEEP("first:",first,0);
6085         /* Ignore EXACT as we deal with it later. */
6086         if (PL_regkind[OP(first)] == EXACT) {
6087             if (OP(first) == EXACT)
6088                 NOOP;   /* Empty, get anchored substr later. */
6089             else
6090                 ri->regstclass = first;
6091         }
6092 #ifdef TRIE_STCLASS
6093         else if (PL_regkind[OP(first)] == TRIE &&
6094                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0) 
6095         {
6096             regnode *trie_op;
6097             /* this can happen only on restudy */
6098             if ( OP(first) == TRIE ) {
6099                 struct regnode_1 *trieop = (struct regnode_1 *)
6100                     PerlMemShared_calloc(1, sizeof(struct regnode_1));
6101                 StructCopy(first,trieop,struct regnode_1);
6102                 trie_op=(regnode *)trieop;
6103             } else {
6104                 struct regnode_charclass *trieop = (struct regnode_charclass *)
6105                     PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
6106                 StructCopy(first,trieop,struct regnode_charclass);
6107                 trie_op=(regnode *)trieop;
6108             }
6109             OP(trie_op)+=2;
6110             make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
6111             ri->regstclass = trie_op;
6112         }
6113 #endif
6114         else if (REGNODE_SIMPLE(OP(first)))
6115             ri->regstclass = first;
6116         else if (PL_regkind[OP(first)] == BOUND ||
6117                  PL_regkind[OP(first)] == NBOUND)
6118             ri->regstclass = first;
6119         else if (PL_regkind[OP(first)] == BOL) {
6120             r->extflags |= (OP(first) == MBOL
6121                            ? RXf_ANCH_MBOL
6122                            : (OP(first) == SBOL
6123                               ? RXf_ANCH_SBOL
6124                               : RXf_ANCH_BOL));
6125             first = NEXTOPER(first);
6126             goto again;
6127         }
6128         else if (OP(first) == GPOS) {
6129             r->extflags |= RXf_ANCH_GPOS;
6130             first = NEXTOPER(first);
6131             goto again;
6132         }
6133         else if ((!sawopen || !RExC_sawback) &&
6134             (OP(first) == STAR &&
6135             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
6136             !(r->extflags & RXf_ANCH) && !pRExC_state->num_code_blocks)
6137         {
6138             /* turn .* into ^.* with an implied $*=1 */
6139             const int type =
6140                 (OP(NEXTOPER(first)) == REG_ANY)
6141                     ? RXf_ANCH_MBOL
6142                     : RXf_ANCH_SBOL;
6143             r->extflags |= type;
6144             r->intflags |= PREGf_IMPLICIT;
6145             first = NEXTOPER(first);
6146             goto again;
6147         }
6148         if (sawplus && !sawlookahead && (!sawopen || !RExC_sawback)
6149             && !pRExC_state->num_code_blocks) /* May examine pos and $& */
6150             /* x+ must match at the 1st pos of run of x's */
6151             r->intflags |= PREGf_SKIP;
6152
6153         /* Scan is after the zeroth branch, first is atomic matcher. */
6154 #ifdef TRIE_STUDY_OPT
6155         DEBUG_PARSE_r(
6156             if (!restudied)
6157                 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
6158                               (IV)(first - scan + 1))
6159         );
6160 #else
6161         DEBUG_PARSE_r(
6162             PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
6163                 (IV)(first - scan + 1))
6164         );
6165 #endif
6166
6167
6168         /*
6169         * If there's something expensive in the r.e., find the
6170         * longest literal string that must appear and make it the
6171         * regmust.  Resolve ties in favor of later strings, since
6172         * the regstart check works with the beginning of the r.e.
6173         * and avoiding duplication strengthens checking.  Not a
6174         * strong reason, but sufficient in the absence of others.
6175         * [Now we resolve ties in favor of the earlier string if
6176         * it happens that c_offset_min has been invalidated, since the
6177         * earlier string may buy us something the later one won't.]
6178         */
6179
6180         data.longest_fixed = newSVpvs("");
6181         data.longest_float = newSVpvs("");
6182         data.last_found = newSVpvs("");
6183         data.longest = &(data.longest_fixed);
6184         ENTER_with_name("study_chunk");
6185         SAVEFREESV(data.longest_fixed);
6186         SAVEFREESV(data.longest_float);
6187         SAVEFREESV(data.last_found);
6188         first = scan;
6189         if (!ri->regstclass) {
6190             cl_init(pRExC_state, &ch_class);
6191             data.start_class = &ch_class;
6192             stclass_flag = SCF_DO_STCLASS_AND;
6193         } else                          /* XXXX Check for BOUND? */
6194             stclass_flag = 0;
6195         data.last_closep = &last_close;
6196         
6197         minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */
6198             &data, -1, NULL, NULL,
6199             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
6200
6201
6202         CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
6203
6204
6205         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
6206              && data.last_start_min == 0 && data.last_end > 0
6207              && !RExC_seen_zerolen
6208              && !(RExC_seen & REG_SEEN_VERBARG)
6209              && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
6210             r->extflags |= RXf_CHECK_ALL;
6211         scan_commit(pRExC_state, &data,&minlen,0);
6212
6213         longest_float_length = CHR_SVLEN(data.longest_float);
6214
6215         if (! ((SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
6216                    && data.offset_fixed == data.offset_float_min
6217                    && SvCUR(data.longest_fixed) == SvCUR(data.longest_float)))
6218             && S_setup_longest (aTHX_ pRExC_state,
6219                                     data.longest_float,
6220                                     &(r->float_utf8),
6221                                     &(r->float_substr),
6222                                     &(r->float_end_shift),
6223                                     data.lookbehind_float,
6224                                     data.offset_float_min,
6225                                     data.minlen_float,
6226                                     longest_float_length,
6227                                     cBOOL(data.flags & SF_FL_BEFORE_EOL),
6228                                     cBOOL(data.flags & SF_FL_BEFORE_MEOL)))
6229         {
6230             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
6231             r->float_max_offset = data.offset_float_max;
6232             if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
6233                 r->float_max_offset -= data.lookbehind_float;
6234             SvREFCNT_inc_simple_void_NN(data.longest_float);
6235         }
6236         else {
6237             r->float_substr = r->float_utf8 = NULL;
6238             longest_float_length = 0;
6239         }
6240
6241         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
6242
6243         if (S_setup_longest (aTHX_ pRExC_state,
6244                                 data.longest_fixed,
6245                                 &(r->anchored_utf8),
6246                                 &(r->anchored_substr),
6247                                 &(r->anchored_end_shift),
6248                                 data.lookbehind_fixed,
6249                                 data.offset_fixed,
6250                                 data.minlen_fixed,
6251                                 longest_fixed_length,
6252                                 cBOOL(data.flags & SF_FIX_BEFORE_EOL),
6253                                 cBOOL(data.flags & SF_FIX_BEFORE_MEOL)))
6254         {
6255             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
6256             SvREFCNT_inc_simple_void_NN(data.longest_fixed);
6257         }
6258         else {
6259             r->anchored_substr = r->anchored_utf8 = NULL;
6260             longest_fixed_length = 0;
6261         }
6262         LEAVE_with_name("study_chunk");
6263
6264         if (ri->regstclass
6265             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
6266             ri->regstclass = NULL;
6267
6268         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
6269             && stclass_flag
6270             && ! TEST_SSC_EOS(data.start_class)
6271             && !cl_is_anything(data.start_class))
6272         {
6273             const U32 n = add_data(pRExC_state, 1, "f");
6274             OP(data.start_class) = ANYOF_SYNTHETIC;
6275
6276             Newx(RExC_rxi->data->data[n], 1,
6277                 struct regnode_charclass_class);
6278             StructCopy(data.start_class,
6279                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
6280                        struct regnode_charclass_class);
6281             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
6282             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
6283             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
6284                       regprop(r, sv, (regnode*)data.start_class);
6285                       PerlIO_printf(Perl_debug_log,
6286                                     "synthetic stclass \"%s\".\n",
6287                                     SvPVX_const(sv));});
6288         }
6289
6290         /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
6291         if (longest_fixed_length > longest_float_length) {
6292             r->check_end_shift = r->anchored_end_shift;
6293             r->check_substr = r->anchored_substr;
6294             r->check_utf8 = r->anchored_utf8;
6295             r->check_offset_min = r->check_offset_max = r->anchored_offset;
6296             if (r->extflags & RXf_ANCH_SINGLE)
6297                 r->extflags |= RXf_NOSCAN;
6298         }
6299         else {
6300             r->check_end_shift = r->float_end_shift;
6301             r->check_substr = r->float_substr;
6302             r->check_utf8 = r->float_utf8;
6303             r->check_offset_min = r->float_min_offset;
6304             r->check_offset_max = r->float_max_offset;
6305         }
6306         /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
6307            This should be changed ASAP!  */
6308         if ((r->check_substr || r->check_utf8) && !(r->extflags & RXf_ANCH_GPOS)) {
6309             r->extflags |= RXf_USE_INTUIT;
6310             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
6311                 r->extflags |= RXf_INTUIT_TAIL;
6312         }
6313         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
6314         if ( (STRLEN)minlen < longest_float_length )
6315             minlen= longest_float_length;
6316         if ( (STRLEN)minlen < longest_fixed_length )
6317             minlen= longest_fixed_length;     
6318         */
6319     }
6320     else {
6321         /* Several toplevels. Best we can is to set minlen. */
6322         I32 fake;
6323         struct regnode_charclass_class ch_class;
6324         I32 last_close = 0;
6325
6326         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
6327
6328         scan = ri->program + 1;
6329         cl_init(pRExC_state, &ch_class);
6330         data.start_class = &ch_class;
6331         data.last_closep = &last_close;
6332
6333         
6334         minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
6335             &data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
6336         
6337         CHECK_RESTUDY_GOTO_butfirst(NOOP);
6338
6339         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
6340                 = r->float_substr = r->float_utf8 = NULL;
6341
6342         if (! TEST_SSC_EOS(data.start_class)
6343             && !cl_is_anything(data.start_class))
6344         {
6345             const U32 n = add_data(pRExC_state, 1, "f");
6346             OP(data.start_class) = ANYOF_SYNTHETIC;
6347
6348             Newx(RExC_rxi->data->data[n], 1,
6349                 struct regnode_charclass_class);
6350             StructCopy(data.start_class,
6351                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
6352                        struct regnode_charclass_class);
6353             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
6354             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
6355             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
6356                       regprop(r, sv, (regnode*)data.start_class);
6357                       PerlIO_printf(Perl_debug_log,
6358                                     "synthetic stclass \"%s\".\n",
6359                                     SvPVX_const(sv));});
6360         }
6361     }
6362
6363     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
6364        the "real" pattern. */
6365     DEBUG_OPTIMISE_r({
6366         PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n",
6367                       (IV)minlen, (IV)r->minlen);
6368     });
6369     r->minlenret = minlen;
6370     if (r->minlen < minlen) 
6371         r->minlen = minlen;
6372     
6373     if (RExC_seen & REG_SEEN_GPOS)
6374         r->extflags |= RXf_GPOS_SEEN;
6375     if (RExC_seen & REG_SEEN_LOOKBEHIND)
6376         r->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the lookbehind */
6377     if (pRExC_state->num_code_blocks)
6378         r->extflags |= RXf_EVAL_SEEN;
6379     if (RExC_seen & REG_SEEN_CANY)
6380         r->extflags |= RXf_CANY_SEEN;
6381     if (RExC_seen & REG_SEEN_VERBARG)
6382     {
6383         r->intflags |= PREGf_VERBARG_SEEN;
6384         r->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */
6385     }
6386     if (RExC_seen & REG_SEEN_CUTGROUP)
6387         r->intflags |= PREGf_CUTGROUP_SEEN;
6388     if (pm_flags & PMf_USE_RE_EVAL)
6389         r->intflags |= PREGf_USE_RE_EVAL;
6390     if (RExC_paren_names)
6391         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
6392     else
6393         RXp_PAREN_NAMES(r) = NULL;
6394
6395     {
6396         regnode *first = ri->program + 1;
6397         U8 fop = OP(first);
6398         regnode *next = NEXTOPER(first);
6399         U8 nop = OP(next);
6400
6401         if (PL_regkind[fop] == NOTHING && nop == END)
6402             r->extflags |= RXf_NULL;
6403         else if (PL_regkind[fop] == BOL && nop == END)
6404             r->extflags |= RXf_START_ONLY;
6405         else if (fop == PLUS && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE && OP(regnext(first)) == END)
6406             r->extflags |= RXf_WHITE;
6407         else if ( r->extflags & RXf_SPLIT && fop == EXACT && STR_LEN(first) == 1 && *(STRING(first)) == ' ' && OP(regnext(first)) == END )
6408             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
6409
6410     }
6411 #ifdef DEBUGGING
6412     if (RExC_paren_names) {
6413         ri->name_list_idx = add_data( pRExC_state, 1, "a" );
6414         ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list);
6415     } else
6416 #endif
6417         ri->name_list_idx = 0;
6418
6419     if (RExC_recurse_count) {
6420         for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
6421             const regnode *scan = RExC_recurse[RExC_recurse_count-1];
6422             ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
6423         }
6424     }
6425     Newxz(r->offs, RExC_npar, regexp_paren_pair);
6426     /* assume we don't need to swap parens around before we match */
6427
6428     DEBUG_DUMP_r({
6429         PerlIO_printf(Perl_debug_log,"Final program:\n");
6430         regdump(r);
6431     });
6432 #ifdef RE_TRACK_PATTERN_OFFSETS
6433     DEBUG_OFFSETS_r(if (ri->u.offsets) {
6434         const U32 len = ri->u.offsets[0];
6435         U32 i;
6436         GET_RE_DEBUG_FLAGS_DECL;
6437         PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
6438         for (i = 1; i <= len; i++) {
6439             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
6440                 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
6441                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
6442             }
6443         PerlIO_printf(Perl_debug_log, "\n");
6444     });
6445 #endif
6446
6447 #ifdef USE_ITHREADS
6448     /* under ithreads the ?pat? PMf_USED flag on the pmop is simulated
6449      * by setting the regexp SV to readonly-only instead. If the
6450      * pattern's been recompiled, the USEDness should remain. */
6451     if (old_re && SvREADONLY(old_re))
6452         SvREADONLY_on(rx);
6453 #endif
6454     return rx;
6455 }
6456
6457
6458 SV*
6459 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
6460                     const U32 flags)
6461 {
6462     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
6463
6464     PERL_UNUSED_ARG(value);
6465
6466     if (flags & RXapif_FETCH) {
6467         return reg_named_buff_fetch(rx, key, flags);
6468     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
6469         Perl_croak_no_modify();
6470         return NULL;
6471     } else if (flags & RXapif_EXISTS) {
6472         return reg_named_buff_exists(rx, key, flags)
6473             ? &PL_sv_yes
6474             : &PL_sv_no;
6475     } else if (flags & RXapif_REGNAMES) {
6476         return reg_named_buff_all(rx, flags);
6477     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
6478         return reg_named_buff_scalar(rx, flags);
6479     } else {
6480         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
6481         return NULL;
6482     }
6483 }
6484
6485 SV*
6486 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
6487                          const U32 flags)
6488 {
6489     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
6490     PERL_UNUSED_ARG(lastkey);
6491
6492     if (flags & RXapif_FIRSTKEY)
6493         return reg_named_buff_firstkey(rx, flags);
6494     else if (flags & RXapif_NEXTKEY)
6495         return reg_named_buff_nextkey(rx, flags);
6496     else {
6497         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter", (int)flags);
6498         return NULL;
6499     }
6500 }
6501
6502 SV*
6503 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
6504                           const U32 flags)
6505 {
6506     AV *retarray = NULL;
6507     SV *ret;
6508     struct regexp *const rx = ReANY(r);
6509
6510     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
6511
6512     if (flags & RXapif_ALL)
6513         retarray=newAV();
6514
6515     if (rx && RXp_PAREN_NAMES(rx)) {
6516         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
6517         if (he_str) {
6518             IV i;
6519             SV* sv_dat=HeVAL(he_str);
6520             I32 *nums=(I32*)SvPVX(sv_dat);
6521             for ( i=0; i<SvIVX(sv_dat); i++ ) {
6522                 if ((I32)(rx->nparens) >= nums[i]
6523                     && rx->offs[nums[i]].start != -1
6524                     && rx->offs[nums[i]].end != -1)
6525                 {
6526                     ret = newSVpvs("");
6527                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
6528                     if (!retarray)
6529                         return ret;
6530                 } else {
6531                     if (retarray)
6532                         ret = newSVsv(&PL_sv_undef);
6533                 }
6534                 if (retarray)
6535                     av_push(retarray, ret);
6536             }
6537             if (retarray)
6538                 return newRV_noinc(MUTABLE_SV(retarray));
6539         }
6540     }
6541     return NULL;
6542 }
6543
6544 bool
6545 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
6546                            const U32 flags)
6547 {
6548     struct regexp *const rx = ReANY(r);
6549
6550     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
6551
6552     if (rx && RXp_PAREN_NAMES(rx)) {
6553         if (flags & RXapif_ALL) {
6554             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
6555         } else {
6556             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
6557             if (sv) {
6558                 SvREFCNT_dec_NN(sv);
6559                 return TRUE;
6560             } else {
6561                 return FALSE;
6562             }
6563         }
6564     } else {
6565         return FALSE;
6566     }
6567 }
6568
6569 SV*
6570 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
6571 {
6572     struct regexp *const rx = ReANY(r);
6573
6574     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
6575
6576     if ( rx && RXp_PAREN_NAMES(rx) ) {
6577         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
6578
6579         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
6580     } else {
6581         return FALSE;
6582     }
6583 }
6584
6585 SV*
6586 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
6587 {
6588     struct regexp *const rx = ReANY(r);
6589     GET_RE_DEBUG_FLAGS_DECL;
6590
6591     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
6592
6593     if (rx && RXp_PAREN_NAMES(rx)) {
6594         HV *hv = RXp_PAREN_NAMES(rx);
6595         HE *temphe;
6596         while ( (temphe = hv_iternext_flags(hv,0)) ) {
6597             IV i;
6598             IV parno = 0;
6599             SV* sv_dat = HeVAL(temphe);
6600             I32 *nums = (I32*)SvPVX(sv_dat);
6601             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
6602                 if ((I32)(rx->lastparen) >= nums[i] &&
6603                     rx->offs[nums[i]].start != -1 &&
6604                     rx->offs[nums[i]].end != -1)
6605                 {
6606                     parno = nums[i];
6607                     break;
6608                 }
6609             }
6610             if (parno || flags & RXapif_ALL) {
6611                 return newSVhek(HeKEY_hek(temphe));
6612             }
6613         }
6614     }
6615     return NULL;
6616 }
6617
6618 SV*
6619 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
6620 {
6621     SV *ret;
6622     AV *av;
6623     I32 length;
6624     struct regexp *const rx = ReANY(r);
6625
6626     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
6627
6628     if (rx && RXp_PAREN_NAMES(rx)) {
6629         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
6630             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
6631         } else if (flags & RXapif_ONE) {
6632             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
6633             av = MUTABLE_AV(SvRV(ret));
6634             length = av_len(av);
6635             SvREFCNT_dec_NN(ret);
6636             return newSViv(length + 1);
6637         } else {
6638             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", (int)flags);
6639             return NULL;
6640         }
6641     }
6642     return &PL_sv_undef;
6643 }
6644
6645 SV*
6646 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
6647 {
6648     struct regexp *const rx = ReANY(r);
6649     AV *av = newAV();
6650
6651     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
6652
6653     if (rx && RXp_PAREN_NAMES(rx)) {
6654         HV *hv= RXp_PAREN_NAMES(rx);
6655         HE *temphe;
6656         (void)hv_iterinit(hv);
6657         while ( (temphe = hv_iternext_flags(hv,0)) ) {
6658             IV i;
6659             IV parno = 0;
6660             SV* sv_dat = HeVAL(temphe);
6661             I32 *nums = (I32*)SvPVX(sv_dat);
6662             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
6663                 if ((I32)(rx->lastparen) >= nums[i] &&
6664                     rx->offs[nums[i]].start != -1 &&
6665                     rx->offs[nums[i]].end != -1)
6666                 {
6667                     parno = nums[i];
6668                     break;
6669                 }
6670             }
6671             if (parno || flags & RXapif_ALL) {
6672                 av_push(av, newSVhek(HeKEY_hek(temphe)));
6673             }
6674         }
6675     }
6676
6677     return newRV_noinc(MUTABLE_SV(av));
6678 }
6679
6680 void
6681 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
6682                              SV * const sv)
6683 {
6684     struct regexp *const rx = ReANY(r);
6685     char *s = NULL;
6686     I32 i = 0;
6687     I32 s1, t1;
6688     I32 n = paren;
6689
6690     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
6691         
6692     if ( (    n == RX_BUFF_IDX_CARET_PREMATCH
6693            || n == RX_BUFF_IDX_CARET_FULLMATCH
6694            || n == RX_BUFF_IDX_CARET_POSTMATCH
6695          )
6696          && !(rx->extflags & RXf_PMf_KEEPCOPY)
6697     )
6698         goto ret_undef;
6699
6700     if (!rx->subbeg)
6701         goto ret_undef;
6702
6703     if (n == RX_BUFF_IDX_CARET_FULLMATCH)
6704         /* no need to distinguish between them any more */
6705         n = RX_BUFF_IDX_FULLMATCH;
6706
6707     if ((n == RX_BUFF_IDX_PREMATCH || n == RX_BUFF_IDX_CARET_PREMATCH)
6708         && rx->offs[0].start != -1)
6709     {
6710         /* $`, ${^PREMATCH} */
6711         i = rx->offs[0].start;
6712         s = rx->subbeg;
6713     }
6714     else 
6715     if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
6716         && rx->offs[0].end != -1)
6717     {
6718         /* $', ${^POSTMATCH} */
6719         s = rx->subbeg - rx->suboffset + rx->offs[0].end;
6720         i = rx->sublen + rx->suboffset - rx->offs[0].end;
6721     } 
6722     else
6723     if ( 0 <= n && n <= (I32)rx->nparens &&
6724         (s1 = rx->offs[n].start) != -1 &&
6725         (t1 = rx->offs[n].end) != -1)
6726     {
6727         /* $&, ${^MATCH},  $1 ... */
6728         i = t1 - s1;
6729         s = rx->subbeg + s1 - rx->suboffset;
6730     } else {
6731         goto ret_undef;
6732     }          
6733
6734     assert(s >= rx->subbeg);
6735     assert(rx->sublen >= (s - rx->subbeg) + i );
6736     if (i >= 0) {
6737 #if NO_TAINT_SUPPORT
6738         sv_setpvn(sv, s, i);
6739 #else
6740         const int oldtainted = TAINT_get;
6741         TAINT_NOT;
6742         sv_setpvn(sv, s, i);
6743         TAINT_set(oldtainted);
6744 #endif
6745         if ( (rx->extflags & RXf_CANY_SEEN)
6746             ? (RXp_MATCH_UTF8(rx)
6747                         && (!i || is_utf8_string((U8*)s, i)))
6748             : (RXp_MATCH_UTF8(rx)) )
6749         {
6750             SvUTF8_on(sv);
6751         }
6752         else
6753             SvUTF8_off(sv);
6754         if (TAINTING_get) {
6755             if (RXp_MATCH_TAINTED(rx)) {
6756                 if (SvTYPE(sv) >= SVt_PVMG) {
6757                     MAGIC* const mg = SvMAGIC(sv);
6758                     MAGIC* mgt;
6759                     TAINT;
6760                     SvMAGIC_set(sv, mg->mg_moremagic);
6761                     SvTAINT(sv);
6762                     if ((mgt = SvMAGIC(sv))) {
6763                         mg->mg_moremagic = mgt;
6764                         SvMAGIC_set(sv, mg);
6765                     }
6766                 } else {
6767                     TAINT;
6768                     SvTAINT(sv);
6769                 }
6770             } else 
6771                 SvTAINTED_off(sv);
6772         }
6773     } else {
6774       ret_undef:
6775         sv_setsv(sv,&PL_sv_undef);
6776         return;
6777     }
6778 }
6779
6780 void
6781 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
6782                                                          SV const * const value)
6783 {
6784     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
6785
6786     PERL_UNUSED_ARG(rx);
6787     PERL_UNUSED_ARG(paren);
6788     PERL_UNUSED_ARG(value);
6789
6790     if (!PL_localizing)
6791         Perl_croak_no_modify();
6792 }
6793
6794 I32
6795 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
6796                               const I32 paren)
6797 {
6798     struct regexp *const rx = ReANY(r);
6799     I32 i;
6800     I32 s1, t1;
6801
6802     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
6803
6804     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
6805     switch (paren) {
6806       case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */
6807          if (!(rx->extflags & RXf_PMf_KEEPCOPY))
6808             goto warn_undef;
6809         /*FALLTHROUGH*/
6810
6811       case RX_BUFF_IDX_PREMATCH:       /* $` */
6812         if (rx->offs[0].start != -1) {
6813                         i = rx->offs[0].start;
6814                         if (i > 0) {
6815                                 s1 = 0;
6816                                 t1 = i;
6817                                 goto getlen;
6818                         }
6819             }
6820         return 0;
6821
6822       case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */
6823          if (!(rx->extflags & RXf_PMf_KEEPCOPY))
6824             goto warn_undef;
6825       case RX_BUFF_IDX_POSTMATCH:       /* $' */
6826             if (rx->offs[0].end != -1) {
6827                         i = rx->sublen - rx->offs[0].end;
6828                         if (i > 0) {
6829                                 s1 = rx->offs[0].end;
6830                                 t1 = rx->sublen;
6831                                 goto getlen;
6832                         }
6833             }
6834         return 0;
6835
6836       case RX_BUFF_IDX_CARET_FULLMATCH: /* ${^MATCH} */
6837          if (!(rx->extflags & RXf_PMf_KEEPCOPY))
6838             goto warn_undef;
6839         /*FALLTHROUGH*/
6840
6841       /* $& / ${^MATCH}, $1, $2, ... */
6842       default:
6843             if (paren <= (I32)rx->nparens &&
6844             (s1 = rx->offs[paren].start) != -1 &&
6845             (t1 = rx->offs[paren].end) != -1)
6846             {
6847             i = t1 - s1;
6848             goto getlen;
6849         } else {
6850           warn_undef:
6851             if (ckWARN(WARN_UNINITIALIZED))
6852                 report_uninit((const SV *)sv);
6853             return 0;
6854         }
6855     }
6856   getlen:
6857     if (i > 0 && RXp_MATCH_UTF8(rx)) {
6858         const char * const s = rx->subbeg - rx->suboffset + s1;
6859         const U8 *ep;
6860         STRLEN el;
6861
6862         i = t1 - s1;
6863         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
6864                         i = el;
6865     }
6866     return i;
6867 }
6868
6869 SV*
6870 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
6871 {
6872     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
6873         PERL_UNUSED_ARG(rx);
6874         if (0)
6875             return NULL;
6876         else
6877             return newSVpvs("Regexp");
6878 }
6879
6880 /* Scans the name of a named buffer from the pattern.
6881  * If flags is REG_RSN_RETURN_NULL returns null.
6882  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
6883  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
6884  * to the parsed name as looked up in the RExC_paren_names hash.
6885  * If there is an error throws a vFAIL().. type exception.
6886  */
6887
6888 #define REG_RSN_RETURN_NULL    0
6889 #define REG_RSN_RETURN_NAME    1
6890 #define REG_RSN_RETURN_DATA    2
6891
6892 STATIC SV*
6893 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
6894 {
6895     char *name_start = RExC_parse;
6896
6897     PERL_ARGS_ASSERT_REG_SCAN_NAME;
6898
6899     if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
6900          /* skip IDFIRST by using do...while */
6901         if (UTF)
6902             do {
6903                 RExC_parse += UTF8SKIP(RExC_parse);
6904             } while (isWORDCHAR_utf8((U8*)RExC_parse));
6905         else
6906             do {
6907                 RExC_parse++;
6908             } while (isWORDCHAR(*RExC_parse));
6909     } else {
6910         RExC_parse++; /* so the <- from the vFAIL is after the offending character */
6911         vFAIL("Group name must start with a non-digit word character");
6912     }
6913     if ( flags ) {
6914         SV* sv_name
6915             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
6916                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
6917         if ( flags == REG_RSN_RETURN_NAME)
6918             return sv_name;
6919         else if (flags==REG_RSN_RETURN_DATA) {
6920             HE *he_str = NULL;
6921             SV *sv_dat = NULL;
6922             if ( ! sv_name )      /* should not happen*/
6923                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
6924             if (RExC_paren_names)
6925                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
6926             if ( he_str )
6927                 sv_dat = HeVAL(he_str);
6928             if ( ! sv_dat )
6929                 vFAIL("Reference to nonexistent named group");
6930             return sv_dat;
6931         }
6932         else {
6933             Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
6934                        (unsigned long) flags);
6935         }
6936         assert(0); /* NOT REACHED */
6937     }
6938     return NULL;
6939 }
6940
6941 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
6942     int rem=(int)(RExC_end - RExC_parse);                       \
6943     int cut;                                                    \
6944     int num;                                                    \
6945     int iscut=0;                                                \
6946     if (rem>10) {                                               \
6947         rem=10;                                                 \
6948         iscut=1;                                                \
6949     }                                                           \
6950     cut=10-rem;                                                 \
6951     if (RExC_lastparse!=RExC_parse)                             \
6952         PerlIO_printf(Perl_debug_log," >%.*s%-*s",              \
6953             rem, RExC_parse,                                    \
6954             cut + 4,                                            \
6955             iscut ? "..." : "<"                                 \
6956         );                                                      \
6957     else                                                        \
6958         PerlIO_printf(Perl_debug_log,"%16s","");                \
6959                                                                 \
6960     if (SIZE_ONLY)                                              \
6961        num = RExC_size + 1;                                     \
6962     else                                                        \
6963        num=REG_NODE_NUM(RExC_emit);                             \
6964     if (RExC_lastnum!=num)                                      \
6965        PerlIO_printf(Perl_debug_log,"|%4d",num);                \
6966     else                                                        \
6967        PerlIO_printf(Perl_debug_log,"|%4s","");                 \
6968     PerlIO_printf(Perl_debug_log,"|%*s%-4s",                    \
6969         (int)((depth*2)), "",                                   \
6970         (funcname)                                              \
6971     );                                                          \
6972     RExC_lastnum=num;                                           \
6973     RExC_lastparse=RExC_parse;                                  \
6974 })
6975
6976
6977
6978 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
6979     DEBUG_PARSE_MSG((funcname));                            \
6980     PerlIO_printf(Perl_debug_log,"%4s","\n");               \
6981 })
6982 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({           \
6983     DEBUG_PARSE_MSG((funcname));                            \
6984     PerlIO_printf(Perl_debug_log,fmt "\n",args);               \
6985 })
6986
6987 /* This section of code defines the inversion list object and its methods.  The
6988  * interfaces are highly subject to change, so as much as possible is static to
6989  * this file.  An inversion list is here implemented as a malloc'd C UV array
6990  * with some added info that is placed as UVs at the beginning in a header
6991  * portion.  An inversion list for Unicode is an array of code points, sorted
6992  * by ordinal number.  The zeroth element is the first code point in the list.
6993  * The 1th element is the first element beyond that not in the list.  In other
6994  * words, the first range is
6995  *  invlist[0]..(invlist[1]-1)
6996  * The other ranges follow.  Thus every element whose index is divisible by two
6997  * marks the beginning of a range that is in the list, and every element not
6998  * divisible by two marks the beginning of a range not in the list.  A single
6999  * element inversion list that contains the single code point N generally
7000  * consists of two elements
7001  *  invlist[0] == N
7002  *  invlist[1] == N+1
7003  * (The exception is when N is the highest representable value on the
7004  * machine, in which case the list containing just it would be a single
7005  * element, itself.  By extension, if the last range in the list extends to
7006  * infinity, then the first element of that range will be in the inversion list
7007  * at a position that is divisible by two, and is the final element in the
7008  * list.)
7009  * Taking the complement (inverting) an inversion list is quite simple, if the
7010  * first element is 0, remove it; otherwise add a 0 element at the beginning.
7011  * This implementation reserves an element at the beginning of each inversion
7012  * list to contain 0 when the list contains 0, and contains 1 otherwise.  The
7013  * actual beginning of the list is either that element if 0, or the next one if
7014  * 1.
7015  *
7016  * More about inversion lists can be found in "Unicode Demystified"
7017  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
7018  * More will be coming when functionality is added later.
7019  *
7020  * The inversion list data structure is currently implemented as an SV pointing
7021  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
7022  * array of UV whose memory management is automatically handled by the existing
7023  * facilities for SV's.
7024  *
7025  * Some of the methods should always be private to the implementation, and some
7026  * should eventually be made public */
7027
7028 /* The header definitions are in F<inline_invlist.c> */
7029 #define TO_INTERNAL_SIZE(x) (((x) + HEADER_LENGTH) * sizeof(UV))
7030 #define FROM_INTERNAL_SIZE(x) (((x)/ sizeof(UV)) - HEADER_LENGTH)
7031
7032 #define INVLIST_INITIAL_LEN 10
7033
7034 PERL_STATIC_INLINE UV*
7035 S__invlist_array_init(pTHX_ SV* const invlist, const bool will_have_0)
7036 {
7037     /* Returns a pointer to the first element in the inversion list's array.
7038      * This is called upon initialization of an inversion list.  Where the
7039      * array begins depends on whether the list has the code point U+0000
7040      * in it or not.  The other parameter tells it whether the code that
7041      * follows this call is about to put a 0 in the inversion list or not.
7042      * The first element is either the element with 0, if 0, or the next one,
7043      * if 1 */
7044
7045     UV* zero = get_invlist_zero_addr(invlist);
7046
7047     PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
7048
7049     /* Must be empty */
7050     assert(! *_get_invlist_len_addr(invlist));
7051
7052     /* 1^1 = 0; 1^0 = 1 */
7053     *zero = 1 ^ will_have_0;
7054     return zero + *zero;
7055 }
7056
7057 PERL_STATIC_INLINE UV*
7058 S_invlist_array(pTHX_ SV* const invlist)
7059 {
7060     /* Returns the pointer to the inversion list's array.  Every time the
7061      * length changes, this needs to be called in case malloc or realloc moved
7062      * it */
7063
7064     PERL_ARGS_ASSERT_INVLIST_ARRAY;
7065
7066     /* Must not be empty.  If these fail, you probably didn't check for <len>
7067      * being non-zero before trying to get the array */
7068     assert(*_get_invlist_len_addr(invlist));
7069     assert(*get_invlist_zero_addr(invlist) == 0
7070            || *get_invlist_zero_addr(invlist) == 1);
7071
7072     /* The array begins either at the element reserved for zero if the
7073      * list contains 0 (that element will be set to 0), or otherwise the next
7074      * element (in which case the reserved element will be set to 1). */
7075     return (UV *) (get_invlist_zero_addr(invlist)
7076                    + *get_invlist_zero_addr(invlist));
7077 }
7078
7079 PERL_STATIC_INLINE void
7080 S_invlist_set_len(pTHX_ SV* const invlist, const UV len)
7081 {
7082     /* Sets the current number of elements stored in the inversion list */
7083
7084     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
7085
7086     *_get_invlist_len_addr(invlist) = len;
7087
7088     assert(len <= SvLEN(invlist));
7089
7090     SvCUR_set(invlist, TO_INTERNAL_SIZE(len));
7091     /* If the list contains U+0000, that element is part of the header,
7092      * and should not be counted as part of the array.  It will contain
7093      * 0 in that case, and 1 otherwise.  So we could flop 0=>1, 1=>0 and
7094      * subtract:
7095      *  SvCUR_set(invlist,
7096      *            TO_INTERNAL_SIZE(len
7097      *                             - (*get_invlist_zero_addr(inv_list) ^ 1)));
7098      * But, this is only valid if len is not 0.  The consequences of not doing
7099      * this is that the memory allocation code may think that 1 more UV is
7100      * being used than actually is, and so might do an unnecessary grow.  That
7101      * seems worth not bothering to make this the precise amount.
7102      *
7103      * Note that when inverting, SvCUR shouldn't change */
7104 }
7105
7106 PERL_STATIC_INLINE IV*
7107 S_get_invlist_previous_index_addr(pTHX_ SV* invlist)
7108 {
7109     /* Return the address of the UV that is reserved to hold the cached index
7110      * */
7111
7112     PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR;
7113
7114     return (IV *) (SvPVX(invlist) + (INVLIST_PREVIOUS_INDEX_OFFSET * sizeof (UV)));
7115 }
7116
7117 PERL_STATIC_INLINE IV
7118 S_invlist_previous_index(pTHX_ SV* const invlist)
7119 {
7120     /* Returns cached index of previous search */
7121
7122     PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX;
7123
7124     return *get_invlist_previous_index_addr(invlist);
7125 }
7126
7127 PERL_STATIC_INLINE void
7128 S_invlist_set_previous_index(pTHX_ SV* const invlist, const IV index)
7129 {
7130     /* Caches <index> for later retrieval */
7131
7132     PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX;
7133
7134     assert(index == 0 || index < (int) _invlist_len(invlist));
7135
7136     *get_invlist_previous_index_addr(invlist) = index;
7137 }
7138
7139 PERL_STATIC_INLINE UV
7140 S_invlist_max(pTHX_ SV* const invlist)
7141 {
7142     /* Returns the maximum number of elements storable in the inversion list's
7143      * array, without having to realloc() */
7144
7145     PERL_ARGS_ASSERT_INVLIST_MAX;
7146
7147     return SvLEN(invlist) == 0  /* This happens under _new_invlist_C_array */
7148            ? _invlist_len(invlist)
7149            : FROM_INTERNAL_SIZE(SvLEN(invlist));
7150 }
7151
7152 PERL_STATIC_INLINE UV*
7153 S_get_invlist_zero_addr(pTHX_ SV* invlist)
7154 {
7155     /* Return the address of the UV that is reserved to hold 0 if the inversion
7156      * list contains 0.  This has to be the last element of the heading, as the
7157      * list proper starts with either it if 0, or the next element if not.
7158      * (But we force it to contain either 0 or 1) */
7159
7160     PERL_ARGS_ASSERT_GET_INVLIST_ZERO_ADDR;
7161
7162     return (UV *) (SvPVX(invlist) + (INVLIST_ZERO_OFFSET * sizeof (UV)));
7163 }
7164
7165 #ifndef PERL_IN_XSUB_RE
7166 SV*
7167 Perl__new_invlist(pTHX_ IV initial_size)
7168 {
7169
7170     /* Return a pointer to a newly constructed inversion list, with enough
7171      * space to store 'initial_size' elements.  If that number is negative, a
7172      * system default is used instead */
7173
7174     SV* new_list;
7175
7176     if (initial_size < 0) {
7177         initial_size = INVLIST_INITIAL_LEN;
7178     }
7179
7180     /* Allocate the initial space */
7181     new_list = newSV(TO_INTERNAL_SIZE(initial_size));
7182     invlist_set_len(new_list, 0);
7183
7184     /* Force iterinit() to be used to get iteration to work */
7185     *get_invlist_iter_addr(new_list) = UV_MAX;
7186
7187     /* This should force a segfault if a method doesn't initialize this
7188      * properly */
7189     *get_invlist_zero_addr(new_list) = UV_MAX;
7190
7191     *get_invlist_previous_index_addr(new_list) = 0;
7192     *get_invlist_version_id_addr(new_list) = INVLIST_VERSION_ID;
7193 #if HEADER_LENGTH != 5
7194 #   error Need to regenerate INVLIST_VERSION_ID by running perl -E 'say int(rand 2**31-1)', and then changing the #if to the new length
7195 #endif
7196
7197     return new_list;
7198 }
7199 #endif
7200
7201 STATIC SV*
7202 S__new_invlist_C_array(pTHX_ UV* list)
7203 {
7204     /* Return a pointer to a newly constructed inversion list, initialized to
7205      * point to <list>, which has to be in the exact correct inversion list
7206      * form, including internal fields.  Thus this is a dangerous routine that
7207      * should not be used in the wrong hands */
7208
7209     SV* invlist = newSV_type(SVt_PV);
7210
7211     PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
7212
7213     SvPV_set(invlist, (char *) list);
7214     SvLEN_set(invlist, 0);  /* Means we own the contents, and the system
7215                                shouldn't touch it */
7216     SvCUR_set(invlist, TO_INTERNAL_SIZE(_invlist_len(invlist)));
7217
7218     if (*get_invlist_version_id_addr(invlist) != INVLIST_VERSION_ID) {
7219         Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
7220     }
7221
7222     /* Initialize the iteration pointer.
7223      * XXX This could be done at compile time in charclass_invlists.h, but I
7224      * (khw) am not confident that the suffixes for specifying the C constant
7225      * UV_MAX are portable, e.g.  'ull' on a 32 bit machine that is configured
7226      * to use 64 bits; might need a Configure probe */
7227     invlist_iterfinish(invlist);
7228
7229     return invlist;
7230 }
7231
7232 STATIC void
7233 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
7234 {
7235     /* Grow the maximum size of an inversion list */
7236
7237     PERL_ARGS_ASSERT_INVLIST_EXTEND;
7238
7239     SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max));
7240 }
7241
7242 PERL_STATIC_INLINE void
7243 S_invlist_trim(pTHX_ SV* const invlist)
7244 {
7245     PERL_ARGS_ASSERT_INVLIST_TRIM;
7246
7247     /* Change the length of the inversion list to how many entries it currently
7248      * has */
7249
7250     SvPV_shrink_to_cur((SV *) invlist);
7251 }
7252
7253 #define _invlist_union_complement_2nd(a, b, output) _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
7254
7255 STATIC void
7256 S__append_range_to_invlist(pTHX_ SV* const invlist, const UV start, const UV end)
7257 {
7258    /* Subject to change or removal.  Append the range from 'start' to 'end' at
7259     * the end of the inversion list.  The range must be above any existing
7260     * ones. */
7261
7262     UV* array;
7263     UV max = invlist_max(invlist);
7264     UV len = _invlist_len(invlist);
7265
7266     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
7267
7268     if (len == 0) { /* Empty lists must be initialized */
7269         array = _invlist_array_init(invlist, start == 0);
7270     }
7271     else {
7272         /* Here, the existing list is non-empty. The current max entry in the
7273          * list is generally the first value not in the set, except when the
7274          * set extends to the end of permissible values, in which case it is
7275          * the first entry in that final set, and so this call is an attempt to
7276          * append out-of-order */
7277
7278         UV final_element = len - 1;
7279         array = invlist_array(invlist);
7280         if (array[final_element] > start
7281             || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
7282         {
7283             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",
7284                        array[final_element], start,
7285                        ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
7286         }
7287
7288         /* Here, it is a legal append.  If the new range begins with the first
7289          * value not in the set, it is extending the set, so the new first
7290          * value not in the set is one greater than the newly extended range.
7291          * */
7292         if (array[final_element] == start) {
7293             if (end != UV_MAX) {
7294                 array[final_element] = end + 1;
7295             }
7296             else {
7297                 /* But if the end is the maximum representable on the machine,
7298                  * just let the range that this would extend to have no end */
7299                 invlist_set_len(invlist, len - 1);
7300             }
7301             return;
7302         }
7303     }
7304
7305     /* Here the new range doesn't extend any existing set.  Add it */
7306
7307     len += 2;   /* Includes an element each for the start and end of range */
7308
7309     /* If overflows the existing space, extend, which may cause the array to be
7310      * moved */
7311     if (max < len) {
7312         invlist_extend(invlist, len);
7313         invlist_set_len(invlist, len);  /* Have to set len here to avoid assert
7314                                            failure in invlist_array() */
7315         array = invlist_array(invlist);
7316     }
7317     else {
7318         invlist_set_len(invlist, len);
7319     }
7320
7321     /* The next item on the list starts the range, the one after that is
7322      * one past the new range.  */
7323     array[len - 2] = start;
7324     if (end != UV_MAX) {
7325         array[len - 1] = end + 1;
7326     }
7327     else {
7328         /* But if the end is the maximum representable on the machine, just let
7329          * the range have no end */
7330         invlist_set_len(invlist, len - 1);
7331     }
7332 }
7333
7334 #ifndef PERL_IN_XSUB_RE
7335
7336 IV
7337 Perl__invlist_search(pTHX_ SV* const invlist, const UV cp)
7338 {
7339     /* Searches the inversion list for the entry that contains the input code
7340      * point <cp>.  If <cp> is not in the list, -1 is returned.  Otherwise, the
7341      * return value is the index into the list's array of the range that
7342      * contains <cp> */
7343
7344     IV low = 0;
7345     IV mid;
7346     IV high = _invlist_len(invlist);
7347     const IV highest_element = high - 1;
7348     const UV* array;
7349
7350     PERL_ARGS_ASSERT__INVLIST_SEARCH;
7351
7352     /* If list is empty, return failure. */
7353     if (high == 0) {
7354         return -1;
7355     }
7356
7357     /* (We can't get the array unless we know the list is non-empty) */
7358     array = invlist_array(invlist);
7359
7360     mid = invlist_previous_index(invlist);
7361     assert(mid >=0 && mid <= highest_element);
7362
7363     /* <mid> contains the cache of the result of the previous call to this
7364      * function (0 the first time).  See if this call is for the same result,
7365      * or if it is for mid-1.  This is under the theory that calls to this
7366      * function will often be for related code points that are near each other.
7367      * And benchmarks show that caching gives better results.  We also test
7368      * here if the code point is within the bounds of the list.  These tests
7369      * replace others that would have had to be made anyway to make sure that
7370      * the array bounds were not exceeded, and these give us extra information
7371      * at the same time */
7372     if (cp >= array[mid]) {
7373         if (cp >= array[highest_element]) {
7374             return highest_element;
7375         }
7376
7377         /* Here, array[mid] <= cp < array[highest_element].  This means that
7378          * the final element is not the answer, so can exclude it; it also
7379          * means that <mid> is not the final element, so can refer to 'mid + 1'
7380          * safely */
7381         if (cp < array[mid + 1]) {
7382             return mid;
7383         }
7384         high--;
7385         low = mid + 1;
7386     }
7387     else { /* cp < aray[mid] */
7388         if (cp < array[0]) { /* Fail if outside the array */
7389             return -1;
7390         }
7391         high = mid;
7392         if (cp >= array[mid - 1]) {
7393             goto found_entry;
7394         }
7395     }
7396
7397     /* Binary search.  What we are looking for is <i> such that
7398      *  array[i] <= cp < array[i+1]
7399      * The loop below converges on the i+1.  Note that there may not be an
7400      * (i+1)th element in the array, and things work nonetheless */
7401     while (low < high) {
7402         mid = (low + high) / 2;
7403         assert(mid <= highest_element);
7404         if (array[mid] <= cp) { /* cp >= array[mid] */
7405             low = mid + 1;
7406
7407             /* We could do this extra test to exit the loop early.
7408             if (cp < array[low]) {
7409                 return mid;
7410             }
7411             */
7412         }
7413         else { /* cp < array[mid] */
7414             high = mid;
7415         }
7416     }
7417
7418   found_entry:
7419     high--;
7420     invlist_set_previous_index(invlist, high);
7421     return high;
7422 }
7423
7424 void
7425 Perl__invlist_populate_swatch(pTHX_ SV* const invlist, const UV start, const UV end, U8* swatch)
7426 {
7427     /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
7428      * but is used when the swash has an inversion list.  This makes this much
7429      * faster, as it uses a binary search instead of a linear one.  This is
7430      * intimately tied to that function, and perhaps should be in utf8.c,
7431      * except it is intimately tied to inversion lists as well.  It assumes
7432      * that <swatch> is all 0's on input */
7433
7434     UV current = start;
7435     const IV len = _invlist_len(invlist);
7436     IV i;
7437     const UV * array;
7438
7439     PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
7440
7441     if (len == 0) { /* Empty inversion list */
7442         return;
7443     }
7444
7445     array = invlist_array(invlist);
7446
7447     /* Find which element it is */
7448     i = _invlist_search(invlist, start);
7449
7450     /* We populate from <start> to <end> */
7451     while (current < end) {
7452         UV upper;
7453
7454         /* The inversion list gives the results for every possible code point
7455          * after the first one in the list.  Only those ranges whose index is
7456          * even are ones that the inversion list matches.  For the odd ones,
7457          * and if the initial code point is not in the list, we have to skip
7458          * forward to the next element */
7459         if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
7460             i++;
7461             if (i >= len) { /* Finished if beyond the end of the array */
7462                 return;
7463             }
7464             current = array[i];
7465             if (current >= end) {   /* Finished if beyond the end of what we
7466                                        are populating */
7467                 if (LIKELY(end < UV_MAX)) {
7468                     return;
7469                 }
7470
7471                 /* We get here when the upper bound is the maximum
7472                  * representable on the machine, and we are looking for just
7473                  * that code point.  Have to special case it */
7474                 i = len;
7475                 goto join_end_of_list;
7476             }
7477         }
7478         assert(current >= start);
7479
7480         /* The current range ends one below the next one, except don't go past
7481          * <end> */
7482         i++;
7483         upper = (i < len && array[i] < end) ? array[i] : end;
7484
7485         /* Here we are in a range that matches.  Populate a bit in the 3-bit U8
7486          * for each code point in it */
7487         for (; current < upper; current++) {
7488             const STRLEN offset = (STRLEN)(current - start);
7489             swatch[offset >> 3] |= 1 << (offset & 7);
7490         }
7491
7492     join_end_of_list:
7493
7494         /* Quit if at the end of the list */
7495         if (i >= len) {
7496
7497             /* But first, have to deal with the highest possible code point on
7498              * the platform.  The previous code assumes that <end> is one
7499              * beyond where we want to populate, but that is impossible at the
7500              * platform's infinity, so have to handle it specially */
7501             if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
7502             {
7503                 const STRLEN offset = (STRLEN)(end - start);
7504                 swatch[offset >> 3] |= 1 << (offset & 7);
7505             }
7506             return;
7507         }
7508
7509         /* Advance to the next range, which will be for code points not in the
7510          * inversion list */
7511         current = array[i];
7512     }
7513
7514     return;
7515 }
7516
7517 void
7518 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** output)
7519 {
7520     /* Take the union of two inversion lists and point <output> to it.  *output
7521      * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
7522      * the reference count to that list will be decremented.  The first list,
7523      * <a>, may be NULL, in which case a copy of the second list is returned.
7524      * If <complement_b> is TRUE, the union is taken of the complement
7525      * (inversion) of <b> instead of b itself.
7526      *
7527      * The basis for this comes from "Unicode Demystified" Chapter 13 by
7528      * Richard Gillam, published by Addison-Wesley, and explained at some
7529      * length there.  The preface says to incorporate its examples into your
7530      * code at your own risk.
7531      *
7532      * The algorithm is like a merge sort.
7533      *
7534      * XXX A potential performance improvement is to keep track as we go along
7535      * if only one of the inputs contributes to the result, meaning the other
7536      * is a subset of that one.  In that case, we can skip the final copy and
7537      * return the larger of the input lists, but then outside code might need
7538      * to keep track of whether to free the input list or not */
7539
7540     UV* array_a;    /* a's array */
7541     UV* array_b;
7542     UV len_a;       /* length of a's array */
7543     UV len_b;
7544
7545     SV* u;                      /* the resulting union */
7546     UV* array_u;
7547     UV len_u;
7548
7549     UV i_a = 0;             /* current index into a's array */
7550     UV i_b = 0;
7551     UV i_u = 0;
7552
7553     /* running count, as explained in the algorithm source book; items are
7554      * stopped accumulating and are output when the count changes to/from 0.
7555      * The count is incremented when we start a range that's in the set, and
7556      * decremented when we start a range that's not in the set.  So its range
7557      * is 0 to 2.  Only when the count is zero is something not in the set.
7558      */
7559     UV count = 0;
7560
7561     PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
7562     assert(a != b);
7563
7564     /* If either one is empty, the union is the other one */
7565     if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
7566         if (*output == a) {
7567             if (a != NULL) {
7568                 SvREFCNT_dec_NN(a);
7569             }
7570         }
7571         if (*output != b) {
7572             *output = invlist_clone(b);
7573             if (complement_b) {
7574                 _invlist_invert(*output);
7575             }
7576         } /* else *output already = b; */
7577         return;
7578     }
7579     else if ((len_b = _invlist_len(b)) == 0) {
7580         if (*output == b) {
7581             SvREFCNT_dec_NN(b);
7582         }
7583
7584         /* The complement of an empty list is a list that has everything in it,
7585          * so the union with <a> includes everything too */
7586         if (complement_b) {
7587             if (a == *output) {
7588                 SvREFCNT_dec_NN(a);
7589             }
7590             *output = _new_invlist(1);
7591             _append_range_to_invlist(*output, 0, UV_MAX);
7592         }
7593         else if (*output != a) {
7594             *output = invlist_clone(a);
7595         }
7596         /* else *output already = a; */
7597         return;
7598     }
7599
7600     /* Here both lists exist and are non-empty */
7601     array_a = invlist_array(a);
7602     array_b = invlist_array(b);
7603
7604     /* If are to take the union of 'a' with the complement of b, set it
7605      * up so are looking at b's complement. */
7606     if (complement_b) {
7607
7608         /* To complement, we invert: if the first element is 0, remove it.  To
7609          * do this, we just pretend the array starts one later, and clear the
7610          * flag as we don't have to do anything else later */
7611         if (array_b[0] == 0) {
7612             array_b++;
7613             len_b--;
7614             complement_b = FALSE;
7615         }
7616         else {
7617
7618             /* But if the first element is not zero, we unshift a 0 before the
7619              * array.  The data structure reserves a space for that 0 (which
7620              * should be a '1' right now), so physical shifting is unneeded,
7621              * but temporarily change that element to 0.  Before exiting the
7622              * routine, we must restore the element to '1' */
7623             array_b--;
7624             len_b++;
7625             array_b[0] = 0;
7626         }
7627     }
7628
7629     /* Size the union for the worst case: that the sets are completely
7630      * disjoint */
7631     u = _new_invlist(len_a + len_b);
7632
7633     /* Will contain U+0000 if either component does */
7634     array_u = _invlist_array_init(u, (len_a > 0 && array_a[0] == 0)
7635                                       || (len_b > 0 && array_b[0] == 0));
7636
7637     /* Go through each list item by item, stopping when exhausted one of
7638      * them */
7639     while (i_a < len_a && i_b < len_b) {
7640         UV cp;      /* The element to potentially add to the union's array */
7641         bool cp_in_set;   /* is it in the the input list's set or not */
7642
7643         /* We need to take one or the other of the two inputs for the union.
7644          * Since we are merging two sorted lists, we take the smaller of the
7645          * next items.  In case of a tie, we take the one that is in its set
7646          * first.  If we took one not in the set first, it would decrement the
7647          * count, possibly to 0 which would cause it to be output as ending the
7648          * range, and the next time through we would take the same number, and
7649          * output it again as beginning the next range.  By doing it the
7650          * opposite way, there is no possibility that the count will be
7651          * momentarily decremented to 0, and thus the two adjoining ranges will
7652          * be seamlessly merged.  (In a tie and both are in the set or both not
7653          * in the set, it doesn't matter which we take first.) */
7654         if (array_a[i_a] < array_b[i_b]
7655             || (array_a[i_a] == array_b[i_b]
7656                 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
7657         {
7658             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
7659             cp= array_a[i_a++];
7660         }
7661         else {
7662             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
7663             cp = array_b[i_b++];
7664         }
7665
7666         /* Here, have chosen which of the two inputs to look at.  Only output
7667          * if the running count changes to/from 0, which marks the
7668          * beginning/end of a range in that's in the set */
7669         if (cp_in_set) {
7670             if (count == 0) {
7671                 array_u[i_u++] = cp;
7672             }
7673             count++;
7674         }
7675         else {
7676             count--;
7677             if (count == 0) {
7678                 array_u[i_u++] = cp;
7679             }
7680         }
7681     }
7682
7683     /* Here, we are finished going through at least one of the lists, which
7684      * means there is something remaining in at most one.  We check if the list
7685      * that hasn't been exhausted is positioned such that we are in the middle
7686      * of a range in its set or not.  (i_a and i_b point to the element beyond
7687      * the one we care about.) If in the set, we decrement 'count'; if 0, there
7688      * is potentially more to output.
7689      * There are four cases:
7690      *  1) Both weren't in their sets, count is 0, and remains 0.  What's left
7691      *     in the union is entirely from the non-exhausted set.
7692      *  2) Both were in their sets, count is 2.  Nothing further should
7693      *     be output, as everything that remains will be in the exhausted
7694      *     list's set, hence in the union; decrementing to 1 but not 0 insures
7695      *     that
7696      *  3) the exhausted was in its set, non-exhausted isn't, count is 1.
7697      *     Nothing further should be output because the union includes
7698      *     everything from the exhausted set.  Not decrementing ensures that.
7699      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1;
7700      *     decrementing to 0 insures that we look at the remainder of the
7701      *     non-exhausted set */
7702     if ((i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
7703         || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
7704     {
7705         count--;
7706     }
7707
7708     /* The final length is what we've output so far, plus what else is about to
7709      * be output.  (If 'count' is non-zero, then the input list we exhausted
7710      * has everything remaining up to the machine's limit in its set, and hence
7711      * in the union, so there will be no further output. */
7712     len_u = i_u;
7713     if (count == 0) {
7714         /* At most one of the subexpressions will be non-zero */
7715         len_u += (len_a - i_a) + (len_b - i_b);
7716     }
7717
7718     /* Set result to final length, which can change the pointer to array_u, so
7719      * re-find it */
7720     if (len_u != _invlist_len(u)) {
7721         invlist_set_len(u, len_u);
7722         invlist_trim(u);
7723         array_u = invlist_array(u);
7724     }
7725
7726     /* When 'count' is 0, the list that was exhausted (if one was shorter than
7727      * the other) ended with everything above it not in its set.  That means
7728      * that the remaining part of the union is precisely the same as the
7729      * non-exhausted list, so can just copy it unchanged.  (If both list were
7730      * exhausted at the same time, then the operations below will be both 0.)
7731      */
7732     if (count == 0) {
7733         IV copy_count; /* At most one will have a non-zero copy count */
7734         if ((copy_count = len_a - i_a) > 0) {
7735             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
7736         }
7737         else if ((copy_count = len_b - i_b) > 0) {
7738             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
7739         }
7740     }
7741
7742     /* If we've changed b, restore it */
7743     if (complement_b) {
7744         array_b[0] = 1;
7745     }
7746
7747     /*  We may be removing a reference to one of the inputs */
7748     if (a == *output || b == *output) {
7749         assert(! invlist_is_iterating(*output));
7750         SvREFCNT_dec_NN(*output);
7751     }
7752
7753     *output = u;
7754     return;
7755 }
7756
7757 void
7758 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** i)
7759 {
7760     /* Take the intersection of two inversion lists and point <i> to it.  *i
7761      * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
7762      * the reference count to that list will be decremented.
7763      * If <complement_b> is TRUE, the result will be the intersection of <a>
7764      * and the complement (or inversion) of <b> instead of <b> directly.
7765      *
7766      * The basis for this comes from "Unicode Demystified" Chapter 13 by
7767      * Richard Gillam, published by Addison-Wesley, and explained at some
7768      * length there.  The preface says to incorporate its examples into your
7769      * code at your own risk.  In fact, it had bugs
7770      *
7771      * The algorithm is like a merge sort, and is essentially the same as the
7772      * union above
7773      */
7774
7775     UV* array_a;                /* a's array */
7776     UV* array_b;
7777     UV len_a;   /* length of a's array */
7778     UV len_b;
7779
7780     SV* r;                   /* the resulting intersection */
7781     UV* array_r;
7782     UV len_r;
7783
7784     UV i_a = 0;             /* current index into a's array */
7785     UV i_b = 0;
7786     UV i_r = 0;
7787
7788     /* running count, as explained in the algorithm source book; items are
7789      * stopped accumulating and are output when the count changes to/from 2.
7790      * The count is incremented when we start a range that's in the set, and
7791      * decremented when we start a range that's not in the set.  So its range
7792      * is 0 to 2.  Only when the count is 2 is something in the intersection.
7793      */
7794     UV count = 0;
7795
7796     PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
7797     assert(a != b);
7798
7799     /* Special case if either one is empty */
7800     len_a = _invlist_len(a);
7801     if ((len_a == 0) || ((len_b = _invlist_len(b)) == 0)) {
7802
7803         if (len_a != 0 && complement_b) {
7804
7805             /* Here, 'a' is not empty, therefore from the above 'if', 'b' must
7806              * be empty.  Here, also we are using 'b's complement, which hence
7807              * must be every possible code point.  Thus the intersection is
7808              * simply 'a'. */
7809             if (*i != a) {
7810                 *i = invlist_clone(a);
7811
7812                 if (*i == b) {
7813                     SvREFCNT_dec_NN(b);
7814                 }
7815             }
7816             /* else *i is already 'a' */
7817             return;
7818         }
7819
7820         /* Here, 'a' or 'b' is empty and not using the complement of 'b'.  The
7821          * intersection must be empty */
7822         if (*i == a) {
7823             SvREFCNT_dec_NN(a);
7824         }
7825         else if (*i == b) {
7826             SvREFCNT_dec_NN(b);
7827         }
7828         *i = _new_invlist(0);
7829         return;
7830     }
7831
7832     /* Here both lists exist and are non-empty */
7833     array_a = invlist_array(a);
7834     array_b = invlist_array(b);
7835
7836     /* If are to take the intersection of 'a' with the complement of b, set it
7837      * up so are looking at b's complement. */
7838     if (complement_b) {
7839
7840         /* To complement, we invert: if the first element is 0, remove it.  To
7841          * do this, we just pretend the array starts one later, and clear the
7842          * flag as we don't have to do anything else later */
7843         if (array_b[0] == 0) {
7844             array_b++;
7845             len_b--;
7846             complement_b = FALSE;
7847         }
7848         else {
7849
7850             /* But if the first element is not zero, we unshift a 0 before the
7851              * array.  The data structure reserves a space for that 0 (which
7852              * should be a '1' right now), so physical shifting is unneeded,
7853              * but temporarily change that element to 0.  Before exiting the
7854              * routine, we must restore the element to '1' */
7855             array_b--;
7856             len_b++;
7857             array_b[0] = 0;
7858         }
7859     }
7860
7861     /* Size the intersection for the worst case: that the intersection ends up
7862      * fragmenting everything to be completely disjoint */
7863     r= _new_invlist(len_a + len_b);
7864
7865     /* Will contain U+0000 iff both components do */
7866     array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
7867                                      && len_b > 0 && array_b[0] == 0);
7868
7869     /* Go through each list item by item, stopping when exhausted one of
7870      * them */
7871     while (i_a < len_a && i_b < len_b) {
7872         UV cp;      /* The element to potentially add to the intersection's
7873                        array */
7874         bool cp_in_set; /* Is it in the input list's set or not */
7875
7876         /* We need to take one or the other of the two inputs for the
7877          * intersection.  Since we are merging two sorted lists, we take the
7878          * smaller of the next items.  In case of a tie, we take the one that
7879          * is not in its set first (a difference from the union algorithm).  If
7880          * we took one in the set first, it would increment the count, possibly
7881          * to 2 which would cause it to be output as starting a range in the
7882          * intersection, and the next time through we would take that same
7883          * number, and output it again as ending the set.  By doing it the
7884          * opposite of this, there is no possibility that the count will be
7885          * momentarily incremented to 2.  (In a tie and both are in the set or
7886          * both not in the set, it doesn't matter which we take first.) */
7887         if (array_a[i_a] < array_b[i_b]
7888             || (array_a[i_a] == array_b[i_b]
7889                 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
7890         {
7891             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
7892             cp= array_a[i_a++];
7893         }
7894         else {
7895             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
7896             cp= array_b[i_b++];
7897         }
7898
7899         /* Here, have chosen which of the two inputs to look at.  Only output
7900          * if the running count changes to/from 2, which marks the
7901          * beginning/end of a range that's in the intersection */
7902         if (cp_in_set) {
7903             count++;
7904             if (count == 2) {
7905                 array_r[i_r++] = cp;
7906             }
7907         }
7908         else {
7909             if (count == 2) {
7910                 array_r[i_r++] = cp;
7911             }
7912             count--;
7913         }
7914     }
7915
7916     /* Here, we are finished going through at least one of the lists, which
7917      * means there is something remaining in at most one.  We check if the list
7918      * that has been exhausted is positioned such that we are in the middle
7919      * of a range in its set or not.  (i_a and i_b point to elements 1 beyond
7920      * the ones we care about.)  There are four cases:
7921      *  1) Both weren't in their sets, count is 0, and remains 0.  There's
7922      *     nothing left in the intersection.
7923      *  2) Both were in their sets, count is 2 and perhaps is incremented to
7924      *     above 2.  What should be output is exactly that which is in the
7925      *     non-exhausted set, as everything it has is also in the intersection
7926      *     set, and everything it doesn't have can't be in the intersection
7927      *  3) The exhausted was in its set, non-exhausted isn't, count is 1, and
7928      *     gets incremented to 2.  Like the previous case, the intersection is
7929      *     everything that remains in the non-exhausted set.
7930      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1, and
7931      *     remains 1.  And the intersection has nothing more. */
7932     if ((i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
7933         || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
7934     {
7935         count++;
7936     }
7937
7938     /* The final length is what we've output so far plus what else is in the
7939      * intersection.  At most one of the subexpressions below will be non-zero */
7940     len_r = i_r;
7941     if (count >= 2) {
7942         len_r += (len_a - i_a) + (len_b - i_b);
7943     }
7944
7945     /* Set result to final length, which can change the pointer to array_r, so
7946      * re-find it */
7947     if (len_r != _invlist_len(r)) {
7948         invlist_set_len(r, len_r);
7949         invlist_trim(r);
7950         array_r = invlist_array(r);
7951     }
7952
7953     /* Finish outputting any remaining */
7954     if (count >= 2) { /* At most one will have a non-zero copy count */
7955         IV copy_count;
7956         if ((copy_count = len_a - i_a) > 0) {
7957             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
7958         }
7959         else if ((copy_count = len_b - i_b) > 0) {
7960             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
7961         }
7962     }
7963
7964     /* If we've changed b, restore it */
7965     if (complement_b) {
7966         array_b[0] = 1;
7967     }
7968
7969     /*  We may be removing a reference to one of the inputs */
7970     if (a == *i || b == *i) {
7971         assert(! invlist_is_iterating(*i));
7972         SvREFCNT_dec_NN(*i);
7973     }
7974
7975     *i = r;
7976     return;
7977 }
7978
7979 SV*
7980 Perl__add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end)
7981 {
7982     /* Add the range from 'start' to 'end' inclusive to the inversion list's
7983      * set.  A pointer to the inversion list is returned.  This may actually be
7984      * a new list, in which case the passed in one has been destroyed.  The
7985      * passed in inversion list can be NULL, in which case a new one is created
7986      * with just the one range in it */
7987
7988     SV* range_invlist;
7989     UV len;
7990
7991     if (invlist == NULL) {
7992         invlist = _new_invlist(2);
7993         len = 0;
7994     }
7995     else {
7996         len = _invlist_len(invlist);
7997     }
7998
7999     /* If comes after the final entry actually in the list, can just append it
8000      * to the end, */
8001     if (len == 0
8002         || (! ELEMENT_RANGE_MATCHES_INVLIST(len - 1)
8003             && start >= invlist_array(invlist)[len - 1]))
8004     {
8005         _append_range_to_invlist(invlist, start, end);
8006         return invlist;
8007     }
8008
8009     /* Here, can't just append things, create and return a new inversion list
8010      * which is the union of this range and the existing inversion list */
8011     range_invlist = _new_invlist(2);
8012     _append_range_to_invlist(range_invlist, start, end);
8013
8014     _invlist_union(invlist, range_invlist, &invlist);
8015
8016     /* The temporary can be freed */
8017     SvREFCNT_dec_NN(range_invlist);
8018
8019     return invlist;
8020 }
8021
8022 #endif
8023
8024 PERL_STATIC_INLINE SV*
8025 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
8026     return _add_range_to_invlist(invlist, cp, cp);
8027 }
8028
8029 #ifndef PERL_IN_XSUB_RE
8030 void
8031 Perl__invlist_invert(pTHX_ SV* const invlist)
8032 {
8033     /* Complement the input inversion list.  This adds a 0 if the list didn't
8034      * have a zero; removes it otherwise.  As described above, the data
8035      * structure is set up so that this is very efficient */
8036
8037     UV* len_pos = _get_invlist_len_addr(invlist);
8038
8039     PERL_ARGS_ASSERT__INVLIST_INVERT;
8040
8041     assert(! invlist_is_iterating(invlist));
8042
8043     /* The inverse of matching nothing is matching everything */
8044     if (*len_pos == 0) {
8045         _append_range_to_invlist(invlist, 0, UV_MAX);
8046         return;
8047     }
8048
8049     /* The exclusive or complents 0 to 1; and 1 to 0.  If the result is 1, the
8050      * zero element was a 0, so it is being removed, so the length decrements
8051      * by 1; and vice-versa.  SvCUR is unaffected */
8052     if (*get_invlist_zero_addr(invlist) ^= 1) {
8053         (*len_pos)--;
8054     }
8055     else {
8056         (*len_pos)++;
8057     }
8058 }
8059
8060 void
8061 Perl__invlist_invert_prop(pTHX_ SV* const invlist)
8062 {
8063     /* Complement the input inversion list (which must be a Unicode property,
8064      * all of which don't match above the Unicode maximum code point.)  And
8065      * Perl has chosen to not have the inversion match above that either.  This
8066      * adds a 0x110000 if the list didn't end with it, and removes it if it did
8067      */
8068
8069     UV len;
8070     UV* array;
8071
8072     PERL_ARGS_ASSERT__INVLIST_INVERT_PROP;
8073
8074     _invlist_invert(invlist);
8075
8076     len = _invlist_len(invlist);
8077
8078     if (len != 0) { /* If empty do nothing */
8079         array = invlist_array(invlist);
8080         if (array[len - 1] != PERL_UNICODE_MAX + 1) {
8081             /* Add 0x110000.  First, grow if necessary */
8082             len++;
8083             if (invlist_max(invlist) < len) {
8084                 invlist_extend(invlist, len);
8085                 array = invlist_array(invlist);
8086             }
8087             invlist_set_len(invlist, len);
8088             array[len - 1] = PERL_UNICODE_MAX + 1;
8089         }
8090         else {  /* Remove the 0x110000 */
8091             invlist_set_len(invlist, len - 1);
8092         }
8093     }
8094
8095     return;
8096 }
8097 #endif
8098
8099 PERL_STATIC_INLINE SV*
8100 S_invlist_clone(pTHX_ SV* const invlist)
8101 {
8102
8103     /* Return a new inversion list that is a copy of the input one, which is
8104      * unchanged */
8105
8106     /* Need to allocate extra space to accommodate Perl's addition of a
8107      * trailing NUL to SvPV's, since it thinks they are always strings */
8108     SV* new_invlist = _new_invlist(_invlist_len(invlist) + 1);
8109     STRLEN length = SvCUR(invlist);
8110
8111     PERL_ARGS_ASSERT_INVLIST_CLONE;
8112
8113     SvCUR_set(new_invlist, length); /* This isn't done automatically */
8114     Copy(SvPVX(invlist), SvPVX(new_invlist), length, char);
8115
8116     return new_invlist;
8117 }
8118
8119 PERL_STATIC_INLINE UV*
8120 S_get_invlist_iter_addr(pTHX_ SV* invlist)
8121 {
8122     /* Return the address of the UV that contains the current iteration
8123      * position */
8124
8125     PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
8126
8127     return (UV *) (SvPVX(invlist) + (INVLIST_ITER_OFFSET * sizeof (UV)));
8128 }
8129
8130 PERL_STATIC_INLINE UV*
8131 S_get_invlist_version_id_addr(pTHX_ SV* invlist)
8132 {
8133     /* Return the address of the UV that contains the version id. */
8134
8135     PERL_ARGS_ASSERT_GET_INVLIST_VERSION_ID_ADDR;
8136
8137     return (UV *) (SvPVX(invlist) + (INVLIST_VERSION_ID_OFFSET * sizeof (UV)));
8138 }
8139
8140 PERL_STATIC_INLINE void
8141 S_invlist_iterinit(pTHX_ SV* invlist)   /* Initialize iterator for invlist */
8142 {
8143     PERL_ARGS_ASSERT_INVLIST_ITERINIT;
8144
8145     *get_invlist_iter_addr(invlist) = 0;
8146 }
8147
8148 PERL_STATIC_INLINE void
8149 S_invlist_iterfinish(pTHX_ SV* invlist)
8150 {
8151     /* Terminate iterator for invlist.  This is to catch development errors.
8152      * Any iteration that is interrupted before completed should call this
8153      * function.  Functions that add code points anywhere else but to the end
8154      * of an inversion list assert that they are not in the middle of an
8155      * iteration.  If they were, the addition would make the iteration
8156      * problematical: if the iteration hadn't reached the place where things
8157      * were being added, it would be ok */
8158
8159     PERL_ARGS_ASSERT_INVLIST_ITERFINISH;
8160
8161     *get_invlist_iter_addr(invlist) = UV_MAX;
8162 }
8163
8164 STATIC bool
8165 S_invlist_iternext(pTHX_ SV* invlist, UV* start, UV* end)
8166 {
8167     /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
8168      * This call sets in <*start> and <*end>, the next range in <invlist>.
8169      * Returns <TRUE> if successful and the next call will return the next
8170      * range; <FALSE> if was already at the end of the list.  If the latter,
8171      * <*start> and <*end> are unchanged, and the next call to this function
8172      * will start over at the beginning of the list */
8173
8174     UV* pos = get_invlist_iter_addr(invlist);
8175     UV len = _invlist_len(invlist);
8176     UV *array;
8177
8178     PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
8179
8180     if (*pos >= len) {
8181         *pos = UV_MAX;  /* Force iterinit() to be required next time */
8182         return FALSE;
8183     }
8184
8185     array = invlist_array(invlist);
8186
8187     *start = array[(*pos)++];
8188
8189     if (*pos >= len) {
8190         *end = UV_MAX;
8191     }
8192     else {
8193         *end = array[(*pos)++] - 1;
8194     }
8195
8196     return TRUE;
8197 }
8198
8199 PERL_STATIC_INLINE bool
8200 S_invlist_is_iterating(pTHX_ SV* const invlist)
8201 {
8202     PERL_ARGS_ASSERT_INVLIST_IS_ITERATING;
8203
8204     return *(get_invlist_iter_addr(invlist)) < UV_MAX;
8205 }
8206
8207 PERL_STATIC_INLINE UV
8208 S_invlist_highest(pTHX_ SV* const invlist)
8209 {
8210     /* Returns the highest code point that matches an inversion list.  This API
8211      * has an ambiguity, as it returns 0 under either the highest is actually
8212      * 0, or if the list is empty.  If this distinction matters to you, check
8213      * for emptiness before calling this function */
8214
8215     UV len = _invlist_len(invlist);
8216     UV *array;
8217
8218     PERL_ARGS_ASSERT_INVLIST_HIGHEST;
8219
8220     if (len == 0) {
8221         return 0;
8222     }
8223
8224     array = invlist_array(invlist);
8225
8226     /* The last element in the array in the inversion list always starts a
8227      * range that goes to infinity.  That range may be for code points that are
8228      * matched in the inversion list, or it may be for ones that aren't
8229      * matched.  In the latter case, the highest code point in the set is one
8230      * less than the beginning of this range; otherwise it is the final element
8231      * of this range: infinity */
8232     return (ELEMENT_RANGE_MATCHES_INVLIST(len - 1))
8233            ? UV_MAX
8234            : array[len - 1] - 1;
8235 }
8236
8237 #ifndef PERL_IN_XSUB_RE
8238 SV *
8239 Perl__invlist_contents(pTHX_ SV* const invlist)
8240 {
8241     /* Get the contents of an inversion list into a string SV so that they can
8242      * be printed out.  It uses the format traditionally done for debug tracing
8243      */
8244
8245     UV start, end;
8246     SV* output = newSVpvs("\n");
8247
8248     PERL_ARGS_ASSERT__INVLIST_CONTENTS;
8249
8250     assert(! invlist_is_iterating(invlist));
8251
8252     invlist_iterinit(invlist);
8253     while (invlist_iternext(invlist, &start, &end)) {
8254         if (end == UV_MAX) {
8255             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\tINFINITY\n", start);
8256         }
8257         else if (end != start) {
8258             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\t%04"UVXf"\n",
8259                     start,       end);
8260         }
8261         else {
8262             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\n", start);
8263         }
8264     }
8265
8266     return output;
8267 }
8268 #endif
8269
8270 #ifdef PERL_ARGS_ASSERT__INVLIST_DUMP
8271 void
8272 Perl__invlist_dump(pTHX_ SV* const invlist, const char * const header)
8273 {
8274     /* Dumps out the ranges in an inversion list.  The string 'header'
8275      * if present is output on a line before the first range */
8276
8277     UV start, end;
8278
8279     PERL_ARGS_ASSERT__INVLIST_DUMP;
8280
8281     if (header && strlen(header)) {
8282         PerlIO_printf(Perl_debug_log, "%s\n", header);
8283     }
8284     if (invlist_is_iterating(invlist)) {
8285         PerlIO_printf(Perl_debug_log, "Can't dump because is in middle of iterating\n");
8286         return;
8287     }
8288
8289     invlist_iterinit(invlist);
8290     while (invlist_iternext(invlist, &start, &end)) {
8291         if (end == UV_MAX) {
8292             PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. INFINITY\n", start);
8293         }
8294         else if (end != start) {
8295             PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. 0x%04"UVXf"\n",
8296                                                  start,         end);
8297         }
8298         else {
8299             PerlIO_printf(Perl_debug_log, "0x%04"UVXf"\n", start);
8300         }
8301     }
8302 }
8303 #endif
8304
8305 #if 0
8306 bool
8307 S__invlistEQ(pTHX_ SV* const a, SV* const b, bool complement_b)
8308 {
8309     /* Return a boolean as to if the two passed in inversion lists are
8310      * identical.  The final argument, if TRUE, says to take the complement of
8311      * the second inversion list before doing the comparison */
8312
8313     UV* array_a = invlist_array(a);
8314     UV* array_b = invlist_array(b);
8315     UV len_a = _invlist_len(a);
8316     UV len_b = _invlist_len(b);
8317
8318     UV i = 0;               /* current index into the arrays */
8319     bool retval = TRUE;     /* Assume are identical until proven otherwise */
8320
8321     PERL_ARGS_ASSERT__INVLISTEQ;
8322
8323     /* If are to compare 'a' with the complement of b, set it
8324      * up so are looking at b's complement. */
8325     if (complement_b) {
8326
8327         /* The complement of nothing is everything, so <a> would have to have
8328          * just one element, starting at zero (ending at infinity) */
8329         if (len_b == 0) {
8330             return (len_a == 1 && array_a[0] == 0);
8331         }
8332         else if (array_b[0] == 0) {
8333
8334             /* Otherwise, to complement, we invert.  Here, the first element is
8335              * 0, just remove it.  To do this, we just pretend the array starts
8336              * one later, and clear the flag as we don't have to do anything
8337              * else later */
8338
8339             array_b++;
8340             len_b--;
8341             complement_b = FALSE;
8342         }
8343         else {
8344
8345             /* But if the first element is not zero, we unshift a 0 before the
8346              * array.  The data structure reserves a space for that 0 (which
8347              * should be a '1' right now), so physical shifting is unneeded,
8348              * but temporarily change that element to 0.  Before exiting the
8349              * routine, we must restore the element to '1' */
8350             array_b--;
8351             len_b++;
8352             array_b[0] = 0;
8353         }
8354     }
8355
8356     /* Make sure that the lengths are the same, as well as the final element
8357      * before looping through the remainder.  (Thus we test the length, final,
8358      * and first elements right off the bat) */
8359     if (len_a != len_b || array_a[len_a-1] != array_b[len_a-1]) {
8360         retval = FALSE;
8361     }
8362     else for (i = 0; i < len_a - 1; i++) {
8363         if (array_a[i] != array_b[i]) {
8364             retval = FALSE;
8365             break;
8366         }
8367     }
8368
8369     if (complement_b) {
8370         array_b[0] = 1;
8371     }
8372     return retval;
8373 }
8374 #endif
8375
8376 #undef HEADER_LENGTH
8377 #undef INVLIST_INITIAL_LENGTH
8378 #undef TO_INTERNAL_SIZE
8379 #undef FROM_INTERNAL_SIZE
8380 #undef INVLIST_LEN_OFFSET
8381 #undef INVLIST_ZERO_OFFSET
8382 #undef INVLIST_ITER_OFFSET
8383 #undef INVLIST_VERSION_ID
8384 #undef INVLIST_PREVIOUS_INDEX_OFFSET
8385
8386 /* End of inversion list object */
8387
8388 STATIC void
8389 S_parse_lparen_question_flags(pTHX_ struct RExC_state_t *pRExC_state)
8390 {
8391     /* This parses the flags that are in either the '(?foo)' or '(?foo:bar)'
8392      * constructs, and updates RExC_flags with them.  On input, RExC_parse
8393      * should point to the first flag; it is updated on output to point to the
8394      * final ')' or ':'.  There needs to be at least one flag, or this will
8395      * abort */
8396
8397     /* for (?g), (?gc), and (?o) warnings; warning
8398        about (?c) will warn about (?g) -- japhy    */
8399
8400 #define WASTED_O  0x01
8401 #define WASTED_G  0x02
8402 #define WASTED_C  0x04
8403 #define WASTED_GC (0x02|0x04)
8404     I32 wastedflags = 0x00;
8405     U32 posflags = 0, negflags = 0;
8406     U32 *flagsp = &posflags;
8407     char has_charset_modifier = '\0';
8408     regex_charset cs;
8409     bool has_use_defaults = FALSE;
8410     const char* const seqstart = RExC_parse - 1; /* Point to the '?' */
8411
8412     PERL_ARGS_ASSERT_PARSE_LPAREN_QUESTION_FLAGS;
8413
8414     /* '^' as an initial flag sets certain defaults */
8415     if (UCHARAT(RExC_parse) == '^') {
8416         RExC_parse++;
8417         has_use_defaults = TRUE;
8418         STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
8419         set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
8420                                         ? REGEX_UNICODE_CHARSET
8421                                         : REGEX_DEPENDS_CHARSET);
8422     }
8423
8424     cs = get_regex_charset(RExC_flags);
8425     if (cs == REGEX_DEPENDS_CHARSET
8426         && (RExC_utf8 || RExC_uni_semantics))
8427     {
8428         cs = REGEX_UNICODE_CHARSET;
8429     }
8430
8431     while (*RExC_parse) {
8432         /* && strchr("iogcmsx", *RExC_parse) */
8433         /* (?g), (?gc) and (?o) are useless here
8434            and must be globally applied -- japhy */
8435         switch (*RExC_parse) {
8436
8437             /* Code for the imsx flags */
8438             CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
8439
8440             case LOCALE_PAT_MOD:
8441                 if (has_charset_modifier) {
8442                     goto excess_modifier;
8443                 }
8444                 else if (flagsp == &negflags) {
8445                     goto neg_modifier;
8446                 }
8447                 cs = REGEX_LOCALE_CHARSET;
8448                 has_charset_modifier = LOCALE_PAT_MOD;
8449                 RExC_contains_locale = 1;
8450                 break;
8451             case UNICODE_PAT_MOD:
8452                 if (has_charset_modifier) {
8453                     goto excess_modifier;
8454                 }
8455                 else if (flagsp == &negflags) {
8456                     goto neg_modifier;
8457                 }
8458                 cs = REGEX_UNICODE_CHARSET;
8459                 has_charset_modifier = UNICODE_PAT_MOD;
8460                 break;
8461             case ASCII_RESTRICT_PAT_MOD:
8462                 if (flagsp == &negflags) {
8463                     goto neg_modifier;
8464                 }
8465                 if (has_charset_modifier) {
8466                     if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
8467                         goto excess_modifier;
8468                     }
8469                     /* Doubled modifier implies more restricted */
8470                     cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
8471                 }
8472                 else {
8473                     cs = REGEX_ASCII_RESTRICTED_CHARSET;
8474                 }
8475                 has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
8476                 break;
8477             case DEPENDS_PAT_MOD:
8478                 if (has_use_defaults) {
8479                     goto fail_modifiers;
8480                 }
8481                 else if (flagsp == &negflags) {
8482                     goto neg_modifier;
8483                 }
8484                 else if (has_charset_modifier) {
8485                     goto excess_modifier;
8486                 }
8487
8488                 /* The dual charset means unicode semantics if the
8489                  * pattern (or target, not known until runtime) are
8490                  * utf8, or something in the pattern indicates unicode
8491                  * semantics */
8492                 cs = (RExC_utf8 || RExC_uni_semantics)
8493                      ? REGEX_UNICODE_CHARSET
8494                      : REGEX_DEPENDS_CHARSET;
8495                 has_charset_modifier = DEPENDS_PAT_MOD;
8496                 break;
8497             excess_modifier:
8498                 RExC_parse++;
8499                 if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
8500                     vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
8501                 }
8502                 else if (has_charset_modifier == *(RExC_parse - 1)) {
8503                     vFAIL2("Regexp modifier \"%c\" may not appear twice", *(RExC_parse - 1));
8504                 }
8505                 else {
8506                     vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
8507                 }
8508                 /*NOTREACHED*/
8509             neg_modifier:
8510                 RExC_parse++;
8511                 vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", *(RExC_parse - 1));
8512                 /*NOTREACHED*/
8513             case ONCE_PAT_MOD: /* 'o' */
8514             case GLOBAL_PAT_MOD: /* 'g' */
8515                 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
8516                     const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
8517                     if (! (wastedflags & wflagbit) ) {
8518                         wastedflags |= wflagbit;
8519                         vWARN5(
8520                             RExC_parse + 1,
8521                             "Useless (%s%c) - %suse /%c modifier",
8522                             flagsp == &negflags ? "?-" : "?",
8523                             *RExC_parse,
8524                             flagsp == &negflags ? "don't " : "",
8525                             *RExC_parse
8526                         );
8527                     }
8528                 }
8529                 break;
8530
8531             case CONTINUE_PAT_MOD: /* 'c' */
8532                 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
8533                     if (! (wastedflags & WASTED_C) ) {
8534                         wastedflags |= WASTED_GC;
8535                         vWARN3(
8536                             RExC_parse + 1,
8537                             "Useless (%sc) - %suse /gc modifier",
8538                             flagsp == &negflags ? "?-" : "?",
8539                             flagsp == &negflags ? "don't " : ""
8540                         );
8541                     }
8542                 }
8543                 break;
8544             case KEEPCOPY_PAT_MOD: /* 'p' */
8545                 if (flagsp == &negflags) {
8546                     if (SIZE_ONLY)
8547                         ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
8548                 } else {
8549                     *flagsp |= RXf_PMf_KEEPCOPY;
8550                 }
8551                 break;
8552             case '-':
8553                 /* A flag is a default iff it is following a minus, so
8554                  * if there is a minus, it means will be trying to
8555                  * re-specify a default which is an error */
8556                 if (has_use_defaults || flagsp == &negflags) {
8557                     goto fail_modifiers;
8558                 }
8559                 flagsp = &negflags;
8560                 wastedflags = 0;  /* reset so (?g-c) warns twice */
8561                 break;
8562             case ':':
8563             case ')':
8564                 RExC_flags |= posflags;
8565                 RExC_flags &= ~negflags;
8566                 set_regex_charset(&RExC_flags, cs);
8567                 return;
8568                 /*NOTREACHED*/
8569             default:
8570             fail_modifiers:
8571                 RExC_parse++;
8572                 vFAIL3("Sequence (%.*s...) not recognized",
8573                        RExC_parse-seqstart, seqstart);
8574                 /*NOTREACHED*/
8575         }
8576
8577         ++RExC_parse;
8578     }
8579 }
8580
8581 /*
8582  - reg - regular expression, i.e. main body or parenthesized thing
8583  *
8584  * Caller must absorb opening parenthesis.
8585  *
8586  * Combining parenthesis handling with the base level of regular expression
8587  * is a trifle forced, but the need to tie the tails of the branches to what
8588  * follows makes it hard to avoid.
8589  */
8590 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
8591 #ifdef DEBUGGING
8592 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
8593 #else
8594 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
8595 #endif
8596
8597 /* Returns NULL, setting *flagp to TRYAGAIN at the end of (?) that only sets
8598    flags. Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan
8599    needs to be restarted.
8600    Otherwise would only return NULL if regbranch() returns NULL, which
8601    cannot happen.  */
8602 STATIC regnode *
8603 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
8604     /* paren: Parenthesized? 0=top; 1,2=inside '(': changed to letter.
8605      * 2 is like 1, but indicates that nextchar() has been called to advance
8606      * RExC_parse beyond the '('.  Things like '(?' are indivisible tokens, and
8607      * this flag alerts us to the need to check for that */
8608 {
8609     dVAR;
8610     regnode *ret;               /* Will be the head of the group. */
8611     regnode *br;
8612     regnode *lastbr;
8613     regnode *ender = NULL;
8614     I32 parno = 0;
8615     I32 flags;
8616     U32 oregflags = RExC_flags;
8617     bool have_branch = 0;
8618     bool is_open = 0;
8619     I32 freeze_paren = 0;
8620     I32 after_freeze = 0;
8621
8622     char * parse_start = RExC_parse; /* MJD */
8623     char * const oregcomp_parse = RExC_parse;
8624
8625     GET_RE_DEBUG_FLAGS_DECL;
8626
8627     PERL_ARGS_ASSERT_REG;
8628     DEBUG_PARSE("reg ");
8629
8630     *flagp = 0;                         /* Tentatively. */
8631
8632
8633     /* Make an OPEN node, if parenthesized. */
8634     if (paren) {
8635
8636         /* Under /x, space and comments can be gobbled up between the '(' and
8637          * here (if paren ==2).  The forms '(*VERB' and '(?...' disallow such
8638          * intervening space, as the sequence is a token, and a token should be
8639          * indivisible */
8640         bool has_intervening_patws = paren == 2 && *(RExC_parse - 1) != '(';
8641
8642         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
8643             char *start_verb = RExC_parse;
8644             STRLEN verb_len = 0;
8645             char *start_arg = NULL;
8646             unsigned char op = 0;
8647             int argok = 1;
8648             int internal_argval = 0; /* internal_argval is only useful if !argok */
8649
8650             if (has_intervening_patws && SIZE_ONLY) {
8651                 ckWARNregdep(RExC_parse + 1, "In '(*VERB...)', splitting the initial '(*' is deprecated");
8652             }
8653             while ( *RExC_parse && *RExC_parse != ')' ) {
8654                 if ( *RExC_parse == ':' ) {
8655                     start_arg = RExC_parse + 1;
8656                     break;
8657                 }
8658                 RExC_parse++;
8659             }
8660             ++start_verb;
8661             verb_len = RExC_parse - start_verb;
8662             if ( start_arg ) {
8663                 RExC_parse++;
8664                 while ( *RExC_parse && *RExC_parse != ')' ) 
8665                     RExC_parse++;
8666                 if ( *RExC_parse != ')' ) 
8667                     vFAIL("Unterminated verb pattern argument");
8668                 if ( RExC_parse == start_arg )
8669                     start_arg = NULL;
8670             } else {
8671                 if ( *RExC_parse != ')' )
8672                     vFAIL("Unterminated verb pattern");
8673             }
8674             
8675             switch ( *start_verb ) {
8676             case 'A':  /* (*ACCEPT) */
8677                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
8678                     op = ACCEPT;
8679                     internal_argval = RExC_nestroot;
8680                 }
8681                 break;
8682             case 'C':  /* (*COMMIT) */
8683                 if ( memEQs(start_verb,verb_len,"COMMIT") )
8684                     op = COMMIT;
8685                 break;
8686             case 'F':  /* (*FAIL) */
8687                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
8688                     op = OPFAIL;
8689                     argok = 0;
8690                 }
8691                 break;
8692             case ':':  /* (*:NAME) */
8693             case 'M':  /* (*MARK:NAME) */
8694                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
8695                     op = MARKPOINT;
8696                     argok = -1;
8697                 }
8698                 break;
8699             case 'P':  /* (*PRUNE) */
8700                 if ( memEQs(start_verb,verb_len,"PRUNE") )
8701                     op = PRUNE;
8702                 break;
8703             case 'S':   /* (*SKIP) */  
8704                 if ( memEQs(start_verb,verb_len,"SKIP") ) 
8705                     op = SKIP;
8706                 break;
8707             case 'T':  /* (*THEN) */
8708                 /* [19:06] <TimToady> :: is then */
8709                 if ( memEQs(start_verb,verb_len,"THEN") ) {
8710                     op = CUTGROUP;
8711                     RExC_seen |= REG_SEEN_CUTGROUP;
8712                 }
8713                 break;
8714             }
8715             if ( ! op ) {
8716                 RExC_parse++;
8717                 vFAIL3("Unknown verb pattern '%.*s'",
8718                     verb_len, start_verb);
8719             }
8720             if ( argok ) {
8721                 if ( start_arg && internal_argval ) {
8722                     vFAIL3("Verb pattern '%.*s' may not have an argument",
8723                         verb_len, start_verb); 
8724                 } else if ( argok < 0 && !start_arg ) {
8725                     vFAIL3("Verb pattern '%.*s' has a mandatory argument",
8726                         verb_len, start_verb);    
8727                 } else {
8728                     ret = reganode(pRExC_state, op, internal_argval);
8729                     if ( ! internal_argval && ! SIZE_ONLY ) {
8730                         if (start_arg) {
8731                             SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
8732                             ARG(ret) = add_data( pRExC_state, 1, "S" );
8733                             RExC_rxi->data->data[ARG(ret)]=(void*)sv;
8734                             ret->flags = 0;
8735                         } else {
8736                             ret->flags = 1; 
8737                         }
8738                     }               
8739                 }
8740                 if (!internal_argval)
8741                     RExC_seen |= REG_SEEN_VERBARG;
8742             } else if ( start_arg ) {
8743                 vFAIL3("Verb pattern '%.*s' may not have an argument",
8744                         verb_len, start_verb);    
8745             } else {
8746                 ret = reg_node(pRExC_state, op);
8747             }
8748             nextchar(pRExC_state);
8749             return ret;
8750         } else 
8751         if (*RExC_parse == '?') { /* (?...) */
8752             bool is_logical = 0;
8753             const char * const seqstart = RExC_parse;
8754             if (has_intervening_patws && SIZE_ONLY) {
8755                 ckWARNregdep(RExC_parse + 1, "In '(?...)', splitting the initial '(?' is deprecated");
8756             }
8757
8758             RExC_parse++;
8759             paren = *RExC_parse++;
8760             ret = NULL;                 /* For look-ahead/behind. */
8761             switch (paren) {
8762
8763             case 'P':   /* (?P...) variants for those used to PCRE/Python */
8764                 paren = *RExC_parse++;
8765                 if ( paren == '<')         /* (?P<...>) named capture */
8766                     goto named_capture;
8767                 else if (paren == '>') {   /* (?P>name) named recursion */
8768                     goto named_recursion;
8769                 }
8770                 else if (paren == '=') {   /* (?P=...)  named backref */
8771                     /* this pretty much dupes the code for \k<NAME> in regatom(), if
8772                        you change this make sure you change that */
8773                     char* name_start = RExC_parse;
8774                     U32 num = 0;
8775                     SV *sv_dat = reg_scan_name(pRExC_state,
8776                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8777                     if (RExC_parse == name_start || *RExC_parse != ')')
8778                         vFAIL2("Sequence %.3s... not terminated",parse_start);
8779
8780                     if (!SIZE_ONLY) {
8781                         num = add_data( pRExC_state, 1, "S" );
8782                         RExC_rxi->data->data[num]=(void*)sv_dat;
8783                         SvREFCNT_inc_simple_void(sv_dat);
8784                     }
8785                     RExC_sawback = 1;
8786                     ret = reganode(pRExC_state,
8787                                    ((! FOLD)
8788                                      ? NREF
8789                                      : (ASCII_FOLD_RESTRICTED)
8790                                        ? NREFFA
8791                                        : (AT_LEAST_UNI_SEMANTICS)
8792                                          ? NREFFU
8793                                          : (LOC)
8794                                            ? NREFFL
8795                                            : NREFF),
8796                                     num);
8797                     *flagp |= HASWIDTH;
8798
8799                     Set_Node_Offset(ret, parse_start+1);
8800                     Set_Node_Cur_Length(ret); /* MJD */
8801
8802                     nextchar(pRExC_state);
8803                     return ret;
8804                 }
8805                 RExC_parse++;
8806                 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8807                 /*NOTREACHED*/
8808             case '<':           /* (?<...) */
8809                 if (*RExC_parse == '!')
8810                     paren = ',';
8811                 else if (*RExC_parse != '=') 
8812               named_capture:
8813                 {               /* (?<...>) */
8814                     char *name_start;
8815                     SV *svname;
8816                     paren= '>';
8817             case '\'':          /* (?'...') */
8818                     name_start= RExC_parse;
8819                     svname = reg_scan_name(pRExC_state,
8820                         SIZE_ONLY ?  /* reverse test from the others */
8821                         REG_RSN_RETURN_NAME : 
8822                         REG_RSN_RETURN_NULL);
8823                     if (RExC_parse == name_start) {
8824                         RExC_parse++;
8825                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8826                         /*NOTREACHED*/
8827                     }
8828                     if (*RExC_parse != paren)
8829                         vFAIL2("Sequence (?%c... not terminated",
8830                             paren=='>' ? '<' : paren);
8831                     if (SIZE_ONLY) {
8832                         HE *he_str;
8833                         SV *sv_dat = NULL;
8834                         if (!svname) /* shouldn't happen */
8835                             Perl_croak(aTHX_
8836                                 "panic: reg_scan_name returned NULL");
8837                         if (!RExC_paren_names) {
8838                             RExC_paren_names= newHV();
8839                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
8840 #ifdef DEBUGGING
8841                             RExC_paren_name_list= newAV();
8842                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
8843 #endif
8844                         }
8845                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
8846                         if ( he_str )
8847                             sv_dat = HeVAL(he_str);
8848                         if ( ! sv_dat ) {
8849                             /* croak baby croak */
8850                             Perl_croak(aTHX_
8851                                 "panic: paren_name hash element allocation failed");
8852                         } else if ( SvPOK(sv_dat) ) {
8853                             /* (?|...) can mean we have dupes so scan to check
8854                                its already been stored. Maybe a flag indicating
8855                                we are inside such a construct would be useful,
8856                                but the arrays are likely to be quite small, so
8857                                for now we punt -- dmq */
8858                             IV count = SvIV(sv_dat);
8859                             I32 *pv = (I32*)SvPVX(sv_dat);
8860                             IV i;
8861                             for ( i = 0 ; i < count ; i++ ) {
8862                                 if ( pv[i] == RExC_npar ) {
8863                                     count = 0;
8864                                     break;
8865                                 }
8866                             }
8867                             if ( count ) {
8868                                 pv = (I32*)SvGROW(sv_dat, SvCUR(sv_dat) + sizeof(I32)+1);
8869                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
8870                                 pv[count] = RExC_npar;
8871                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
8872                             }
8873                         } else {
8874                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
8875                             sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
8876                             SvIOK_on(sv_dat);
8877                             SvIV_set(sv_dat, 1);
8878                         }
8879 #ifdef DEBUGGING
8880                         /* Yes this does cause a memory leak in debugging Perls */
8881                         if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
8882                             SvREFCNT_dec_NN(svname);
8883 #endif
8884
8885                         /*sv_dump(sv_dat);*/
8886                     }
8887                     nextchar(pRExC_state);
8888                     paren = 1;
8889                     goto capturing_parens;
8890                 }
8891                 RExC_seen |= REG_SEEN_LOOKBEHIND;
8892                 RExC_in_lookbehind++;
8893                 RExC_parse++;
8894             case '=':           /* (?=...) */
8895                 RExC_seen_zerolen++;
8896                 break;
8897             case '!':           /* (?!...) */
8898                 RExC_seen_zerolen++;
8899                 if (*RExC_parse == ')') {
8900                     ret=reg_node(pRExC_state, OPFAIL);
8901                     nextchar(pRExC_state);
8902                     return ret;
8903                 }
8904                 break;
8905             case '|':           /* (?|...) */
8906                 /* branch reset, behave like a (?:...) except that
8907                    buffers in alternations share the same numbers */
8908                 paren = ':'; 
8909                 after_freeze = freeze_paren = RExC_npar;
8910                 break;
8911             case ':':           /* (?:...) */
8912             case '>':           /* (?>...) */
8913                 break;
8914             case '$':           /* (?$...) */
8915             case '@':           /* (?@...) */
8916                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
8917                 break;
8918             case '#':           /* (?#...) */
8919                 /* XXX As soon as we disallow separating the '?' and '*' (by
8920                  * spaces or (?#...) comment), it is believed that this case
8921                  * will be unreachable and can be removed.  See
8922                  * [perl #117327] */
8923                 while (*RExC_parse && *RExC_parse != ')')
8924                     RExC_parse++;
8925                 if (*RExC_parse != ')')
8926                     FAIL("Sequence (?#... not terminated");
8927                 nextchar(pRExC_state);
8928                 *flagp = TRYAGAIN;
8929                 return NULL;
8930             case '0' :           /* (?0) */
8931             case 'R' :           /* (?R) */
8932                 if (*RExC_parse != ')')
8933                     FAIL("Sequence (?R) not terminated");
8934                 ret = reg_node(pRExC_state, GOSTART);
8935                 *flagp |= POSTPONED;
8936                 nextchar(pRExC_state);
8937                 return ret;
8938                 /*notreached*/
8939             { /* named and numeric backreferences */
8940                 I32 num;
8941             case '&':            /* (?&NAME) */
8942                 parse_start = RExC_parse - 1;
8943               named_recursion:
8944                 {
8945                     SV *sv_dat = reg_scan_name(pRExC_state,
8946                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8947                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
8948                 }
8949                 goto gen_recurse_regop;
8950                 assert(0); /* NOT REACHED */
8951             case '+':
8952                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
8953                     RExC_parse++;
8954                     vFAIL("Illegal pattern");
8955                 }
8956                 goto parse_recursion;
8957                 /* NOT REACHED*/
8958             case '-': /* (?-1) */
8959                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
8960                     RExC_parse--; /* rewind to let it be handled later */
8961                     goto parse_flags;
8962                 } 
8963                 /*FALLTHROUGH */
8964             case '1': case '2': case '3': case '4': /* (?1) */
8965             case '5': case '6': case '7': case '8': case '9':
8966                 RExC_parse--;
8967               parse_recursion:
8968                 num = atoi(RExC_parse);
8969                 parse_start = RExC_parse - 1; /* MJD */
8970                 if (*RExC_parse == '-')
8971                     RExC_parse++;
8972                 while (isDIGIT(*RExC_parse))
8973                         RExC_parse++;
8974                 if (*RExC_parse!=')') 
8975                     vFAIL("Expecting close bracket");
8976
8977               gen_recurse_regop:
8978                 if ( paren == '-' ) {
8979                     /*
8980                     Diagram of capture buffer numbering.
8981                     Top line is the normal capture buffer numbers
8982                     Bottom line is the negative indexing as from
8983                     the X (the (?-2))
8984
8985                     +   1 2    3 4 5 X          6 7
8986                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
8987                     -   5 4    3 2 1 X          x x
8988
8989                     */
8990                     num = RExC_npar + num;
8991                     if (num < 1)  {
8992                         RExC_parse++;
8993                         vFAIL("Reference to nonexistent group");
8994                     }
8995                 } else if ( paren == '+' ) {
8996                     num = RExC_npar + num - 1;
8997                 }
8998
8999                 ret = reganode(pRExC_state, GOSUB, num);
9000                 if (!SIZE_ONLY) {
9001                     if (num > (I32)RExC_rx->nparens) {
9002                         RExC_parse++;
9003                         vFAIL("Reference to nonexistent group");
9004                     }
9005                     ARG2L_SET( ret, RExC_recurse_count++);
9006                     RExC_emit++;
9007                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
9008                         "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
9009                 } else {
9010                     RExC_size++;
9011                 }
9012                 RExC_seen |= REG_SEEN_RECURSE;
9013                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
9014                 Set_Node_Offset(ret, parse_start); /* MJD */
9015
9016                 *flagp |= POSTPONED;
9017                 nextchar(pRExC_state);
9018                 return ret;
9019             } /* named and numeric backreferences */
9020             assert(0); /* NOT REACHED */
9021
9022             case '?':           /* (??...) */
9023                 is_logical = 1;
9024                 if (*RExC_parse != '{') {
9025                     RExC_parse++;
9026                     vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
9027                     /*NOTREACHED*/
9028                 }
9029                 *flagp |= POSTPONED;
9030                 paren = *RExC_parse++;
9031                 /* FALL THROUGH */
9032             case '{':           /* (?{...}) */
9033             {
9034                 U32 n = 0;
9035                 struct reg_code_block *cb;
9036
9037                 RExC_seen_zerolen++;
9038
9039                 if (   !pRExC_state->num_code_blocks
9040                     || pRExC_state->code_index >= pRExC_state->num_code_blocks
9041                     || pRExC_state->code_blocks[pRExC_state->code_index].start
9042                         != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
9043                             - RExC_start)
9044                 ) {
9045                     if (RExC_pm_flags & PMf_USE_RE_EVAL)
9046                         FAIL("panic: Sequence (?{...}): no code block found\n");
9047                     FAIL("Eval-group not allowed at runtime, use re 'eval'");
9048                 }
9049                 /* this is a pre-compiled code block (?{...}) */
9050                 cb = &pRExC_state->code_blocks[pRExC_state->code_index];
9051                 RExC_parse = RExC_start + cb->end;
9052                 if (!SIZE_ONLY) {
9053                     OP *o = cb->block;
9054                     if (cb->src_regex) {
9055                         n = add_data(pRExC_state, 2, "rl");
9056                         RExC_rxi->data->data[n] =
9057                             (void*)SvREFCNT_inc((SV*)cb->src_regex);
9058                         RExC_rxi->data->data[n+1] = (void*)o;
9059                     }
9060                     else {
9061                         n = add_data(pRExC_state, 1,
9062                                (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l");
9063                         RExC_rxi->data->data[n] = (void*)o;
9064                     }
9065                 }
9066                 pRExC_state->code_index++;
9067                 nextchar(pRExC_state);
9068
9069                 if (is_logical) {
9070                     regnode *eval;
9071                     ret = reg_node(pRExC_state, LOGICAL);
9072                     eval = reganode(pRExC_state, EVAL, n);
9073                     if (!SIZE_ONLY) {
9074                         ret->flags = 2;
9075                         /* for later propagation into (??{}) return value */
9076                         eval->flags = (U8) (RExC_flags & RXf_PMf_COMPILETIME);
9077                     }
9078                     REGTAIL(pRExC_state, ret, eval);
9079                     /* deal with the length of this later - MJD */
9080                     return ret;
9081                 }
9082                 ret = reganode(pRExC_state, EVAL, n);
9083                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
9084                 Set_Node_Offset(ret, parse_start);
9085                 return ret;
9086             }
9087             case '(':           /* (?(?{...})...) and (?(?=...)...) */
9088             {
9089                 int is_define= 0;
9090                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
9091                     if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
9092                         || RExC_parse[1] == '<'
9093                         || RExC_parse[1] == '{') { /* Lookahead or eval. */
9094                         I32 flag;
9095                         regnode *tail;
9096
9097                         ret = reg_node(pRExC_state, LOGICAL);
9098                         if (!SIZE_ONLY)
9099                             ret->flags = 1;
9100                         
9101                         tail = reg(pRExC_state, 1, &flag, depth+1);
9102                         if (flag & RESTART_UTF8) {
9103                             *flagp = RESTART_UTF8;
9104                             return NULL;
9105                         }
9106                         REGTAIL(pRExC_state, ret, tail);
9107                         goto insert_if;
9108                     }
9109                 }
9110                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
9111                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
9112                 {
9113                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
9114                     char *name_start= RExC_parse++;
9115                     U32 num = 0;
9116                     SV *sv_dat=reg_scan_name(pRExC_state,
9117                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
9118                     if (RExC_parse == name_start || *RExC_parse != ch)
9119                         vFAIL2("Sequence (?(%c... not terminated",
9120                             (ch == '>' ? '<' : ch));
9121                     RExC_parse++;
9122                     if (!SIZE_ONLY) {
9123                         num = add_data( pRExC_state, 1, "S" );
9124                         RExC_rxi->data->data[num]=(void*)sv_dat;
9125                         SvREFCNT_inc_simple_void(sv_dat);
9126                     }
9127                     ret = reganode(pRExC_state,NGROUPP,num);
9128                     goto insert_if_check_paren;
9129                 }
9130                 else if (RExC_parse[0] == 'D' &&
9131                          RExC_parse[1] == 'E' &&
9132                          RExC_parse[2] == 'F' &&
9133                          RExC_parse[3] == 'I' &&
9134                          RExC_parse[4] == 'N' &&
9135                          RExC_parse[5] == 'E')
9136                 {
9137                     ret = reganode(pRExC_state,DEFINEP,0);
9138                     RExC_parse +=6 ;
9139                     is_define = 1;
9140                     goto insert_if_check_paren;
9141                 }
9142                 else if (RExC_parse[0] == 'R') {
9143                     RExC_parse++;
9144                     parno = 0;
9145                     if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
9146                         parno = atoi(RExC_parse++);
9147                         while (isDIGIT(*RExC_parse))
9148                             RExC_parse++;
9149                     } else if (RExC_parse[0] == '&') {
9150                         SV *sv_dat;
9151                         RExC_parse++;
9152                         sv_dat = reg_scan_name(pRExC_state,
9153                             SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
9154                         parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
9155                     }
9156                     ret = reganode(pRExC_state,INSUBP,parno); 
9157                     goto insert_if_check_paren;
9158                 }
9159                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
9160                     /* (?(1)...) */
9161                     char c;
9162                     parno = atoi(RExC_parse++);
9163
9164                     while (isDIGIT(*RExC_parse))
9165                         RExC_parse++;
9166                     ret = reganode(pRExC_state, GROUPP, parno);
9167
9168                  insert_if_check_paren:
9169                     if ((c = *nextchar(pRExC_state)) != ')')
9170                         vFAIL("Switch condition not recognized");
9171                   insert_if:
9172                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
9173                     br = regbranch(pRExC_state, &flags, 1,depth+1);
9174                     if (br == NULL) {
9175                         if (flags & RESTART_UTF8) {
9176                             *flagp = RESTART_UTF8;
9177                             return NULL;
9178                         }
9179                         FAIL2("panic: regbranch returned NULL, flags=%#X",
9180                               flags);
9181                     } else
9182                         REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
9183                     c = *nextchar(pRExC_state);
9184                     if (flags&HASWIDTH)
9185                         *flagp |= HASWIDTH;
9186                     if (c == '|') {
9187                         if (is_define) 
9188                             vFAIL("(?(DEFINE)....) does not allow branches");
9189                         lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
9190                         if (!regbranch(pRExC_state, &flags, 1,depth+1)) {
9191                             if (flags & RESTART_UTF8) {
9192                                 *flagp = RESTART_UTF8;
9193                                 return NULL;
9194                             }
9195                             FAIL2("panic: regbranch returned NULL, flags=%#X",
9196                                   flags);
9197                         }
9198                         REGTAIL(pRExC_state, ret, lastbr);
9199                         if (flags&HASWIDTH)
9200                             *flagp |= HASWIDTH;
9201                         c = *nextchar(pRExC_state);
9202                     }
9203                     else
9204                         lastbr = NULL;
9205                     if (c != ')')
9206                         vFAIL("Switch (?(condition)... contains too many branches");
9207                     ender = reg_node(pRExC_state, TAIL);
9208                     REGTAIL(pRExC_state, br, ender);
9209                     if (lastbr) {
9210                         REGTAIL(pRExC_state, lastbr, ender);
9211                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
9212                     }
9213                     else
9214                         REGTAIL(pRExC_state, ret, ender);
9215                     RExC_size++; /* XXX WHY do we need this?!!
9216                                     For large programs it seems to be required
9217                                     but I can't figure out why. -- dmq*/
9218                     return ret;
9219                 }
9220                 else {
9221                     vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
9222                 }
9223             }
9224             case '[':           /* (?[ ... ]) */
9225                 return handle_regex_sets(pRExC_state, NULL, flagp, depth,
9226                                          oregcomp_parse);
9227             case 0:
9228                 RExC_parse--; /* for vFAIL to print correctly */
9229                 vFAIL("Sequence (? incomplete");
9230                 break;
9231             default: /* e.g., (?i) */
9232                 --RExC_parse;
9233               parse_flags:
9234                 parse_lparen_question_flags(pRExC_state);
9235                 if (UCHARAT(RExC_parse) != ':') {
9236                     nextchar(pRExC_state);
9237                     *flagp = TRYAGAIN;
9238                     return NULL;
9239                 }
9240                 paren = ':';
9241                 nextchar(pRExC_state);
9242                 ret = NULL;
9243                 goto parse_rest;
9244             } /* end switch */
9245         }
9246         else {                  /* (...) */
9247           capturing_parens:
9248             parno = RExC_npar;
9249             RExC_npar++;
9250             
9251             ret = reganode(pRExC_state, OPEN, parno);
9252             if (!SIZE_ONLY ){
9253                 if (!RExC_nestroot) 
9254                     RExC_nestroot = parno;
9255                 if (RExC_seen & REG_SEEN_RECURSE
9256                     && !RExC_open_parens[parno-1])
9257                 {
9258                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
9259                         "Setting open paren #%"IVdf" to %d\n", 
9260                         (IV)parno, REG_NODE_NUM(ret)));
9261                     RExC_open_parens[parno-1]= ret;
9262                 }
9263             }
9264             Set_Node_Length(ret, 1); /* MJD */
9265             Set_Node_Offset(ret, RExC_parse); /* MJD */
9266             is_open = 1;
9267         }
9268     }
9269     else                        /* ! paren */
9270         ret = NULL;
9271    
9272    parse_rest:
9273     /* Pick up the branches, linking them together. */
9274     parse_start = RExC_parse;   /* MJD */
9275     br = regbranch(pRExC_state, &flags, 1,depth+1);
9276
9277     /*     branch_len = (paren != 0); */
9278
9279     if (br == NULL) {
9280         if (flags & RESTART_UTF8) {
9281             *flagp = RESTART_UTF8;
9282             return NULL;
9283         }
9284         FAIL2("panic: regbranch returned NULL, flags=%#X", flags);
9285     }
9286     if (*RExC_parse == '|') {
9287         if (!SIZE_ONLY && RExC_extralen) {
9288             reginsert(pRExC_state, BRANCHJ, br, depth+1);
9289         }
9290         else {                  /* MJD */
9291             reginsert(pRExC_state, BRANCH, br, depth+1);
9292             Set_Node_Length(br, paren != 0);
9293             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
9294         }
9295         have_branch = 1;
9296         if (SIZE_ONLY)
9297             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
9298     }
9299     else if (paren == ':') {
9300         *flagp |= flags&SIMPLE;
9301     }
9302     if (is_open) {                              /* Starts with OPEN. */
9303         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
9304     }
9305     else if (paren != '?')              /* Not Conditional */
9306         ret = br;
9307     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
9308     lastbr = br;
9309     while (*RExC_parse == '|') {
9310         if (!SIZE_ONLY && RExC_extralen) {
9311             ender = reganode(pRExC_state, LONGJMP,0);
9312             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
9313         }
9314         if (SIZE_ONLY)
9315             RExC_extralen += 2;         /* Account for LONGJMP. */
9316         nextchar(pRExC_state);
9317         if (freeze_paren) {
9318             if (RExC_npar > after_freeze)
9319                 after_freeze = RExC_npar;
9320             RExC_npar = freeze_paren;       
9321         }
9322         br = regbranch(pRExC_state, &flags, 0, depth+1);
9323
9324         if (br == NULL) {
9325             if (flags & RESTART_UTF8) {
9326                 *flagp = RESTART_UTF8;
9327                 return NULL;
9328             }
9329             FAIL2("panic: regbranch returned NULL, flags=%#X", flags);
9330         }
9331         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
9332         lastbr = br;
9333         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
9334     }
9335
9336     if (have_branch || paren != ':') {
9337         /* Make a closing node, and hook it on the end. */
9338         switch (paren) {
9339         case ':':
9340             ender = reg_node(pRExC_state, TAIL);
9341             break;
9342         case 1: case 2:
9343             ender = reganode(pRExC_state, CLOSE, parno);
9344             if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
9345                 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
9346                         "Setting close paren #%"IVdf" to %d\n", 
9347                         (IV)parno, REG_NODE_NUM(ender)));
9348                 RExC_close_parens[parno-1]= ender;
9349                 if (RExC_nestroot == parno) 
9350                     RExC_nestroot = 0;
9351             }       
9352             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
9353             Set_Node_Length(ender,1); /* MJD */
9354             break;
9355         case '<':
9356         case ',':
9357         case '=':
9358         case '!':
9359             *flagp &= ~HASWIDTH;
9360             /* FALL THROUGH */
9361         case '>':
9362             ender = reg_node(pRExC_state, SUCCEED);
9363             break;
9364         case 0:
9365             ender = reg_node(pRExC_state, END);
9366             if (!SIZE_ONLY) {
9367                 assert(!RExC_opend); /* there can only be one! */
9368                 RExC_opend = ender;
9369             }
9370             break;
9371         }
9372         DEBUG_PARSE_r(if (!SIZE_ONLY) {
9373             SV * const mysv_val1=sv_newmortal();
9374             SV * const mysv_val2=sv_newmortal();
9375             DEBUG_PARSE_MSG("lsbr");
9376             regprop(RExC_rx, mysv_val1, lastbr);
9377             regprop(RExC_rx, mysv_val2, ender);
9378             PerlIO_printf(Perl_debug_log, "~ tying lastbr %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
9379                           SvPV_nolen_const(mysv_val1),
9380                           (IV)REG_NODE_NUM(lastbr),
9381                           SvPV_nolen_const(mysv_val2),
9382                           (IV)REG_NODE_NUM(ender),
9383                           (IV)(ender - lastbr)
9384             );
9385         });
9386         REGTAIL(pRExC_state, lastbr, ender);
9387
9388         if (have_branch && !SIZE_ONLY) {
9389             char is_nothing= 1;
9390             if (depth==1)
9391                 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
9392
9393             /* Hook the tails of the branches to the closing node. */
9394             for (br = ret; br; br = regnext(br)) {
9395                 const U8 op = PL_regkind[OP(br)];
9396                 if (op == BRANCH) {
9397                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
9398                     if (OP(NEXTOPER(br)) != NOTHING || regnext(NEXTOPER(br)) != ender)
9399                         is_nothing= 0;
9400                 }
9401                 else if (op == BRANCHJ) {
9402                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
9403                     /* for now we always disable this optimisation * /
9404                     if (OP(NEXTOPER(NEXTOPER(br))) != NOTHING || regnext(NEXTOPER(NEXTOPER(br))) != ender)
9405                     */
9406                         is_nothing= 0;
9407                 }
9408             }
9409             if (is_nothing) {
9410                 br= PL_regkind[OP(ret)] != BRANCH ? regnext(ret) : ret;
9411                 DEBUG_PARSE_r(if (!SIZE_ONLY) {
9412                     SV * const mysv_val1=sv_newmortal();
9413                     SV * const mysv_val2=sv_newmortal();
9414                     DEBUG_PARSE_MSG("NADA");
9415                     regprop(RExC_rx, mysv_val1, ret);
9416                     regprop(RExC_rx, mysv_val2, ender);
9417                     PerlIO_printf(Perl_debug_log, "~ converting ret %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
9418                                   SvPV_nolen_const(mysv_val1),
9419                                   (IV)REG_NODE_NUM(ret),
9420                                   SvPV_nolen_const(mysv_val2),
9421                                   (IV)REG_NODE_NUM(ender),
9422                                   (IV)(ender - ret)
9423                     );
9424                 });
9425                 OP(br)= NOTHING;
9426                 if (OP(ender) == TAIL) {
9427                     NEXT_OFF(br)= 0;
9428                     RExC_emit= br + 1;
9429                 } else {
9430                     regnode *opt;
9431                     for ( opt= br + 1; opt < ender ; opt++ )
9432                         OP(opt)= OPTIMIZED;
9433                     NEXT_OFF(br)= ender - br;
9434                 }
9435             }
9436         }
9437     }
9438
9439     {
9440         const char *p;
9441         static const char parens[] = "=!<,>";
9442
9443         if (paren && (p = strchr(parens, paren))) {
9444             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
9445             int flag = (p - parens) > 1;
9446
9447             if (paren == '>')
9448                 node = SUSPEND, flag = 0;
9449             reginsert(pRExC_state, node,ret, depth+1);
9450             Set_Node_Cur_Length(ret);
9451             Set_Node_Offset(ret, parse_start + 1);
9452             ret->flags = flag;
9453             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
9454         }
9455     }
9456
9457     /* Check for proper termination. */
9458     if (paren) {
9459         /* restore original flags, but keep (?p) */
9460         RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY);
9461         if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
9462             RExC_parse = oregcomp_parse;
9463             vFAIL("Unmatched (");
9464         }
9465     }
9466     else if (!paren && RExC_parse < RExC_end) {
9467         if (*RExC_parse == ')') {
9468             RExC_parse++;
9469             vFAIL("Unmatched )");
9470         }
9471         else
9472             FAIL("Junk on end of regexp");      /* "Can't happen". */
9473         assert(0); /* NOTREACHED */
9474     }
9475
9476     if (RExC_in_lookbehind) {
9477         RExC_in_lookbehind--;
9478     }
9479     if (after_freeze > RExC_npar)
9480         RExC_npar = after_freeze;
9481     return(ret);
9482 }
9483
9484 /*
9485  - regbranch - one alternative of an | operator
9486  *
9487  * Implements the concatenation operator.
9488  *
9489  * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
9490  * restarted.
9491  */
9492 STATIC regnode *
9493 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
9494 {
9495     dVAR;
9496     regnode *ret;
9497     regnode *chain = NULL;
9498     regnode *latest;
9499     I32 flags = 0, c = 0;
9500     GET_RE_DEBUG_FLAGS_DECL;
9501
9502     PERL_ARGS_ASSERT_REGBRANCH;
9503
9504     DEBUG_PARSE("brnc");
9505
9506     if (first)
9507         ret = NULL;
9508     else {
9509         if (!SIZE_ONLY && RExC_extralen)
9510             ret = reganode(pRExC_state, BRANCHJ,0);
9511         else {
9512             ret = reg_node(pRExC_state, BRANCH);
9513             Set_Node_Length(ret, 1);
9514         }
9515     }
9516
9517     if (!first && SIZE_ONLY)
9518         RExC_extralen += 1;                     /* BRANCHJ */
9519
9520     *flagp = WORST;                     /* Tentatively. */
9521
9522     RExC_parse--;
9523     nextchar(pRExC_state);
9524     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
9525         flags &= ~TRYAGAIN;
9526         latest = regpiece(pRExC_state, &flags,depth+1);
9527         if (latest == NULL) {
9528             if (flags & TRYAGAIN)
9529                 continue;
9530             if (flags & RESTART_UTF8) {
9531                 *flagp = RESTART_UTF8;
9532                 return NULL;
9533             }
9534             FAIL2("panic: regpiece returned NULL, flags=%#X", flags);
9535         }
9536         else if (ret == NULL)
9537             ret = latest;
9538         *flagp |= flags&(HASWIDTH|POSTPONED);
9539         if (chain == NULL)      /* First piece. */
9540             *flagp |= flags&SPSTART;
9541         else {
9542             RExC_naughty++;
9543             REGTAIL(pRExC_state, chain, latest);
9544         }
9545         chain = latest;
9546         c++;
9547     }
9548     if (chain == NULL) {        /* Loop ran zero times. */
9549         chain = reg_node(pRExC_state, NOTHING);
9550         if (ret == NULL)
9551             ret = chain;
9552     }
9553     if (c == 1) {
9554         *flagp |= flags&SIMPLE;
9555     }
9556
9557     return ret;
9558 }
9559
9560 /*
9561  - regpiece - something followed by possible [*+?]
9562  *
9563  * Note that the branching code sequences used for ? and the general cases
9564  * of * and + are somewhat optimized:  they use the same NOTHING node as
9565  * both the endmarker for their branch list and the body of the last branch.
9566  * It might seem that this node could be dispensed with entirely, but the
9567  * endmarker role is not redundant.
9568  *
9569  * Returns NULL, setting *flagp to TRYAGAIN if regatom() returns NULL with
9570  * TRYAGAIN.
9571  * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
9572  * restarted.
9573  */
9574 STATIC regnode *
9575 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
9576 {
9577     dVAR;
9578     regnode *ret;
9579     char op;
9580     char *next;
9581     I32 flags;
9582     const char * const origparse = RExC_parse;
9583     I32 min;
9584     I32 max = REG_INFTY;
9585 #ifdef RE_TRACK_PATTERN_OFFSETS
9586     char *parse_start;
9587 #endif
9588     const char *maxpos = NULL;
9589
9590     /* Save the original in case we change the emitted regop to a FAIL. */
9591     regnode * const orig_emit = RExC_emit;
9592
9593     GET_RE_DEBUG_FLAGS_DECL;
9594
9595     PERL_ARGS_ASSERT_REGPIECE;
9596
9597     DEBUG_PARSE("piec");
9598
9599     ret = regatom(pRExC_state, &flags,depth+1);
9600     if (ret == NULL) {
9601         if (flags & (TRYAGAIN|RESTART_UTF8))
9602             *flagp |= flags & (TRYAGAIN|RESTART_UTF8);
9603         else
9604             FAIL2("panic: regatom returned NULL, flags=%#X", flags);
9605         return(NULL);
9606     }
9607
9608     op = *RExC_parse;
9609
9610     if (op == '{' && regcurly(RExC_parse, FALSE)) {
9611         maxpos = NULL;
9612 #ifdef RE_TRACK_PATTERN_OFFSETS
9613         parse_start = RExC_parse; /* MJD */
9614 #endif
9615         next = RExC_parse + 1;
9616         while (isDIGIT(*next) || *next == ',') {
9617             if (*next == ',') {
9618                 if (maxpos)
9619                     break;
9620                 else
9621                     maxpos = next;
9622             }
9623             next++;
9624         }
9625         if (*next == '}') {             /* got one */
9626             if (!maxpos)
9627                 maxpos = next;
9628             RExC_parse++;
9629             min = atoi(RExC_parse);
9630             if (*maxpos == ',')
9631                 maxpos++;
9632             else
9633                 maxpos = RExC_parse;
9634             max = atoi(maxpos);
9635             if (!max && *maxpos != '0')
9636                 max = REG_INFTY;                /* meaning "infinity" */
9637             else if (max >= REG_INFTY)
9638                 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
9639             RExC_parse = next;
9640             nextchar(pRExC_state);
9641             if (max < min) {    /* If can't match, warn and optimize to fail
9642                                    unconditionally */
9643                 if (SIZE_ONLY) {
9644                     ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
9645
9646                     /* We can't back off the size because we have to reserve
9647                      * enough space for all the things we are about to throw
9648                      * away, but we can shrink it by the ammount we are about
9649                      * to re-use here */
9650                     RExC_size = PREVOPER(RExC_size) - regarglen[(U8)OPFAIL];
9651                 }
9652                 else {
9653                     RExC_emit = orig_emit;
9654                 }
9655                 ret = reg_node(pRExC_state, OPFAIL);
9656                 return ret;
9657             }
9658             else if (max == 0) {    /* replace {0} with a nothing node */
9659                 if (SIZE_ONLY) {
9660                     RExC_size = PREVOPER(RExC_size) - regarglen[(U8)NOTHING];
9661                 }
9662                 else {
9663                     RExC_emit = orig_emit;
9664                 }
9665                 ret = reg_node(pRExC_state, NOTHING);
9666                 return ret;
9667             }
9668
9669         do_curly:
9670             if ((flags&SIMPLE)) {
9671                 RExC_naughty += 2 + RExC_naughty / 2;
9672                 reginsert(pRExC_state, CURLY, ret, depth+1);
9673                 Set_Node_Offset(ret, parse_start+1); /* MJD */
9674                 Set_Node_Cur_Length(ret);
9675             }
9676             else {
9677                 regnode * const w = reg_node(pRExC_state, WHILEM);
9678
9679                 w->flags = 0;
9680                 REGTAIL(pRExC_state, ret, w);
9681                 if (!SIZE_ONLY && RExC_extralen) {
9682                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
9683                     reginsert(pRExC_state, NOTHING,ret, depth+1);
9684                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
9685                 }
9686                 reginsert(pRExC_state, CURLYX,ret, depth+1);
9687                                 /* MJD hk */
9688                 Set_Node_Offset(ret, parse_start+1);
9689                 Set_Node_Length(ret,
9690                                 op == '{' ? (RExC_parse - parse_start) : 1);
9691
9692                 if (!SIZE_ONLY && RExC_extralen)
9693                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
9694                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
9695                 if (SIZE_ONLY)
9696                     RExC_whilem_seen++, RExC_extralen += 3;
9697                 RExC_naughty += 4 + RExC_naughty;       /* compound interest */
9698             }
9699             ret->flags = 0;
9700
9701             if (min > 0)
9702                 *flagp = WORST;
9703             if (max > 0)
9704                 *flagp |= HASWIDTH;
9705             if (!SIZE_ONLY) {
9706                 ARG1_SET(ret, (U16)min);
9707                 ARG2_SET(ret, (U16)max);
9708             }
9709
9710             goto nest_check;
9711         }
9712     }
9713
9714     if (!ISMULT1(op)) {
9715         *flagp = flags;
9716         return(ret);
9717     }
9718
9719 #if 0                           /* Now runtime fix should be reliable. */
9720
9721     /* if this is reinstated, don't forget to put this back into perldiag:
9722
9723             =item Regexp *+ operand could be empty at {#} in regex m/%s/
9724
9725            (F) The part of the regexp subject to either the * or + quantifier
9726            could match an empty string. The {#} shows in the regular
9727            expression about where the problem was discovered.
9728
9729     */
9730
9731     if (!(flags&HASWIDTH) && op != '?')
9732       vFAIL("Regexp *+ operand could be empty");
9733 #endif
9734
9735 #ifdef RE_TRACK_PATTERN_OFFSETS
9736     parse_start = RExC_parse;
9737 #endif
9738     nextchar(pRExC_state);
9739
9740     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
9741
9742     if (op == '*' && (flags&SIMPLE)) {
9743         reginsert(pRExC_state, STAR, ret, depth+1);
9744         ret->flags = 0;
9745         RExC_naughty += 4;
9746     }
9747     else if (op == '*') {
9748         min = 0;
9749         goto do_curly;
9750     }
9751     else if (op == '+' && (flags&SIMPLE)) {
9752         reginsert(pRExC_state, PLUS, ret, depth+1);
9753         ret->flags = 0;
9754         RExC_naughty += 3;
9755     }
9756     else if (op == '+') {
9757         min = 1;
9758         goto do_curly;
9759     }
9760     else if (op == '?') {
9761         min = 0; max = 1;
9762         goto do_curly;
9763     }
9764   nest_check:
9765     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
9766         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
9767         ckWARN3reg(RExC_parse,
9768                    "%.*s matches null string many times",
9769                    (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
9770                    origparse);
9771         (void)ReREFCNT_inc(RExC_rx_sv);
9772     }
9773
9774     if (RExC_parse < RExC_end && *RExC_parse == '?') {
9775         nextchar(pRExC_state);
9776         reginsert(pRExC_state, MINMOD, ret, depth+1);
9777         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
9778     }
9779 #ifndef REG_ALLOW_MINMOD_SUSPEND
9780     else
9781 #endif
9782     if (RExC_parse < RExC_end && *RExC_parse == '+') {
9783         regnode *ender;
9784         nextchar(pRExC_state);
9785         ender = reg_node(pRExC_state, SUCCEED);
9786         REGTAIL(pRExC_state, ret, ender);
9787         reginsert(pRExC_state, SUSPEND, ret, depth+1);
9788         ret->flags = 0;
9789         ender = reg_node(pRExC_state, TAIL);
9790         REGTAIL(pRExC_state, ret, ender);
9791         /*ret= ender;*/
9792     }
9793
9794     if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
9795         RExC_parse++;
9796         vFAIL("Nested quantifiers");
9797     }
9798
9799     return(ret);
9800 }
9801
9802 STATIC bool
9803 S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, UV *valuep, I32 *flagp, U32 depth, bool in_char_class,
9804         const bool strict   /* Apply stricter parsing rules? */
9805     )
9806 {
9807    
9808  /* This is expected to be called by a parser routine that has recognized '\N'
9809    and needs to handle the rest. RExC_parse is expected to point at the first
9810    char following the N at the time of the call.  On successful return,
9811    RExC_parse has been updated to point to just after the sequence identified
9812    by this routine, and <*flagp> has been updated.
9813
9814    The \N may be inside (indicated by the boolean <in_char_class>) or outside a
9815    character class.
9816
9817    \N may begin either a named sequence, or if outside a character class, mean
9818    to match a non-newline.  For non single-quoted regexes, the tokenizer has
9819    attempted to decide which, and in the case of a named sequence, converted it
9820    into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...},
9821    where c1... are the characters in the sequence.  For single-quoted regexes,
9822    the tokenizer passes the \N sequence through unchanged; this code will not
9823    attempt to determine this nor expand those, instead raising a syntax error.
9824    The net effect is that if the beginning of the passed-in pattern isn't '{U+'
9825    or there is no '}', it signals that this \N occurrence means to match a
9826    non-newline.
9827
9828    Only the \N{U+...} form should occur in a character class, for the same
9829    reason that '.' inside a character class means to just match a period: it
9830    just doesn't make sense.
9831
9832    The function raises an error (via vFAIL), and doesn't return for various
9833    syntax errors.  Otherwise it returns TRUE and sets <node_p> or <valuep> on
9834    success; it returns FALSE otherwise. Returns FALSE, setting *flagp to
9835    RESTART_UTF8 if the sizing scan needs to be restarted. Such a restart is
9836    only possible if node_p is non-NULL.
9837
9838
9839    If <valuep> is non-null, it means the caller can accept an input sequence
9840    consisting of a just a single code point; <*valuep> is set to that value
9841    if the input is such.
9842
9843    If <node_p> is non-null it signifies that the caller can accept any other
9844    legal sequence (i.e., one that isn't just a single code point).  <*node_p>
9845    is set as follows:
9846     1) \N means not-a-NL: points to a newly created REG_ANY node;
9847     2) \N{}:              points to a new NOTHING node;
9848     3) otherwise:         points to a new EXACT node containing the resolved
9849                           string.
9850    Note that FALSE is returned for single code point sequences if <valuep> is
9851    null.
9852  */
9853
9854     char * endbrace;    /* '}' following the name */
9855     char* p;
9856     char *endchar;      /* Points to '.' or '}' ending cur char in the input
9857                            stream */
9858     bool has_multiple_chars; /* true if the input stream contains a sequence of
9859                                 more than one character */
9860
9861     GET_RE_DEBUG_FLAGS_DECL;
9862  
9863     PERL_ARGS_ASSERT_GROK_BSLASH_N;
9864
9865     GET_RE_DEBUG_FLAGS;
9866
9867     assert(cBOOL(node_p) ^ cBOOL(valuep));  /* Exactly one should be set */
9868
9869     /* The [^\n] meaning of \N ignores spaces and comments under the /x
9870      * modifier.  The other meaning does not */
9871     p = (RExC_flags & RXf_PMf_EXTENDED)
9872         ? regwhite( pRExC_state, RExC_parse )
9873         : RExC_parse;
9874
9875     /* Disambiguate between \N meaning a named character versus \N meaning
9876      * [^\n].  The former is assumed when it can't be the latter. */
9877     if (*p != '{' || regcurly(p, FALSE)) {
9878         RExC_parse = p;
9879         if (! node_p) {
9880             /* no bare \N in a charclass */
9881             if (in_char_class) {
9882                 vFAIL("\\N in a character class must be a named character: \\N{...}");
9883             }
9884             return FALSE;
9885         }
9886         nextchar(pRExC_state);
9887         *node_p = reg_node(pRExC_state, REG_ANY);
9888         *flagp |= HASWIDTH|SIMPLE;
9889         RExC_naughty++;
9890         RExC_parse--;
9891         Set_Node_Length(*node_p, 1); /* MJD */
9892         return TRUE;
9893     }
9894
9895     /* Here, we have decided it should be a named character or sequence */
9896
9897     /* The test above made sure that the next real character is a '{', but
9898      * under the /x modifier, it could be separated by space (or a comment and
9899      * \n) and this is not allowed (for consistency with \x{...} and the
9900      * tokenizer handling of \N{NAME}). */
9901     if (*RExC_parse != '{') {
9902         vFAIL("Missing braces on \\N{}");
9903     }
9904
9905     RExC_parse++;       /* Skip past the '{' */
9906
9907     if (! (endbrace = strchr(RExC_parse, '}')) /* no trailing brace */
9908         || ! (endbrace == RExC_parse            /* nothing between the {} */
9909               || (endbrace - RExC_parse >= 2    /* U+ (bad hex is checked below */
9910                   && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg) */
9911     {
9912         if (endbrace) RExC_parse = endbrace;    /* position msg's '<--HERE' */
9913         vFAIL("\\N{NAME} must be resolved by the lexer");
9914     }
9915
9916     if (endbrace == RExC_parse) {   /* empty: \N{} */
9917         bool ret = TRUE;
9918         if (node_p) {
9919             *node_p = reg_node(pRExC_state,NOTHING);
9920         }
9921         else if (in_char_class) {
9922             if (SIZE_ONLY && in_char_class) {
9923                 if (strict) {
9924                     RExC_parse++;   /* Position after the "}" */
9925                     vFAIL("Zero length \\N{}");
9926                 }
9927                 else {
9928                     ckWARNreg(RExC_parse,
9929                               "Ignoring zero length \\N{} in character class");
9930                 }
9931             }
9932             ret = FALSE;
9933         }
9934         else {
9935             return FALSE;
9936         }
9937         nextchar(pRExC_state);
9938         return ret;
9939     }
9940
9941     RExC_uni_semantics = 1; /* Unicode named chars imply Unicode semantics */
9942     RExC_parse += 2;    /* Skip past the 'U+' */
9943
9944     endchar = RExC_parse + strcspn(RExC_parse, ".}");
9945
9946     /* Code points are separated by dots.  If none, there is only one code
9947      * point, and is terminated by the brace */
9948     has_multiple_chars = (endchar < endbrace);
9949
9950     if (valuep && (! has_multiple_chars || in_char_class)) {
9951         /* We only pay attention to the first char of
9952         multichar strings being returned in char classes. I kinda wonder
9953         if this makes sense as it does change the behaviour
9954         from earlier versions, OTOH that behaviour was broken
9955         as well. XXX Solution is to recharacterize as
9956         [rest-of-class]|multi1|multi2... */
9957
9958         STRLEN length_of_hex = (STRLEN)(endchar - RExC_parse);
9959         I32 grok_hex_flags = PERL_SCAN_ALLOW_UNDERSCORES
9960             | PERL_SCAN_DISALLOW_PREFIX
9961             | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
9962
9963         *valuep = grok_hex(RExC_parse, &length_of_hex, &grok_hex_flags, NULL);
9964
9965         /* The tokenizer should have guaranteed validity, but it's possible to
9966          * bypass it by using single quoting, so check */
9967         if (length_of_hex == 0
9968             || length_of_hex != (STRLEN)(endchar - RExC_parse) )
9969         {
9970             RExC_parse += length_of_hex;        /* Includes all the valid */
9971             RExC_parse += (RExC_orig_utf8)      /* point to after 1st invalid */
9972                             ? UTF8SKIP(RExC_parse)
9973                             : 1;
9974             /* Guard against malformed utf8 */
9975             if (RExC_parse >= endchar) {
9976                 RExC_parse = endchar;
9977             }
9978             vFAIL("Invalid hexadecimal number in \\N{U+...}");
9979         }
9980
9981         if (in_char_class && has_multiple_chars) {
9982             if (strict) {
9983                 RExC_parse = endbrace;
9984                 vFAIL("\\N{} in character class restricted to one character");
9985             }
9986             else {
9987                 ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
9988             }
9989         }
9990
9991         RExC_parse = endbrace + 1;
9992     }
9993     else if (! node_p || ! has_multiple_chars) {
9994
9995         /* Here, the input is legal, but not according to the caller's
9996          * options.  We fail without advancing the parse, so that the
9997          * caller can try again */
9998         RExC_parse = p;
9999         return FALSE;
10000     }
10001     else {
10002
10003         /* What is done here is to convert this to a sub-pattern of the form
10004          * (?:\x{char1}\x{char2}...)
10005          * and then call reg recursively.  That way, it retains its atomicness,
10006          * while not having to worry about special handling that some code
10007          * points may have.  toke.c has converted the original Unicode values
10008          * to native, so that we can just pass on the hex values unchanged.  We
10009          * do have to set a flag to keep recoding from happening in the
10010          * recursion */
10011
10012         SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP);
10013         STRLEN len;
10014         char *orig_end = RExC_end;
10015         I32 flags;
10016
10017         while (RExC_parse < endbrace) {
10018
10019             /* Convert to notation the rest of the code understands */
10020             sv_catpv(substitute_parse, "\\x{");
10021             sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
10022             sv_catpv(substitute_parse, "}");
10023
10024             /* Point to the beginning of the next character in the sequence. */
10025             RExC_parse = endchar + 1;
10026             endchar = RExC_parse + strcspn(RExC_parse, ".}");
10027         }
10028         sv_catpv(substitute_parse, ")");
10029
10030         RExC_parse = SvPV(substitute_parse, len);
10031
10032         /* Don't allow empty number */
10033         if (len < 8) {
10034             vFAIL("Invalid hexadecimal number in \\N{U+...}");
10035         }
10036         RExC_end = RExC_parse + len;
10037
10038         /* The values are Unicode, and therefore not subject to recoding */
10039         RExC_override_recoding = 1;
10040
10041         if (!(*node_p = reg(pRExC_state, 1, &flags, depth+1))) {
10042             if (flags & RESTART_UTF8) {
10043                 *flagp = RESTART_UTF8;
10044                 return FALSE;
10045             }
10046             FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#X",
10047                   flags);
10048         } 
10049         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
10050
10051         RExC_parse = endbrace;
10052         RExC_end = orig_end;
10053         RExC_override_recoding = 0;
10054
10055         nextchar(pRExC_state);
10056     }
10057
10058     return TRUE;
10059 }
10060
10061
10062 /*
10063  * reg_recode
10064  *
10065  * It returns the code point in utf8 for the value in *encp.
10066  *    value: a code value in the source encoding
10067  *    encp:  a pointer to an Encode object
10068  *
10069  * If the result from Encode is not a single character,
10070  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
10071  */
10072 STATIC UV
10073 S_reg_recode(pTHX_ const char value, SV **encp)
10074 {
10075     STRLEN numlen = 1;
10076     SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP);
10077     const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
10078     const STRLEN newlen = SvCUR(sv);
10079     UV uv = UNICODE_REPLACEMENT;
10080
10081     PERL_ARGS_ASSERT_REG_RECODE;
10082
10083     if (newlen)
10084         uv = SvUTF8(sv)
10085              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
10086              : *(U8*)s;
10087
10088     if (!newlen || numlen != newlen) {
10089         uv = UNICODE_REPLACEMENT;
10090         *encp = NULL;
10091     }
10092     return uv;
10093 }
10094
10095 PERL_STATIC_INLINE U8
10096 S_compute_EXACTish(pTHX_ RExC_state_t *pRExC_state)
10097 {
10098     U8 op;
10099
10100     PERL_ARGS_ASSERT_COMPUTE_EXACTISH;
10101
10102     if (! FOLD) {
10103         return EXACT;
10104     }
10105
10106     op = get_regex_charset(RExC_flags);
10107     if (op >= REGEX_ASCII_RESTRICTED_CHARSET) {
10108         op--; /* /a is same as /u, and map /aa's offset to what /a's would have
10109                  been, so there is no hole */
10110     }
10111
10112     return op + EXACTF;
10113 }
10114
10115 PERL_STATIC_INLINE void
10116 S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state, regnode *node, I32* flagp, STRLEN len, UV code_point)
10117 {
10118     /* This knows the details about sizing an EXACTish node, setting flags for
10119      * it (by setting <*flagp>, and potentially populating it with a single
10120      * character.
10121      *
10122      * If <len> (the length in bytes) is non-zero, this function assumes that
10123      * the node has already been populated, and just does the sizing.  In this
10124      * case <code_point> should be the final code point that has already been
10125      * placed into the node.  This value will be ignored except that under some
10126      * circumstances <*flagp> is set based on it.
10127      *
10128      * If <len> is zero, the function assumes that the node is to contain only
10129      * the single character given by <code_point> and calculates what <len>
10130      * should be.  In pass 1, it sizes the node appropriately.  In pass 2, it
10131      * additionally will populate the node's STRING with <code_point>, if <len>
10132      * is 0.  In both cases <*flagp> is appropriately set
10133      *
10134      * It knows that under FOLD, the Latin Sharp S and UTF characters above
10135      * 255, must be folded (the former only when the rules indicate it can
10136      * match 'ss') */
10137
10138     bool len_passed_in = cBOOL(len != 0);
10139     U8 character[UTF8_MAXBYTES_CASE+1];
10140
10141     PERL_ARGS_ASSERT_ALLOC_MAYBE_POPULATE_EXACT;
10142
10143     if (! len_passed_in) {
10144         if (UTF) {
10145             if (FOLD && (! LOC || code_point > 255)) {
10146                 _to_uni_fold_flags(NATIVE_TO_UNI(code_point),
10147                                    character,
10148                                    &len,
10149                                    FOLD_FLAGS_FULL | ((LOC)
10150                                                      ? FOLD_FLAGS_LOCALE
10151                                                      : (ASCII_FOLD_RESTRICTED)
10152                                                        ? FOLD_FLAGS_NOMIX_ASCII
10153                                                        : 0));
10154             }
10155             else {
10156                 uvchr_to_utf8( character, code_point);
10157                 len = UTF8SKIP(character);
10158             }
10159         }
10160         else if (! FOLD
10161                  || code_point != LATIN_SMALL_LETTER_SHARP_S
10162                  || ASCII_FOLD_RESTRICTED
10163                  || ! AT_LEAST_UNI_SEMANTICS)
10164         {
10165             *character = (U8) code_point;
10166             len = 1;
10167         }
10168         else {
10169             *character = 's';
10170             *(character + 1) = 's';
10171             len = 2;
10172         }
10173     }
10174
10175     if (SIZE_ONLY) {
10176         RExC_size += STR_SZ(len);
10177     }
10178     else {
10179         RExC_emit += STR_SZ(len);
10180         STR_LEN(node) = len;
10181         if (! len_passed_in) {
10182             Copy((char *) character, STRING(node), len, char);
10183         }
10184     }
10185
10186     *flagp |= HASWIDTH;
10187
10188     /* A single character node is SIMPLE, except for the special-cased SHARP S
10189      * under /di. */
10190     if ((len == 1 || (UTF && len == UNISKIP(code_point)))
10191         && (code_point != LATIN_SMALL_LETTER_SHARP_S
10192             || ! FOLD || ! DEPENDS_SEMANTICS))
10193     {
10194         *flagp |= SIMPLE;
10195     }
10196 }
10197
10198 /*
10199  - regatom - the lowest level
10200
10201    Try to identify anything special at the start of the pattern. If there
10202    is, then handle it as required. This may involve generating a single regop,
10203    such as for an assertion; or it may involve recursing, such as to
10204    handle a () structure.
10205
10206    If the string doesn't start with something special then we gobble up
10207    as much literal text as we can.
10208
10209    Once we have been able to handle whatever type of thing started the
10210    sequence, we return.
10211
10212    Note: we have to be careful with escapes, as they can be both literal
10213    and special, and in the case of \10 and friends, context determines which.
10214
10215    A summary of the code structure is:
10216
10217    switch (first_byte) {
10218         cases for each special:
10219             handle this special;
10220             break;
10221         case '\\':
10222             switch (2nd byte) {
10223                 cases for each unambiguous special:
10224                     handle this special;
10225                     break;
10226                 cases for each ambigous special/literal:
10227                     disambiguate;
10228                     if (special)  handle here
10229                     else goto defchar;
10230                 default: // unambiguously literal:
10231                     goto defchar;
10232             }
10233         default:  // is a literal char
10234             // FALL THROUGH
10235         defchar:
10236             create EXACTish node for literal;
10237             while (more input and node isn't full) {
10238                 switch (input_byte) {
10239                    cases for each special;
10240                        make sure parse pointer is set so that the next call to
10241                            regatom will see this special first
10242                        goto loopdone; // EXACTish node terminated by prev. char
10243                    default:
10244                        append char to EXACTISH node;
10245                 }
10246                 get next input byte;
10247             }
10248         loopdone:
10249    }
10250    return the generated node;
10251
10252    Specifically there are two separate switches for handling
10253    escape sequences, with the one for handling literal escapes requiring
10254    a dummy entry for all of the special escapes that are actually handled
10255    by the other.
10256
10257    Returns NULL, setting *flagp to TRYAGAIN if reg() returns NULL with
10258    TRYAGAIN.  
10259    Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
10260    restarted.
10261    Otherwise does not return NULL.
10262 */
10263
10264 STATIC regnode *
10265 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
10266 {
10267     dVAR;
10268     regnode *ret = NULL;
10269     I32 flags = 0;
10270     char *parse_start = RExC_parse;
10271     U8 op;
10272     int invert = 0;
10273
10274     GET_RE_DEBUG_FLAGS_DECL;
10275
10276     *flagp = WORST;             /* Tentatively. */
10277
10278     DEBUG_PARSE("atom");
10279
10280     PERL_ARGS_ASSERT_REGATOM;
10281
10282 tryagain:
10283     switch ((U8)*RExC_parse) {
10284     case '^':
10285         RExC_seen_zerolen++;
10286         nextchar(pRExC_state);
10287         if (RExC_flags & RXf_PMf_MULTILINE)
10288             ret = reg_node(pRExC_state, MBOL);
10289         else if (RExC_flags & RXf_PMf_SINGLELINE)
10290             ret = reg_node(pRExC_state, SBOL);
10291         else
10292             ret = reg_node(pRExC_state, BOL);
10293         Set_Node_Length(ret, 1); /* MJD */
10294         break;
10295     case '$':
10296         nextchar(pRExC_state);
10297         if (*RExC_parse)
10298             RExC_seen_zerolen++;
10299         if (RExC_flags & RXf_PMf_MULTILINE)
10300             ret = reg_node(pRExC_state, MEOL);
10301         else if (RExC_flags & RXf_PMf_SINGLELINE)
10302             ret = reg_node(pRExC_state, SEOL);
10303         else
10304             ret = reg_node(pRExC_state, EOL);
10305         Set_Node_Length(ret, 1); /* MJD */
10306         break;
10307     case '.':
10308         nextchar(pRExC_state);
10309         if (RExC_flags & RXf_PMf_SINGLELINE)
10310             ret = reg_node(pRExC_state, SANY);
10311         else
10312             ret = reg_node(pRExC_state, REG_ANY);
10313         *flagp |= HASWIDTH|SIMPLE;
10314         RExC_naughty++;
10315         Set_Node_Length(ret, 1); /* MJD */
10316         break;
10317     case '[':
10318     {
10319         char * const oregcomp_parse = ++RExC_parse;
10320         ret = regclass(pRExC_state, flagp,depth+1,
10321                        FALSE, /* means parse the whole char class */
10322                        TRUE, /* allow multi-char folds */
10323                        FALSE, /* don't silence non-portable warnings. */
10324                        NULL);
10325         if (*RExC_parse != ']') {
10326             RExC_parse = oregcomp_parse;
10327             vFAIL("Unmatched [");
10328         }
10329         if (ret == NULL) {
10330             if (*flagp & RESTART_UTF8)
10331                 return NULL;
10332             FAIL2("panic: regclass returned NULL to regatom, flags=%#X",
10333                   *flagp);
10334         }
10335         nextchar(pRExC_state);
10336         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
10337         break;
10338     }
10339     case '(':
10340         nextchar(pRExC_state);
10341         ret = reg(pRExC_state, 2, &flags,depth+1);
10342         if (ret == NULL) {
10343                 if (flags & TRYAGAIN) {
10344                     if (RExC_parse == RExC_end) {
10345                          /* Make parent create an empty node if needed. */
10346                         *flagp |= TRYAGAIN;
10347                         return(NULL);
10348                     }
10349                     goto tryagain;
10350                 }
10351                 if (flags & RESTART_UTF8) {
10352                     *flagp = RESTART_UTF8;
10353                     return NULL;
10354                 }
10355                 FAIL2("panic: reg returned NULL to regatom, flags=%#X", flags);
10356         }
10357         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
10358         break;
10359     case '|':
10360     case ')':
10361         if (flags & TRYAGAIN) {
10362             *flagp |= TRYAGAIN;
10363             return NULL;
10364         }
10365         vFAIL("Internal urp");
10366                                 /* Supposed to be caught earlier. */
10367         break;
10368     case '{':
10369         if (!regcurly(RExC_parse, FALSE)) {
10370             RExC_parse++;
10371             goto defchar;
10372         }
10373         /* FALL THROUGH */
10374     case '?':
10375     case '+':
10376     case '*':
10377         RExC_parse++;
10378         vFAIL("Quantifier follows nothing");
10379         break;
10380     case '\\':
10381         /* Special Escapes
10382
10383            This switch handles escape sequences that resolve to some kind
10384            of special regop and not to literal text. Escape sequnces that
10385            resolve to literal text are handled below in the switch marked
10386            "Literal Escapes".
10387
10388            Every entry in this switch *must* have a corresponding entry
10389            in the literal escape switch. However, the opposite is not
10390            required, as the default for this switch is to jump to the
10391            literal text handling code.
10392         */
10393         switch ((U8)*++RExC_parse) {
10394             U8 arg;
10395         /* Special Escapes */
10396         case 'A':
10397             RExC_seen_zerolen++;
10398             ret = reg_node(pRExC_state, SBOL);
10399             *flagp |= SIMPLE;
10400             goto finish_meta_pat;
10401         case 'G':
10402             ret = reg_node(pRExC_state, GPOS);
10403             RExC_seen |= REG_SEEN_GPOS;
10404             *flagp |= SIMPLE;
10405             goto finish_meta_pat;
10406         case 'K':
10407             RExC_seen_zerolen++;
10408             ret = reg_node(pRExC_state, KEEPS);
10409             *flagp |= SIMPLE;
10410             /* XXX:dmq : disabling in-place substitution seems to
10411              * be necessary here to avoid cases of memory corruption, as
10412              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
10413              */
10414             RExC_seen |= REG_SEEN_LOOKBEHIND;
10415             goto finish_meta_pat;
10416         case 'Z':
10417             ret = reg_node(pRExC_state, SEOL);
10418             *flagp |= SIMPLE;
10419             RExC_seen_zerolen++;                /* Do not optimize RE away */
10420             goto finish_meta_pat;
10421         case 'z':
10422             ret = reg_node(pRExC_state, EOS);
10423             *flagp |= SIMPLE;
10424             RExC_seen_zerolen++;                /* Do not optimize RE away */
10425             goto finish_meta_pat;
10426         case 'C':
10427             ret = reg_node(pRExC_state, CANY);
10428             RExC_seen |= REG_SEEN_CANY;
10429             *flagp |= HASWIDTH|SIMPLE;
10430             goto finish_meta_pat;
10431         case 'X':
10432             ret = reg_node(pRExC_state, CLUMP);
10433             *flagp |= HASWIDTH;
10434             goto finish_meta_pat;
10435
10436         case 'W':
10437             invert = 1;
10438             /* FALLTHROUGH */
10439         case 'w':
10440             arg = ANYOF_WORDCHAR;
10441             goto join_posix;
10442
10443         case 'b':
10444             RExC_seen_zerolen++;
10445             RExC_seen |= REG_SEEN_LOOKBEHIND;
10446             op = BOUND + get_regex_charset(RExC_flags);
10447             if (op > BOUNDA) {  /* /aa is same as /a */
10448                 op = BOUNDA;
10449             }
10450             ret = reg_node(pRExC_state, op);
10451             FLAGS(ret) = get_regex_charset(RExC_flags);
10452             *flagp |= SIMPLE;
10453             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
10454                 ckWARNdep(RExC_parse, "\"\\b{\" is deprecated; use \"\\b\\{\" or \"\\b[{]\" instead");
10455             }
10456             goto finish_meta_pat;
10457         case 'B':
10458             RExC_seen_zerolen++;
10459             RExC_seen |= REG_SEEN_LOOKBEHIND;
10460             op = NBOUND + get_regex_charset(RExC_flags);
10461             if (op > NBOUNDA) { /* /aa is same as /a */
10462                 op = NBOUNDA;
10463             }
10464             ret = reg_node(pRExC_state, op);
10465             FLAGS(ret) = get_regex_charset(RExC_flags);
10466             *flagp |= SIMPLE;
10467             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
10468                 ckWARNdep(RExC_parse, "\"\\B{\" is deprecated; use \"\\B\\{\" or \"\\B[{]\" instead");
10469             }
10470             goto finish_meta_pat;
10471
10472         case 'D':
10473             invert = 1;
10474             /* FALLTHROUGH */
10475         case 'd':
10476             arg = ANYOF_DIGIT;
10477             goto join_posix;
10478
10479         case 'R':
10480             ret = reg_node(pRExC_state, LNBREAK);
10481             *flagp |= HASWIDTH|SIMPLE;
10482             goto finish_meta_pat;
10483
10484         case 'H':
10485             invert = 1;
10486             /* FALLTHROUGH */
10487         case 'h':
10488             arg = ANYOF_BLANK;
10489             op = POSIXU;
10490             goto join_posix_op_known;
10491
10492         case 'V':
10493             invert = 1;
10494             /* FALLTHROUGH */
10495         case 'v':
10496             arg = ANYOF_VERTWS;
10497             op = POSIXU;
10498             goto join_posix_op_known;
10499
10500         case 'S':
10501             invert = 1;
10502             /* FALLTHROUGH */
10503         case 's':
10504             arg = ANYOF_SPACE;
10505
10506         join_posix:
10507
10508             op = POSIXD + get_regex_charset(RExC_flags);
10509             if (op > POSIXA) {  /* /aa is same as /a */
10510                 op = POSIXA;
10511             }
10512
10513         join_posix_op_known:
10514
10515             if (invert) {
10516                 op += NPOSIXD - POSIXD;
10517             }
10518
10519             ret = reg_node(pRExC_state, op);
10520             if (! SIZE_ONLY) {
10521                 FLAGS(ret) = namedclass_to_classnum(arg);
10522             }
10523
10524             *flagp |= HASWIDTH|SIMPLE;
10525             /* FALL THROUGH */
10526
10527          finish_meta_pat:           
10528             nextchar(pRExC_state);
10529             Set_Node_Length(ret, 2); /* MJD */
10530             break;          
10531         case 'p':
10532         case 'P':
10533             {
10534 #ifdef DEBUGGING
10535                 char* parse_start = RExC_parse - 2;
10536 #endif
10537
10538                 RExC_parse--;
10539
10540                 ret = regclass(pRExC_state, flagp,depth+1,
10541                                TRUE, /* means just parse this element */
10542                                FALSE, /* don't allow multi-char folds */
10543                                FALSE, /* don't silence non-portable warnings.
10544                                          It would be a bug if these returned
10545                                          non-portables */
10546                                NULL);
10547                 /* regclass() can only return RESTART_UTF8 if multi-char folds
10548                    are allowed.  */
10549                 if (!ret)
10550                     FAIL2("panic: regclass returned NULL to regatom, flags=%#X",
10551                           *flagp);
10552
10553                 RExC_parse--;
10554
10555                 Set_Node_Offset(ret, parse_start + 2);
10556                 Set_Node_Cur_Length(ret);
10557                 nextchar(pRExC_state);
10558             }
10559             break;
10560         case 'N': 
10561             /* Handle \N and \N{NAME} with multiple code points here and not
10562              * below because it can be multicharacter. join_exact() will join
10563              * them up later on.  Also this makes sure that things like
10564              * /\N{BLAH}+/ and \N{BLAH} being multi char Just Happen. dmq.
10565              * The options to the grok function call causes it to fail if the
10566              * sequence is just a single code point.  We then go treat it as
10567              * just another character in the current EXACT node, and hence it
10568              * gets uniform treatment with all the other characters.  The
10569              * special treatment for quantifiers is not needed for such single
10570              * character sequences */
10571             ++RExC_parse;
10572             if (! grok_bslash_N(pRExC_state, &ret, NULL, flagp, depth, FALSE,
10573                                 FALSE /* not strict */ )) {
10574                 if (*flagp & RESTART_UTF8)
10575                     return NULL;
10576                 RExC_parse--;
10577                 goto defchar;
10578             }
10579             break;
10580         case 'k':    /* Handle \k<NAME> and \k'NAME' */
10581         parse_named_seq:
10582         {   
10583             char ch= RExC_parse[1];         
10584             if (ch != '<' && ch != '\'' && ch != '{') {
10585                 RExC_parse++;
10586                 vFAIL2("Sequence %.2s... not terminated",parse_start);
10587             } else {
10588                 /* this pretty much dupes the code for (?P=...) in reg(), if
10589                    you change this make sure you change that */
10590                 char* name_start = (RExC_parse += 2);
10591                 U32 num = 0;
10592                 SV *sv_dat = reg_scan_name(pRExC_state,
10593                     SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
10594                 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
10595                 if (RExC_parse == name_start || *RExC_parse != ch)
10596                     vFAIL2("Sequence %.3s... not terminated",parse_start);
10597
10598                 if (!SIZE_ONLY) {
10599                     num = add_data( pRExC_state, 1, "S" );
10600                     RExC_rxi->data->data[num]=(void*)sv_dat;
10601                     SvREFCNT_inc_simple_void(sv_dat);
10602                 }
10603
10604                 RExC_sawback = 1;
10605                 ret = reganode(pRExC_state,
10606                                ((! FOLD)
10607                                  ? NREF
10608                                  : (ASCII_FOLD_RESTRICTED)
10609                                    ? NREFFA
10610                                    : (AT_LEAST_UNI_SEMANTICS)
10611                                      ? NREFFU
10612                                      : (LOC)
10613                                        ? NREFFL
10614                                        : NREFF),
10615                                 num);
10616                 *flagp |= HASWIDTH;
10617
10618                 /* override incorrect value set in reganode MJD */
10619                 Set_Node_Offset(ret, parse_start+1);
10620                 Set_Node_Cur_Length(ret); /* MJD */
10621                 nextchar(pRExC_state);
10622
10623             }
10624             break;
10625         }
10626         case 'g': 
10627         case '1': case '2': case '3': case '4':
10628         case '5': case '6': case '7': case '8': case '9':
10629             {
10630                 I32 num;
10631                 bool isg = *RExC_parse == 'g';
10632                 bool isrel = 0; 
10633                 bool hasbrace = 0;
10634                 if (isg) {
10635                     RExC_parse++;
10636                     if (*RExC_parse == '{') {
10637                         RExC_parse++;
10638                         hasbrace = 1;
10639                     }
10640                     if (*RExC_parse == '-') {
10641                         RExC_parse++;
10642                         isrel = 1;
10643                     }
10644                     if (hasbrace && !isDIGIT(*RExC_parse)) {
10645                         if (isrel) RExC_parse--;
10646                         RExC_parse -= 2;                            
10647                         goto parse_named_seq;
10648                 }   }
10649                 num = atoi(RExC_parse);
10650                 if (isg && num == 0)
10651                     vFAIL("Reference to invalid group 0");
10652                 if (isrel) {
10653                     num = RExC_npar - num;
10654                     if (num < 1)
10655                         vFAIL("Reference to nonexistent or unclosed group");
10656                 }
10657                 if (!isg && num > 9 && num >= RExC_npar)
10658                     /* Probably a character specified in octal, e.g. \35 */
10659                     goto defchar;
10660                 else {
10661                     char * const parse_start = RExC_parse - 1; /* MJD */
10662                     while (isDIGIT(*RExC_parse))
10663                         RExC_parse++;
10664                     if (parse_start == RExC_parse - 1) 
10665                         vFAIL("Unterminated \\g... pattern");
10666                     if (hasbrace) {
10667                         if (*RExC_parse != '}') 
10668                             vFAIL("Unterminated \\g{...} pattern");
10669                         RExC_parse++;
10670                     }    
10671                     if (!SIZE_ONLY) {
10672                         if (num > (I32)RExC_rx->nparens)
10673                             vFAIL("Reference to nonexistent group");
10674                     }
10675                     RExC_sawback = 1;
10676                     ret = reganode(pRExC_state,
10677                                    ((! FOLD)
10678                                      ? REF
10679                                      : (ASCII_FOLD_RESTRICTED)
10680                                        ? REFFA
10681                                        : (AT_LEAST_UNI_SEMANTICS)
10682                                          ? REFFU
10683                                          : (LOC)
10684                                            ? REFFL
10685                                            : REFF),
10686                                     num);
10687                     *flagp |= HASWIDTH;
10688
10689                     /* override incorrect value set in reganode MJD */
10690                     Set_Node_Offset(ret, parse_start+1);
10691                     Set_Node_Cur_Length(ret); /* MJD */
10692                     RExC_parse--;
10693                     nextchar(pRExC_state);
10694                 }
10695             }
10696             break;
10697         case '\0':
10698             if (RExC_parse >= RExC_end)
10699                 FAIL("Trailing \\");
10700             /* FALL THROUGH */
10701         default:
10702             /* Do not generate "unrecognized" warnings here, we fall
10703                back into the quick-grab loop below */
10704             parse_start--;
10705             goto defchar;
10706         }
10707         break;
10708
10709     case '#':
10710         if (RExC_flags & RXf_PMf_EXTENDED) {
10711             if ( reg_skipcomment( pRExC_state ) )
10712                 goto tryagain;
10713         }
10714         /* FALL THROUGH */
10715
10716     default:
10717
10718             parse_start = RExC_parse - 1;
10719
10720             RExC_parse++;
10721
10722         defchar: {
10723             STRLEN len = 0;
10724             UV ender;
10725             char *p;
10726             char *s;
10727 #define MAX_NODE_STRING_SIZE 127
10728             char foldbuf[MAX_NODE_STRING_SIZE+UTF8_MAXBYTES_CASE];
10729             char *s0;
10730             U8 upper_parse = MAX_NODE_STRING_SIZE;
10731             STRLEN foldlen;
10732             U8 node_type;
10733             bool next_is_quantifier;
10734             char * oldp = NULL;
10735
10736             /* If a folding node contains only code points that don't
10737              * participate in folds, it can be changed into an EXACT node,
10738              * which allows the optimizer more things to look for */
10739             bool maybe_exact;
10740
10741             ender = 0;
10742             node_type = compute_EXACTish(pRExC_state);
10743             ret = reg_node(pRExC_state, node_type);
10744
10745             /* In pass1, folded, we use a temporary buffer instead of the
10746              * actual node, as the node doesn't exist yet */
10747             s = (SIZE_ONLY && FOLD) ? foldbuf : STRING(ret);
10748
10749             s0 = s;
10750
10751         reparse:
10752
10753             /* We do the EXACTFish to EXACT node only if folding, and not if in
10754              * locale, as whether a character folds or not isn't known until
10755              * runtime */
10756             maybe_exact = FOLD && ! LOC;
10757
10758             /* XXX The node can hold up to 255 bytes, yet this only goes to
10759              * 127.  I (khw) do not know why.  Keeping it somewhat less than
10760              * 255 allows us to not have to worry about overflow due to
10761              * converting to utf8 and fold expansion, but that value is
10762              * 255-UTF8_MAXBYTES_CASE.  join_exact() may join adjacent nodes
10763              * split up by this limit into a single one using the real max of
10764              * 255.  Even at 127, this breaks under rare circumstances.  If
10765              * folding, we do not want to split a node at a character that is a
10766              * non-final in a multi-char fold, as an input string could just
10767              * happen to want to match across the node boundary.  The join
10768              * would solve that problem if the join actually happens.  But a
10769              * series of more than two nodes in a row each of 127 would cause
10770              * the first join to succeed to get to 254, but then there wouldn't
10771              * be room for the next one, which could at be one of those split
10772              * multi-char folds.  I don't know of any fool-proof solution.  One
10773              * could back off to end with only a code point that isn't such a
10774              * non-final, but it is possible for there not to be any in the
10775              * entire node. */
10776             for (p = RExC_parse - 1;
10777                  len < upper_parse && p < RExC_end;
10778                  len++)
10779             {
10780                 oldp = p;
10781
10782                 if (RExC_flags & RXf_PMf_EXTENDED)
10783                     p = regwhite( pRExC_state, p );
10784                 switch ((U8)*p) {
10785                 case '^':
10786                 case '$':
10787                 case '.':
10788                 case '[':
10789                 case '(':
10790                 case ')':
10791                 case '|':
10792                     goto loopdone;
10793                 case '\\':
10794                     /* Literal Escapes Switch
10795
10796                        This switch is meant to handle escape sequences that
10797                        resolve to a literal character.
10798
10799                        Every escape sequence that represents something
10800                        else, like an assertion or a char class, is handled
10801                        in the switch marked 'Special Escapes' above in this
10802                        routine, but also has an entry here as anything that
10803                        isn't explicitly mentioned here will be treated as
10804                        an unescaped equivalent literal.
10805                     */
10806
10807                     switch ((U8)*++p) {
10808                     /* These are all the special escapes. */
10809                     case 'A':             /* Start assertion */
10810                     case 'b': case 'B':   /* Word-boundary assertion*/
10811                     case 'C':             /* Single char !DANGEROUS! */
10812                     case 'd': case 'D':   /* digit class */
10813                     case 'g': case 'G':   /* generic-backref, pos assertion */
10814                     case 'h': case 'H':   /* HORIZWS */
10815                     case 'k': case 'K':   /* named backref, keep marker */
10816                     case 'p': case 'P':   /* Unicode property */
10817                               case 'R':   /* LNBREAK */
10818                     case 's': case 'S':   /* space class */
10819                     case 'v': case 'V':   /* VERTWS */
10820                     case 'w': case 'W':   /* word class */
10821                     case 'X':             /* eXtended Unicode "combining character sequence" */
10822                     case 'z': case 'Z':   /* End of line/string assertion */
10823                         --p;
10824                         goto loopdone;
10825
10826                     /* Anything after here is an escape that resolves to a
10827                        literal. (Except digits, which may or may not)
10828                      */
10829                     case 'n':
10830                         ender = '\n';
10831                         p++;
10832                         break;
10833                     case 'N': /* Handle a single-code point named character. */
10834                         /* The options cause it to fail if a multiple code
10835                          * point sequence.  Handle those in the switch() above
10836                          * */
10837                         RExC_parse = p + 1;
10838                         if (! grok_bslash_N(pRExC_state, NULL, &ender,
10839                                             flagp, depth, FALSE,
10840                                             FALSE /* not strict */ ))
10841                         {
10842                             if (*flagp & RESTART_UTF8)
10843                                 FAIL("panic: grok_bslash_N set RESTART_UTF8");
10844                             RExC_parse = p = oldp;
10845                             goto loopdone;
10846                         }
10847                         p = RExC_parse;
10848                         if (ender > 0xff) {
10849                             REQUIRE_UTF8;
10850                         }
10851                         break;
10852                     case 'r':
10853                         ender = '\r';
10854                         p++;
10855                         break;
10856                     case 't':
10857                         ender = '\t';
10858                         p++;
10859                         break;
10860                     case 'f':
10861                         ender = '\f';
10862                         p++;
10863                         break;
10864                     case 'e':
10865                           ender = ASCII_TO_NATIVE('\033');
10866                         p++;
10867                         break;
10868                     case 'a':
10869                           ender = ASCII_TO_NATIVE('\007');
10870                         p++;
10871                         break;
10872                     case 'o':
10873                         {
10874                             UV result;
10875                             const char* error_msg;
10876
10877                             bool valid = grok_bslash_o(&p,
10878                                                        &result,
10879                                                        &error_msg,
10880                                                        TRUE, /* out warnings */
10881                                                        FALSE, /* not strict */
10882                                                        TRUE, /* Output warnings
10883                                                                 for non-
10884                                                                 portables */
10885                                                        UTF);
10886                             if (! valid) {
10887                                 RExC_parse = p; /* going to die anyway; point
10888                                                    to exact spot of failure */
10889                                 vFAIL(error_msg);
10890                             }
10891                             ender = result;
10892                             if (PL_encoding && ender < 0x100) {
10893                                 goto recode_encoding;
10894                             }
10895                             if (ender > 0xff) {
10896                                 REQUIRE_UTF8;
10897                             }
10898                             break;
10899                         }
10900                     case 'x':
10901                         {
10902                             UV result = UV_MAX; /* initialize to erroneous
10903                                                    value */
10904                             const char* error_msg;
10905
10906                             bool valid = grok_bslash_x(&p,
10907                                                        &result,
10908                                                        &error_msg,
10909                                                        TRUE, /* out warnings */
10910                                                        FALSE, /* not strict */
10911                                                        TRUE, /* Output warnings
10912                                                                 for non-
10913                                                                 portables */
10914                                                        UTF);
10915                             if (! valid) {
10916                                 RExC_parse = p; /* going to die anyway; point
10917                                                    to exact spot of failure */
10918                                 vFAIL(error_msg);
10919                             }
10920                             ender = result;
10921
10922                             if (PL_encoding && ender < 0x100) {
10923                                 goto recode_encoding;
10924                             }
10925                             if (ender > 0xff) {
10926                                 REQUIRE_UTF8;
10927                             }
10928                             break;
10929                         }
10930                     case 'c':
10931                         p++;
10932                         ender = grok_bslash_c(*p++, UTF, SIZE_ONLY);
10933                         break;
10934                     case '0': case '1': case '2': case '3':case '4':
10935                     case '5': case '6': case '7':
10936                         if (*p == '0' ||
10937                             (isDIGIT(p[1]) && atoi(p) >= RExC_npar))
10938                         {
10939                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
10940                             STRLEN numlen = 3;
10941                             ender = grok_oct(p, &numlen, &flags, NULL);
10942                             if (ender > 0xff) {
10943                                 REQUIRE_UTF8;
10944                             }
10945                             p += numlen;
10946                             if (SIZE_ONLY   /* like \08, \178 */
10947                                 && numlen < 3
10948                                 && p < RExC_end
10949                                 && isDIGIT(*p) && ckWARN(WARN_REGEXP))
10950                             {
10951                                 reg_warn_non_literal_string(
10952                                          p + 1,
10953                                          form_short_octal_warning(p, numlen));
10954                             }
10955                         }
10956                         else {  /* Not to be treated as an octal constant, go
10957                                    find backref */
10958                             --p;
10959                             goto loopdone;
10960                         }
10961                         if (PL_encoding && ender < 0x100)
10962                             goto recode_encoding;
10963                         break;
10964                     recode_encoding:
10965                         if (! RExC_override_recoding) {
10966                             SV* enc = PL_encoding;
10967                             ender = reg_recode((const char)(U8)ender, &enc);
10968                             if (!enc && SIZE_ONLY)
10969                                 ckWARNreg(p, "Invalid escape in the specified encoding");
10970                             REQUIRE_UTF8;
10971                         }
10972                         break;
10973                     case '\0':
10974                         if (p >= RExC_end)
10975                             FAIL("Trailing \\");
10976                         /* FALL THROUGH */
10977                     default:
10978                         if (!SIZE_ONLY&& isALPHANUMERIC(*p)) {
10979                             /* Include any { following the alpha to emphasize
10980                              * that it could be part of an escape at some point
10981                              * in the future */
10982                             int len = (isALPHA(*p) && *(p + 1) == '{') ? 2 : 1;
10983                             ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
10984                         }
10985                         goto normal_default;
10986                     } /* End of switch on '\' */
10987                     break;
10988                 default:    /* A literal character */
10989
10990                     if (! SIZE_ONLY
10991                         && RExC_flags & RXf_PMf_EXTENDED
10992                         && ckWARN(WARN_DEPRECATED)
10993                         && is_PATWS_non_low(p, UTF))
10994                     {
10995                         vWARN_dep(p + ((UTF) ? UTF8SKIP(p) : 1),
10996                                 "Escape literal pattern white space under /x");
10997                     }
10998
10999                   normal_default:
11000                     if (UTF8_IS_START(*p) && UTF) {
11001                         STRLEN numlen;
11002                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
11003                                                &numlen, UTF8_ALLOW_DEFAULT);
11004                         p += numlen;
11005                     }
11006                     else
11007                         ender = (U8) *p++;
11008                     break;
11009                 } /* End of switch on the literal */
11010
11011                 /* Here, have looked at the literal character and <ender>
11012                  * contains its ordinal, <p> points to the character after it
11013                  */
11014
11015                 if ( RExC_flags & RXf_PMf_EXTENDED)
11016                     p = regwhite( pRExC_state, p );
11017
11018                 /* If the next thing is a quantifier, it applies to this
11019                  * character only, which means that this character has to be in
11020                  * its own node and can't just be appended to the string in an
11021                  * existing node, so if there are already other characters in
11022                  * the node, close the node with just them, and set up to do
11023                  * this character again next time through, when it will be the
11024                  * only thing in its new node */
11025                 if ((next_is_quantifier = (p < RExC_end && ISMULT2(p))) && len)
11026                 {
11027                     p = oldp;
11028                     goto loopdone;
11029                 }
11030
11031                 if (FOLD) {
11032                     if (UTF
11033                             /* See comments for join_exact() as to why we fold
11034                              * this non-UTF at compile time */
11035                         || (node_type == EXACTFU
11036                             && ender == LATIN_SMALL_LETTER_SHARP_S))
11037                     {
11038
11039
11040                         /* Prime the casefolded buffer.  Locale rules, which
11041                          * apply only to code points < 256, aren't known until
11042                          * execution, so for them, just output the original
11043                          * character using utf8.  If we start to fold non-UTF
11044                          * patterns, be sure to update join_exact() */
11045                         if (LOC && ender < 256) {
11046                             if (UNI_IS_INVARIANT(ender)) {
11047                                 *s = (U8) ender;
11048                                 foldlen = 1;
11049                             } else {
11050                                 *s = UTF8_TWO_BYTE_HI(ender);
11051                                 *(s + 1) = UTF8_TWO_BYTE_LO(ender);
11052                                 foldlen = 2;
11053                             }
11054                         }
11055                         else {
11056                             UV folded = _to_uni_fold_flags(
11057                                            ender,
11058                                            (U8 *) s,
11059                                            &foldlen,
11060                                            FOLD_FLAGS_FULL
11061                                            | ((LOC) ?  FOLD_FLAGS_LOCALE
11062                                                     : (ASCII_FOLD_RESTRICTED)
11063                                                       ? FOLD_FLAGS_NOMIX_ASCII
11064                                                       : 0)
11065                                             );
11066
11067                             /* If this node only contains non-folding code
11068                              * points so far, see if this new one is also
11069                              * non-folding */
11070                             if (maybe_exact) {
11071                                 if (folded != ender) {
11072                                     maybe_exact = FALSE;
11073                                 }
11074                                 else {
11075                                     /* Here the fold is the original; we have
11076                                      * to check further to see if anything
11077                                      * folds to it */
11078                                     if (! PL_utf8_foldable) {
11079                                         SV* swash = swash_init("utf8",
11080                                                            "_Perl_Any_Folds",
11081                                                            &PL_sv_undef, 1, 0);
11082                                         PL_utf8_foldable =
11083                                                     _get_swash_invlist(swash);
11084                                         SvREFCNT_dec_NN(swash);
11085                                     }
11086                                     if (_invlist_contains_cp(PL_utf8_foldable,
11087                                                              ender))
11088                                     {
11089                                         maybe_exact = FALSE;
11090                                     }
11091                                 }
11092                             }
11093                             ender = folded;
11094                         }
11095                         s += foldlen;
11096
11097                         /* The loop increments <len> each time, as all but this
11098                          * path (and the one just below for UTF) through it add
11099                          * a single byte to the EXACTish node.  But this one
11100                          * has changed len to be the correct final value, so
11101                          * subtract one to cancel out the increment that
11102                          * follows */
11103                         len += foldlen - 1;
11104                     }
11105                     else {
11106                         *(s++) = (char) ender;
11107                         maybe_exact &= ! IS_IN_SOME_FOLD_L1(ender);
11108                     }
11109                 }
11110                 else if (UTF) {
11111                     const STRLEN unilen = reguni(pRExC_state, ender, s);
11112                     if (unilen > 0) {
11113                        s   += unilen;
11114                        len += unilen;
11115                     }
11116
11117                     /* See comment just above for - 1 */
11118                     len--;
11119                 }
11120                 else {
11121                     REGC((char)ender, s++);
11122                 }
11123
11124                 if (next_is_quantifier) {
11125
11126                     /* Here, the next input is a quantifier, and to get here,
11127                      * the current character is the only one in the node.
11128                      * Also, here <len> doesn't include the final byte for this
11129                      * character */
11130                     len++;
11131                     goto loopdone;
11132                 }
11133
11134             } /* End of loop through literal characters */
11135
11136             /* Here we have either exhausted the input or ran out of room in
11137              * the node.  (If we encountered a character that can't be in the
11138              * node, transfer is made directly to <loopdone>, and so we
11139              * wouldn't have fallen off the end of the loop.)  In the latter
11140              * case, we artificially have to split the node into two, because
11141              * we just don't have enough space to hold everything.  This
11142              * creates a problem if the final character participates in a
11143              * multi-character fold in the non-final position, as a match that
11144              * should have occurred won't, due to the way nodes are matched,
11145              * and our artificial boundary.  So back off until we find a non-
11146              * problematic character -- one that isn't at the beginning or
11147              * middle of such a fold.  (Either it doesn't participate in any
11148              * folds, or appears only in the final position of all the folds it
11149              * does participate in.)  A better solution with far fewer false
11150              * positives, and that would fill the nodes more completely, would
11151              * be to actually have available all the multi-character folds to
11152              * test against, and to back-off only far enough to be sure that
11153              * this node isn't ending with a partial one.  <upper_parse> is set
11154              * further below (if we need to reparse the node) to include just
11155              * up through that final non-problematic character that this code
11156              * identifies, so when it is set to less than the full node, we can
11157              * skip the rest of this */
11158             if (FOLD && p < RExC_end && upper_parse == MAX_NODE_STRING_SIZE) {
11159
11160                 const STRLEN full_len = len;
11161
11162                 assert(len >= MAX_NODE_STRING_SIZE);
11163
11164                 /* Here, <s> points to the final byte of the final character.
11165                  * Look backwards through the string until find a non-
11166                  * problematic character */
11167
11168                 if (! UTF) {
11169
11170                     /* These two have no multi-char folds to non-UTF characters
11171                      */
11172                     if (ASCII_FOLD_RESTRICTED || LOC) {
11173                         goto loopdone;
11174                     }
11175
11176                     while (--s >= s0 && IS_NON_FINAL_FOLD(*s)) { }
11177                     len = s - s0 + 1;
11178                 }
11179                 else {
11180                     if (!  PL_NonL1NonFinalFold) {
11181                         PL_NonL1NonFinalFold = _new_invlist_C_array(
11182                                         NonL1_Perl_Non_Final_Folds_invlist);
11183                     }
11184
11185                     /* Point to the first byte of the final character */
11186                     s = (char *) utf8_hop((U8 *) s, -1);
11187
11188                     while (s >= s0) {   /* Search backwards until find
11189                                            non-problematic char */
11190                         if (UTF8_IS_INVARIANT(*s)) {
11191
11192                             /* There are no ascii characters that participate
11193                              * in multi-char folds under /aa.  In EBCDIC, the
11194                              * non-ascii invariants are all control characters,
11195                              * so don't ever participate in any folds. */
11196                             if (ASCII_FOLD_RESTRICTED
11197                                 || ! IS_NON_FINAL_FOLD(*s))
11198                             {
11199                                 break;
11200                             }
11201                         }
11202                         else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
11203
11204                             /* No Latin1 characters participate in multi-char
11205                              * folds under /l */
11206                             if (LOC
11207                                 || ! IS_NON_FINAL_FOLD(TWO_BYTE_UTF8_TO_UNI(
11208                                                                 *s, *(s+1))))
11209                             {
11210                                 break;
11211                             }
11212                         }
11213                         else if (! _invlist_contains_cp(
11214                                         PL_NonL1NonFinalFold,
11215                                         valid_utf8_to_uvchr((U8 *) s, NULL)))
11216                         {
11217                             break;
11218                         }
11219
11220                         /* Here, the current character is problematic in that
11221                          * it does occur in the non-final position of some
11222                          * fold, so try the character before it, but have to
11223                          * special case the very first byte in the string, so
11224                          * we don't read outside the string */
11225                         s = (s == s0) ? s -1 : (char *) utf8_hop((U8 *) s, -1);
11226                     } /* End of loop backwards through the string */
11227
11228                     /* If there were only problematic characters in the string,
11229                      * <s> will point to before s0, in which case the length
11230                      * should be 0, otherwise include the length of the
11231                      * non-problematic character just found */
11232                     len = (s < s0) ? 0 : s - s0 + UTF8SKIP(s);
11233                 }
11234
11235                 /* Here, have found the final character, if any, that is
11236                  * non-problematic as far as ending the node without splitting
11237                  * it across a potential multi-char fold.  <len> contains the
11238                  * number of bytes in the node up-to and including that
11239                  * character, or is 0 if there is no such character, meaning
11240                  * the whole node contains only problematic characters.  In
11241                  * this case, give up and just take the node as-is.  We can't
11242                  * do any better */
11243                 if (len == 0) {
11244                     len = full_len;
11245                 } else {
11246
11247                     /* Here, the node does contain some characters that aren't
11248                      * problematic.  If one such is the final character in the
11249                      * node, we are done */
11250                     if (len == full_len) {
11251                         goto loopdone;
11252                     }
11253                     else if (len + ((UTF) ? UTF8SKIP(s) : 1) == full_len) {
11254
11255                         /* If the final character is problematic, but the
11256                          * penultimate is not, back-off that last character to
11257                          * later start a new node with it */
11258                         p = oldp;
11259                         goto loopdone;
11260                     }
11261
11262                     /* Here, the final non-problematic character is earlier
11263                      * in the input than the penultimate character.  What we do
11264                      * is reparse from the beginning, going up only as far as
11265                      * this final ok one, thus guaranteeing that the node ends
11266                      * in an acceptable character.  The reason we reparse is
11267                      * that we know how far in the character is, but we don't
11268                      * know how to correlate its position with the input parse.
11269                      * An alternate implementation would be to build that
11270                      * correlation as we go along during the original parse,
11271                      * but that would entail extra work for every node, whereas
11272                      * this code gets executed only when the string is too
11273                      * large for the node, and the final two characters are
11274                      * problematic, an infrequent occurrence.  Yet another
11275                      * possible strategy would be to save the tail of the
11276                      * string, and the next time regatom is called, initialize
11277                      * with that.  The problem with this is that unless you
11278                      * back off one more character, you won't be guaranteed
11279                      * regatom will get called again, unless regbranch,
11280                      * regpiece ... are also changed.  If you do back off that
11281                      * extra character, so that there is input guaranteed to
11282                      * force calling regatom, you can't handle the case where
11283                      * just the first character in the node is acceptable.  I
11284                      * (khw) decided to try this method which doesn't have that
11285                      * pitfall; if performance issues are found, we can do a
11286                      * combination of the current approach plus that one */
11287                     upper_parse = len;
11288                     len = 0;
11289                     s = s0;
11290                     goto reparse;
11291                 }
11292             }   /* End of verifying node ends with an appropriate char */
11293
11294         loopdone:   /* Jumped to when encounters something that shouldn't be in
11295                        the node */
11296
11297             /* If 'maybe_exact' is still set here, means there are no
11298              * code points in the node that participate in folds */
11299             if (FOLD && maybe_exact) {
11300                 OP(ret) = EXACT;
11301             }
11302
11303             /* I (khw) don't know if you can get here with zero length, but the
11304              * old code handled this situation by creating a zero-length EXACT
11305              * node.  Might as well be NOTHING instead */
11306             if (len == 0) {
11307                 OP(ret) = NOTHING;
11308             }
11309             else{
11310                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, len, ender);
11311             }
11312
11313             RExC_parse = p - 1;
11314             Set_Node_Cur_Length(ret); /* MJD */
11315             nextchar(pRExC_state);
11316             {
11317                 /* len is STRLEN which is unsigned, need to copy to signed */
11318                 IV iv = len;
11319                 if (iv < 0)
11320                     vFAIL("Internal disaster");
11321             }
11322
11323         } /* End of label 'defchar:' */
11324         break;
11325     } /* End of giant switch on input character */
11326
11327     return(ret);
11328 }
11329
11330 STATIC char *
11331 S_regwhite( RExC_state_t *pRExC_state, char *p )
11332 {
11333     const char *e = RExC_end;
11334
11335     PERL_ARGS_ASSERT_REGWHITE;
11336
11337     while (p < e) {
11338         if (isSPACE(*p))
11339             ++p;
11340         else if (*p == '#') {
11341             bool ended = 0;
11342             do {
11343                 if (*p++ == '\n') {
11344                     ended = 1;
11345                     break;
11346                 }
11347             } while (p < e);
11348             if (!ended)
11349                 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
11350         }
11351         else
11352             break;
11353     }
11354     return p;
11355 }
11356
11357 STATIC char *
11358 S_regpatws( RExC_state_t *pRExC_state, char *p , const bool recognize_comment )
11359 {
11360     /* Returns the next non-pattern-white space, non-comment character (the
11361      * latter only if 'recognize_comment is true) in the string p, which is
11362      * ended by RExC_end.  If there is no line break ending a comment,
11363      * RExC_seen has added the REG_SEEN_RUN_ON_COMMENT flag; */
11364     const char *e = RExC_end;
11365
11366     PERL_ARGS_ASSERT_REGPATWS;
11367
11368     while (p < e) {
11369         STRLEN len;
11370         if ((len = is_PATWS_safe(p, e, UTF))) {
11371             p += len;
11372         }
11373         else if (recognize_comment && *p == '#') {
11374             bool ended = 0;
11375             do {
11376                 p++;
11377                 if (is_LNBREAK_safe(p, e, UTF)) {
11378                     ended = 1;
11379                     break;
11380                 }
11381             } while (p < e);
11382             if (!ended)
11383                 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
11384         }
11385         else
11386             break;
11387     }
11388     return p;
11389 }
11390
11391 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
11392    Character classes ([:foo:]) can also be negated ([:^foo:]).
11393    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
11394    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
11395    but trigger failures because they are currently unimplemented. */
11396
11397 #define POSIXCC_DONE(c)   ((c) == ':')
11398 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
11399 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
11400
11401 PERL_STATIC_INLINE I32
11402 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value, const bool strict)
11403 {
11404     dVAR;
11405     I32 namedclass = OOB_NAMEDCLASS;
11406
11407     PERL_ARGS_ASSERT_REGPPOSIXCC;
11408
11409     if (value == '[' && RExC_parse + 1 < RExC_end &&
11410         /* I smell either [: or [= or [. -- POSIX has been here, right? */
11411         POSIXCC(UCHARAT(RExC_parse)))
11412     {
11413         const char c = UCHARAT(RExC_parse);
11414         char* const s = RExC_parse++;
11415
11416         while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
11417             RExC_parse++;
11418         if (RExC_parse == RExC_end) {
11419             if (strict) {
11420
11421                 /* Try to give a better location for the error (than the end of
11422                  * the string) by looking for the matching ']' */
11423                 RExC_parse = s;
11424                 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
11425                     RExC_parse++;
11426                 }
11427                 vFAIL2("Unmatched '%c' in POSIX class", c);
11428             }
11429             /* Grandfather lone [:, [=, [. */
11430             RExC_parse = s;
11431         }
11432         else {
11433             const char* const t = RExC_parse++; /* skip over the c */
11434             assert(*t == c);
11435
11436             if (UCHARAT(RExC_parse) == ']') {
11437                 const char *posixcc = s + 1;
11438                 RExC_parse++; /* skip over the ending ] */
11439
11440                 if (*s == ':') {
11441                     const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
11442                     const I32 skip = t - posixcc;
11443
11444                     /* Initially switch on the length of the name.  */
11445                     switch (skip) {
11446                     case 4:
11447                         if (memEQ(posixcc, "word", 4)) /* this is not POSIX,
11448                                                           this is the Perl \w
11449                                                         */
11450                             namedclass = ANYOF_WORDCHAR;
11451                         break;
11452                     case 5:
11453                         /* Names all of length 5.  */
11454                         /* alnum alpha ascii blank cntrl digit graph lower
11455                            print punct space upper  */
11456                         /* Offset 4 gives the best switch position.  */
11457                         switch (posixcc[4]) {
11458                         case 'a':
11459                             if (memEQ(posixcc, "alph", 4)) /* alpha */
11460                                 namedclass = ANYOF_ALPHA;
11461                             break;
11462                         case 'e':
11463                             if (memEQ(posixcc, "spac", 4)) /* space */
11464                                 namedclass = ANYOF_PSXSPC;
11465                             break;
11466                         case 'h':
11467                             if (memEQ(posixcc, "grap", 4)) /* graph */
11468                                 namedclass = ANYOF_GRAPH;
11469                             break;
11470                         case 'i':
11471                             if (memEQ(posixcc, "asci", 4)) /* ascii */
11472                                 namedclass = ANYOF_ASCII;
11473                             break;
11474                         case 'k':
11475                             if (memEQ(posixcc, "blan", 4)) /* blank */
11476                                 namedclass = ANYOF_BLANK;
11477                             break;
11478                         case 'l':
11479                             if (memEQ(posixcc, "cntr", 4)) /* cntrl */
11480                                 namedclass = ANYOF_CNTRL;
11481                             break;
11482                         case 'm':
11483                             if (memEQ(posixcc, "alnu", 4)) /* alnum */
11484                                 namedclass = ANYOF_ALPHANUMERIC;
11485                             break;
11486                         case 'r':
11487                             if (memEQ(posixcc, "lowe", 4)) /* lower */
11488                                 namedclass = (FOLD) ? ANYOF_CASED : ANYOF_LOWER;
11489                             else if (memEQ(posixcc, "uppe", 4)) /* upper */
11490                                 namedclass = (FOLD) ? ANYOF_CASED : ANYOF_UPPER;
11491                             break;
11492                         case 't':
11493                             if (memEQ(posixcc, "digi", 4)) /* digit */
11494                                 namedclass = ANYOF_DIGIT;
11495                             else if (memEQ(posixcc, "prin", 4)) /* print */
11496                                 namedclass = ANYOF_PRINT;
11497                             else if (memEQ(posixcc, "punc", 4)) /* punct */
11498                                 namedclass = ANYOF_PUNCT;
11499                             break;
11500                         }
11501                         break;
11502                     case 6:
11503                         if (memEQ(posixcc, "xdigit", 6))
11504                             namedclass = ANYOF_XDIGIT;
11505                         break;
11506                     }
11507
11508                     if (namedclass == OOB_NAMEDCLASS)
11509                         Simple_vFAIL3("POSIX class [:%.*s:] unknown",
11510                                       t - s - 1, s + 1);
11511
11512                     /* The #defines are structured so each complement is +1 to
11513                      * the normal one */
11514                     if (complement) {
11515                         namedclass++;
11516                     }
11517                     assert (posixcc[skip] == ':');
11518                     assert (posixcc[skip+1] == ']');
11519                 } else if (!SIZE_ONLY) {
11520                     /* [[=foo=]] and [[.foo.]] are still future. */
11521
11522                     /* adjust RExC_parse so the warning shows after
11523                        the class closes */
11524                     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
11525                         RExC_parse++;
11526                     vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
11527                 }
11528             } else {
11529                 /* Maternal grandfather:
11530                  * "[:" ending in ":" but not in ":]" */
11531                 if (strict) {
11532                     vFAIL("Unmatched '[' in POSIX class");
11533                 }
11534
11535                 /* Grandfather lone [:, [=, [. */
11536                 RExC_parse = s;
11537             }
11538         }
11539     }
11540
11541     return namedclass;
11542 }
11543
11544 STATIC bool
11545 S_could_it_be_a_POSIX_class(pTHX_ RExC_state_t *pRExC_state)
11546 {
11547     /* This applies some heuristics at the current parse position (which should
11548      * be at a '[') to see if what follows might be intended to be a [:posix:]
11549      * class.  It returns true if it really is a posix class, of course, but it
11550      * also can return true if it thinks that what was intended was a posix
11551      * class that didn't quite make it.
11552      *
11553      * It will return true for
11554      *      [:alphanumerics:
11555      *      [:alphanumerics]  (as long as the ] isn't followed immediately by a
11556      *                         ')' indicating the end of the (?[
11557      *      [:any garbage including %^&$ punctuation:]
11558      *
11559      * This is designed to be called only from S_handle_regex_sets; it could be
11560      * easily adapted to be called from the spot at the beginning of regclass()
11561      * that checks to see in a normal bracketed class if the surrounding []
11562      * have been omitted ([:word:] instead of [[:word:]]).  But doing so would
11563      * change long-standing behavior, so I (khw) didn't do that */
11564     char* p = RExC_parse + 1;
11565     char first_char = *p;
11566
11567     PERL_ARGS_ASSERT_COULD_IT_BE_A_POSIX_CLASS;
11568
11569     assert(*(p - 1) == '[');
11570
11571     if (! POSIXCC(first_char)) {
11572         return FALSE;
11573     }
11574
11575     p++;
11576     while (p < RExC_end && isWORDCHAR(*p)) p++;
11577
11578     if (p >= RExC_end) {
11579         return FALSE;
11580     }
11581
11582     if (p - RExC_parse > 2    /* Got at least 1 word character */
11583         && (*p == first_char
11584             || (*p == ']' && p + 1 < RExC_end && *(p + 1) != ')')))
11585     {
11586         return TRUE;
11587     }
11588
11589     p = (char *) memchr(RExC_parse, ']', RExC_end - RExC_parse);
11590
11591     return (p
11592             && p - RExC_parse > 2 /* [:] evaluates to colon;
11593                                       [::] is a bad posix class. */
11594             && first_char == *(p - 1));
11595 }
11596
11597 STATIC regnode *
11598 S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist, I32 *flagp, U32 depth,
11599                    char * const oregcomp_parse)
11600 {
11601     /* Handle the (?[...]) construct to do set operations */
11602
11603     U8 curchar;
11604     UV start, end;      /* End points of code point ranges */
11605     SV* result_string;
11606     char *save_end, *save_parse;
11607     SV* final;
11608     STRLEN len;
11609     regnode* node;
11610     AV* stack;
11611     const bool save_fold = FOLD;
11612
11613     GET_RE_DEBUG_FLAGS_DECL;
11614
11615     PERL_ARGS_ASSERT_HANDLE_REGEX_SETS;
11616
11617     if (LOC) {
11618         vFAIL("(?[...]) not valid in locale");
11619     }
11620     RExC_uni_semantics = 1;
11621
11622     /* This will return only an ANYOF regnode, or (unlikely) something smaller
11623      * (such as EXACT).  Thus we can skip most everything if just sizing.  We
11624      * call regclass to handle '[]' so as to not have to reinvent its parsing
11625      * rules here (throwing away the size it computes each time).  And, we exit
11626      * upon an unescaped ']' that isn't one ending a regclass.  To do both
11627      * these things, we need to realize that something preceded by a backslash
11628      * is escaped, so we have to keep track of backslashes */
11629     if (SIZE_ONLY) {
11630
11631         Perl_ck_warner_d(aTHX_
11632             packWARN(WARN_EXPERIMENTAL__REGEX_SETS),
11633             "The regex_sets feature is experimental" REPORT_LOCATION,
11634             (int) (RExC_parse - RExC_precomp) , RExC_precomp, RExC_parse);
11635
11636         while (RExC_parse < RExC_end) {
11637             SV* current = NULL;
11638             RExC_parse = regpatws(pRExC_state, RExC_parse,
11639                                 TRUE); /* means recognize comments */
11640             switch (*RExC_parse) {
11641                 default:
11642                     break;
11643                 case '\\':
11644                     /* Skip the next byte (which could cause us to end up in
11645                      * the middle of a UTF-8 character, but since none of those
11646                      * are confusable with anything we currently handle in this
11647                      * switch (invariants all), it's safe.  We'll just hit the
11648                      * default: case next time and keep on incrementing until
11649                      * we find one of the invariants we do handle. */
11650                     RExC_parse++;
11651                     break;
11652                 case '[':
11653                 {
11654                     /* If this looks like it is a [:posix:] class, leave the
11655                      * parse pointer at the '[' to fool regclass() into
11656                      * thinking it is part of a '[[:posix:]]'.  That function
11657                      * will use strict checking to force a syntax error if it
11658                      * doesn't work out to a legitimate class */
11659                     bool is_posix_class
11660                                     = could_it_be_a_POSIX_class(pRExC_state);
11661                     if (! is_posix_class) {
11662                         RExC_parse++;
11663                     }
11664
11665                     /* regclass() can only return RESTART_UTF8 if multi-char
11666                        folds are allowed.  */
11667                     if (!regclass(pRExC_state, flagp,depth+1,
11668                                   is_posix_class, /* parse the whole char
11669                                                      class only if not a
11670                                                      posix class */
11671                                   FALSE, /* don't allow multi-char folds */
11672                                   TRUE, /* silence non-portable warnings. */
11673                                   &current))
11674                         FAIL2("panic: regclass returned NULL to handle_sets, flags=%#X",
11675                               *flagp);
11676
11677                     /* function call leaves parse pointing to the ']', except
11678                      * if we faked it */
11679                     if (is_posix_class) {
11680                         RExC_parse--;
11681                     }
11682
11683                     SvREFCNT_dec(current);   /* In case it returned something */
11684                     break;
11685                 }
11686
11687                 case ']':
11688                     RExC_parse++;
11689                     if (RExC_parse < RExC_end
11690                         && *RExC_parse == ')')
11691                     {
11692                         node = reganode(pRExC_state, ANYOF, 0);
11693                         RExC_size += ANYOF_SKIP;
11694                         nextchar(pRExC_state);
11695                         Set_Node_Length(node,
11696                                 RExC_parse - oregcomp_parse + 1); /* MJD */
11697                         return node;
11698                     }
11699                     goto no_close;
11700             }
11701             RExC_parse++;
11702         }
11703
11704         no_close:
11705         FAIL("Syntax error in (?[...])");
11706     }
11707
11708     /* Pass 2 only after this.  Everything in this construct is a
11709      * metacharacter.  Operands begin with either a '\' (for an escape
11710      * sequence), or a '[' for a bracketed character class.  Any other
11711      * character should be an operator, or parenthesis for grouping.  Both
11712      * types of operands are handled by calling regclass() to parse them.  It
11713      * is called with a parameter to indicate to return the computed inversion
11714      * list.  The parsing here is implemented via a stack.  Each entry on the
11715      * stack is a single character representing one of the operators, or the
11716      * '('; or else a pointer to an operand inversion list. */
11717
11718 #define IS_OPERAND(a)  (! SvIOK(a))
11719
11720     /* The stack starts empty.  It is a syntax error if the first thing parsed
11721      * is a binary operator; everything else is pushed on the stack.  When an
11722      * operand is parsed, the top of the stack is examined.  If it is a binary
11723      * operator, the item before it should be an operand, and both are replaced
11724      * by the result of doing that operation on the new operand and the one on
11725      * the stack.   Thus a sequence of binary operands is reduced to a single
11726      * one before the next one is parsed.
11727      *
11728      * A unary operator may immediately follow a binary in the input, for
11729      * example
11730      *      [a] + ! [b]
11731      * When an operand is parsed and the top of the stack is a unary operator,
11732      * the operation is performed, and then the stack is rechecked to see if
11733      * this new operand is part of a binary operation; if so, it is handled as
11734      * above.
11735      *
11736      * A '(' is simply pushed on the stack; it is valid only if the stack is
11737      * empty, or the top element of the stack is an operator or another '('
11738      * (for which the parenthesized expression will become an operand).  By the
11739      * time the corresponding ')' is parsed everything in between should have
11740      * been parsed and evaluated to a single operand (or else is a syntax
11741      * error), and is handled as a regular operand */
11742
11743     stack = newAV();
11744
11745     while (RExC_parse < RExC_end) {
11746         I32 top_index = av_tindex(stack);
11747         SV** top_ptr;
11748         SV* current = NULL;
11749
11750         /* Skip white space */
11751         RExC_parse = regpatws(pRExC_state, RExC_parse,
11752                                 TRUE); /* means recognize comments */
11753         if (RExC_parse >= RExC_end) {
11754             Perl_croak(aTHX_ "panic: Read past end of '(?[ ])'");
11755         }
11756         if ((curchar = UCHARAT(RExC_parse)) == ']') {
11757             break;
11758         }
11759
11760         switch (curchar) {
11761
11762             case '?':
11763                 if (av_tindex(stack) >= 0   /* This makes sure that we can
11764                                                safely subtract 1 from
11765                                                RExC_parse in the next clause.
11766                                                If we have something on the
11767                                                stack, we have parsed something
11768                                              */
11769                     && UCHARAT(RExC_parse - 1) == '('
11770                     && RExC_parse < RExC_end)
11771                 {
11772                     /* If is a '(?', could be an embedded '(?flags:(?[...])'.
11773                      * This happens when we have some thing like
11774                      *
11775                      *   my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
11776                      *   ...
11777                      *   qr/(?[ \p{Digit} & $thai_or_lao ])/;
11778                      *
11779                      * Here we would be handling the interpolated
11780                      * '$thai_or_lao'.  We handle this by a recursive call to
11781                      * ourselves which returns the inversion list the
11782                      * interpolated expression evaluates to.  We use the flags
11783                      * from the interpolated pattern. */
11784                     U32 save_flags = RExC_flags;
11785                     const char * const save_parse = ++RExC_parse;
11786
11787                     parse_lparen_question_flags(pRExC_state);
11788
11789                     if (RExC_parse == save_parse  /* Makes sure there was at
11790                                                      least one flag (or this
11791                                                      embedding wasn't compiled)
11792                                                    */
11793                         || RExC_parse >= RExC_end - 4
11794                         || UCHARAT(RExC_parse) != ':'
11795                         || UCHARAT(++RExC_parse) != '('
11796                         || UCHARAT(++RExC_parse) != '?'
11797                         || UCHARAT(++RExC_parse) != '[')
11798                     {
11799
11800                         /* In combination with the above, this moves the
11801                          * pointer to the point just after the first erroneous
11802                          * character (or if there are no flags, to where they
11803                          * should have been) */
11804                         if (RExC_parse >= RExC_end - 4) {
11805                             RExC_parse = RExC_end;
11806                         }
11807                         else if (RExC_parse != save_parse) {
11808                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
11809                         }
11810                         vFAIL("Expecting '(?flags:(?[...'");
11811                     }
11812                     RExC_parse++;
11813                     (void) handle_regex_sets(pRExC_state, &current, flagp,
11814                                                     depth+1, oregcomp_parse);
11815
11816                     /* Here, 'current' contains the embedded expression's
11817                      * inversion list, and RExC_parse points to the trailing
11818                      * ']'; the next character should be the ')' which will be
11819                      * paired with the '(' that has been put on the stack, so
11820                      * the whole embedded expression reduces to '(operand)' */
11821                     RExC_parse++;
11822
11823                     RExC_flags = save_flags;
11824                     goto handle_operand;
11825                 }
11826                 /* FALL THROUGH */
11827
11828             default:
11829                 RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
11830                 vFAIL("Unexpected character");
11831
11832             case '\\':
11833                 /* regclass() can only return RESTART_UTF8 if multi-char
11834                    folds are allowed.  */
11835                 if (!regclass(pRExC_state, flagp,depth+1,
11836                               TRUE, /* means parse just the next thing */
11837                               FALSE, /* don't allow multi-char folds */
11838                               FALSE, /* don't silence non-portable warnings.  */
11839                               &current))
11840                     FAIL2("panic: regclass returned NULL to handle_sets, flags=%#X",
11841                           *flagp);
11842                 /* regclass() will return with parsing just the \ sequence,
11843                  * leaving the parse pointer at the next thing to parse */
11844                 RExC_parse--;
11845                 goto handle_operand;
11846
11847             case '[':   /* Is a bracketed character class */
11848             {
11849                 bool is_posix_class = could_it_be_a_POSIX_class(pRExC_state);
11850
11851                 if (! is_posix_class) {
11852                     RExC_parse++;
11853                 }
11854
11855                 /* regclass() can only return RESTART_UTF8 if multi-char
11856                    folds are allowed.  */
11857                 if(!regclass(pRExC_state, flagp,depth+1,
11858                              is_posix_class, /* parse the whole char class
11859                                                 only if not a posix class */
11860                              FALSE, /* don't allow multi-char folds */
11861                              FALSE, /* don't silence non-portable warnings.  */
11862                              &current))
11863                     FAIL2("panic: regclass returned NULL to handle_sets, flags=%#X",
11864                           *flagp);
11865                 /* function call leaves parse pointing to the ']', except if we
11866                  * faked it */
11867                 if (is_posix_class) {
11868                     RExC_parse--;
11869                 }
11870
11871                 goto handle_operand;
11872             }
11873
11874             case '&':
11875             case '|':
11876             case '+':
11877             case '-':
11878             case '^':
11879                 if (top_index < 0
11880                     || ( ! (top_ptr = av_fetch(stack, top_index, FALSE)))
11881                     || ! IS_OPERAND(*top_ptr))
11882                 {
11883                     RExC_parse++;
11884                     vFAIL2("Unexpected binary operator '%c' with no preceding operand", curchar);
11885                 }
11886                 av_push(stack, newSVuv(curchar));
11887                 break;
11888
11889             case '!':
11890                 av_push(stack, newSVuv(curchar));
11891                 break;
11892
11893             case '(':
11894                 if (top_index >= 0) {
11895                     top_ptr = av_fetch(stack, top_index, FALSE);
11896                     assert(top_ptr);
11897                     if (IS_OPERAND(*top_ptr)) {
11898                         RExC_parse++;
11899                         vFAIL("Unexpected '(' with no preceding operator");
11900                     }
11901                 }
11902                 av_push(stack, newSVuv(curchar));
11903                 break;
11904
11905             case ')':
11906             {
11907                 SV* lparen;
11908                 if (top_index < 1
11909                     || ! (current = av_pop(stack))
11910                     || ! IS_OPERAND(current)
11911                     || ! (lparen = av_pop(stack))
11912                     || IS_OPERAND(lparen)
11913                     || SvUV(lparen) != '(')
11914                 {
11915                     RExC_parse++;
11916                     vFAIL("Unexpected ')'");
11917                 }
11918                 top_index -= 2;
11919                 SvREFCNT_dec_NN(lparen);
11920
11921                 /* FALL THROUGH */
11922             }
11923
11924               handle_operand:
11925
11926                 /* Here, we have an operand to process, in 'current' */
11927
11928                 if (top_index < 0) {    /* Just push if stack is empty */
11929                     av_push(stack, current);
11930                 }
11931                 else {
11932                     SV* top = av_pop(stack);
11933                     char current_operator;
11934
11935                     if (IS_OPERAND(top)) {
11936                         vFAIL("Operand with no preceding operator");
11937                     }
11938                     current_operator = (char) SvUV(top);
11939                     switch (current_operator) {
11940                         case '(':   /* Push the '(' back on followed by the new
11941                                        operand */
11942                             av_push(stack, top);
11943                             av_push(stack, current);
11944                             SvREFCNT_inc(top);  /* Counters the '_dec' done
11945                                                    just after the 'break', so
11946                                                    it doesn't get wrongly freed
11947                                                  */
11948                             break;
11949
11950                         case '!':
11951                             _invlist_invert(current);
11952
11953                             /* Unlike binary operators, the top of the stack,
11954                              * now that this unary one has been popped off, may
11955                              * legally be an operator, and we now have operand
11956                              * for it. */
11957                             top_index--;
11958                             SvREFCNT_dec_NN(top);
11959                             goto handle_operand;
11960
11961                         case '&':
11962                             _invlist_intersection(av_pop(stack),
11963                                                    current,
11964                                                    &current);
11965                             av_push(stack, current);
11966                             break;
11967
11968                         case '|':
11969                         case '+':
11970                             _invlist_union(av_pop(stack), current, &current);
11971                             av_push(stack, current);
11972                             break;
11973
11974                         case '-':
11975                             _invlist_subtract(av_pop(stack), current, &current);
11976                             av_push(stack, current);
11977                             break;
11978
11979                         case '^':   /* The union minus the intersection */
11980                         {
11981                             SV* i = NULL;
11982                             SV* u = NULL;
11983                             SV* element;
11984
11985                             element = av_pop(stack);
11986                             _invlist_union(element, current, &u);
11987                             _invlist_intersection(element, current, &i);
11988                             _invlist_subtract(u, i, &current);
11989                             av_push(stack, current);
11990                             SvREFCNT_dec_NN(i);
11991                             SvREFCNT_dec_NN(u);
11992                             SvREFCNT_dec_NN(element);
11993                             break;
11994                         }
11995
11996                         default:
11997                             Perl_croak(aTHX_ "panic: Unexpected item on '(?[ ])' stack");
11998                 }
11999                 SvREFCNT_dec_NN(top);
12000             }
12001         }
12002
12003         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
12004     }
12005
12006     if (av_tindex(stack) < 0   /* Was empty */
12007         || ((final = av_pop(stack)) == NULL)
12008         || ! IS_OPERAND(final)
12009         || av_tindex(stack) >= 0)  /* More left on stack */
12010     {
12011         vFAIL("Incomplete expression within '(?[ ])'");
12012     }
12013
12014     /* Here, 'final' is the resultant inversion list from evaluating the
12015      * expression.  Return it if so requested */
12016     if (return_invlist) {
12017         *return_invlist = final;
12018         return END;
12019     }
12020
12021     /* Otherwise generate a resultant node, based on 'final'.  regclass() is
12022      * expecting a string of ranges and individual code points */
12023     invlist_iterinit(final);
12024     result_string = newSVpvs("");
12025     while (invlist_iternext(final, &start, &end)) {
12026         if (start == end) {
12027             Perl_sv_catpvf(aTHX_ result_string, "\\x{%"UVXf"}", start);
12028         }
12029         else {
12030             Perl_sv_catpvf(aTHX_ result_string, "\\x{%"UVXf"}-\\x{%"UVXf"}",
12031                                                      start,          end);
12032         }
12033     }
12034
12035     save_parse = RExC_parse;
12036     RExC_parse = SvPV(result_string, len);
12037     save_end = RExC_end;
12038     RExC_end = RExC_parse + len;
12039
12040     /* We turn off folding around the call, as the class we have constructed
12041      * already has all folding taken into consideration, and we don't want
12042      * regclass() to add to that */
12043     RExC_flags &= ~RXf_PMf_FOLD;
12044     /* regclass() can only return RESTART_UTF8 if multi-char folds are allowed.
12045      */
12046     node = regclass(pRExC_state, flagp,depth+1,
12047                     FALSE, /* means parse the whole char class */
12048                     FALSE, /* don't allow multi-char folds */
12049                     TRUE, /* silence non-portable warnings.  The above may very
12050                              well have generated non-portable code points, but
12051                              they're valid on this machine */
12052                     NULL);
12053     if (!node)
12054         FAIL2("panic: regclass returned NULL to handle_sets, flags=%#"UVxf,
12055                     PTR2UV(flagp));
12056     if (save_fold) {
12057         RExC_flags |= RXf_PMf_FOLD;
12058     }
12059     RExC_parse = save_parse + 1;
12060     RExC_end = save_end;
12061     SvREFCNT_dec_NN(final);
12062     SvREFCNT_dec_NN(result_string);
12063     SvREFCNT_dec_NN(stack);
12064
12065     nextchar(pRExC_state);
12066     Set_Node_Length(node, RExC_parse - oregcomp_parse + 1); /* MJD */
12067     return node;
12068 }
12069 #undef IS_OPERAND
12070
12071 /* The names of properties whose definitions are not known at compile time are
12072  * stored in this SV, after a constant heading.  So if the length has been
12073  * changed since initialization, then there is a run-time definition. */
12074 #define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION (SvCUR(listsv) != initial_listsv_len)
12075
12076 STATIC regnode *
12077 S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
12078                  const bool stop_at_1,  /* Just parse the next thing, don't
12079                                            look for a full character class */
12080                  bool allow_multi_folds,
12081                  const bool silence_non_portable,   /* Don't output warnings
12082                                                        about too large
12083                                                        characters */
12084                  SV** ret_invlist)  /* Return an inversion list, not a node */
12085 {
12086     /* parse a bracketed class specification.  Most of these will produce an
12087      * ANYOF node; but something like [a] will produce an EXACT node; [aA], an
12088      * EXACTFish node; [[:ascii:]], a POSIXA node; etc.  It is more complex
12089      * under /i with multi-character folds: it will be rewritten following the
12090      * paradigm of this example, where the <multi-fold>s are characters which
12091      * fold to multiple character sequences:
12092      *      /[abc\x{multi-fold1}def\x{multi-fold2}ghi]/i
12093      * gets effectively rewritten as:
12094      *      /(?:\x{multi-fold1}|\x{multi-fold2}|[abcdefghi]/i
12095      * reg() gets called (recursively) on the rewritten version, and this
12096      * function will return what it constructs.  (Actually the <multi-fold>s
12097      * aren't physically removed from the [abcdefghi], it's just that they are
12098      * ignored in the recursion by means of a flag:
12099      * <RExC_in_multi_char_class>.)
12100      *
12101      * ANYOF nodes contain a bit map for the first 256 characters, with the
12102      * corresponding bit set if that character is in the list.  For characters
12103      * above 255, a range list or swash is used.  There are extra bits for \w,
12104      * etc. in locale ANYOFs, as what these match is not determinable at
12105      * compile time
12106      *
12107      * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs
12108      * to be restarted.  This can only happen if ret_invlist is non-NULL.
12109      */
12110
12111     dVAR;
12112     UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE;
12113     IV range = 0;
12114     UV value = OOB_UNICODE, save_value = OOB_UNICODE;
12115     regnode *ret;
12116     STRLEN numlen;
12117     IV namedclass = OOB_NAMEDCLASS;
12118     char *rangebegin = NULL;
12119     bool need_class = 0;
12120     SV *listsv = NULL;
12121     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
12122                                       than just initialized.  */
12123     SV* properties = NULL;    /* Code points that match \p{} \P{} */
12124     SV* posixes = NULL;     /* Code points that match classes like, [:word:],
12125                                extended beyond the Latin1 range */
12126     UV element_count = 0;   /* Number of distinct elements in the class.
12127                                Optimizations may be possible if this is tiny */
12128     AV * multi_char_matches = NULL; /* Code points that fold to more than one
12129                                        character; used under /i */
12130     UV n;
12131     char * stop_ptr = RExC_end;    /* where to stop parsing */
12132     const bool skip_white = cBOOL(ret_invlist); /* ignore unescaped white
12133                                                    space? */
12134     const bool strict = cBOOL(ret_invlist); /* Apply strict parsing rules? */
12135
12136     /* Unicode properties are stored in a swash; this holds the current one
12137      * being parsed.  If this swash is the only above-latin1 component of the
12138      * character class, an optimization is to pass it directly on to the
12139      * execution engine.  Otherwise, it is set to NULL to indicate that there
12140      * are other things in the class that have to be dealt with at execution
12141      * time */
12142     SV* swash = NULL;           /* Code points that match \p{} \P{} */
12143
12144     /* Set if a component of this character class is user-defined; just passed
12145      * on to the engine */
12146     bool has_user_defined_property = FALSE;
12147
12148     /* inversion list of code points this node matches only when the target
12149      * string is in UTF-8.  (Because is under /d) */
12150     SV* depends_list = NULL;
12151
12152     /* inversion list of code points this node matches.  For much of the
12153      * function, it includes only those that match regardless of the utf8ness
12154      * of the target string */
12155     SV* cp_list = NULL;
12156
12157 #ifdef EBCDIC
12158     /* In a range, counts how many 0-2 of the ends of it came from literals,
12159      * not escapes.  Thus we can tell if 'A' was input vs \x{C1} */
12160     UV literal_endpoint = 0;
12161 #endif
12162     bool invert = FALSE;    /* Is this class to be complemented */
12163
12164     /* Is there any thing like \W or [:^digit:] that matches above the legal
12165      * Unicode range? */
12166     bool runtime_posix_matches_above_Unicode = FALSE;
12167
12168     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
12169         case we need to change the emitted regop to an EXACT. */
12170     const char * orig_parse = RExC_parse;
12171     const I32 orig_size = RExC_size;
12172     GET_RE_DEBUG_FLAGS_DECL;
12173
12174     PERL_ARGS_ASSERT_REGCLASS;
12175 #ifndef DEBUGGING
12176     PERL_UNUSED_ARG(depth);
12177 #endif
12178
12179     DEBUG_PARSE("clas");
12180
12181     /* Assume we are going to generate an ANYOF node. */
12182     ret = reganode(pRExC_state, ANYOF, 0);
12183
12184     if (SIZE_ONLY) {
12185         RExC_size += ANYOF_SKIP;
12186         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
12187     }
12188     else {
12189         ANYOF_FLAGS(ret) = 0;
12190
12191         RExC_emit += ANYOF_SKIP;
12192         if (LOC) {
12193             ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
12194         }
12195         listsv = newSVpvs_flags("# comment\n", SVs_TEMP);
12196         initial_listsv_len = SvCUR(listsv);
12197         SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated.  */
12198     }
12199
12200     if (skip_white) {
12201         RExC_parse = regpatws(pRExC_state, RExC_parse,
12202                               FALSE /* means don't recognize comments */);
12203     }
12204
12205     if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
12206         RExC_parse++;
12207         invert = TRUE;
12208         allow_multi_folds = FALSE;
12209         RExC_naughty++;
12210         if (skip_white) {
12211             RExC_parse = regpatws(pRExC_state, RExC_parse,
12212                                   FALSE /* means don't recognize comments */);
12213         }
12214     }
12215
12216     /* Check that they didn't say [:posix:] instead of [[:posix:]] */
12217     if (!SIZE_ONLY && RExC_parse < RExC_end && POSIXCC(UCHARAT(RExC_parse))) {
12218         const char *s = RExC_parse;
12219         const char  c = *s++;
12220
12221         while (isWORDCHAR(*s))
12222             s++;
12223         if (*s && c == *s && s[1] == ']') {
12224             SAVEFREESV(RExC_rx_sv);
12225             ckWARN3reg(s+2,
12226                        "POSIX syntax [%c %c] belongs inside character classes",
12227                        c, c);
12228             (void)ReREFCNT_inc(RExC_rx_sv);
12229         }
12230     }
12231
12232     /* If the caller wants us to just parse a single element, accomplish this
12233      * by faking the loop ending condition */
12234     if (stop_at_1 && RExC_end > RExC_parse) {
12235         stop_ptr = RExC_parse + 1;
12236     }
12237
12238     /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */
12239     if (UCHARAT(RExC_parse) == ']')
12240         goto charclassloop;
12241
12242 parseit:
12243     while (1) {
12244         if  (RExC_parse >= stop_ptr) {
12245             break;
12246         }
12247
12248         if (skip_white) {
12249             RExC_parse = regpatws(pRExC_state, RExC_parse,
12250                                   FALSE /* means don't recognize comments */);
12251         }
12252
12253         if  (UCHARAT(RExC_parse) == ']') {
12254             break;
12255         }
12256
12257     charclassloop:
12258
12259         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
12260         save_value = value;
12261         save_prevvalue = prevvalue;
12262
12263         if (!range) {
12264             rangebegin = RExC_parse;
12265             element_count++;
12266         }
12267         if (UTF) {
12268             value = utf8n_to_uvchr((U8*)RExC_parse,
12269                                    RExC_end - RExC_parse,
12270                                    &numlen, UTF8_ALLOW_DEFAULT);
12271             RExC_parse += numlen;
12272         }
12273         else
12274             value = UCHARAT(RExC_parse++);
12275
12276         if (value == '['
12277             && RExC_parse < RExC_end
12278             && POSIXCC(UCHARAT(RExC_parse)))
12279         {
12280             namedclass = regpposixcc(pRExC_state, value, strict);
12281         }
12282         else if (value == '\\') {
12283             if (UTF) {
12284                 value = utf8n_to_uvchr((U8*)RExC_parse,
12285                                    RExC_end - RExC_parse,
12286                                    &numlen, UTF8_ALLOW_DEFAULT);
12287                 RExC_parse += numlen;
12288             }
12289             else
12290                 value = UCHARAT(RExC_parse++);
12291
12292             /* Some compilers cannot handle switching on 64-bit integer
12293              * values, therefore value cannot be an UV.  Yes, this will
12294              * be a problem later if we want switch on Unicode.
12295              * A similar issue a little bit later when switching on
12296              * namedclass. --jhi */
12297
12298             /* If the \ is escaping white space when white space is being
12299              * skipped, it means that that white space is wanted literally, and
12300              * is already in 'value'.  Otherwise, need to translate the escape
12301              * into what it signifies. */
12302             if (! skip_white || ! is_PATWS_cp(value)) switch ((I32)value) {
12303
12304             case 'w':   namedclass = ANYOF_WORDCHAR;    break;
12305             case 'W':   namedclass = ANYOF_NWORDCHAR;   break;
12306             case 's':   namedclass = ANYOF_SPACE;       break;
12307             case 'S':   namedclass = ANYOF_NSPACE;      break;
12308             case 'd':   namedclass = ANYOF_DIGIT;       break;
12309             case 'D':   namedclass = ANYOF_NDIGIT;      break;
12310             case 'v':   namedclass = ANYOF_VERTWS;      break;
12311             case 'V':   namedclass = ANYOF_NVERTWS;     break;
12312             case 'h':   namedclass = ANYOF_HORIZWS;     break;
12313             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
12314             case 'N':  /* Handle \N{NAME} in class */
12315                 {
12316                     /* We only pay attention to the first char of 
12317                     multichar strings being returned. I kinda wonder
12318                     if this makes sense as it does change the behaviour
12319                     from earlier versions, OTOH that behaviour was broken
12320                     as well. */
12321                     if (! grok_bslash_N(pRExC_state, NULL, &value, flagp, depth,
12322                                       TRUE, /* => charclass */
12323                                       strict))
12324                     {
12325                         if (*flagp & RESTART_UTF8)
12326                             FAIL("panic: grok_bslash_N set RESTART_UTF8");
12327                         goto parseit;
12328                     }
12329                 }
12330                 break;
12331             case 'p':
12332             case 'P':
12333                 {
12334                 char *e;
12335
12336                 /* We will handle any undefined properties ourselves */
12337                 U8 swash_init_flags = _CORE_SWASH_INIT_RETURN_IF_UNDEF;
12338
12339                 if (RExC_parse >= RExC_end)
12340                     vFAIL2("Empty \\%c{}", (U8)value);
12341                 if (*RExC_parse == '{') {
12342                     const U8 c = (U8)value;
12343                     e = strchr(RExC_parse++, '}');
12344                     if (!e)
12345                         vFAIL2("Missing right brace on \\%c{}", c);
12346                     while (isSPACE(UCHARAT(RExC_parse)))
12347                         RExC_parse++;
12348                     if (e == RExC_parse)
12349                         vFAIL2("Empty \\%c{}", c);
12350                     n = e - RExC_parse;
12351                     while (isSPACE(UCHARAT(RExC_parse + n - 1)))
12352                         n--;
12353                 }
12354                 else {
12355                     e = RExC_parse;
12356                     n = 1;
12357                 }
12358                 if (!SIZE_ONLY) {
12359                     SV* invlist;
12360                     char* name;
12361
12362                     if (UCHARAT(RExC_parse) == '^') {
12363                          RExC_parse++;
12364                          n--;
12365                          /* toggle.  (The rhs xor gets the single bit that
12366                           * differs between P and p; the other xor inverts just
12367                           * that bit) */
12368                          value ^= 'P' ^ 'p';
12369
12370                          while (isSPACE(UCHARAT(RExC_parse))) {
12371                               RExC_parse++;
12372                               n--;
12373                          }
12374                     }
12375                     /* Try to get the definition of the property into
12376                      * <invlist>.  If /i is in effect, the effective property
12377                      * will have its name be <__NAME_i>.  The design is
12378                      * discussed in commit
12379                      * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
12380                     Newx(name, n + sizeof("_i__\n"), char);
12381
12382                     sprintf(name, "%s%.*s%s\n",
12383                                     (FOLD) ? "__" : "",
12384                                     (int)n,
12385                                     RExC_parse,
12386                                     (FOLD) ? "_i" : ""
12387                     );
12388
12389                     /* Look up the property name, and get its swash and
12390                      * inversion list, if the property is found  */
12391                     if (swash) {
12392                         SvREFCNT_dec_NN(swash);
12393                     }
12394                     swash = _core_swash_init("utf8", name, &PL_sv_undef,
12395                                              1, /* binary */
12396                                              0, /* not tr/// */
12397                                              NULL, /* No inversion list */
12398                                              &swash_init_flags
12399                                             );
12400                     if (! swash || ! (invlist = _get_swash_invlist(swash))) {
12401                         if (swash) {
12402                             SvREFCNT_dec_NN(swash);
12403                             swash = NULL;
12404                         }
12405
12406                         /* Here didn't find it.  It could be a user-defined
12407                          * property that will be available at run-time.  If we
12408                          * accept only compile-time properties, is an error;
12409                          * otherwise add it to the list for run-time look up */
12410                         if (ret_invlist) {
12411                             RExC_parse = e + 1;
12412                             vFAIL3("Property '%.*s' is unknown", (int) n, name);
12413                         }
12414                         Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s\n",
12415                                         (value == 'p' ? '+' : '!'),
12416                                         name);
12417                         has_user_defined_property = TRUE;
12418
12419                         /* We don't know yet, so have to assume that the
12420                          * property could match something in the Latin1 range,
12421                          * hence something that isn't utf8.  Note that this
12422                          * would cause things in <depends_list> to match
12423                          * inappropriately, except that any \p{}, including
12424                          * this one forces Unicode semantics, which means there
12425                          * is <no depends_list> */
12426                         ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
12427                     }
12428                     else {
12429
12430                         /* Here, did get the swash and its inversion list.  If
12431                          * the swash is from a user-defined property, then this
12432                          * whole character class should be regarded as such */
12433                         has_user_defined_property =
12434                                     (swash_init_flags
12435                                      & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY);
12436
12437                         /* Invert if asking for the complement */
12438                         if (value == 'P') {
12439                             _invlist_union_complement_2nd(properties,
12440                                                           invlist,
12441                                                           &properties);
12442
12443                             /* The swash can't be used as-is, because we've
12444                              * inverted things; delay removing it to here after
12445                              * have copied its invlist above */
12446                             SvREFCNT_dec_NN(swash);
12447                             swash = NULL;
12448                         }
12449                         else {
12450                             _invlist_union(properties, invlist, &properties);
12451                         }
12452                     }
12453                     Safefree(name);
12454                 }
12455                 RExC_parse = e + 1;
12456                 namedclass = ANYOF_UNIPROP;  /* no official name, but it's
12457                                                 named */
12458
12459                 /* \p means they want Unicode semantics */
12460                 RExC_uni_semantics = 1;
12461                 }
12462                 break;
12463             case 'n':   value = '\n';                   break;
12464             case 'r':   value = '\r';                   break;
12465             case 't':   value = '\t';                   break;
12466             case 'f':   value = '\f';                   break;
12467             case 'b':   value = '\b';                   break;
12468             case 'e':   value = ASCII_TO_NATIVE('\033');break;
12469             case 'a':   value = ASCII_TO_NATIVE('\007');break;
12470             case 'o':
12471                 RExC_parse--;   /* function expects to be pointed at the 'o' */
12472                 {
12473                     const char* error_msg;
12474                     bool valid = grok_bslash_o(&RExC_parse,
12475                                                &value,
12476                                                &error_msg,
12477                                                SIZE_ONLY,   /* warnings in pass
12478                                                                1 only */
12479                                                strict,
12480                                                silence_non_portable,
12481                                                UTF);
12482                     if (! valid) {
12483                         vFAIL(error_msg);
12484                     }
12485                 }
12486                 if (PL_encoding && value < 0x100) {
12487                     goto recode_encoding;
12488                 }
12489                 break;
12490             case 'x':
12491                 RExC_parse--;   /* function expects to be pointed at the 'x' */
12492                 {
12493                     const char* error_msg;
12494                     bool valid = grok_bslash_x(&RExC_parse,
12495                                                &value,
12496                                                &error_msg,
12497                                                TRUE, /* Output warnings */
12498                                                strict,
12499                                                silence_non_portable,
12500                                                UTF);
12501                     if (! valid) {
12502                         vFAIL(error_msg);
12503                     }
12504                 }
12505                 if (PL_encoding && value < 0x100)
12506                     goto recode_encoding;
12507                 break;
12508             case 'c':
12509                 value = grok_bslash_c(*RExC_parse++, UTF, SIZE_ONLY);
12510                 break;
12511             case '0': case '1': case '2': case '3': case '4':
12512             case '5': case '6': case '7':
12513                 {
12514                     /* Take 1-3 octal digits */
12515                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
12516                     numlen = (strict) ? 4 : 3;
12517                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
12518                     RExC_parse += numlen;
12519                     if (numlen != 3) {
12520                         if (strict) {
12521                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
12522                             vFAIL("Need exactly 3 octal digits");
12523                         }
12524                         else if (! SIZE_ONLY /* like \08, \178 */
12525                                  && numlen < 3
12526                                  && RExC_parse < RExC_end
12527                                  && isDIGIT(*RExC_parse)
12528                                  && ckWARN(WARN_REGEXP))
12529                         {
12530                             SAVEFREESV(RExC_rx_sv);
12531                             reg_warn_non_literal_string(
12532                                  RExC_parse + 1,
12533                                  form_short_octal_warning(RExC_parse, numlen));
12534                             (void)ReREFCNT_inc(RExC_rx_sv);
12535                         }
12536                     }
12537                     if (PL_encoding && value < 0x100)
12538                         goto recode_encoding;
12539                     break;
12540                 }
12541             recode_encoding:
12542                 if (! RExC_override_recoding) {
12543                     SV* enc = PL_encoding;
12544                     value = reg_recode((const char)(U8)value, &enc);
12545                     if (!enc) {
12546                         if (strict) {
12547                             vFAIL("Invalid escape in the specified encoding");
12548                         }
12549                         else if (SIZE_ONLY) {
12550                             ckWARNreg(RExC_parse,
12551                                   "Invalid escape in the specified encoding");
12552                         }
12553                     }
12554                     break;
12555                 }
12556             default:
12557                 /* Allow \_ to not give an error */
12558                 if (!SIZE_ONLY && isWORDCHAR(value) && value != '_') {
12559                     if (strict) {
12560                         vFAIL2("Unrecognized escape \\%c in character class",
12561                                (int)value);
12562                     }
12563                     else {
12564                         SAVEFREESV(RExC_rx_sv);
12565                         ckWARN2reg(RExC_parse,
12566                             "Unrecognized escape \\%c in character class passed through",
12567                             (int)value);
12568                         (void)ReREFCNT_inc(RExC_rx_sv);
12569                     }
12570                 }
12571                 break;
12572             }   /* End of switch on char following backslash */
12573         } /* end of handling backslash escape sequences */
12574 #ifdef EBCDIC
12575         else
12576             literal_endpoint++;
12577 #endif
12578
12579         /* Here, we have the current token in 'value' */
12580
12581         /* What matches in a locale is not known until runtime.  This includes
12582          * what the Posix classes (like \w, [:space:]) match.  Room must be
12583          * reserved (one time per class) to store such classes, either if Perl
12584          * is compiled so that locale nodes always should have this space, or
12585          * if there is such class info to be stored.  The space will contain a
12586          * bit for each named class that is to be matched against.  This isn't
12587          * needed for \p{} and pseudo-classes, as they are not affected by
12588          * locale, and hence are dealt with separately */
12589         if (LOC
12590             && ! need_class
12591             && (ANYOF_LOCALE == ANYOF_CLASS
12592                 || (namedclass > OOB_NAMEDCLASS && namedclass < ANYOF_MAX)))
12593         {
12594             need_class = 1;
12595             if (SIZE_ONLY) {
12596                 RExC_size += ANYOF_CLASS_SKIP - ANYOF_SKIP;
12597             }
12598             else {
12599                 RExC_emit += ANYOF_CLASS_SKIP - ANYOF_SKIP;
12600                 ANYOF_CLASS_ZERO(ret);
12601             }
12602             ANYOF_FLAGS(ret) |= ANYOF_CLASS;
12603         }
12604
12605         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
12606
12607             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
12608              * literal, as is the character that began the false range, i.e.
12609              * the 'a' in the examples */
12610             if (range) {
12611                 if (!SIZE_ONLY) {
12612                     const int w = (RExC_parse >= rangebegin)
12613                                   ? RExC_parse - rangebegin
12614                                   : 0;
12615                     if (strict) {
12616                         vFAIL4("False [] range \"%*.*s\"", w, w, rangebegin);
12617                     }
12618                     else {
12619                         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
12620                         ckWARN4reg(RExC_parse,
12621                                 "False [] range \"%*.*s\"",
12622                                 w, w, rangebegin);
12623                         (void)ReREFCNT_inc(RExC_rx_sv);
12624                         cp_list = add_cp_to_invlist(cp_list, '-');
12625                         cp_list = add_cp_to_invlist(cp_list, prevvalue);
12626                     }
12627                 }
12628
12629                 range = 0; /* this was not a true range */
12630                 element_count += 2; /* So counts for three values */
12631             }
12632
12633             if (! SIZE_ONLY) {
12634                 U8 classnum = namedclass_to_classnum(namedclass);
12635                 if (namedclass >= ANYOF_MAX) {  /* If a special class */
12636                     if (namedclass != ANYOF_UNIPROP) { /* UNIPROP = \p and \P */
12637
12638                         /* Here, should be \h, \H, \v, or \V.  Neither /d nor
12639                          * /l make a difference in what these match.  There
12640                          * would be problems if these characters had folds
12641                          * other than themselves, as cp_list is subject to
12642                          * folding. */
12643                         if (classnum != _CC_VERTSPACE) {
12644                             assert(   namedclass == ANYOF_HORIZWS
12645                                    || namedclass == ANYOF_NHORIZWS);
12646
12647                             /* It turns out that \h is just a synonym for
12648                              * XPosixBlank */
12649                             classnum = _CC_BLANK;
12650                         }
12651
12652                         _invlist_union_maybe_complement_2nd(
12653                                 cp_list,
12654                                 PL_XPosix_ptrs[classnum],
12655                                 cBOOL(namedclass % 2), /* Complement if odd
12656                                                           (NHORIZWS, NVERTWS)
12657                                                         */
12658                                 &cp_list);
12659                     }
12660                 }
12661                 else if (classnum == _CC_ASCII) {
12662 #ifdef HAS_ISASCII
12663                     if (LOC) {
12664                         ANYOF_CLASS_SET(ret, namedclass);
12665                     }
12666                     else
12667 #endif  /* Not isascii(); just use the hard-coded definition for it */
12668                         _invlist_union_maybe_complement_2nd(
12669                                 posixes,
12670                                 PL_ASCII,
12671                                 cBOOL(namedclass % 2), /* Complement if odd
12672                                                           (NASCII) */
12673                                 &posixes);
12674                 }
12675                 else {  /* Garden variety class */
12676
12677                     /* The ascii range inversion list */
12678                     SV* ascii_source = PL_Posix_ptrs[classnum];
12679
12680                     /* The full Latin1 range inversion list */
12681                     SV* l1_source = PL_L1Posix_ptrs[classnum];
12682
12683                     /* This code is structured into two major clauses.  The
12684                      * first is for classes whose complete definitions may not
12685                      * already be known.  It not, the Latin1 definition
12686                      * (guaranteed to already known) is used plus code is
12687                      * generated to load the rest at run-time (only if needed).
12688                      * If the complete definition is known, it drops down to
12689                      * the second clause, where the complete definition is
12690                      * known */
12691
12692                     if (classnum < _FIRST_NON_SWASH_CC) {
12693
12694                         /* Here, the class has a swash, which may or not
12695                          * already be loaded */
12696
12697                         /* The name of the property to use to match the full
12698                          * eXtended Unicode range swash for this character
12699                          * class */
12700                         const char *Xname = swash_property_names[classnum];
12701
12702                         /* If returning the inversion list, we can't defer
12703                          * getting this until runtime */
12704                         if (ret_invlist && !  PL_utf8_swash_ptrs[classnum]) {
12705                             PL_utf8_swash_ptrs[classnum] =
12706                                 _core_swash_init("utf8", Xname, &PL_sv_undef,
12707                                              1, /* binary */
12708                                              0, /* not tr/// */
12709                                              NULL, /* No inversion list */
12710                                              NULL  /* No flags */
12711                                             );
12712                             assert(PL_utf8_swash_ptrs[classnum]);
12713                         }
12714                         if ( !  PL_utf8_swash_ptrs[classnum]) {
12715                             if (namedclass % 2 == 0) { /* A non-complemented
12716                                                           class */
12717                                 /* If not /a matching, there are code points we
12718                                  * don't know at compile time.  Arrange for the
12719                                  * unknown matches to be loaded at run-time, if
12720                                  * needed */
12721                                 if (! AT_LEAST_ASCII_RESTRICTED) {
12722                                     Perl_sv_catpvf(aTHX_ listsv, "+utf8::%s\n",
12723                                                                  Xname);
12724                                 }
12725                                 if (LOC) {  /* Under locale, set run-time
12726                                                lookup */
12727                                     ANYOF_CLASS_SET(ret, namedclass);
12728                                 }
12729                                 else {
12730                                     /* Add the current class's code points to
12731                                      * the running total */
12732                                     _invlist_union(posixes,
12733                                                    (AT_LEAST_ASCII_RESTRICTED)
12734                                                         ? ascii_source
12735                                                         : l1_source,
12736                                                    &posixes);
12737                                 }
12738                             }
12739                             else {  /* A complemented class */
12740                                 if (AT_LEAST_ASCII_RESTRICTED) {
12741                                     /* Under /a should match everything above
12742                                      * ASCII, plus the complement of the set's
12743                                      * ASCII matches */
12744                                     _invlist_union_complement_2nd(posixes,
12745                                                                   ascii_source,
12746                                                                   &posixes);
12747                                 }
12748                                 else {
12749                                     /* Arrange for the unknown matches to be
12750                                      * loaded at run-time, if needed */
12751                                     Perl_sv_catpvf(aTHX_ listsv, "!utf8::%s\n",
12752                                                                  Xname);
12753                                     runtime_posix_matches_above_Unicode = TRUE;
12754                                     if (LOC) {
12755                                         ANYOF_CLASS_SET(ret, namedclass);
12756                                     }
12757                                     else {
12758
12759                                         /* We want to match everything in
12760                                          * Latin1, except those things that
12761                                          * l1_source matches */
12762                                         SV* scratch_list = NULL;
12763                                         _invlist_subtract(PL_Latin1, l1_source,
12764                                                           &scratch_list);
12765
12766                                         /* Add the list from this class to the
12767                                          * running total */
12768                                         if (! posixes) {
12769                                             posixes = scratch_list;
12770                                         }
12771                                         else {
12772                                             _invlist_union(posixes,
12773                                                            scratch_list,
12774                                                            &posixes);
12775                                             SvREFCNT_dec_NN(scratch_list);
12776                                         }
12777                                         if (DEPENDS_SEMANTICS) {
12778                                             ANYOF_FLAGS(ret)
12779                                                   |= ANYOF_NON_UTF8_LATIN1_ALL;
12780                                         }
12781                                     }
12782                                 }
12783                             }
12784                             goto namedclass_done;
12785                         }
12786
12787                         /* Here, there is a swash loaded for the class.  If no
12788                          * inversion list for it yet, get it */
12789                         if (! PL_XPosix_ptrs[classnum]) {
12790                             PL_XPosix_ptrs[classnum]
12791                              = _swash_to_invlist(PL_utf8_swash_ptrs[classnum]);
12792                         }
12793                     }
12794
12795                     /* Here there is an inversion list already loaded for the
12796                      * entire class */
12797
12798                     if (namedclass % 2 == 0) {  /* A non-complemented class,
12799                                                    like ANYOF_PUNCT */
12800                         if (! LOC) {
12801                             /* For non-locale, just add it to any existing list
12802                              * */
12803                             _invlist_union(posixes,
12804                                            (AT_LEAST_ASCII_RESTRICTED)
12805                                                ? ascii_source
12806                                                : PL_XPosix_ptrs[classnum],
12807                                            &posixes);
12808                         }
12809                         else {  /* Locale */
12810                             SV* scratch_list = NULL;
12811
12812                             /* For above Latin1 code points, we use the full
12813                              * Unicode range */
12814                             _invlist_intersection(PL_AboveLatin1,
12815                                                   PL_XPosix_ptrs[classnum],
12816                                                   &scratch_list);
12817                             /* And set the output to it, adding instead if
12818                              * there already is an output.  Checking if
12819                              * 'posixes' is NULL first saves an extra clone.
12820                              * Its reference count will be decremented at the
12821                              * next union, etc, or if this is the only
12822                              * instance, at the end of the routine */
12823                             if (! posixes) {
12824                                 posixes = scratch_list;
12825                             }
12826                             else {
12827                                 _invlist_union(posixes, scratch_list, &posixes);
12828                                 SvREFCNT_dec_NN(scratch_list);
12829                             }
12830
12831 #ifndef HAS_ISBLANK
12832                             if (namedclass != ANYOF_BLANK) {
12833 #endif
12834                                 /* Set this class in the node for runtime
12835                                  * matching */
12836                                 ANYOF_CLASS_SET(ret, namedclass);
12837 #ifndef HAS_ISBLANK
12838                             }
12839                             else {
12840                                 /* No isblank(), use the hard-coded ASCII-range
12841                                  * blanks, adding them to the running total. */
12842
12843                                 _invlist_union(posixes, ascii_source, &posixes);
12844                             }
12845 #endif
12846                         }
12847                     }
12848                     else {  /* A complemented class, like ANYOF_NPUNCT */
12849                         if (! LOC) {
12850                             _invlist_union_complement_2nd(
12851                                                 posixes,
12852                                                 (AT_LEAST_ASCII_RESTRICTED)
12853                                                     ? ascii_source
12854                                                     : PL_XPosix_ptrs[classnum],
12855                                                 &posixes);
12856                             /* Under /d, everything in the upper half of the
12857                              * Latin1 range matches this complement */
12858                             if (DEPENDS_SEMANTICS) {
12859                                 ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL;
12860                             }
12861                         }
12862                         else {  /* Locale */
12863                             SV* scratch_list = NULL;
12864                             _invlist_subtract(PL_AboveLatin1,
12865                                               PL_XPosix_ptrs[classnum],
12866                                               &scratch_list);
12867                             if (! posixes) {
12868                                 posixes = scratch_list;
12869                             }
12870                             else {
12871                                 _invlist_union(posixes, scratch_list, &posixes);
12872                                 SvREFCNT_dec_NN(scratch_list);
12873                             }
12874 #ifndef HAS_ISBLANK
12875                             if (namedclass != ANYOF_NBLANK) {
12876 #endif
12877                                 ANYOF_CLASS_SET(ret, namedclass);
12878 #ifndef HAS_ISBLANK
12879                             }
12880                             else {
12881                                 /* Get the list of all code points in Latin1
12882                                  * that are not ASCII blanks, and add them to
12883                                  * the running total */
12884                                 _invlist_subtract(PL_Latin1, ascii_source,
12885                                                   &scratch_list);
12886                                 _invlist_union(posixes, scratch_list, &posixes);
12887                                 SvREFCNT_dec_NN(scratch_list);
12888                             }
12889 #endif
12890                         }
12891                     }
12892                 }
12893               namedclass_done:
12894                 continue;   /* Go get next character */
12895             }
12896         } /* end of namedclass \blah */
12897
12898         /* Here, we have a single value.  If 'range' is set, it is the ending
12899          * of a range--check its validity.  Later, we will handle each
12900          * individual code point in the range.  If 'range' isn't set, this
12901          * could be the beginning of a range, so check for that by looking
12902          * ahead to see if the next real character to be processed is the range
12903          * indicator--the minus sign */
12904
12905         if (skip_white) {
12906             RExC_parse = regpatws(pRExC_state, RExC_parse,
12907                                 FALSE /* means don't recognize comments */);
12908         }
12909
12910         if (range) {
12911             if (prevvalue > value) /* b-a */ {
12912                 const int w = RExC_parse - rangebegin;
12913                 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
12914                 range = 0; /* not a valid range */
12915             }
12916         }
12917         else {
12918             prevvalue = value; /* save the beginning of the potential range */
12919             if (! stop_at_1     /* Can't be a range if parsing just one thing */
12920                 && *RExC_parse == '-')
12921             {
12922                 char* next_char_ptr = RExC_parse + 1;
12923                 if (skip_white) {   /* Get the next real char after the '-' */
12924                     next_char_ptr = regpatws(pRExC_state,
12925                                              RExC_parse + 1,
12926                                              FALSE); /* means don't recognize
12927                                                         comments */
12928                 }
12929
12930                 /* If the '-' is at the end of the class (just before the ']',
12931                  * it is a literal minus; otherwise it is a range */
12932                 if (next_char_ptr < RExC_end && *next_char_ptr != ']') {
12933                     RExC_parse = next_char_ptr;
12934
12935                     /* a bad range like \w-, [:word:]- ? */
12936                     if (namedclass > OOB_NAMEDCLASS) {
12937                         if (strict || ckWARN(WARN_REGEXP)) {
12938                             const int w =
12939                                 RExC_parse >= rangebegin ?
12940                                 RExC_parse - rangebegin : 0;
12941                             if (strict) {
12942                                 vFAIL4("False [] range \"%*.*s\"",
12943                                     w, w, rangebegin);
12944                             }
12945                             else {
12946                                 vWARN4(RExC_parse,
12947                                     "False [] range \"%*.*s\"",
12948                                     w, w, rangebegin);
12949                             }
12950                         }
12951                         if (!SIZE_ONLY) {
12952                             cp_list = add_cp_to_invlist(cp_list, '-');
12953                         }
12954                         element_count++;
12955                     } else
12956                         range = 1;      /* yeah, it's a range! */
12957                     continue;   /* but do it the next time */
12958                 }
12959             }
12960         }
12961
12962         /* Here, <prevvalue> is the beginning of the range, if any; or <value>
12963          * if not */
12964
12965         /* non-Latin1 code point implies unicode semantics.  Must be set in
12966          * pass1 so is there for the whole of pass 2 */
12967         if (value > 255) {
12968             RExC_uni_semantics = 1;
12969         }
12970
12971         /* Ready to process either the single value, or the completed range.
12972          * For single-valued non-inverted ranges, we consider the possibility
12973          * of multi-char folds.  (We made a conscious decision to not do this
12974          * for the other cases because it can often lead to non-intuitive
12975          * results.  For example, you have the peculiar case that:
12976          *  "s s" =~ /^[^\xDF]+$/i => Y
12977          *  "ss"  =~ /^[^\xDF]+$/i => N
12978          *
12979          * See [perl #89750] */
12980         if (FOLD && allow_multi_folds && value == prevvalue) {
12981             if (value == LATIN_SMALL_LETTER_SHARP_S
12982                 || (value > 255 && _invlist_contains_cp(PL_HasMultiCharFold,
12983                                                         value)))
12984             {
12985                 /* Here <value> is indeed a multi-char fold.  Get what it is */
12986
12987                 U8 foldbuf[UTF8_MAXBYTES_CASE];
12988                 STRLEN foldlen;
12989
12990                 UV folded = _to_uni_fold_flags(
12991                                 value,
12992                                 foldbuf,
12993                                 &foldlen,
12994                                 FOLD_FLAGS_FULL
12995                                 | ((LOC) ?  FOLD_FLAGS_LOCALE
12996                                             : (ASCII_FOLD_RESTRICTED)
12997                                               ? FOLD_FLAGS_NOMIX_ASCII
12998                                               : 0)
12999                                 );
13000
13001                 /* Here, <folded> should be the first character of the
13002                  * multi-char fold of <value>, with <foldbuf> containing the
13003                  * whole thing.  But, if this fold is not allowed (because of
13004                  * the flags), <fold> will be the same as <value>, and should
13005                  * be processed like any other character, so skip the special
13006                  * handling */
13007                 if (folded != value) {
13008
13009                     /* Skip if we are recursed, currently parsing the class
13010                      * again.  Otherwise add this character to the list of
13011                      * multi-char folds. */
13012                     if (! RExC_in_multi_char_class) {
13013                         AV** this_array_ptr;
13014                         AV* this_array;
13015                         STRLEN cp_count = utf8_length(foldbuf,
13016                                                       foldbuf + foldlen);
13017                         SV* multi_fold = sv_2mortal(newSVpvn("", 0));
13018
13019                         Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%"UVXf"}", value);
13020
13021
13022                         if (! multi_char_matches) {
13023                             multi_char_matches = newAV();
13024                         }
13025
13026                         /* <multi_char_matches> is actually an array of arrays.
13027                          * There will be one or two top-level elements: [2],
13028                          * and/or [3].  The [2] element is an array, each
13029                          * element thereof is a character which folds to two
13030                          * characters; likewise for [3].  (Unicode guarantees a
13031                          * maximum of 3 characters in any fold.)  When we
13032                          * rewrite the character class below, we will do so
13033                          * such that the longest folds are written first, so
13034                          * that it prefers the longest matching strings first.
13035                          * This is done even if it turns out that any
13036                          * quantifier is non-greedy, out of programmer
13037                          * laziness.  Tom Christiansen has agreed that this is
13038                          * ok.  This makes the test for the ligature 'ffi' come
13039                          * before the test for 'ff' */
13040                         if (av_exists(multi_char_matches, cp_count)) {
13041                             this_array_ptr = (AV**) av_fetch(multi_char_matches,
13042                                                              cp_count, FALSE);
13043                             this_array = *this_array_ptr;
13044                         }
13045                         else {
13046                             this_array = newAV();
13047                             av_store(multi_char_matches, cp_count,
13048                                      (SV*) this_array);
13049                         }
13050                         av_push(this_array, multi_fold);
13051                     }
13052
13053                     /* This element should not be processed further in this
13054                      * class */
13055                     element_count--;
13056                     value = save_value;
13057                     prevvalue = save_prevvalue;
13058                     continue;
13059                 }
13060             }
13061         }
13062
13063         /* Deal with this element of the class */
13064         if (! SIZE_ONLY) {
13065 #ifndef EBCDIC
13066             cp_list = _add_range_to_invlist(cp_list, prevvalue, value);
13067 #else
13068             SV* this_range = _new_invlist(1);
13069             _append_range_to_invlist(this_range, prevvalue, value);
13070
13071             /* In EBCDIC, the ranges 'A-Z' and 'a-z' are each not contiguous.
13072              * If this range was specified using something like 'i-j', we want
13073              * to include only the 'i' and the 'j', and not anything in
13074              * between, so exclude non-ASCII, non-alphabetics from it.
13075              * However, if the range was specified with something like
13076              * [\x89-\x91] or [\x89-j], all code points within it should be
13077              * included.  literal_endpoint==2 means both ends of the range used
13078              * a literal character, not \x{foo} */
13079             if (literal_endpoint == 2
13080                 && (prevvalue >= 'a' && value <= 'z')
13081                     || (prevvalue >= 'A' && value <= 'Z'))
13082             {
13083                 _invlist_intersection(this_range, PL_Posix_ptrs[_CC_ALPHA],
13084                                       &this_range);
13085             }
13086             _invlist_union(cp_list, this_range, &cp_list);
13087             literal_endpoint = 0;
13088 #endif
13089         }
13090
13091         range = 0; /* this range (if it was one) is done now */
13092     } /* End of loop through all the text within the brackets */
13093
13094     /* If anything in the class expands to more than one character, we have to
13095      * deal with them by building up a substitute parse string, and recursively
13096      * calling reg() on it, instead of proceeding */
13097     if (multi_char_matches) {
13098         SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
13099         I32 cp_count;
13100         STRLEN len;
13101         char *save_end = RExC_end;
13102         char *save_parse = RExC_parse;
13103         bool first_time = TRUE;     /* First multi-char occurrence doesn't get
13104                                        a "|" */
13105         I32 reg_flags;
13106
13107         assert(! invert);
13108 #if 0   /* Have decided not to deal with multi-char folds in inverted classes,
13109            because too confusing */
13110         if (invert) {
13111             sv_catpv(substitute_parse, "(?:");
13112         }
13113 #endif
13114
13115         /* Look at the longest folds first */
13116         for (cp_count = av_len(multi_char_matches); cp_count > 0; cp_count--) {
13117
13118             if (av_exists(multi_char_matches, cp_count)) {
13119                 AV** this_array_ptr;
13120                 SV* this_sequence;
13121
13122                 this_array_ptr = (AV**) av_fetch(multi_char_matches,
13123                                                  cp_count, FALSE);
13124                 while ((this_sequence = av_pop(*this_array_ptr)) !=
13125                                                                 &PL_sv_undef)
13126                 {
13127                     if (! first_time) {
13128                         sv_catpv(substitute_parse, "|");
13129                     }
13130                     first_time = FALSE;
13131
13132                     sv_catpv(substitute_parse, SvPVX(this_sequence));
13133                 }
13134             }
13135         }
13136
13137         /* If the character class contains anything else besides these
13138          * multi-character folds, have to include it in recursive parsing */
13139         if (element_count) {
13140             sv_catpv(substitute_parse, "|[");
13141             sv_catpvn(substitute_parse, orig_parse, RExC_parse - orig_parse);
13142             sv_catpv(substitute_parse, "]");
13143         }
13144
13145         sv_catpv(substitute_parse, ")");
13146 #if 0
13147         if (invert) {
13148             /* This is a way to get the parse to skip forward a whole named
13149              * sequence instead of matching the 2nd character when it fails the
13150              * first */
13151             sv_catpv(substitute_parse, "(*THEN)(*SKIP)(*FAIL)|.)");
13152         }
13153 #endif
13154
13155         RExC_parse = SvPV(substitute_parse, len);
13156         RExC_end = RExC_parse + len;
13157         RExC_in_multi_char_class = 1;
13158         RExC_emit = (regnode *)orig_emit;
13159
13160         ret = reg(pRExC_state, 1, &reg_flags, depth+1);
13161
13162         *flagp |= reg_flags&(HASWIDTH|SIMPLE|SPSTART|POSTPONED|RESTART_UTF8);
13163
13164         RExC_parse = save_parse;
13165         RExC_end = save_end;
13166         RExC_in_multi_char_class = 0;
13167         SvREFCNT_dec_NN(multi_char_matches);
13168         return ret;
13169     }
13170
13171     /* If the character class contains only a single element, it may be
13172      * optimizable into another node type which is smaller and runs faster.
13173      * Check if this is the case for this class */
13174     if (element_count == 1 && ! ret_invlist) {
13175         U8 op = END;
13176         U8 arg = 0;
13177
13178         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class, like \w or
13179                                               [:digit:] or \p{foo} */
13180
13181             /* All named classes are mapped into POSIXish nodes, with its FLAG
13182              * argument giving which class it is */
13183             switch ((I32)namedclass) {
13184                 case ANYOF_UNIPROP:
13185                     break;
13186
13187                 /* These don't depend on the charset modifiers.  They always
13188                  * match under /u rules */
13189                 case ANYOF_NHORIZWS:
13190                 case ANYOF_HORIZWS:
13191                     namedclass = ANYOF_BLANK + namedclass - ANYOF_HORIZWS;
13192                     /* FALLTHROUGH */
13193
13194                 case ANYOF_NVERTWS:
13195                 case ANYOF_VERTWS:
13196                     op = POSIXU;
13197                     goto join_posix;
13198
13199                 /* The actual POSIXish node for all the rest depends on the
13200                  * charset modifier.  The ones in the first set depend only on
13201                  * ASCII or, if available on this platform, locale */
13202                 case ANYOF_ASCII:
13203                 case ANYOF_NASCII:
13204 #ifdef HAS_ISASCII
13205                     op = (LOC) ? POSIXL : POSIXA;
13206 #else
13207                     op = POSIXA;
13208 #endif
13209                     goto join_posix;
13210
13211                 case ANYOF_NCASED:
13212                 case ANYOF_LOWER:
13213                 case ANYOF_NLOWER:
13214                 case ANYOF_UPPER:
13215                 case ANYOF_NUPPER:
13216                     /* under /a could be alpha */
13217                     if (FOLD) {
13218                         if (ASCII_RESTRICTED) {
13219                             namedclass = ANYOF_ALPHA + (namedclass % 2);
13220                         }
13221                         else if (! LOC) {
13222                             break;
13223                         }
13224                     }
13225                     /* FALLTHROUGH */
13226
13227                 /* The rest have more possibilities depending on the charset.
13228                  * We take advantage of the enum ordering of the charset
13229                  * modifiers to get the exact node type, */
13230                 default:
13231                     op = POSIXD + get_regex_charset(RExC_flags);
13232                     if (op > POSIXA) { /* /aa is same as /a */
13233                         op = POSIXA;
13234                     }
13235 #ifndef HAS_ISBLANK
13236                     if (op == POSIXL
13237                         && (namedclass == ANYOF_BLANK
13238                             || namedclass == ANYOF_NBLANK))
13239                     {
13240                         op = POSIXA;
13241                     }
13242 #endif
13243
13244                 join_posix:
13245                     /* The odd numbered ones are the complements of the
13246                      * next-lower even number one */
13247                     if (namedclass % 2 == 1) {
13248                         invert = ! invert;
13249                         namedclass--;
13250                     }
13251                     arg = namedclass_to_classnum(namedclass);
13252                     break;
13253             }
13254         }
13255         else if (value == prevvalue) {
13256
13257             /* Here, the class consists of just a single code point */
13258
13259             if (invert) {
13260                 if (! LOC && value == '\n') {
13261                     op = REG_ANY; /* Optimize [^\n] */
13262                     *flagp |= HASWIDTH|SIMPLE;
13263                     RExC_naughty++;
13264                 }
13265             }
13266             else if (value < 256 || UTF) {
13267
13268                 /* Optimize a single value into an EXACTish node, but not if it
13269                  * would require converting the pattern to UTF-8. */
13270                 op = compute_EXACTish(pRExC_state);
13271             }
13272         } /* Otherwise is a range */
13273         else if (! LOC) {   /* locale could vary these */
13274             if (prevvalue == '0') {
13275                 if (value == '9') {
13276                     arg = _CC_DIGIT;
13277                     op = POSIXA;
13278                 }
13279             }
13280         }
13281
13282         /* Here, we have changed <op> away from its initial value iff we found
13283          * an optimization */
13284         if (op != END) {
13285
13286             /* Throw away this ANYOF regnode, and emit the calculated one,
13287              * which should correspond to the beginning, not current, state of
13288              * the parse */
13289             const char * cur_parse = RExC_parse;
13290             RExC_parse = (char *)orig_parse;
13291             if ( SIZE_ONLY) {
13292                 if (! LOC) {
13293
13294                     /* To get locale nodes to not use the full ANYOF size would
13295                      * require moving the code above that writes the portions
13296                      * of it that aren't in other nodes to after this point.
13297                      * e.g.  ANYOF_CLASS_SET */
13298                     RExC_size = orig_size;
13299                 }
13300             }
13301             else {
13302                 RExC_emit = (regnode *)orig_emit;
13303                 if (PL_regkind[op] == POSIXD) {
13304                     if (invert) {
13305                         op += NPOSIXD - POSIXD;
13306                     }
13307                 }
13308             }
13309
13310             ret = reg_node(pRExC_state, op);
13311
13312             if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
13313                 if (! SIZE_ONLY) {
13314                     FLAGS(ret) = arg;
13315                 }
13316                 *flagp |= HASWIDTH|SIMPLE;
13317             }
13318             else if (PL_regkind[op] == EXACT) {
13319                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value);
13320             }
13321
13322             RExC_parse = (char *) cur_parse;
13323
13324             SvREFCNT_dec(posixes);
13325             SvREFCNT_dec(cp_list);
13326             return ret;
13327         }
13328     }
13329
13330     if (SIZE_ONLY)
13331         return ret;
13332     /****** !SIZE_ONLY (Pass 2) AFTER HERE *********/
13333
13334     /* If folding, we calculate all characters that could fold to or from the
13335      * ones already on the list */
13336     if (FOLD && cp_list) {
13337         UV start, end;  /* End points of code point ranges */
13338
13339         SV* fold_intersection = NULL;
13340
13341         /* If the highest code point is within Latin1, we can use the
13342          * compiled-in Alphas list, and not have to go out to disk.  This
13343          * yields two false positives, the masculine and feminine ordinal
13344          * indicators, which are weeded out below using the
13345          * IS_IN_SOME_FOLD_L1() macro */
13346         if (invlist_highest(cp_list) < 256) {
13347             _invlist_intersection(PL_L1Posix_ptrs[_CC_ALPHA], cp_list,
13348                                                            &fold_intersection);
13349         }
13350         else {
13351
13352             /* Here, there are non-Latin1 code points, so we will have to go
13353              * fetch the list of all the characters that participate in folds
13354              */
13355             if (! PL_utf8_foldable) {
13356                 SV* swash = swash_init("utf8", "_Perl_Any_Folds",
13357                                        &PL_sv_undef, 1, 0);
13358                 PL_utf8_foldable = _get_swash_invlist(swash);
13359                 SvREFCNT_dec_NN(swash);
13360             }
13361
13362             /* This is a hash that for a particular fold gives all characters
13363              * that are involved in it */
13364             if (! PL_utf8_foldclosures) {
13365
13366                 /* If we were unable to find any folds, then we likely won't be
13367                  * able to find the closures.  So just create an empty list.
13368                  * Folding will effectively be restricted to the non-Unicode
13369                  * rules hard-coded into Perl.  (This case happens legitimately
13370                  * during compilation of Perl itself before the Unicode tables
13371                  * are generated) */
13372                 if (_invlist_len(PL_utf8_foldable) == 0) {
13373                     PL_utf8_foldclosures = newHV();
13374                 }
13375                 else {
13376                     /* If the folds haven't been read in, call a fold function
13377                      * to force that */
13378                     if (! PL_utf8_tofold) {
13379                         U8 dummy[UTF8_MAXBYTES+1];
13380
13381                         /* This string is just a short named one above \xff */
13382                         to_utf8_fold((U8*) HYPHEN_UTF8, dummy, NULL);
13383                         assert(PL_utf8_tofold); /* Verify that worked */
13384                     }
13385                     PL_utf8_foldclosures =
13386                                     _swash_inversion_hash(PL_utf8_tofold);
13387                 }
13388             }
13389
13390             /* Only the characters in this class that participate in folds need
13391              * be checked.  Get the intersection of this class and all the
13392              * possible characters that are foldable.  This can quickly narrow
13393              * down a large class */
13394             _invlist_intersection(PL_utf8_foldable, cp_list,
13395                                   &fold_intersection);
13396         }
13397
13398         /* Now look at the foldable characters in this class individually */
13399         invlist_iterinit(fold_intersection);
13400         while (invlist_iternext(fold_intersection, &start, &end)) {
13401             UV j;
13402
13403             /* Locale folding for Latin1 characters is deferred until runtime */
13404             if (LOC && start < 256) {
13405                 start = 256;
13406             }
13407
13408             /* Look at every character in the range */
13409             for (j = start; j <= end; j++) {
13410
13411                 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
13412                 STRLEN foldlen;
13413                 SV** listp;
13414
13415                 if (j < 256) {
13416
13417                     /* We have the latin1 folding rules hard-coded here so that
13418                      * an innocent-looking character class, like /[ks]/i won't
13419                      * have to go out to disk to find the possible matches.
13420                      * XXX It would be better to generate these via regen, in
13421                      * case a new version of the Unicode standard adds new
13422                      * mappings, though that is not really likely, and may be
13423                      * caught by the default: case of the switch below. */
13424
13425                     if (IS_IN_SOME_FOLD_L1(j)) {
13426
13427                         /* ASCII is always matched; non-ASCII is matched only
13428                          * under Unicode rules */
13429                         if (isASCII(j) || AT_LEAST_UNI_SEMANTICS) {
13430                             cp_list =
13431                                 add_cp_to_invlist(cp_list, PL_fold_latin1[j]);
13432                         }
13433                         else {
13434                             depends_list =
13435                              add_cp_to_invlist(depends_list, PL_fold_latin1[j]);
13436                         }
13437                     }
13438
13439                     if (HAS_NONLATIN1_FOLD_CLOSURE(j)
13440                         && (! isASCII(j) || ! ASCII_FOLD_RESTRICTED))
13441                     {
13442                         /* Certain Latin1 characters have matches outside
13443                          * Latin1.  To get here, <j> is one of those
13444                          * characters.   None of these matches is valid for
13445                          * ASCII characters under /aa, which is why the 'if'
13446                          * just above excludes those.  These matches only
13447                          * happen when the target string is utf8.  The code
13448                          * below adds the single fold closures for <j> to the
13449                          * inversion list. */
13450                         switch (j) {
13451                             case 'k':
13452                             case 'K':
13453                                 cp_list =
13454                                     add_cp_to_invlist(cp_list, KELVIN_SIGN);
13455                                 break;
13456                             case 's':
13457                             case 'S':
13458                                 cp_list = add_cp_to_invlist(cp_list,
13459                                                     LATIN_SMALL_LETTER_LONG_S);
13460                                 break;
13461                             case MICRO_SIGN:
13462                                 cp_list = add_cp_to_invlist(cp_list,
13463                                                     GREEK_CAPITAL_LETTER_MU);
13464                                 cp_list = add_cp_to_invlist(cp_list,
13465                                                     GREEK_SMALL_LETTER_MU);
13466                                 break;
13467                             case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
13468                             case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
13469                                 cp_list =
13470                                     add_cp_to_invlist(cp_list, ANGSTROM_SIGN);
13471                                 break;
13472                             case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
13473                                 cp_list = add_cp_to_invlist(cp_list,
13474                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
13475                                 break;
13476                             case LATIN_SMALL_LETTER_SHARP_S:
13477                                 cp_list = add_cp_to_invlist(cp_list,
13478                                                 LATIN_CAPITAL_LETTER_SHARP_S);
13479                                 break;
13480                             case 'F': case 'f':
13481                             case 'I': case 'i':
13482                             case 'L': case 'l':
13483                             case 'T': case 't':
13484                             case 'A': case 'a':
13485                             case 'H': case 'h':
13486                             case 'J': case 'j':
13487                             case 'N': case 'n':
13488                             case 'W': case 'w':
13489                             case 'Y': case 'y':
13490                                 /* These all are targets of multi-character
13491                                  * folds from code points that require UTF8 to
13492                                  * express, so they can't match unless the
13493                                  * target string is in UTF-8, so no action here
13494                                  * is necessary, as regexec.c properly handles
13495                                  * the general case for UTF-8 matching and
13496                                  * multi-char folds */
13497                                 break;
13498                             default:
13499                                 /* Use deprecated warning to increase the
13500                                  * chances of this being output */
13501                                 ckWARN2regdep(RExC_parse, "Perl folding rules are not up-to-date for 0x%"UVXf"; please use the perlbug utility to report;", j);
13502                                 break;
13503                         }
13504                     }
13505                     continue;
13506                 }
13507
13508                 /* Here is an above Latin1 character.  We don't have the rules
13509                  * hard-coded for it.  First, get its fold.  This is the simple
13510                  * fold, as the multi-character folds have been handled earlier
13511                  * and separated out */
13512                 _to_uni_fold_flags(j, foldbuf, &foldlen,
13513                                                ((LOC)
13514                                                ? FOLD_FLAGS_LOCALE
13515                                                : (ASCII_FOLD_RESTRICTED)
13516                                                   ? FOLD_FLAGS_NOMIX_ASCII
13517                                                   : 0));
13518
13519                 /* Single character fold of above Latin1.  Add everything in
13520                  * its fold closure to the list that this node should match.
13521                  * The fold closures data structure is a hash with the keys
13522                  * being the UTF-8 of every character that is folded to, like
13523                  * 'k', and the values each an array of all code points that
13524                  * fold to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ].
13525                  * Multi-character folds are not included */
13526                 if ((listp = hv_fetch(PL_utf8_foldclosures,
13527                                       (char *) foldbuf, foldlen, FALSE)))
13528                 {
13529                     AV* list = (AV*) *listp;
13530                     IV k;
13531                     for (k = 0; k <= av_len(list); k++) {
13532                         SV** c_p = av_fetch(list, k, FALSE);
13533                         UV c;
13534                         if (c_p == NULL) {
13535                             Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
13536                         }
13537                         c = SvUV(*c_p);
13538
13539                         /* /aa doesn't allow folds between ASCII and non-; /l
13540                          * doesn't allow them between above and below 256 */
13541                         if ((ASCII_FOLD_RESTRICTED
13542                                   && (isASCII(c) != isASCII(j)))
13543                             || (LOC && ((c < 256) != (j < 256))))
13544                         {
13545                             continue;
13546                         }
13547
13548                         /* Folds involving non-ascii Latin1 characters
13549                          * under /d are added to a separate list */
13550                         if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS)
13551                         {
13552                             cp_list = add_cp_to_invlist(cp_list, c);
13553                         }
13554                         else {
13555                           depends_list = add_cp_to_invlist(depends_list, c);
13556                         }
13557                     }
13558                 }
13559             }
13560         }
13561         SvREFCNT_dec_NN(fold_intersection);
13562     }
13563
13564     /* And combine the result (if any) with any inversion list from posix
13565      * classes.  The lists are kept separate up to now because we don't want to
13566      * fold the classes (folding of those is automatically handled by the swash
13567      * fetching code) */
13568     if (posixes) {
13569         if (! DEPENDS_SEMANTICS) {
13570             if (cp_list) {
13571                 _invlist_union(cp_list, posixes, &cp_list);
13572                 SvREFCNT_dec_NN(posixes);
13573             }
13574             else {
13575                 cp_list = posixes;
13576             }
13577         }
13578         else {
13579             /* Under /d, we put into a separate list the Latin1 things that
13580              * match only when the target string is utf8 */
13581             SV* nonascii_but_latin1_properties = NULL;
13582             _invlist_intersection(posixes, PL_Latin1,
13583                                   &nonascii_but_latin1_properties);
13584             _invlist_subtract(nonascii_but_latin1_properties, PL_ASCII,
13585                               &nonascii_but_latin1_properties);
13586             _invlist_subtract(posixes, nonascii_but_latin1_properties,
13587                               &posixes);
13588             if (cp_list) {
13589                 _invlist_union(cp_list, posixes, &cp_list);
13590                 SvREFCNT_dec_NN(posixes);
13591             }
13592             else {
13593                 cp_list = posixes;
13594             }
13595
13596             if (depends_list) {
13597                 _invlist_union(depends_list, nonascii_but_latin1_properties,
13598                                &depends_list);
13599                 SvREFCNT_dec_NN(nonascii_but_latin1_properties);
13600             }
13601             else {
13602                 depends_list = nonascii_but_latin1_properties;
13603             }
13604         }
13605     }
13606
13607     /* And combine the result (if any) with any inversion list from properties.
13608      * The lists are kept separate up to now so that we can distinguish the two
13609      * in regards to matching above-Unicode.  A run-time warning is generated
13610      * if a Unicode property is matched against a non-Unicode code point. But,
13611      * we allow user-defined properties to match anything, without any warning,
13612      * and we also suppress the warning if there is a portion of the character
13613      * class that isn't a Unicode property, and which matches above Unicode, \W
13614      * or [\x{110000}] for example.
13615      * (Note that in this case, unlike the Posix one above, there is no
13616      * <depends_list>, because having a Unicode property forces Unicode
13617      * semantics */
13618     if (properties) {
13619         bool warn_super = ! has_user_defined_property;
13620         if (cp_list) {
13621
13622             /* If it matters to the final outcome, see if a non-property
13623              * component of the class matches above Unicode.  If so, the
13624              * warning gets suppressed.  This is true even if just a single
13625              * such code point is specified, as though not strictly correct if
13626              * another such code point is matched against, the fact that they
13627              * are using above-Unicode code points indicates they should know
13628              * the issues involved */
13629             if (warn_super) {
13630                 bool non_prop_matches_above_Unicode =
13631                             runtime_posix_matches_above_Unicode
13632                             | (invlist_highest(cp_list) > PERL_UNICODE_MAX);
13633                 if (invert) {
13634                     non_prop_matches_above_Unicode =
13635                                             !  non_prop_matches_above_Unicode;
13636                 }
13637                 warn_super = ! non_prop_matches_above_Unicode;
13638             }
13639
13640             _invlist_union(properties, cp_list, &cp_list);
13641             SvREFCNT_dec_NN(properties);
13642         }
13643         else {
13644             cp_list = properties;
13645         }
13646
13647         if (warn_super) {
13648             OP(ret) = ANYOF_WARN_SUPER;
13649         }
13650     }
13651
13652     /* Here, we have calculated what code points should be in the character
13653      * class.
13654      *
13655      * Now we can see about various optimizations.  Fold calculation (which we
13656      * did above) needs to take place before inversion.  Otherwise /[^k]/i
13657      * would invert to include K, which under /i would match k, which it
13658      * shouldn't.  Therefore we can't invert folded locale now, as it won't be
13659      * folded until runtime */
13660
13661     /* Optimize inverted simple patterns (e.g. [^a-z]) when everything is known
13662      * at compile time.  Besides not inverting folded locale now, we can't
13663      * invert if there are things such as \w, which aren't known until runtime
13664      * */
13665     if (invert
13666         && ! (LOC && (FOLD || (ANYOF_FLAGS(ret) & ANYOF_CLASS)))
13667         && ! depends_list
13668         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
13669     {
13670         _invlist_invert(cp_list);
13671
13672         /* Any swash can't be used as-is, because we've inverted things */
13673         if (swash) {
13674             SvREFCNT_dec_NN(swash);
13675             swash = NULL;
13676         }
13677
13678         /* Clear the invert flag since have just done it here */
13679         invert = FALSE;
13680     }
13681
13682     if (ret_invlist) {
13683         *ret_invlist = cp_list;
13684
13685         /* Discard the generated node */
13686         if (SIZE_ONLY) {
13687             RExC_size = orig_size;
13688         }
13689         else {
13690             RExC_emit = orig_emit;
13691         }
13692         return orig_emit;
13693     }
13694
13695     /* If we didn't do folding, it's because some information isn't available
13696      * until runtime; set the run-time fold flag for these.  (We don't have to
13697      * worry about properties folding, as that is taken care of by the swash
13698      * fetching) */
13699     if (FOLD && LOC)
13700     {
13701        ANYOF_FLAGS(ret) |= ANYOF_LOC_FOLD;
13702     }
13703
13704     /* Some character classes are equivalent to other nodes.  Such nodes take
13705      * up less room and generally fewer operations to execute than ANYOF nodes.
13706      * Above, we checked for and optimized into some such equivalents for
13707      * certain common classes that are easy to test.  Getting to this point in
13708      * the code means that the class didn't get optimized there.  Since this
13709      * code is only executed in Pass 2, it is too late to save space--it has
13710      * been allocated in Pass 1, and currently isn't given back.  But turning
13711      * things into an EXACTish node can allow the optimizer to join it to any
13712      * adjacent such nodes.  And if the class is equivalent to things like /./,
13713      * expensive run-time swashes can be avoided.  Now that we have more
13714      * complete information, we can find things necessarily missed by the
13715      * earlier code.  I (khw) am not sure how much to look for here.  It would
13716      * be easy, but perhaps too slow, to check any candidates against all the
13717      * node types they could possibly match using _invlistEQ(). */
13718
13719     if (cp_list
13720         && ! invert
13721         && ! depends_list
13722         && ! (ANYOF_FLAGS(ret) & ANYOF_CLASS)
13723         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
13724     {
13725         UV start, end;
13726         U8 op = END;  /* The optimzation node-type */
13727         const char * cur_parse= RExC_parse;
13728
13729         invlist_iterinit(cp_list);
13730         if (! invlist_iternext(cp_list, &start, &end)) {
13731
13732             /* Here, the list is empty.  This happens, for example, when a
13733              * Unicode property is the only thing in the character class, and
13734              * it doesn't match anything.  (perluniprops.pod notes such
13735              * properties) */
13736             op = OPFAIL;
13737             *flagp |= HASWIDTH|SIMPLE;
13738         }
13739         else if (start == end) {    /* The range is a single code point */
13740             if (! invlist_iternext(cp_list, &start, &end)
13741
13742                     /* Don't do this optimization if it would require changing
13743                      * the pattern to UTF-8 */
13744                 && (start < 256 || UTF))
13745             {
13746                 /* Here, the list contains a single code point.  Can optimize
13747                  * into an EXACT node */
13748
13749                 value = start;
13750
13751                 if (! FOLD) {
13752                     op = EXACT;
13753                 }
13754                 else if (LOC) {
13755
13756                     /* A locale node under folding with one code point can be
13757                      * an EXACTFL, as its fold won't be calculated until
13758                      * runtime */
13759                     op = EXACTFL;
13760                 }
13761                 else {
13762
13763                     /* Here, we are generally folding, but there is only one
13764                      * code point to match.  If we have to, we use an EXACT
13765                      * node, but it would be better for joining with adjacent
13766                      * nodes in the optimization pass if we used the same
13767                      * EXACTFish node that any such are likely to be.  We can
13768                      * do this iff the code point doesn't participate in any
13769                      * folds.  For example, an EXACTF of a colon is the same as
13770                      * an EXACT one, since nothing folds to or from a colon. */
13771                     if (value < 256) {
13772                         if (IS_IN_SOME_FOLD_L1(value)) {
13773                             op = EXACT;
13774                         }
13775                     }
13776                     else {
13777                         if (! PL_utf8_foldable) {
13778                             SV* swash = swash_init("utf8", "_Perl_Any_Folds",
13779                                                 &PL_sv_undef, 1, 0);
13780                             PL_utf8_foldable = _get_swash_invlist(swash);
13781                             SvREFCNT_dec_NN(swash);
13782                         }
13783                         if (_invlist_contains_cp(PL_utf8_foldable, value)) {
13784                             op = EXACT;
13785                         }
13786                     }
13787
13788                     /* If we haven't found the node type, above, it means we
13789                      * can use the prevailing one */
13790                     if (op == END) {
13791                         op = compute_EXACTish(pRExC_state);
13792                     }
13793                 }
13794             }
13795         }
13796         else if (start == 0) {
13797             if (end == UV_MAX) {
13798                 op = SANY;
13799                 *flagp |= HASWIDTH|SIMPLE;
13800                 RExC_naughty++;
13801             }
13802             else if (end == '\n' - 1
13803                     && invlist_iternext(cp_list, &start, &end)
13804                     && start == '\n' + 1 && end == UV_MAX)
13805             {
13806                 op = REG_ANY;
13807                 *flagp |= HASWIDTH|SIMPLE;
13808                 RExC_naughty++;
13809             }
13810         }
13811         invlist_iterfinish(cp_list);
13812
13813         if (op != END) {
13814             RExC_parse = (char *)orig_parse;
13815             RExC_emit = (regnode *)orig_emit;
13816
13817             ret = reg_node(pRExC_state, op);
13818
13819             RExC_parse = (char *)cur_parse;
13820
13821             if (PL_regkind[op] == EXACT) {
13822                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value);
13823             }
13824
13825             SvREFCNT_dec_NN(cp_list);
13826             return ret;
13827         }
13828     }
13829
13830     /* Here, <cp_list> contains all the code points we can determine at
13831      * compile time that match under all conditions.  Go through it, and
13832      * for things that belong in the bitmap, put them there, and delete from
13833      * <cp_list>.  While we are at it, see if everything above 255 is in the
13834      * list, and if so, set a flag to speed up execution */
13835     ANYOF_BITMAP_ZERO(ret);
13836     if (cp_list) {
13837
13838         /* This gets set if we actually need to modify things */
13839         bool change_invlist = FALSE;
13840
13841         UV start, end;
13842
13843         /* Start looking through <cp_list> */
13844         invlist_iterinit(cp_list);
13845         while (invlist_iternext(cp_list, &start, &end)) {
13846             UV high;
13847             int i;
13848
13849             if (end == UV_MAX && start <= 256) {
13850                 ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
13851             }
13852
13853             /* Quit if are above what we should change */
13854             if (start > 255) {
13855                 break;
13856             }
13857
13858             change_invlist = TRUE;
13859
13860             /* Set all the bits in the range, up to the max that we are doing */
13861             high = (end < 255) ? end : 255;
13862             for (i = start; i <= (int) high; i++) {
13863                 if (! ANYOF_BITMAP_TEST(ret, i)) {
13864                     ANYOF_BITMAP_SET(ret, i);
13865                     prevvalue = value;
13866                     value = i;
13867                 }
13868             }
13869         }
13870         invlist_iterfinish(cp_list);
13871
13872         /* Done with loop; remove any code points that are in the bitmap from
13873          * <cp_list> */
13874         if (change_invlist) {
13875             _invlist_subtract(cp_list, PL_Latin1, &cp_list);
13876         }
13877
13878         /* If have completely emptied it, remove it completely */
13879         if (_invlist_len(cp_list) == 0) {
13880             SvREFCNT_dec_NN(cp_list);
13881             cp_list = NULL;
13882         }
13883     }
13884
13885     if (invert) {
13886         ANYOF_FLAGS(ret) |= ANYOF_INVERT;
13887     }
13888
13889     /* Here, the bitmap has been populated with all the Latin1 code points that
13890      * always match.  Can now add to the overall list those that match only
13891      * when the target string is UTF-8 (<depends_list>). */
13892     if (depends_list) {
13893         if (cp_list) {
13894             _invlist_union(cp_list, depends_list, &cp_list);
13895             SvREFCNT_dec_NN(depends_list);
13896         }
13897         else {
13898             cp_list = depends_list;
13899         }
13900     }
13901
13902     /* If there is a swash and more than one element, we can't use the swash in
13903      * the optimization below. */
13904     if (swash && element_count > 1) {
13905         SvREFCNT_dec_NN(swash);
13906         swash = NULL;
13907     }
13908
13909     if (! cp_list
13910         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
13911     {
13912         ARG_SET(ret, ANYOF_NONBITMAP_EMPTY);
13913     }
13914     else {
13915         /* av[0] stores the character class description in its textual form:
13916          *       used later (regexec.c:Perl_regclass_swash()) to initialize the
13917          *       appropriate swash, and is also useful for dumping the regnode.
13918          * av[1] if NULL, is a placeholder to later contain the swash computed
13919          *       from av[0].  But if no further computation need be done, the
13920          *       swash is stored there now.
13921          * av[2] stores the cp_list inversion list for use in addition or
13922          *       instead of av[0]; used only if av[1] is NULL
13923          * av[3] is set if any component of the class is from a user-defined
13924          *       property; used only if av[1] is NULL */
13925         AV * const av = newAV();
13926         SV *rv;
13927
13928         av_store(av, 0, (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
13929                         ? SvREFCNT_inc(listsv) : &PL_sv_undef);
13930         if (swash) {
13931             av_store(av, 1, swash);
13932             SvREFCNT_dec_NN(cp_list);
13933         }
13934         else {
13935             av_store(av, 1, NULL);
13936             if (cp_list) {
13937                 av_store(av, 2, cp_list);
13938                 av_store(av, 3, newSVuv(has_user_defined_property));
13939             }
13940         }
13941
13942         rv = newRV_noinc(MUTABLE_SV(av));
13943         n = add_data(pRExC_state, 1, "s");
13944         RExC_rxi->data->data[n] = (void*)rv;
13945         ARG_SET(ret, n);
13946     }
13947
13948     *flagp |= HASWIDTH|SIMPLE;
13949     return ret;
13950 }
13951 #undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
13952
13953
13954 /* reg_skipcomment()
13955
13956    Absorbs an /x style # comments from the input stream.
13957    Returns true if there is more text remaining in the stream.
13958    Will set the REG_SEEN_RUN_ON_COMMENT flag if the comment
13959    terminates the pattern without including a newline.
13960
13961    Note its the callers responsibility to ensure that we are
13962    actually in /x mode
13963
13964 */
13965
13966 STATIC bool
13967 S_reg_skipcomment(pTHX_ RExC_state_t *pRExC_state)
13968 {
13969     bool ended = 0;
13970
13971     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
13972
13973     while (RExC_parse < RExC_end)
13974         if (*RExC_parse++ == '\n') {
13975             ended = 1;
13976             break;
13977         }
13978     if (!ended) {
13979         /* we ran off the end of the pattern without ending
13980            the comment, so we have to add an \n when wrapping */
13981         RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
13982         return 0;
13983     } else
13984         return 1;
13985 }
13986
13987 /* nextchar()
13988
13989    Advances the parse position, and optionally absorbs
13990    "whitespace" from the inputstream.
13991
13992    Without /x "whitespace" means (?#...) style comments only,
13993    with /x this means (?#...) and # comments and whitespace proper.
13994
13995    Returns the RExC_parse point from BEFORE the scan occurs.
13996
13997    This is the /x friendly way of saying RExC_parse++.
13998 */
13999
14000 STATIC char*
14001 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
14002 {
14003     char* const retval = RExC_parse++;
14004
14005     PERL_ARGS_ASSERT_NEXTCHAR;
14006
14007     for (;;) {
14008         if (RExC_end - RExC_parse >= 3
14009             && *RExC_parse == '('
14010             && RExC_parse[1] == '?'
14011             && RExC_parse[2] == '#')
14012         {
14013             while (*RExC_parse != ')') {
14014                 if (RExC_parse == RExC_end)
14015                     FAIL("Sequence (?#... not terminated");
14016                 RExC_parse++;
14017             }
14018             RExC_parse++;
14019             continue;
14020         }
14021         if (RExC_flags & RXf_PMf_EXTENDED) {
14022             if (isSPACE(*RExC_parse)) {
14023                 RExC_parse++;
14024                 continue;
14025             }
14026             else if (*RExC_parse == '#') {
14027                 if ( reg_skipcomment( pRExC_state ) )
14028                     continue;
14029             }
14030         }
14031         return retval;
14032     }
14033 }
14034
14035 /*
14036 - reg_node - emit a node
14037 */
14038 STATIC regnode *                        /* Location. */
14039 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
14040 {
14041     dVAR;
14042     regnode *ptr;
14043     regnode * const ret = RExC_emit;
14044     GET_RE_DEBUG_FLAGS_DECL;
14045
14046     PERL_ARGS_ASSERT_REG_NODE;
14047
14048     if (SIZE_ONLY) {
14049         SIZE_ALIGN(RExC_size);
14050         RExC_size += 1;
14051         return(ret);
14052     }
14053     if (RExC_emit >= RExC_emit_bound)
14054         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
14055                    op, RExC_emit, RExC_emit_bound);
14056
14057     NODE_ALIGN_FILL(ret);
14058     ptr = ret;
14059     FILL_ADVANCE_NODE(ptr, op);
14060 #ifdef RE_TRACK_PATTERN_OFFSETS
14061     if (RExC_offsets) {         /* MJD */
14062         MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n", 
14063               "reg_node", __LINE__, 
14064               PL_reg_name[op],
14065               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] 
14066                 ? "Overwriting end of array!\n" : "OK",
14067               (UV)(RExC_emit - RExC_emit_start),
14068               (UV)(RExC_parse - RExC_start),
14069               (UV)RExC_offsets[0])); 
14070         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
14071     }
14072 #endif
14073     RExC_emit = ptr;
14074     return(ret);
14075 }
14076
14077 /*
14078 - reganode - emit a node with an argument
14079 */
14080 STATIC regnode *                        /* Location. */
14081 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
14082 {
14083     dVAR;
14084     regnode *ptr;
14085     regnode * const ret = RExC_emit;
14086     GET_RE_DEBUG_FLAGS_DECL;
14087
14088     PERL_ARGS_ASSERT_REGANODE;
14089
14090     if (SIZE_ONLY) {
14091         SIZE_ALIGN(RExC_size);
14092         RExC_size += 2;
14093         /* 
14094            We can't do this:
14095            
14096            assert(2==regarglen[op]+1); 
14097
14098            Anything larger than this has to allocate the extra amount.
14099            If we changed this to be:
14100            
14101            RExC_size += (1 + regarglen[op]);
14102            
14103            then it wouldn't matter. Its not clear what side effect
14104            might come from that so its not done so far.
14105            -- dmq
14106         */
14107         return(ret);
14108     }
14109     if (RExC_emit >= RExC_emit_bound)
14110         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
14111                    op, RExC_emit, RExC_emit_bound);
14112
14113     NODE_ALIGN_FILL(ret);
14114     ptr = ret;
14115     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
14116 #ifdef RE_TRACK_PATTERN_OFFSETS
14117     if (RExC_offsets) {         /* MJD */
14118         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
14119               "reganode",
14120               __LINE__,
14121               PL_reg_name[op],
14122               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? 
14123               "Overwriting end of array!\n" : "OK",
14124               (UV)(RExC_emit - RExC_emit_start),
14125               (UV)(RExC_parse - RExC_start),
14126               (UV)RExC_offsets[0])); 
14127         Set_Cur_Node_Offset;
14128     }
14129 #endif            
14130     RExC_emit = ptr;
14131     return(ret);
14132 }
14133
14134 /*
14135 - reguni - emit (if appropriate) a Unicode character
14136 */
14137 STATIC STRLEN
14138 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
14139 {
14140     dVAR;
14141
14142     PERL_ARGS_ASSERT_REGUNI;
14143
14144     return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
14145 }
14146
14147 /*
14148 - reginsert - insert an operator in front of already-emitted operand
14149 *
14150 * Means relocating the operand.
14151 */
14152 STATIC void
14153 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
14154 {
14155     dVAR;
14156     regnode *src;
14157     regnode *dst;
14158     regnode *place;
14159     const int offset = regarglen[(U8)op];
14160     const int size = NODE_STEP_REGNODE + offset;
14161     GET_RE_DEBUG_FLAGS_DECL;
14162
14163     PERL_ARGS_ASSERT_REGINSERT;
14164     PERL_UNUSED_ARG(depth);
14165 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
14166     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
14167     if (SIZE_ONLY) {
14168         RExC_size += size;
14169         return;
14170     }
14171
14172     src = RExC_emit;
14173     RExC_emit += size;
14174     dst = RExC_emit;
14175     if (RExC_open_parens) {
14176         int paren;
14177         /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
14178         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
14179             if ( RExC_open_parens[paren] >= opnd ) {
14180                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
14181                 RExC_open_parens[paren] += size;
14182             } else {
14183                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
14184             }
14185             if ( RExC_close_parens[paren] >= opnd ) {
14186                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
14187                 RExC_close_parens[paren] += size;
14188             } else {
14189                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
14190             }
14191         }
14192     }
14193
14194     while (src > opnd) {
14195         StructCopy(--src, --dst, regnode);
14196 #ifdef RE_TRACK_PATTERN_OFFSETS
14197         if (RExC_offsets) {     /* MJD 20010112 */
14198             MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
14199                   "reg_insert",
14200                   __LINE__,
14201                   PL_reg_name[op],
14202                   (UV)(dst - RExC_emit_start) > RExC_offsets[0] 
14203                     ? "Overwriting end of array!\n" : "OK",
14204                   (UV)(src - RExC_emit_start),
14205                   (UV)(dst - RExC_emit_start),
14206                   (UV)RExC_offsets[0])); 
14207             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
14208             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
14209         }
14210 #endif
14211     }
14212     
14213
14214     place = opnd;               /* Op node, where operand used to be. */
14215 #ifdef RE_TRACK_PATTERN_OFFSETS
14216     if (RExC_offsets) {         /* MJD */
14217         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
14218               "reginsert",
14219               __LINE__,
14220               PL_reg_name[op],
14221               (UV)(place - RExC_emit_start) > RExC_offsets[0] 
14222               ? "Overwriting end of array!\n" : "OK",
14223               (UV)(place - RExC_emit_start),
14224               (UV)(RExC_parse - RExC_start),
14225               (UV)RExC_offsets[0]));
14226         Set_Node_Offset(place, RExC_parse);
14227         Set_Node_Length(place, 1);
14228     }
14229 #endif    
14230     src = NEXTOPER(place);
14231     FILL_ADVANCE_NODE(place, op);
14232     Zero(src, offset, regnode);
14233 }
14234
14235 /*
14236 - regtail - set the next-pointer at the end of a node chain of p to val.
14237 - SEE ALSO: regtail_study
14238 */
14239 /* TODO: All three parms should be const */
14240 STATIC void
14241 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
14242 {
14243     dVAR;
14244     regnode *scan;
14245     GET_RE_DEBUG_FLAGS_DECL;
14246
14247     PERL_ARGS_ASSERT_REGTAIL;
14248 #ifndef DEBUGGING
14249     PERL_UNUSED_ARG(depth);
14250 #endif
14251
14252     if (SIZE_ONLY)
14253         return;
14254
14255     /* Find last node. */
14256     scan = p;
14257     for (;;) {
14258         regnode * const temp = regnext(scan);
14259         DEBUG_PARSE_r({
14260             SV * const mysv=sv_newmortal();
14261             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
14262             regprop(RExC_rx, mysv, scan);
14263             PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
14264                 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
14265                     (temp == NULL ? "->" : ""),
14266                     (temp == NULL ? PL_reg_name[OP(val)] : "")
14267             );
14268         });
14269         if (temp == NULL)
14270             break;
14271         scan = temp;
14272     }
14273
14274     if (reg_off_by_arg[OP(scan)]) {
14275         ARG_SET(scan, val - scan);
14276     }
14277     else {
14278         NEXT_OFF(scan) = val - scan;
14279     }
14280 }
14281
14282 #ifdef DEBUGGING
14283 /*
14284 - regtail_study - set the next-pointer at the end of a node chain of p to val.
14285 - Look for optimizable sequences at the same time.
14286 - currently only looks for EXACT chains.
14287
14288 This is experimental code. The idea is to use this routine to perform 
14289 in place optimizations on branches and groups as they are constructed,
14290 with the long term intention of removing optimization from study_chunk so
14291 that it is purely analytical.
14292
14293 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
14294 to control which is which.
14295
14296 */
14297 /* TODO: All four parms should be const */
14298
14299 STATIC U8
14300 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
14301 {
14302     dVAR;
14303     regnode *scan;
14304     U8 exact = PSEUDO;
14305 #ifdef EXPERIMENTAL_INPLACESCAN
14306     I32 min = 0;
14307 #endif
14308     GET_RE_DEBUG_FLAGS_DECL;
14309
14310     PERL_ARGS_ASSERT_REGTAIL_STUDY;
14311
14312
14313     if (SIZE_ONLY)
14314         return exact;
14315
14316     /* Find last node. */
14317
14318     scan = p;
14319     for (;;) {
14320         regnode * const temp = regnext(scan);
14321 #ifdef EXPERIMENTAL_INPLACESCAN
14322         if (PL_regkind[OP(scan)] == EXACT) {
14323             bool has_exactf_sharp_s;    /* Unexamined in this routine */
14324             if (join_exact(pRExC_state,scan,&min, &has_exactf_sharp_s, 1,val,depth+1))
14325                 return EXACT;
14326         }
14327 #endif
14328         if ( exact ) {
14329             switch (OP(scan)) {
14330                 case EXACT:
14331                 case EXACTF:
14332                 case EXACTFA:
14333                 case EXACTFU:
14334                 case EXACTFU_SS:
14335                 case EXACTFU_TRICKYFOLD:
14336                 case EXACTFL:
14337                         if( exact == PSEUDO )
14338                             exact= OP(scan);
14339                         else if ( exact != OP(scan) )
14340                             exact= 0;
14341                 case NOTHING:
14342                     break;
14343                 default:
14344                     exact= 0;
14345             }
14346         }
14347         DEBUG_PARSE_r({
14348             SV * const mysv=sv_newmortal();
14349             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
14350             regprop(RExC_rx, mysv, scan);
14351             PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
14352                 SvPV_nolen_const(mysv),
14353                 REG_NODE_NUM(scan),
14354                 PL_reg_name[exact]);
14355         });
14356         if (temp == NULL)
14357             break;
14358         scan = temp;
14359     }
14360     DEBUG_PARSE_r({
14361         SV * const mysv_val=sv_newmortal();
14362         DEBUG_PARSE_MSG("");
14363         regprop(RExC_rx, mysv_val, val);
14364         PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
14365                       SvPV_nolen_const(mysv_val),
14366                       (IV)REG_NODE_NUM(val),
14367                       (IV)(val - scan)
14368         );
14369     });
14370     if (reg_off_by_arg[OP(scan)]) {
14371         ARG_SET(scan, val - scan);
14372     }
14373     else {
14374         NEXT_OFF(scan) = val - scan;
14375     }
14376
14377     return exact;
14378 }
14379 #endif
14380
14381 /*
14382  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
14383  */
14384 #ifdef DEBUGGING
14385 static void 
14386 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
14387 {
14388     int bit;
14389     int set=0;
14390     regex_charset cs;
14391
14392     for (bit=0; bit<32; bit++) {
14393         if (flags & (1<<bit)) {
14394             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
14395                 continue;
14396             }
14397             if (!set++ && lead) 
14398                 PerlIO_printf(Perl_debug_log, "%s",lead);
14399             PerlIO_printf(Perl_debug_log, "%s ",PL_reg_extflags_name[bit]);
14400         }               
14401     }      
14402     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
14403             if (!set++ && lead) {
14404                 PerlIO_printf(Perl_debug_log, "%s",lead);
14405             }
14406             switch (cs) {
14407                 case REGEX_UNICODE_CHARSET:
14408                     PerlIO_printf(Perl_debug_log, "UNICODE");
14409                     break;
14410                 case REGEX_LOCALE_CHARSET:
14411                     PerlIO_printf(Perl_debug_log, "LOCALE");
14412                     break;
14413                 case REGEX_ASCII_RESTRICTED_CHARSET:
14414                     PerlIO_printf(Perl_debug_log, "ASCII-RESTRICTED");
14415                     break;
14416                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
14417                     PerlIO_printf(Perl_debug_log, "ASCII-MORE_RESTRICTED");
14418                     break;
14419                 default:
14420                     PerlIO_printf(Perl_debug_log, "UNKNOWN CHARACTER SET");
14421                     break;
14422             }
14423     }
14424     if (lead)  {
14425         if (set) 
14426             PerlIO_printf(Perl_debug_log, "\n");
14427         else 
14428             PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
14429     }            
14430 }   
14431 #endif
14432
14433 void
14434 Perl_regdump(pTHX_ const regexp *r)
14435 {
14436 #ifdef DEBUGGING
14437     dVAR;
14438     SV * const sv = sv_newmortal();
14439     SV *dsv= sv_newmortal();
14440     RXi_GET_DECL(r,ri);
14441     GET_RE_DEBUG_FLAGS_DECL;
14442
14443     PERL_ARGS_ASSERT_REGDUMP;
14444
14445     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
14446
14447     /* Header fields of interest. */
14448     if (r->anchored_substr) {
14449         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr), 
14450             RE_SV_DUMPLEN(r->anchored_substr), 30);
14451         PerlIO_printf(Perl_debug_log,
14452                       "anchored %s%s at %"IVdf" ",
14453                       s, RE_SV_TAIL(r->anchored_substr),
14454                       (IV)r->anchored_offset);
14455     } else if (r->anchored_utf8) {
14456         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8), 
14457             RE_SV_DUMPLEN(r->anchored_utf8), 30);
14458         PerlIO_printf(Perl_debug_log,
14459                       "anchored utf8 %s%s at %"IVdf" ",
14460                       s, RE_SV_TAIL(r->anchored_utf8),
14461                       (IV)r->anchored_offset);
14462     }                 
14463     if (r->float_substr) {
14464         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr), 
14465             RE_SV_DUMPLEN(r->float_substr), 30);
14466         PerlIO_printf(Perl_debug_log,
14467                       "floating %s%s at %"IVdf"..%"UVuf" ",
14468                       s, RE_SV_TAIL(r->float_substr),
14469                       (IV)r->float_min_offset, (UV)r->float_max_offset);
14470     } else if (r->float_utf8) {
14471         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8), 
14472             RE_SV_DUMPLEN(r->float_utf8), 30);
14473         PerlIO_printf(Perl_debug_log,
14474                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
14475                       s, RE_SV_TAIL(r->float_utf8),
14476                       (IV)r->float_min_offset, (UV)r->float_max_offset);
14477     }
14478     if (r->check_substr || r->check_utf8)
14479         PerlIO_printf(Perl_debug_log,
14480                       (const char *)
14481                       (r->check_substr == r->float_substr
14482                        && r->check_utf8 == r->float_utf8
14483                        ? "(checking floating" : "(checking anchored"));
14484     if (r->extflags & RXf_NOSCAN)
14485         PerlIO_printf(Perl_debug_log, " noscan");
14486     if (r->extflags & RXf_CHECK_ALL)
14487         PerlIO_printf(Perl_debug_log, " isall");
14488     if (r->check_substr || r->check_utf8)
14489         PerlIO_printf(Perl_debug_log, ") ");
14490
14491     if (ri->regstclass) {
14492         regprop(r, sv, ri->regstclass);
14493         PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
14494     }
14495     if (r->extflags & RXf_ANCH) {
14496         PerlIO_printf(Perl_debug_log, "anchored");
14497         if (r->extflags & RXf_ANCH_BOL)
14498             PerlIO_printf(Perl_debug_log, "(BOL)");
14499         if (r->extflags & RXf_ANCH_MBOL)
14500             PerlIO_printf(Perl_debug_log, "(MBOL)");
14501         if (r->extflags & RXf_ANCH_SBOL)
14502             PerlIO_printf(Perl_debug_log, "(SBOL)");
14503         if (r->extflags & RXf_ANCH_GPOS)
14504             PerlIO_printf(Perl_debug_log, "(GPOS)");
14505         PerlIO_putc(Perl_debug_log, ' ');
14506     }
14507     if (r->extflags & RXf_GPOS_SEEN)
14508         PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
14509     if (r->intflags & PREGf_SKIP)
14510         PerlIO_printf(Perl_debug_log, "plus ");
14511     if (r->intflags & PREGf_IMPLICIT)
14512         PerlIO_printf(Perl_debug_log, "implicit ");
14513     PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
14514     if (r->extflags & RXf_EVAL_SEEN)
14515         PerlIO_printf(Perl_debug_log, "with eval ");
14516     PerlIO_printf(Perl_debug_log, "\n");
14517     DEBUG_FLAGS_r(regdump_extflags("r->extflags: ",r->extflags));            
14518 #else
14519     PERL_ARGS_ASSERT_REGDUMP;
14520     PERL_UNUSED_CONTEXT;
14521     PERL_UNUSED_ARG(r);
14522 #endif  /* DEBUGGING */
14523 }
14524
14525 /*
14526 - regprop - printable representation of opcode
14527 */
14528 #define EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags) \
14529 STMT_START { \
14530         if (do_sep) {                           \
14531             Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]); \
14532             if (flags & ANYOF_INVERT)           \
14533                 /*make sure the invert info is in each */ \
14534                 sv_catpvs(sv, "^");             \
14535             do_sep = 0;                         \
14536         }                                       \
14537 } STMT_END
14538
14539 void
14540 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
14541 {
14542 #ifdef DEBUGGING
14543     dVAR;
14544     int k;
14545
14546     /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
14547     static const char * const anyofs[] = {
14548 #if _CC_WORDCHAR != 0 || _CC_DIGIT != 1 || _CC_ALPHA != 2 || _CC_LOWER != 3 \
14549     || _CC_UPPER != 4 || _CC_PUNCT != 5 || _CC_PRINT != 6                   \
14550     || _CC_ALPHANUMERIC != 7 || _CC_GRAPH != 8 || _CC_CASED != 9            \
14551     || _CC_SPACE != 10 || _CC_BLANK != 11 || _CC_XDIGIT != 12               \
14552     || _CC_PSXSPC != 13 || _CC_CNTRL != 14 || _CC_ASCII != 15               \
14553     || _CC_VERTSPACE != 16
14554   #error Need to adjust order of anyofs[]
14555 #endif
14556         "[\\w]",
14557         "[\\W]",
14558         "[\\d]",
14559         "[\\D]",
14560         "[:alpha:]",
14561         "[:^alpha:]",
14562         "[:lower:]",
14563         "[:^lower:]",
14564         "[:upper:]",
14565         "[:^upper:]",
14566         "[:punct:]",
14567         "[:^punct:]",
14568         "[:print:]",
14569         "[:^print:]",
14570         "[:alnum:]",
14571         "[:^alnum:]",
14572         "[:graph:]",
14573         "[:^graph:]",
14574         "[:cased:]",
14575         "[:^cased:]",
14576         "[\\s]",
14577         "[\\S]",
14578         "[:blank:]",
14579         "[:^blank:]",
14580         "[:xdigit:]",
14581         "[:^xdigit:]",
14582         "[:space:]",
14583         "[:^space:]",
14584         "[:cntrl:]",
14585         "[:^cntrl:]",
14586         "[:ascii:]",
14587         "[:^ascii:]",
14588         "[\\v]",
14589         "[\\V]"
14590     };
14591     RXi_GET_DECL(prog,progi);
14592     GET_RE_DEBUG_FLAGS_DECL;
14593     
14594     PERL_ARGS_ASSERT_REGPROP;
14595
14596     sv_setpvs(sv, "");
14597
14598     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
14599         /* It would be nice to FAIL() here, but this may be called from
14600            regexec.c, and it would be hard to supply pRExC_state. */
14601         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
14602     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
14603
14604     k = PL_regkind[OP(o)];
14605
14606     if (k == EXACT) {
14607         sv_catpvs(sv, " ");
14608         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT) 
14609          * is a crude hack but it may be the best for now since 
14610          * we have no flag "this EXACTish node was UTF-8" 
14611          * --jhi */
14612         pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
14613                   PERL_PV_ESCAPE_UNI_DETECT |
14614                   PERL_PV_ESCAPE_NONASCII   |
14615                   PERL_PV_PRETTY_ELLIPSES   |
14616                   PERL_PV_PRETTY_LTGT       |
14617                   PERL_PV_PRETTY_NOCLEAR
14618                   );
14619     } else if (k == TRIE) {
14620         /* print the details of the trie in dumpuntil instead, as
14621          * progi->data isn't available here */
14622         const char op = OP(o);
14623         const U32 n = ARG(o);
14624         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
14625                (reg_ac_data *)progi->data->data[n] :
14626                NULL;
14627         const reg_trie_data * const trie
14628             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
14629         
14630         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
14631         DEBUG_TRIE_COMPILE_r(
14632             Perl_sv_catpvf(aTHX_ sv,
14633                 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
14634                 (UV)trie->startstate,
14635                 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
14636                 (UV)trie->wordcount,
14637                 (UV)trie->minlen,
14638                 (UV)trie->maxlen,
14639                 (UV)TRIE_CHARCOUNT(trie),
14640                 (UV)trie->uniquecharcount
14641             )
14642         );
14643         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
14644             int i;
14645             int rangestart = -1;
14646             U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
14647             sv_catpvs(sv, "[");
14648             for (i = 0; i <= 256; i++) {
14649                 if (i < 256 && BITMAP_TEST(bitmap,i)) {
14650                     if (rangestart == -1)
14651                         rangestart = i;
14652                 } else if (rangestart != -1) {
14653                     if (i <= rangestart + 3)
14654                         for (; rangestart < i; rangestart++)
14655                             put_byte(sv, rangestart);
14656                     else {
14657                         put_byte(sv, rangestart);
14658                         sv_catpvs(sv, "-");
14659                         put_byte(sv, i - 1);
14660                     }
14661                     rangestart = -1;
14662                 }
14663             }
14664             sv_catpvs(sv, "]");
14665         } 
14666          
14667     } else if (k == CURLY) {
14668         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
14669             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
14670         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
14671     }
14672     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
14673         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
14674     else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
14675         Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
14676         if ( RXp_PAREN_NAMES(prog) ) {
14677             if ( k != REF || (OP(o) < NREF)) {
14678                 AV *list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
14679                 SV **name= av_fetch(list, ARG(o), 0 );
14680                 if (name)
14681                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
14682             }       
14683             else {
14684                 AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]);
14685                 SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]);
14686                 I32 *nums=(I32*)SvPVX(sv_dat);
14687                 SV **name= av_fetch(list, nums[0], 0 );
14688                 I32 n;
14689                 if (name) {
14690                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
14691                         Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
14692                                     (n ? "," : ""), (IV)nums[n]);
14693                     }
14694                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
14695                 }
14696             }
14697         }            
14698     } else if (k == GOSUB) 
14699         Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
14700     else if (k == VERB) {
14701         if (!o->flags) 
14702             Perl_sv_catpvf(aTHX_ sv, ":%"SVf, 
14703                            SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
14704     } else if (k == LOGICAL)
14705         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);     /* 2: embedded, otherwise 1 */
14706     else if (k == ANYOF) {
14707         int i, rangestart = -1;
14708         const U8 flags = ANYOF_FLAGS(o);
14709         int do_sep = 0;
14710
14711
14712         if (flags & ANYOF_LOCALE)
14713             sv_catpvs(sv, "{loc}");
14714         if (flags & ANYOF_LOC_FOLD)
14715             sv_catpvs(sv, "{i}");
14716         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
14717         if (flags & ANYOF_INVERT)
14718             sv_catpvs(sv, "^");
14719
14720         /* output what the standard cp 0-255 bitmap matches */
14721         for (i = 0; i <= 256; i++) {
14722             if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
14723                 if (rangestart == -1)
14724                     rangestart = i;
14725             } else if (rangestart != -1) {
14726                 if (i <= rangestart + 3)
14727                     for (; rangestart < i; rangestart++)
14728                         put_byte(sv, rangestart);
14729                 else {
14730                     put_byte(sv, rangestart);
14731                     sv_catpvs(sv, "-");
14732                     put_byte(sv, i - 1);
14733                 }
14734                 do_sep = 1;
14735                 rangestart = -1;
14736             }
14737         }
14738         
14739         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
14740         /* output any special charclass tests (used entirely under use locale) */
14741         if (ANYOF_CLASS_TEST_ANY_SET(o))
14742             for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
14743                 if (ANYOF_CLASS_TEST(o,i)) {
14744                     sv_catpv(sv, anyofs[i]);
14745                     do_sep = 1;
14746                 }
14747         
14748         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
14749         
14750         if (flags & ANYOF_NON_UTF8_LATIN1_ALL) {
14751             sv_catpvs(sv, "{non-utf8-latin1-all}");
14752         }
14753
14754         /* output information about the unicode matching */
14755         if (flags & ANYOF_UNICODE_ALL)
14756             sv_catpvs(sv, "{unicode_all}");
14757         else if (ANYOF_NONBITMAP(o))
14758             sv_catpvs(sv, "{unicode}");
14759         if (flags & ANYOF_NONBITMAP_NON_UTF8)
14760             sv_catpvs(sv, "{outside bitmap}");
14761
14762         if (ANYOF_NONBITMAP(o)) {
14763             SV *lv; /* Set if there is something outside the bit map */
14764             SV * const sw = regclass_swash(prog, o, FALSE, &lv, NULL);
14765             bool byte_output = FALSE;   /* If something in the bitmap has been
14766                                            output */
14767
14768             if (lv && lv != &PL_sv_undef) {
14769                 if (sw) {
14770                     U8 s[UTF8_MAXBYTES_CASE+1];
14771
14772                     for (i = 0; i <= 256; i++) { /* Look at chars in bitmap */
14773                         uvchr_to_utf8(s, i);
14774
14775                         if (i < 256
14776                             && ! ANYOF_BITMAP_TEST(o, i)    /* Don't duplicate
14777                                                                things already
14778                                                                output as part
14779                                                                of the bitmap */
14780                             && swash_fetch(sw, s, TRUE))
14781                         {
14782                             if (rangestart == -1)
14783                                 rangestart = i;
14784                         } else if (rangestart != -1) {
14785                             byte_output = TRUE;
14786                             if (i <= rangestart + 3)
14787                                 for (; rangestart < i; rangestart++) {
14788                                     put_byte(sv, rangestart);
14789                                 }
14790                             else {
14791                                 put_byte(sv, rangestart);
14792                                 sv_catpvs(sv, "-");
14793                                 put_byte(sv, i-1);
14794                             }
14795                             rangestart = -1;
14796                         }
14797                     }
14798                 }
14799
14800                 {
14801                     char *s = savesvpv(lv);
14802                     char * const origs = s;
14803
14804                     while (*s && *s != '\n')
14805                         s++;
14806
14807                     if (*s == '\n') {
14808                         const char * const t = ++s;
14809
14810                         if (byte_output) {
14811                             sv_catpvs(sv, " ");
14812                         }
14813
14814                         while (*s) {
14815                             if (*s == '\n') {
14816
14817                                 /* Truncate very long output */
14818                                 if (s - origs > 256) {
14819                                     Perl_sv_catpvf(aTHX_ sv,
14820                                                    "%.*s...",
14821                                                    (int) (s - origs - 1),
14822                                                    t);
14823                                     goto out_dump;
14824                                 }
14825                                 *s = ' ';
14826                             }
14827                             else if (*s == '\t') {
14828                                 *s = '-';
14829                             }
14830                             s++;
14831                         }
14832                         if (s[-1] == ' ')
14833                             s[-1] = 0;
14834
14835                         sv_catpv(sv, t);
14836                     }
14837
14838                 out_dump:
14839
14840                     Safefree(origs);
14841                 }
14842                 SvREFCNT_dec_NN(lv);
14843             }
14844         }
14845
14846         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
14847     }
14848     else if (k == POSIXD || k == NPOSIXD) {
14849         U8 index = FLAGS(o) * 2;
14850         if (index > (sizeof(anyofs) / sizeof(anyofs[0]))) {
14851             Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
14852         }
14853         else {
14854             sv_catpv(sv, anyofs[index]);
14855         }
14856     }
14857     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
14858         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
14859 #else
14860     PERL_UNUSED_CONTEXT;
14861     PERL_UNUSED_ARG(sv);
14862     PERL_UNUSED_ARG(o);
14863     PERL_UNUSED_ARG(prog);
14864 #endif  /* DEBUGGING */
14865 }
14866
14867 SV *
14868 Perl_re_intuit_string(pTHX_ REGEXP * const r)
14869 {                               /* Assume that RE_INTUIT is set */
14870     dVAR;
14871     struct regexp *const prog = ReANY(r);
14872     GET_RE_DEBUG_FLAGS_DECL;
14873
14874     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
14875     PERL_UNUSED_CONTEXT;
14876
14877     DEBUG_COMPILE_r(
14878         {
14879             const char * const s = SvPV_nolen_const(prog->check_substr
14880                       ? prog->check_substr : prog->check_utf8);
14881
14882             if (!PL_colorset) reginitcolors();
14883             PerlIO_printf(Perl_debug_log,
14884                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
14885                       PL_colors[4],
14886                       prog->check_substr ? "" : "utf8 ",
14887                       PL_colors[5],PL_colors[0],
14888                       s,
14889                       PL_colors[1],
14890                       (strlen(s) > 60 ? "..." : ""));
14891         } );
14892
14893     return prog->check_substr ? prog->check_substr : prog->check_utf8;
14894 }
14895
14896 /* 
14897    pregfree() 
14898    
14899    handles refcounting and freeing the perl core regexp structure. When 
14900    it is necessary to actually free the structure the first thing it 
14901    does is call the 'free' method of the regexp_engine associated to
14902    the regexp, allowing the handling of the void *pprivate; member 
14903    first. (This routine is not overridable by extensions, which is why 
14904    the extensions free is called first.)
14905    
14906    See regdupe and regdupe_internal if you change anything here. 
14907 */
14908 #ifndef PERL_IN_XSUB_RE
14909 void
14910 Perl_pregfree(pTHX_ REGEXP *r)
14911 {
14912     SvREFCNT_dec(r);
14913 }
14914
14915 void
14916 Perl_pregfree2(pTHX_ REGEXP *rx)
14917 {
14918     dVAR;
14919     struct regexp *const r = ReANY(rx);
14920     GET_RE_DEBUG_FLAGS_DECL;
14921
14922     PERL_ARGS_ASSERT_PREGFREE2;
14923
14924     if (r->mother_re) {
14925         ReREFCNT_dec(r->mother_re);
14926     } else {
14927         CALLREGFREE_PVT(rx); /* free the private data */
14928         SvREFCNT_dec(RXp_PAREN_NAMES(r));
14929         Safefree(r->xpv_len_u.xpvlenu_pv);
14930     }        
14931     if (r->substrs) {
14932         SvREFCNT_dec(r->anchored_substr);
14933         SvREFCNT_dec(r->anchored_utf8);
14934         SvREFCNT_dec(r->float_substr);
14935         SvREFCNT_dec(r->float_utf8);
14936         Safefree(r->substrs);
14937     }
14938     RX_MATCH_COPY_FREE(rx);
14939 #ifdef PERL_ANY_COW
14940     SvREFCNT_dec(r->saved_copy);
14941 #endif
14942     Safefree(r->offs);
14943     SvREFCNT_dec(r->qr_anoncv);
14944     rx->sv_u.svu_rx = 0;
14945 }
14946
14947 /*  reg_temp_copy()
14948     
14949     This is a hacky workaround to the structural issue of match results
14950     being stored in the regexp structure which is in turn stored in
14951     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
14952     could be PL_curpm in multiple contexts, and could require multiple
14953     result sets being associated with the pattern simultaneously, such
14954     as when doing a recursive match with (??{$qr})
14955     
14956     The solution is to make a lightweight copy of the regexp structure 
14957     when a qr// is returned from the code executed by (??{$qr}) this
14958     lightweight copy doesn't actually own any of its data except for
14959     the starp/end and the actual regexp structure itself. 
14960     
14961 */    
14962     
14963     
14964 REGEXP *
14965 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
14966 {
14967     struct regexp *ret;
14968     struct regexp *const r = ReANY(rx);
14969     const bool islv = ret_x && SvTYPE(ret_x) == SVt_PVLV;
14970
14971     PERL_ARGS_ASSERT_REG_TEMP_COPY;
14972
14973     if (!ret_x)
14974         ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
14975     else {
14976         SvOK_off((SV *)ret_x);
14977         if (islv) {
14978             /* For PVLVs, SvANY points to the xpvlv body while sv_u points
14979                to the regexp.  (For SVt_REGEXPs, sv_upgrade has already
14980                made both spots point to the same regexp body.) */
14981             REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
14982             assert(!SvPVX(ret_x));
14983             ret_x->sv_u.svu_rx = temp->sv_any;
14984             temp->sv_any = NULL;
14985             SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
14986             SvREFCNT_dec_NN(temp);
14987             /* SvCUR still resides in the xpvlv struct, so the regexp copy-
14988                ing below will not set it. */
14989             SvCUR_set(ret_x, SvCUR(rx));
14990         }
14991     }
14992     /* This ensures that SvTHINKFIRST(sv) is true, and hence that
14993        sv_force_normal(sv) is called.  */
14994     SvFAKE_on(ret_x);
14995     ret = ReANY(ret_x);
14996     
14997     SvFLAGS(ret_x) |= SvUTF8(rx);
14998     /* We share the same string buffer as the original regexp, on which we
14999        hold a reference count, incremented when mother_re is set below.
15000        The string pointer is copied here, being part of the regexp struct.
15001      */
15002     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
15003            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
15004     if (r->offs) {
15005         const I32 npar = r->nparens+1;
15006         Newx(ret->offs, npar, regexp_paren_pair);
15007         Copy(r->offs, ret->offs, npar, regexp_paren_pair);
15008     }
15009     if (r->substrs) {
15010         Newx(ret->substrs, 1, struct reg_substr_data);
15011         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
15012
15013         SvREFCNT_inc_void(ret->anchored_substr);
15014         SvREFCNT_inc_void(ret->anchored_utf8);
15015         SvREFCNT_inc_void(ret->float_substr);
15016         SvREFCNT_inc_void(ret->float_utf8);
15017
15018         /* check_substr and check_utf8, if non-NULL, point to either their
15019            anchored or float namesakes, and don't hold a second reference.  */
15020     }
15021     RX_MATCH_COPIED_off(ret_x);
15022 #ifdef PERL_ANY_COW
15023     ret->saved_copy = NULL;
15024 #endif
15025     ret->mother_re = ReREFCNT_inc(r->mother_re ? r->mother_re : rx);
15026     SvREFCNT_inc_void(ret->qr_anoncv);
15027     
15028     return ret_x;
15029 }
15030 #endif
15031
15032 /* regfree_internal() 
15033
15034    Free the private data in a regexp. This is overloadable by 
15035    extensions. Perl takes care of the regexp structure in pregfree(), 
15036    this covers the *pprivate pointer which technically perl doesn't 
15037    know about, however of course we have to handle the 
15038    regexp_internal structure when no extension is in use. 
15039    
15040    Note this is called before freeing anything in the regexp 
15041    structure. 
15042  */
15043  
15044 void
15045 Perl_regfree_internal(pTHX_ REGEXP * const rx)
15046 {
15047     dVAR;
15048     struct regexp *const r = ReANY(rx);
15049     RXi_GET_DECL(r,ri);
15050     GET_RE_DEBUG_FLAGS_DECL;
15051
15052     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
15053
15054     DEBUG_COMPILE_r({
15055         if (!PL_colorset)
15056             reginitcolors();
15057         {
15058             SV *dsv= sv_newmortal();
15059             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
15060                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
15061             PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n", 
15062                 PL_colors[4],PL_colors[5],s);
15063         }
15064     });
15065 #ifdef RE_TRACK_PATTERN_OFFSETS
15066     if (ri->u.offsets)
15067         Safefree(ri->u.offsets);             /* 20010421 MJD */
15068 #endif
15069     if (ri->code_blocks) {
15070         int n;
15071         for (n = 0; n < ri->num_code_blocks; n++)
15072             SvREFCNT_dec(ri->code_blocks[n].src_regex);
15073         Safefree(ri->code_blocks);
15074     }
15075
15076     if (ri->data) {
15077         int n = ri->data->count;
15078
15079         while (--n >= 0) {
15080           /* If you add a ->what type here, update the comment in regcomp.h */
15081             switch (ri->data->what[n]) {
15082             case 'a':
15083             case 'r':
15084             case 's':
15085             case 'S':
15086             case 'u':
15087                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
15088                 break;
15089             case 'f':
15090                 Safefree(ri->data->data[n]);
15091                 break;
15092             case 'l':
15093             case 'L':
15094                 break;
15095             case 'T':           
15096                 { /* Aho Corasick add-on structure for a trie node.
15097                      Used in stclass optimization only */
15098                     U32 refcount;
15099                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
15100                     OP_REFCNT_LOCK;
15101                     refcount = --aho->refcount;
15102                     OP_REFCNT_UNLOCK;
15103                     if ( !refcount ) {
15104                         PerlMemShared_free(aho->states);
15105                         PerlMemShared_free(aho->fail);
15106                          /* do this last!!!! */
15107                         PerlMemShared_free(ri->data->data[n]);
15108                         PerlMemShared_free(ri->regstclass);
15109                     }
15110                 }
15111                 break;
15112             case 't':
15113                 {
15114                     /* trie structure. */
15115                     U32 refcount;
15116                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
15117                     OP_REFCNT_LOCK;
15118                     refcount = --trie->refcount;
15119                     OP_REFCNT_UNLOCK;
15120                     if ( !refcount ) {
15121                         PerlMemShared_free(trie->charmap);
15122                         PerlMemShared_free(trie->states);
15123                         PerlMemShared_free(trie->trans);
15124                         if (trie->bitmap)
15125                             PerlMemShared_free(trie->bitmap);
15126                         if (trie->jump)
15127                             PerlMemShared_free(trie->jump);
15128                         PerlMemShared_free(trie->wordinfo);
15129                         /* do this last!!!! */
15130                         PerlMemShared_free(ri->data->data[n]);
15131                     }
15132                 }
15133                 break;
15134             default:
15135                 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
15136             }
15137         }
15138         Safefree(ri->data->what);
15139         Safefree(ri->data);
15140     }
15141
15142     Safefree(ri);
15143 }
15144
15145 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
15146 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
15147 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
15148
15149 /* 
15150    re_dup - duplicate a regexp. 
15151    
15152    This routine is expected to clone a given regexp structure. It is only
15153    compiled under USE_ITHREADS.
15154
15155    After all of the core data stored in struct regexp is duplicated
15156    the regexp_engine.dupe method is used to copy any private data
15157    stored in the *pprivate pointer. This allows extensions to handle
15158    any duplication it needs to do.
15159
15160    See pregfree() and regfree_internal() if you change anything here. 
15161 */
15162 #if defined(USE_ITHREADS)
15163 #ifndef PERL_IN_XSUB_RE
15164 void
15165 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
15166 {
15167     dVAR;
15168     I32 npar;
15169     const struct regexp *r = ReANY(sstr);
15170     struct regexp *ret = ReANY(dstr);
15171     
15172     PERL_ARGS_ASSERT_RE_DUP_GUTS;
15173
15174     npar = r->nparens+1;
15175     Newx(ret->offs, npar, regexp_paren_pair);
15176     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
15177
15178     if (ret->substrs) {
15179         /* Do it this way to avoid reading from *r after the StructCopy().
15180            That way, if any of the sv_dup_inc()s dislodge *r from the L1
15181            cache, it doesn't matter.  */
15182         const bool anchored = r->check_substr
15183             ? r->check_substr == r->anchored_substr
15184             : r->check_utf8 == r->anchored_utf8;
15185         Newx(ret->substrs, 1, struct reg_substr_data);
15186         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
15187
15188         ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
15189         ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
15190         ret->float_substr = sv_dup_inc(ret->float_substr, param);
15191         ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
15192
15193         /* check_substr and check_utf8, if non-NULL, point to either their
15194            anchored or float namesakes, and don't hold a second reference.  */
15195
15196         if (ret->check_substr) {
15197             if (anchored) {
15198                 assert(r->check_utf8 == r->anchored_utf8);
15199                 ret->check_substr = ret->anchored_substr;
15200                 ret->check_utf8 = ret->anchored_utf8;
15201             } else {
15202                 assert(r->check_substr == r->float_substr);
15203                 assert(r->check_utf8 == r->float_utf8);
15204                 ret->check_substr = ret->float_substr;
15205                 ret->check_utf8 = ret->float_utf8;
15206             }
15207         } else if (ret->check_utf8) {
15208             if (anchored) {
15209                 ret->check_utf8 = ret->anchored_utf8;
15210             } else {
15211                 ret->check_utf8 = ret->float_utf8;
15212             }
15213         }
15214     }
15215
15216     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
15217     ret->qr_anoncv = MUTABLE_CV(sv_dup_inc((const SV *)ret->qr_anoncv, param));
15218
15219     if (ret->pprivate)
15220         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
15221
15222     if (RX_MATCH_COPIED(dstr))
15223         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
15224     else
15225         ret->subbeg = NULL;
15226 #ifdef PERL_ANY_COW
15227     ret->saved_copy = NULL;
15228 #endif
15229
15230     /* Whether mother_re be set or no, we need to copy the string.  We
15231        cannot refrain from copying it when the storage points directly to
15232        our mother regexp, because that's
15233                1: a buffer in a different thread
15234                2: something we no longer hold a reference on
15235                so we need to copy it locally.  */
15236     RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED(sstr), SvCUR(sstr)+1);
15237     ret->mother_re   = NULL;
15238     ret->gofs = 0;
15239 }
15240 #endif /* PERL_IN_XSUB_RE */
15241
15242 /*
15243    regdupe_internal()
15244    
15245    This is the internal complement to regdupe() which is used to copy
15246    the structure pointed to by the *pprivate pointer in the regexp.
15247    This is the core version of the extension overridable cloning hook.
15248    The regexp structure being duplicated will be copied by perl prior
15249    to this and will be provided as the regexp *r argument, however 
15250    with the /old/ structures pprivate pointer value. Thus this routine
15251    may override any copying normally done by perl.
15252    
15253    It returns a pointer to the new regexp_internal structure.
15254 */
15255
15256 void *
15257 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
15258 {
15259     dVAR;
15260     struct regexp *const r = ReANY(rx);
15261     regexp_internal *reti;
15262     int len;
15263     RXi_GET_DECL(r,ri);
15264
15265     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
15266     
15267     len = ProgLen(ri);
15268     
15269     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), char, regexp_internal);
15270     Copy(ri->program, reti->program, len+1, regnode);
15271
15272     reti->num_code_blocks = ri->num_code_blocks;
15273     if (ri->code_blocks) {
15274         int n;
15275         Newxc(reti->code_blocks, ri->num_code_blocks, struct reg_code_block,
15276                 struct reg_code_block);
15277         Copy(ri->code_blocks, reti->code_blocks, ri->num_code_blocks,
15278                 struct reg_code_block);
15279         for (n = 0; n < ri->num_code_blocks; n++)
15280              reti->code_blocks[n].src_regex = (REGEXP*)
15281                     sv_dup_inc((SV*)(ri->code_blocks[n].src_regex), param);
15282     }
15283     else
15284         reti->code_blocks = NULL;
15285
15286     reti->regstclass = NULL;
15287
15288     if (ri->data) {
15289         struct reg_data *d;
15290         const int count = ri->data->count;
15291         int i;
15292
15293         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
15294                 char, struct reg_data);
15295         Newx(d->what, count, U8);
15296
15297         d->count = count;
15298         for (i = 0; i < count; i++) {
15299             d->what[i] = ri->data->what[i];
15300             switch (d->what[i]) {
15301                 /* see also regcomp.h and regfree_internal() */
15302             case 'a': /* actually an AV, but the dup function is identical.  */
15303             case 'r':
15304             case 's':
15305             case 'S':
15306             case 'u': /* actually an HV, but the dup function is identical.  */
15307                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
15308                 break;
15309             case 'f':
15310                 /* This is cheating. */
15311                 Newx(d->data[i], 1, struct regnode_charclass_class);
15312                 StructCopy(ri->data->data[i], d->data[i],
15313                             struct regnode_charclass_class);
15314                 reti->regstclass = (regnode*)d->data[i];
15315                 break;
15316             case 'T':
15317                 /* Trie stclasses are readonly and can thus be shared
15318                  * without duplication. We free the stclass in pregfree
15319                  * when the corresponding reg_ac_data struct is freed.
15320                  */
15321                 reti->regstclass= ri->regstclass;
15322                 /* Fall through */
15323             case 't':
15324                 OP_REFCNT_LOCK;
15325                 ((reg_trie_data*)ri->data->data[i])->refcount++;
15326                 OP_REFCNT_UNLOCK;
15327                 /* Fall through */
15328             case 'l':
15329             case 'L':
15330                 d->data[i] = ri->data->data[i];
15331                 break;
15332             default:
15333                 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
15334             }
15335         }
15336
15337         reti->data = d;
15338     }
15339     else
15340         reti->data = NULL;
15341
15342     reti->name_list_idx = ri->name_list_idx;
15343
15344 #ifdef RE_TRACK_PATTERN_OFFSETS
15345     if (ri->u.offsets) {
15346         Newx(reti->u.offsets, 2*len+1, U32);
15347         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
15348     }
15349 #else
15350     SetProgLen(reti,len);
15351 #endif
15352
15353     return (void*)reti;
15354 }
15355
15356 #endif    /* USE_ITHREADS */
15357
15358 #ifndef PERL_IN_XSUB_RE
15359
15360 /*
15361  - regnext - dig the "next" pointer out of a node
15362  */
15363 regnode *
15364 Perl_regnext(pTHX_ regnode *p)
15365 {
15366     dVAR;
15367     I32 offset;
15368
15369     if (!p)
15370         return(NULL);
15371
15372     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
15373         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(p), (int)REGNODE_MAX);
15374     }
15375
15376     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
15377     if (offset == 0)
15378         return(NULL);
15379
15380     return(p+offset);
15381 }
15382 #endif
15383
15384 STATIC void
15385 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
15386 {
15387     va_list args;
15388     STRLEN l1 = strlen(pat1);
15389     STRLEN l2 = strlen(pat2);
15390     char buf[512];
15391     SV *msv;
15392     const char *message;
15393
15394     PERL_ARGS_ASSERT_RE_CROAK2;
15395
15396     if (l1 > 510)
15397         l1 = 510;
15398     if (l1 + l2 > 510)
15399         l2 = 510 - l1;
15400     Copy(pat1, buf, l1 , char);
15401     Copy(pat2, buf + l1, l2 , char);
15402     buf[l1 + l2] = '\n';
15403     buf[l1 + l2 + 1] = '\0';
15404 #ifdef I_STDARG
15405     /* ANSI variant takes additional second argument */
15406     va_start(args, pat2);
15407 #else
15408     va_start(args);
15409 #endif
15410     msv = vmess(buf, &args);
15411     va_end(args);
15412     message = SvPV_const(msv,l1);
15413     if (l1 > 512)
15414         l1 = 512;
15415     Copy(message, buf, l1 , char);
15416     buf[l1-1] = '\0';                   /* Overwrite \n */
15417     Perl_croak(aTHX_ "%s", buf);
15418 }
15419
15420 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
15421
15422 #ifndef PERL_IN_XSUB_RE
15423 void
15424 Perl_save_re_context(pTHX)
15425 {
15426     dVAR;
15427
15428     struct re_save_state *state;
15429
15430     SAVEVPTR(PL_curcop);
15431     SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
15432
15433     state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
15434     PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
15435     SSPUSHUV(SAVEt_RE_STATE);
15436
15437     Copy(&PL_reg_state, state, 1, struct re_save_state);
15438
15439     PL_reg_oldsaved = NULL;
15440     PL_reg_oldsavedlen = 0;
15441     PL_reg_oldsavedoffset = 0;
15442     PL_reg_oldsavedcoffset = 0;
15443     PL_reg_maxiter = 0;
15444     PL_reg_leftiter = 0;
15445     PL_reg_poscache = NULL;
15446     PL_reg_poscache_size = 0;
15447 #ifdef PERL_ANY_COW
15448     PL_nrs = NULL;
15449 #endif
15450
15451     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
15452     if (PL_curpm) {
15453         const REGEXP * const rx = PM_GETRE(PL_curpm);
15454         if (rx) {
15455             U32 i;
15456             for (i = 1; i <= RX_NPARENS(rx); i++) {
15457                 char digits[TYPE_CHARS(long)];
15458                 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
15459                 GV *const *const gvp
15460                     = (GV**)hv_fetch(PL_defstash, digits, len, 0);
15461
15462                 if (gvp) {
15463                     GV * const gv = *gvp;
15464                     if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
15465                         save_scalar(gv);
15466                 }
15467             }
15468         }
15469     }
15470 }
15471 #endif
15472
15473 #ifdef DEBUGGING
15474
15475 STATIC void
15476 S_put_byte(pTHX_ SV *sv, int c)
15477 {
15478     PERL_ARGS_ASSERT_PUT_BYTE;
15479
15480     /* Our definition of isPRINT() ignores locales, so only bytes that are
15481        not part of UTF-8 are considered printable. I assume that the same
15482        holds for UTF-EBCDIC.
15483        Also, code point 255 is not printable in either (it's E0 in EBCDIC,
15484        which Wikipedia says:
15485
15486        EO, or Eight Ones, is an 8-bit EBCDIC character code represented as all
15487        ones (binary 1111 1111, hexadecimal FF). It is similar, but not
15488        identical, to the ASCII delete (DEL) or rubout control character. ...
15489        it is typically mapped to hexadecimal code 9F, in order to provide a
15490        unique character mapping in both directions)
15491
15492        So the old condition can be simplified to !isPRINT(c)  */
15493     if (!isPRINT(c)) {
15494         if (c < 256) {
15495             Perl_sv_catpvf(aTHX_ sv, "\\x%02x", c);
15496         }
15497         else {
15498             Perl_sv_catpvf(aTHX_ sv, "\\x{%x}", c);
15499         }
15500     }
15501     else {
15502         const char string = c;
15503         if (c == '-' || c == ']' || c == '\\' || c == '^')
15504             sv_catpvs(sv, "\\");
15505         sv_catpvn(sv, &string, 1);
15506     }
15507 }
15508
15509
15510 #define CLEAR_OPTSTART \
15511     if (optstart) STMT_START { \
15512             DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
15513             optstart=NULL; \
15514     } STMT_END
15515
15516 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
15517
15518 STATIC const regnode *
15519 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
15520             const regnode *last, const regnode *plast, 
15521             SV* sv, I32 indent, U32 depth)
15522 {
15523     dVAR;
15524     U8 op = PSEUDO;     /* Arbitrary non-END op. */
15525     const regnode *next;
15526     const regnode *optstart= NULL;
15527     
15528     RXi_GET_DECL(r,ri);
15529     GET_RE_DEBUG_FLAGS_DECL;
15530
15531     PERL_ARGS_ASSERT_DUMPUNTIL;
15532
15533 #ifdef DEBUG_DUMPUNTIL
15534     PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
15535         last ? last-start : 0,plast ? plast-start : 0);
15536 #endif
15537             
15538     if (plast && plast < last) 
15539         last= plast;
15540
15541     while (PL_regkind[op] != END && (!last || node < last)) {
15542         /* While that wasn't END last time... */
15543         NODE_ALIGN(node);
15544         op = OP(node);
15545         if (op == CLOSE || op == WHILEM)
15546             indent--;
15547         next = regnext((regnode *)node);
15548
15549         /* Where, what. */
15550         if (OP(node) == OPTIMIZED) {
15551             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
15552                 optstart = node;
15553             else
15554                 goto after_print;
15555         } else
15556             CLEAR_OPTSTART;
15557
15558         regprop(r, sv, node);
15559         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
15560                       (int)(2*indent + 1), "", SvPVX_const(sv));
15561         
15562         if (OP(node) != OPTIMIZED) {                  
15563             if (next == NULL)           /* Next ptr. */
15564                 PerlIO_printf(Perl_debug_log, " (0)");
15565             else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
15566                 PerlIO_printf(Perl_debug_log, " (FAIL)");
15567             else 
15568                 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
15569             (void)PerlIO_putc(Perl_debug_log, '\n'); 
15570         }
15571         
15572       after_print:
15573         if (PL_regkind[(U8)op] == BRANCHJ) {
15574             assert(next);
15575             {
15576                 const regnode *nnode = (OP(next) == LONGJMP
15577                                        ? regnext((regnode *)next)
15578                                        : next);
15579                 if (last && nnode > last)
15580                     nnode = last;
15581                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
15582             }
15583         }
15584         else if (PL_regkind[(U8)op] == BRANCH) {
15585             assert(next);
15586             DUMPUNTIL(NEXTOPER(node), next);
15587         }
15588         else if ( PL_regkind[(U8)op]  == TRIE ) {
15589             const regnode *this_trie = node;
15590             const char op = OP(node);
15591             const U32 n = ARG(node);
15592             const reg_ac_data * const ac = op>=AHOCORASICK ?
15593                (reg_ac_data *)ri->data->data[n] :
15594                NULL;
15595             const reg_trie_data * const trie =
15596                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
15597 #ifdef DEBUGGING
15598             AV *const trie_words = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
15599 #endif
15600             const regnode *nextbranch= NULL;
15601             I32 word_idx;
15602             sv_setpvs(sv, "");
15603             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
15604                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
15605
15606                 PerlIO_printf(Perl_debug_log, "%*s%s ",
15607                    (int)(2*(indent+3)), "",
15608                     elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
15609                             PL_colors[0], PL_colors[1],
15610                             (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
15611                             PERL_PV_PRETTY_ELLIPSES    |
15612                             PERL_PV_PRETTY_LTGT
15613                             )
15614                             : "???"
15615                 );
15616                 if (trie->jump) {
15617                     U16 dist= trie->jump[word_idx+1];
15618                     PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
15619                                   (UV)((dist ? this_trie + dist : next) - start));
15620                     if (dist) {
15621                         if (!nextbranch)
15622                             nextbranch= this_trie + trie->jump[0];    
15623                         DUMPUNTIL(this_trie + dist, nextbranch);
15624                     }
15625                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
15626                         nextbranch= regnext((regnode *)nextbranch);
15627                 } else {
15628                     PerlIO_printf(Perl_debug_log, "\n");
15629                 }
15630             }
15631             if (last && next > last)
15632                 node= last;
15633             else
15634                 node= next;
15635         }
15636         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
15637             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
15638                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
15639         }
15640         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
15641             assert(next);
15642             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
15643         }
15644         else if ( op == PLUS || op == STAR) {
15645             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
15646         }
15647         else if (PL_regkind[(U8)op] == ANYOF) {
15648             /* arglen 1 + class block */
15649             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_CLASS)
15650                     ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
15651             node = NEXTOPER(node);
15652         }
15653         else if (PL_regkind[(U8)op] == EXACT) {
15654             /* Literal string, where present. */
15655             node += NODE_SZ_STR(node) - 1;
15656             node = NEXTOPER(node);
15657         }
15658         else {
15659             node = NEXTOPER(node);
15660             node += regarglen[(U8)op];
15661         }
15662         if (op == CURLYX || op == OPEN)
15663             indent++;
15664     }
15665     CLEAR_OPTSTART;
15666 #ifdef DEBUG_DUMPUNTIL    
15667     PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
15668 #endif
15669     return node;
15670 }
15671
15672 #endif  /* DEBUGGING */
15673
15674 /*
15675  * Local variables:
15676  * c-indentation-style: bsd
15677  * c-basic-offset: 4
15678  * indent-tabs-mode: nil
15679  * End:
15680  *
15681  * ex: set ts=8 sts=4 sw=4 et:
15682  */