]> git.vpit.fr Git - perl/modules/re-engine-Hooks.git/blob - src/5019002/orig/regcomp.c
Add support for perl 5.19.[12]
[perl/modules/re-engine-Hooks.git] / src / 5019002 / 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; if = &emit_dummy,
130                                            implies compiling, so don't emit */
131     regnode     emit_dummy;             /* placeholder for emit to point to */
132     I32         naughty;                /* How bad is this pattern? */
133     I32         sawback;                /* Did we see \1, ...? */
134     U32         seen;
135     I32         size;                   /* Code size. */
136     I32         npar;                   /* Capture buffer count, (OPEN). */
137     I32         cpar;                   /* Capture buffer count, (CLOSE). */
138     I32         nestroot;               /* root parens we are in - used by accept */
139     I32         extralen;
140     I32         seen_zerolen;
141     regnode     **open_parens;          /* pointers to open parens */
142     regnode     **close_parens;         /* pointers to close parens */
143     regnode     *opend;                 /* END node in program */
144     I32         utf8;           /* whether the pattern is utf8 or not */
145     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
146                                 /* XXX use this for future optimisation of case
147                                  * where pattern must be upgraded to utf8. */
148     I32         uni_semantics;  /* If a d charset modifier should use unicode
149                                    rules, even if the pattern is not in
150                                    utf8 */
151     HV          *paren_names;           /* Paren names */
152     
153     regnode     **recurse;              /* Recurse regops */
154     I32         recurse_count;          /* Number of recurse regops */
155     I32         in_lookbehind;
156     I32         contains_locale;
157     I32         override_recoding;
158     I32         in_multi_char_class;
159     struct reg_code_block *code_blocks; /* positions of literal (?{})
160                                             within pattern */
161     int         num_code_blocks;        /* size of code_blocks[] */
162     int         code_index;             /* next code_blocks[] slot */
163 #if ADD_TO_REGEXEC
164     char        *starttry;              /* -Dr: where regtry was called. */
165 #define RExC_starttry   (pRExC_state->starttry)
166 #endif
167     SV          *runtime_code_qr;       /* qr with the runtime code blocks */
168 #ifdef DEBUGGING
169     const char  *lastparse;
170     I32         lastnum;
171     AV          *paren_name_list;       /* idx -> name */
172 #define RExC_lastparse  (pRExC_state->lastparse)
173 #define RExC_lastnum    (pRExC_state->lastnum)
174 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
175 #endif
176 } RExC_state_t;
177
178 #define RExC_flags      (pRExC_state->flags)
179 #define RExC_pm_flags   (pRExC_state->pm_flags)
180 #define RExC_precomp    (pRExC_state->precomp)
181 #define RExC_rx_sv      (pRExC_state->rx_sv)
182 #define RExC_rx         (pRExC_state->rx)
183 #define RExC_rxi        (pRExC_state->rxi)
184 #define RExC_start      (pRExC_state->start)
185 #define RExC_end        (pRExC_state->end)
186 #define RExC_parse      (pRExC_state->parse)
187 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
188 #ifdef RE_TRACK_PATTERN_OFFSETS
189 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the others */
190 #endif
191 #define RExC_emit       (pRExC_state->emit)
192 #define RExC_emit_dummy (pRExC_state->emit_dummy)
193 #define RExC_emit_start (pRExC_state->emit_start)
194 #define RExC_emit_bound (pRExC_state->emit_bound)
195 #define RExC_naughty    (pRExC_state->naughty)
196 #define RExC_sawback    (pRExC_state->sawback)
197 #define RExC_seen       (pRExC_state->seen)
198 #define RExC_size       (pRExC_state->size)
199 #define RExC_npar       (pRExC_state->npar)
200 #define RExC_nestroot   (pRExC_state->nestroot)
201 #define RExC_extralen   (pRExC_state->extralen)
202 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
203 #define RExC_utf8       (pRExC_state->utf8)
204 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
205 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
206 #define RExC_open_parens        (pRExC_state->open_parens)
207 #define RExC_close_parens       (pRExC_state->close_parens)
208 #define RExC_opend      (pRExC_state->opend)
209 #define RExC_paren_names        (pRExC_state->paren_names)
210 #define RExC_recurse    (pRExC_state->recurse)
211 #define RExC_recurse_count      (pRExC_state->recurse_count)
212 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
213 #define RExC_contains_locale    (pRExC_state->contains_locale)
214 #define RExC_override_recoding (pRExC_state->override_recoding)
215 #define RExC_in_multi_char_class (pRExC_state->in_multi_char_class)
216
217
218 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
219 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
220         ((*s) == '{' && regcurly(s, FALSE)))
221
222 #ifdef SPSTART
223 #undef SPSTART          /* dratted cpp namespace... */
224 #endif
225 /*
226  * Flags to be passed up and down.
227  */
228 #define WORST           0       /* Worst case. */
229 #define HASWIDTH        0x01    /* Known to match non-null strings. */
230
231 /* Simple enough to be STAR/PLUS operand; in an EXACTish node must be a single
232  * character.  (There needs to be a case: in the switch statement in regexec.c
233  * for any node marked SIMPLE.)  Note that this is not the same thing as
234  * REGNODE_SIMPLE */
235 #define SIMPLE          0x02
236 #define SPSTART         0x04    /* Starts with * or + */
237 #define POSTPONED       0x08    /* (?1),(?&name), (??{...}) or similar */
238 #define TRYAGAIN        0x10    /* Weeded out a declaration. */
239 #define RESTART_UTF8    0x20    /* Restart, need to calcuate sizes as UTF-8 */
240
241 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
242
243 /* whether trie related optimizations are enabled */
244 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
245 #define TRIE_STUDY_OPT
246 #define FULL_TRIE_STUDY
247 #define TRIE_STCLASS
248 #endif
249
250
251
252 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
253 #define PBITVAL(paren) (1 << ((paren) & 7))
254 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
255 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
256 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
257
258 #define REQUIRE_UTF8    STMT_START {                                       \
259                                      if (!UTF) {                           \
260                                          *flagp = RESTART_UTF8;            \
261                                          return NULL;                      \
262                                      }                                     \
263                         } STMT_END
264
265 /* This converts the named class defined in regcomp.h to its equivalent class
266  * number defined in handy.h. */
267 #define namedclass_to_classnum(class)  ((int) ((class) / 2))
268 #define classnum_to_namedclass(classnum)  ((classnum) * 2)
269
270 /* About scan_data_t.
271
272   During optimisation we recurse through the regexp program performing
273   various inplace (keyhole style) optimisations. In addition study_chunk
274   and scan_commit populate this data structure with information about
275   what strings MUST appear in the pattern. We look for the longest 
276   string that must appear at a fixed location, and we look for the
277   longest string that may appear at a floating location. So for instance
278   in the pattern:
279   
280     /FOO[xX]A.*B[xX]BAR/
281     
282   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
283   strings (because they follow a .* construct). study_chunk will identify
284   both FOO and BAR as being the longest fixed and floating strings respectively.
285   
286   The strings can be composites, for instance
287   
288      /(f)(o)(o)/
289      
290   will result in a composite fixed substring 'foo'.
291   
292   For each string some basic information is maintained:
293   
294   - offset or min_offset
295     This is the position the string must appear at, or not before.
296     It also implicitly (when combined with minlenp) tells us how many
297     characters must match before the string we are searching for.
298     Likewise when combined with minlenp and the length of the string it
299     tells us how many characters must appear after the string we have 
300     found.
301   
302   - max_offset
303     Only used for floating strings. This is the rightmost point that
304     the string can appear at. If set to I32 max it indicates that the
305     string can occur infinitely far to the right.
306   
307   - minlenp
308     A pointer to the minimum number of characters of the pattern that the
309     string was found inside. This is important as in the case of positive
310     lookahead or positive lookbehind we can have multiple patterns 
311     involved. Consider
312     
313     /(?=FOO).*F/
314     
315     The minimum length of the pattern overall is 3, the minimum length
316     of the lookahead part is 3, but the minimum length of the part that
317     will actually match is 1. So 'FOO's minimum length is 3, but the 
318     minimum length for the F is 1. This is important as the minimum length
319     is used to determine offsets in front of and behind the string being 
320     looked for.  Since strings can be composites this is the length of the
321     pattern at the time it was committed with a scan_commit. Note that
322     the length is calculated by study_chunk, so that the minimum lengths
323     are not known until the full pattern has been compiled, thus the 
324     pointer to the value.
325   
326   - lookbehind
327   
328     In the case of lookbehind the string being searched for can be
329     offset past the start point of the final matching string. 
330     If this value was just blithely removed from the min_offset it would
331     invalidate some of the calculations for how many chars must match
332     before or after (as they are derived from min_offset and minlen and
333     the length of the string being searched for). 
334     When the final pattern is compiled and the data is moved from the
335     scan_data_t structure into the regexp structure the information
336     about lookbehind is factored in, with the information that would 
337     have been lost precalculated in the end_shift field for the 
338     associated string.
339
340   The fields pos_min and pos_delta are used to store the minimum offset
341   and the delta to the maximum offset at the current point in the pattern.    
342
343 */
344
345 typedef struct scan_data_t {
346     /*I32 len_min;      unused */
347     /*I32 len_delta;    unused */
348     I32 pos_min;
349     I32 pos_delta;
350     SV *last_found;
351     I32 last_end;           /* min value, <0 unless valid. */
352     I32 last_start_min;
353     I32 last_start_max;
354     SV **longest;           /* Either &l_fixed, or &l_float. */
355     SV *longest_fixed;      /* longest fixed string found in pattern */
356     I32 offset_fixed;       /* offset where it starts */
357     I32 *minlen_fixed;      /* pointer to the minlen relevant to the string */
358     I32 lookbehind_fixed;   /* is the position of the string modfied by LB */
359     SV *longest_float;      /* longest floating string found in pattern */
360     I32 offset_float_min;   /* earliest point in string it can appear */
361     I32 offset_float_max;   /* latest point in string it can appear */
362     I32 *minlen_float;      /* pointer to the minlen relevant to the string */
363     I32 lookbehind_float;   /* is the position of the string modified by LB */
364     I32 flags;
365     I32 whilem_c;
366     I32 *last_closep;
367     struct regnode_charclass_class *start_class;
368 } scan_data_t;
369
370 /*
371  * Forward declarations for pregcomp()'s friends.
372  */
373
374 static const scan_data_t zero_scan_data =
375   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
376
377 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
378 #define SF_BEFORE_SEOL          0x0001
379 #define SF_BEFORE_MEOL          0x0002
380 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
381 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
382
383 #ifdef NO_UNARY_PLUS
384 #  define SF_FIX_SHIFT_EOL      (0+2)
385 #  define SF_FL_SHIFT_EOL               (0+4)
386 #else
387 #  define SF_FIX_SHIFT_EOL      (+2)
388 #  define SF_FL_SHIFT_EOL               (+4)
389 #endif
390
391 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
392 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
393
394 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
395 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
396 #define SF_IS_INF               0x0040
397 #define SF_HAS_PAR              0x0080
398 #define SF_IN_PAR               0x0100
399 #define SF_HAS_EVAL             0x0200
400 #define SCF_DO_SUBSTR           0x0400
401 #define SCF_DO_STCLASS_AND      0x0800
402 #define SCF_DO_STCLASS_OR       0x1000
403 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
404 #define SCF_WHILEM_VISITED_POS  0x2000
405
406 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
407 #define SCF_SEEN_ACCEPT         0x8000 
408 #define SCF_TRIE_DOING_RESTUDY 0x10000
409
410 #define UTF cBOOL(RExC_utf8)
411
412 /* The enums for all these are ordered so things work out correctly */
413 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
414 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_DEPENDS_CHARSET)
415 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
416 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags) >= REGEX_UNICODE_CHARSET)
417 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_RESTRICTED_CHARSET)
418 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags) >= REGEX_ASCII_RESTRICTED_CHARSET)
419 #define ASCII_FOLD_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
420
421 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
422
423 #define OOB_NAMEDCLASS          -1
424
425 /* There is no code point that is out-of-bounds, so this is problematic.  But
426  * its only current use is to initialize a variable that is always set before
427  * looked at. */
428 #define OOB_UNICODE             0xDEADBEEF
429
430 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
431 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
432
433
434 /* length of regex to show in messages that don't mark a position within */
435 #define RegexLengthToShowInErrorMessages 127
436
437 /*
438  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
439  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
440  * op/pragma/warn/regcomp.
441  */
442 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
443 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
444
445 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
446
447 /*
448  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
449  * arg. Show regex, up to a maximum length. If it's too long, chop and add
450  * "...".
451  */
452 #define _FAIL(code) STMT_START {                                        \
453     const char *ellipses = "";                                          \
454     IV len = RExC_end - RExC_precomp;                                   \
455                                                                         \
456     if (!SIZE_ONLY)                                                     \
457         SAVEFREESV(RExC_rx_sv);                                         \
458     if (len > RegexLengthToShowInErrorMessages) {                       \
459         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
460         len = RegexLengthToShowInErrorMessages - 10;                    \
461         ellipses = "...";                                               \
462     }                                                                   \
463     code;                                                               \
464 } STMT_END
465
466 #define FAIL(msg) _FAIL(                            \
467     Perl_croak(aTHX_ "%s in regex m/%.*s%s/",       \
468             msg, (int)len, RExC_precomp, ellipses))
469
470 #define FAIL2(msg,arg) _FAIL(                       \
471     Perl_croak(aTHX_ msg " in regex m/%.*s%s/",     \
472             arg, (int)len, RExC_precomp, ellipses))
473
474 /*
475  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
476  */
477 #define Simple_vFAIL(m) STMT_START {                                    \
478     const IV offset = RExC_parse - RExC_precomp;                        \
479     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
480             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
481 } STMT_END
482
483 /*
484  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
485  */
486 #define vFAIL(m) STMT_START {                           \
487     if (!SIZE_ONLY)                                     \
488         SAVEFREESV(RExC_rx_sv);                         \
489     Simple_vFAIL(m);                                    \
490 } STMT_END
491
492 /*
493  * Like Simple_vFAIL(), but accepts two arguments.
494  */
495 #define Simple_vFAIL2(m,a1) STMT_START {                        \
496     const IV offset = RExC_parse - RExC_precomp;                        \
497     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1,                   \
498             (int)offset, RExC_precomp, RExC_precomp + offset);  \
499 } STMT_END
500
501 /*
502  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
503  */
504 #define vFAIL2(m,a1) STMT_START {                       \
505     if (!SIZE_ONLY)                                     \
506         SAVEFREESV(RExC_rx_sv);                         \
507     Simple_vFAIL2(m, a1);                               \
508 } STMT_END
509
510
511 /*
512  * Like Simple_vFAIL(), but accepts three arguments.
513  */
514 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
515     const IV offset = RExC_parse - RExC_precomp;                \
516     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2,               \
517             (int)offset, RExC_precomp, RExC_precomp + offset);  \
518 } STMT_END
519
520 /*
521  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
522  */
523 #define vFAIL3(m,a1,a2) STMT_START {                    \
524     if (!SIZE_ONLY)                                     \
525         SAVEFREESV(RExC_rx_sv);                         \
526     Simple_vFAIL3(m, a1, a2);                           \
527 } STMT_END
528
529 /*
530  * Like Simple_vFAIL(), but accepts four arguments.
531  */
532 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
533     const IV offset = RExC_parse - RExC_precomp;                \
534     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3,           \
535             (int)offset, RExC_precomp, RExC_precomp + offset);  \
536 } STMT_END
537
538 #define vFAIL4(m,a1,a2,a3) STMT_START {                 \
539     if (!SIZE_ONLY)                                     \
540         SAVEFREESV(RExC_rx_sv);                         \
541     Simple_vFAIL4(m, a1, a2, a3);                       \
542 } STMT_END
543
544 /* m is not necessarily a "literal string", in this macro */
545 #define reg_warn_non_literal_string(loc, m) STMT_START {                \
546     const IV offset = loc - RExC_precomp;                               \
547     Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s" REPORT_LOCATION,      \
548             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
549 } STMT_END
550
551 #define ckWARNreg(loc,m) STMT_START {                                   \
552     const IV offset = loc - RExC_precomp;                               \
553     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
554             (int)offset, RExC_precomp, RExC_precomp + offset);          \
555 } STMT_END
556
557 #define vWARN_dep(loc, m) STMT_START {                                  \
558     const IV offset = loc - RExC_precomp;                               \
559     Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), m REPORT_LOCATION,     \
560             (int)offset, RExC_precomp, RExC_precomp + offset);          \
561 } STMT_END
562
563 #define ckWARNdep(loc,m) STMT_START {                                   \
564     const IV offset = loc - RExC_precomp;                               \
565     Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),                   \
566             m REPORT_LOCATION,                                          \
567             (int)offset, RExC_precomp, RExC_precomp + offset);          \
568 } STMT_END
569
570 #define ckWARNregdep(loc,m) STMT_START {                                \
571     const IV offset = loc - RExC_precomp;                               \
572     Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),     \
573             m REPORT_LOCATION,                                          \
574             (int)offset, RExC_precomp, RExC_precomp + offset);          \
575 } STMT_END
576
577 #define ckWARN2reg_d(loc,m, a1) STMT_START {                            \
578     const IV offset = loc - RExC_precomp;                               \
579     Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP),                       \
580             m REPORT_LOCATION,                                          \
581             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
582 } STMT_END
583
584 #define ckWARN2reg(loc, m, a1) STMT_START {                             \
585     const IV offset = loc - RExC_precomp;                               \
586     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
587             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
588 } STMT_END
589
590 #define vWARN3(loc, m, a1, a2) STMT_START {                             \
591     const IV offset = loc - RExC_precomp;                               \
592     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
593             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
594 } STMT_END
595
596 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                         \
597     const IV offset = loc - RExC_precomp;                               \
598     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
599             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
600 } STMT_END
601
602 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
603     const IV offset = loc - RExC_precomp;                               \
604     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
605             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
606 } STMT_END
607
608 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
609     const IV offset = loc - RExC_precomp;                               \
610     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
611             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
612 } STMT_END
613
614 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
615     const IV offset = loc - RExC_precomp;                               \
616     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
617             a1, a2, a3, a4, (int)offset, RExC_precomp, RExC_precomp + offset); \
618 } STMT_END
619
620
621 /* Allow for side effects in s */
622 #define REGC(c,s) STMT_START {                  \
623     if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
624 } STMT_END
625
626 /* Macros for recording node offsets.   20001227 mjd@plover.com 
627  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
628  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
629  * Element 0 holds the number n.
630  * Position is 1 indexed.
631  */
632 #ifndef RE_TRACK_PATTERN_OFFSETS
633 #define Set_Node_Offset_To_R(node,byte)
634 #define Set_Node_Offset(node,byte)
635 #define Set_Cur_Node_Offset
636 #define Set_Node_Length_To_R(node,len)
637 #define Set_Node_Length(node,len)
638 #define Set_Node_Cur_Length(node,start)
639 #define Node_Offset(n) 
640 #define Node_Length(n) 
641 #define Set_Node_Offset_Length(node,offset,len)
642 #define ProgLen(ri) ri->u.proglen
643 #define SetProgLen(ri,x) ri->u.proglen = x
644 #else
645 #define ProgLen(ri) ri->u.offsets[0]
646 #define SetProgLen(ri,x) ri->u.offsets[0] = x
647 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
648     if (! SIZE_ONLY) {                                                  \
649         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
650                     __LINE__, (int)(node), (int)(byte)));               \
651         if((node) < 0) {                                                \
652             Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \
653         } else {                                                        \
654             RExC_offsets[2*(node)-1] = (byte);                          \
655         }                                                               \
656     }                                                                   \
657 } STMT_END
658
659 #define Set_Node_Offset(node,byte) \
660     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
661 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
662
663 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
664     if (! SIZE_ONLY) {                                                  \
665         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
666                 __LINE__, (int)(node), (int)(len)));                    \
667         if((node) < 0) {                                                \
668             Perl_croak(aTHX_ "value of node is %d in Length macro", (int)(node)); \
669         } else {                                                        \
670             RExC_offsets[2*(node)] = (len);                             \
671         }                                                               \
672     }                                                                   \
673 } STMT_END
674
675 #define Set_Node_Length(node,len) \
676     Set_Node_Length_To_R((node)-RExC_emit_start, len)
677 #define Set_Node_Cur_Length(node, start)                \
678     Set_Node_Length(node, RExC_parse - start)
679
680 /* Get offsets and lengths */
681 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
682 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
683
684 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
685     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
686     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
687 } STMT_END
688 #endif
689
690 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
691 #define EXPERIMENTAL_INPLACESCAN
692 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
693
694 #define DEBUG_STUDYDATA(str,data,depth)                              \
695 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
696     PerlIO_printf(Perl_debug_log,                                    \
697         "%*s" str "Pos:%"IVdf"/%"IVdf                                \
698         " Flags: 0x%"UVXf" Whilem_c: %"IVdf" Lcp: %"IVdf" %s",       \
699         (int)(depth)*2, "",                                          \
700         (IV)((data)->pos_min),                                       \
701         (IV)((data)->pos_delta),                                     \
702         (UV)((data)->flags),                                         \
703         (IV)((data)->whilem_c),                                      \
704         (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
705         is_inf ? "INF " : ""                                         \
706     );                                                               \
707     if ((data)->last_found)                                          \
708         PerlIO_printf(Perl_debug_log,                                \
709             "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
710             " %sFloat: '%s' @ %"IVdf"/%"IVdf"",                      \
711             SvPVX_const((data)->last_found),                         \
712             (IV)((data)->last_end),                                  \
713             (IV)((data)->last_start_min),                            \
714             (IV)((data)->last_start_max),                            \
715             ((data)->longest &&                                      \
716              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
717             SvPVX_const((data)->longest_fixed),                      \
718             (IV)((data)->offset_fixed),                              \
719             ((data)->longest &&                                      \
720              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
721             SvPVX_const((data)->longest_float),                      \
722             (IV)((data)->offset_float_min),                          \
723             (IV)((data)->offset_float_max)                           \
724         );                                                           \
725     PerlIO_printf(Perl_debug_log,"\n");                              \
726 });
727
728 /* Mark that we cannot extend a found fixed substring at this point.
729    Update the longest found anchored substring and the longest found
730    floating substrings if needed. */
731
732 STATIC void
733 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp, int is_inf)
734 {
735     const STRLEN l = CHR_SVLEN(data->last_found);
736     const STRLEN old_l = CHR_SVLEN(*data->longest);
737     GET_RE_DEBUG_FLAGS_DECL;
738
739     PERL_ARGS_ASSERT_SCAN_COMMIT;
740
741     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
742         SvSetMagicSV(*data->longest, data->last_found);
743         if (*data->longest == data->longest_fixed) {
744             data->offset_fixed = l ? data->last_start_min : data->pos_min;
745             if (data->flags & SF_BEFORE_EOL)
746                 data->flags
747                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
748             else
749                 data->flags &= ~SF_FIX_BEFORE_EOL;
750             data->minlen_fixed=minlenp;
751             data->lookbehind_fixed=0;
752         }
753         else { /* *data->longest == data->longest_float */
754             data->offset_float_min = l ? data->last_start_min : data->pos_min;
755             data->offset_float_max = (l
756                                       ? data->last_start_max
757                                       : (data->pos_delta == I32_MAX ? I32_MAX : data->pos_min + data->pos_delta));
758             if (is_inf || (U32)data->offset_float_max > (U32)I32_MAX)
759                 data->offset_float_max = I32_MAX;
760             if (data->flags & SF_BEFORE_EOL)
761                 data->flags
762                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
763             else
764                 data->flags &= ~SF_FL_BEFORE_EOL;
765             data->minlen_float=minlenp;
766             data->lookbehind_float=0;
767         }
768     }
769     SvCUR_set(data->last_found, 0);
770     {
771         SV * const sv = data->last_found;
772         if (SvUTF8(sv) && SvMAGICAL(sv)) {
773             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
774             if (mg)
775                 mg->mg_len = 0;
776         }
777     }
778     data->last_end = -1;
779     data->flags &= ~SF_BEFORE_EOL;
780     DEBUG_STUDYDATA("commit: ",data,0);
781 }
782
783 /* These macros set, clear and test whether the synthetic start class ('ssc',
784  * given by the parameter) matches an empty string (EOS).  This uses the
785  * 'next_off' field in the node, to save a bit in the flags field.  The ssc
786  * stands alone, so there is never a next_off, so this field is otherwise
787  * unused.  The EOS information is used only for compilation, but theoretically
788  * it could be passed on to the execution code.  This could be used to store
789  * more than one bit of information, but only this one is currently used. */
790 #define SET_SSC_EOS(node)   STMT_START { (node)->next_off = TRUE; } STMT_END
791 #define CLEAR_SSC_EOS(node) STMT_START { (node)->next_off = FALSE; } STMT_END
792 #define TEST_SSC_EOS(node)  cBOOL((node)->next_off)
793
794 /* Can match anything (initialization) */
795 STATIC void
796 S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
797 {
798     PERL_ARGS_ASSERT_CL_ANYTHING;
799
800     ANYOF_BITMAP_SETALL(cl);
801     cl->flags = ANYOF_UNICODE_ALL;
802     SET_SSC_EOS(cl);
803
804     /* If any portion of the regex is to operate under locale rules,
805      * initialization includes it.  The reason this isn't done for all regexes
806      * is that the optimizer was written under the assumption that locale was
807      * all-or-nothing.  Given the complexity and lack of documentation in the
808      * optimizer, and that there are inadequate test cases for locale, so many
809      * parts of it may not work properly, it is safest to avoid locale unless
810      * necessary. */
811     if (RExC_contains_locale) {
812         ANYOF_CLASS_SETALL(cl);     /* /l uses class */
813         cl->flags |= ANYOF_LOCALE|ANYOF_CLASS|ANYOF_LOC_FOLD;
814     }
815     else {
816         ANYOF_CLASS_ZERO(cl);       /* Only /l uses class now */
817     }
818 }
819
820 /* Can match anything (initialization) */
821 STATIC int
822 S_cl_is_anything(const struct regnode_charclass_class *cl)
823 {
824     int value;
825
826     PERL_ARGS_ASSERT_CL_IS_ANYTHING;
827
828     for (value = 0; value < ANYOF_MAX; value += 2)
829         if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
830             return 1;
831     if (!(cl->flags & ANYOF_UNICODE_ALL))
832         return 0;
833     if (!ANYOF_BITMAP_TESTALLSET((const void*)cl))
834         return 0;
835     return 1;
836 }
837
838 /* Can match anything (initialization) */
839 STATIC void
840 S_cl_init(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
841 {
842     PERL_ARGS_ASSERT_CL_INIT;
843
844     Zero(cl, 1, struct regnode_charclass_class);
845     cl->type = ANYOF;
846     cl_anything(pRExC_state, cl);
847     ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
848 }
849
850 /* These two functions currently do the exact same thing */
851 #define cl_init_zero            S_cl_init
852
853 /* 'AND' a given class with another one.  Can create false positives.  'cl'
854  * should not be inverted.  'and_with->flags & ANYOF_CLASS' should be 0 if
855  * 'and_with' is a regnode_charclass instead of a regnode_charclass_class. */
856 STATIC void
857 S_cl_and(struct regnode_charclass_class *cl,
858         const struct regnode_charclass_class *and_with)
859 {
860     PERL_ARGS_ASSERT_CL_AND;
861
862     assert(PL_regkind[and_with->type] == ANYOF);
863
864     /* I (khw) am not sure all these restrictions are necessary XXX */
865     if (!(ANYOF_CLASS_TEST_ANY_SET(and_with))
866         && !(ANYOF_CLASS_TEST_ANY_SET(cl))
867         && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
868         && !(and_with->flags & ANYOF_LOC_FOLD)
869         && !(cl->flags & ANYOF_LOC_FOLD)) {
870         int i;
871
872         if (and_with->flags & ANYOF_INVERT)
873             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
874                 cl->bitmap[i] &= ~and_with->bitmap[i];
875         else
876             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
877                 cl->bitmap[i] &= and_with->bitmap[i];
878     } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
879
880     if (and_with->flags & ANYOF_INVERT) {
881
882         /* Here, the and'ed node is inverted.  Get the AND of the flags that
883          * aren't affected by the inversion.  Those that are affected are
884          * handled individually below */
885         U8 affected_flags = cl->flags & ~INVERSION_UNAFFECTED_FLAGS;
886         cl->flags &= (and_with->flags & INVERSION_UNAFFECTED_FLAGS);
887         cl->flags |= affected_flags;
888
889         /* We currently don't know how to deal with things that aren't in the
890          * bitmap, but we know that the intersection is no greater than what
891          * is already in cl, so let there be false positives that get sorted
892          * out after the synthetic start class succeeds, and the node is
893          * matched for real. */
894
895         /* The inversion of these two flags indicate that the resulting
896          * intersection doesn't have them */
897         if (and_with->flags & ANYOF_UNICODE_ALL) {
898             cl->flags &= ~ANYOF_UNICODE_ALL;
899         }
900         if (and_with->flags & ANYOF_NON_UTF8_LATIN1_ALL) {
901             cl->flags &= ~ANYOF_NON_UTF8_LATIN1_ALL;
902         }
903     }
904     else {   /* and'd node is not inverted */
905         U8 outside_bitmap_but_not_utf8; /* Temp variable */
906
907         if (! ANYOF_NONBITMAP(and_with)) {
908
909             /* Here 'and_with' doesn't match anything outside the bitmap
910              * (except possibly ANYOF_UNICODE_ALL), which means the
911              * intersection can't either, except for ANYOF_UNICODE_ALL, in
912              * which case we don't know what the intersection is, but it's no
913              * greater than what cl already has, so can just leave it alone,
914              * with possible false positives */
915             if (! (and_with->flags & ANYOF_UNICODE_ALL)) {
916                 ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
917                 cl->flags &= ~ANYOF_NONBITMAP_NON_UTF8;
918             }
919         }
920         else if (! ANYOF_NONBITMAP(cl)) {
921
922             /* Here, 'and_with' does match something outside the bitmap, and cl
923              * doesn't have a list of things to match outside the bitmap.  If
924              * cl can match all code points above 255, the intersection will
925              * be those above-255 code points that 'and_with' matches.  If cl
926              * can't match all Unicode code points, it means that it can't
927              * match anything outside the bitmap (since the 'if' that got us
928              * into this block tested for that), so we leave the bitmap empty.
929              */
930             if (cl->flags & ANYOF_UNICODE_ALL) {
931                 ARG_SET(cl, ARG(and_with));
932
933                 /* and_with's ARG may match things that don't require UTF8.
934                  * And now cl's will too, in spite of this being an 'and'.  See
935                  * the comments below about the kludge */
936                 cl->flags |= and_with->flags & ANYOF_NONBITMAP_NON_UTF8;
937             }
938         }
939         else {
940             /* Here, both 'and_with' and cl match something outside the
941              * bitmap.  Currently we do not do the intersection, so just match
942              * whatever cl had at the beginning.  */
943         }
944
945
946         /* Take the intersection of the two sets of flags.  However, the
947          * ANYOF_NONBITMAP_NON_UTF8 flag is treated as an 'or'.  This is a
948          * kludge around the fact that this flag is not treated like the others
949          * which are initialized in cl_anything().  The way the optimizer works
950          * is that the synthetic start class (SSC) is initialized to match
951          * anything, and then the first time a real node is encountered, its
952          * values are AND'd with the SSC's with the result being the values of
953          * the real node.  However, there are paths through the optimizer where
954          * the AND never gets called, so those initialized bits are set
955          * inappropriately, which is not usually a big deal, as they just cause
956          * false positives in the SSC, which will just mean a probably
957          * imperceptible slow down in execution.  However this bit has a
958          * higher false positive consequence in that it can cause utf8.pm,
959          * utf8_heavy.pl ... to be loaded when not necessary, which is a much
960          * bigger slowdown and also causes significant extra memory to be used.
961          * In order to prevent this, the code now takes a different tack.  The
962          * bit isn't set unless some part of the regular expression needs it,
963          * but once set it won't get cleared.  This means that these extra
964          * modules won't get loaded unless there was some path through the
965          * pattern that would have required them anyway, and  so any false
966          * positives that occur by not ANDing them out when they could be
967          * aren't as severe as they would be if we treated this bit like all
968          * the others */
969         outside_bitmap_but_not_utf8 = (cl->flags | and_with->flags)
970                                       & ANYOF_NONBITMAP_NON_UTF8;
971         cl->flags &= and_with->flags;
972         cl->flags |= outside_bitmap_but_not_utf8;
973     }
974 }
975
976 /* 'OR' a given class with another one.  Can create false positives.  'cl'
977  * should not be inverted.  'or_with->flags & ANYOF_CLASS' should be 0 if
978  * 'or_with' is a regnode_charclass instead of a regnode_charclass_class. */
979 STATIC void
980 S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
981 {
982     PERL_ARGS_ASSERT_CL_OR;
983
984     if (or_with->flags & ANYOF_INVERT) {
985
986         /* Here, the or'd node is to be inverted.  This means we take the
987          * complement of everything not in the bitmap, but currently we don't
988          * know what that is, so give up and match anything */
989         if (ANYOF_NONBITMAP(or_with)) {
990             cl_anything(pRExC_state, cl);
991         }
992         /* We do not use
993          * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
994          *   <= (B1 | !B2) | (CL1 | !CL2)
995          * which is wasteful if CL2 is small, but we ignore CL2:
996          *   (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
997          * XXXX Can we handle case-fold?  Unclear:
998          *   (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
999          *   (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
1000          */
1001         else if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
1002              && !(or_with->flags & ANYOF_LOC_FOLD)
1003              && !(cl->flags & ANYOF_LOC_FOLD) ) {
1004             int i;
1005
1006             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
1007                 cl->bitmap[i] |= ~or_with->bitmap[i];
1008         } /* XXXX: logic is complicated otherwise */
1009         else {
1010             cl_anything(pRExC_state, cl);
1011         }
1012
1013         /* And, we can just take the union of the flags that aren't affected
1014          * by the inversion */
1015         cl->flags |= or_with->flags & INVERSION_UNAFFECTED_FLAGS;
1016
1017         /* For the remaining flags:
1018             ANYOF_UNICODE_ALL and inverted means to not match anything above
1019                     255, which means that the union with cl should just be
1020                     what cl has in it, so can ignore this flag
1021             ANYOF_NON_UTF8_LATIN1_ALL and inverted means if not utf8 and ord
1022                     is 127-255 to match them, but then invert that, so the
1023                     union with cl should just be what cl has in it, so can
1024                     ignore this flag
1025          */
1026     } else {    /* 'or_with' is not inverted */
1027         /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
1028         if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
1029              && (!(or_with->flags & ANYOF_LOC_FOLD)
1030                  || (cl->flags & ANYOF_LOC_FOLD)) ) {
1031             int i;
1032
1033             /* OR char bitmap and class bitmap separately */
1034             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
1035                 cl->bitmap[i] |= or_with->bitmap[i];
1036             if (or_with->flags & ANYOF_CLASS) {
1037                 ANYOF_CLASS_OR(or_with, cl);
1038             }
1039         }
1040         else { /* XXXX: logic is complicated, leave it along for a moment. */
1041             cl_anything(pRExC_state, cl);
1042         }
1043
1044         if (ANYOF_NONBITMAP(or_with)) {
1045
1046             /* Use the added node's outside-the-bit-map match if there isn't a
1047              * conflict.  If there is a conflict (both nodes match something
1048              * outside the bitmap, but what they match outside is not the same
1049              * pointer, and hence not easily compared until XXX we extend
1050              * inversion lists this far), give up and allow the start class to
1051              * match everything outside the bitmap.  If that stuff is all above
1052              * 255, can just set UNICODE_ALL, otherwise caould be anything. */
1053             if (! ANYOF_NONBITMAP(cl)) {
1054                 ARG_SET(cl, ARG(or_with));
1055             }
1056             else if (ARG(cl) != ARG(or_with)) {
1057
1058                 if ((or_with->flags & ANYOF_NONBITMAP_NON_UTF8)) {
1059                     cl_anything(pRExC_state, cl);
1060                 }
1061                 else {
1062                     cl->flags |= ANYOF_UNICODE_ALL;
1063                 }
1064             }
1065         }
1066
1067         /* Take the union */
1068         cl->flags |= or_with->flags;
1069     }
1070 }
1071
1072 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1073 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
1074 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1075 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list ? (TRIE_LIST_CUR( idx ) - 1) : 0 )
1076
1077
1078 #ifdef DEBUGGING
1079 /*
1080    dump_trie(trie,widecharmap,revcharmap)
1081    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1082    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1083
1084    These routines dump out a trie in a somewhat readable format.
1085    The _interim_ variants are used for debugging the interim
1086    tables that are used to generate the final compressed
1087    representation which is what dump_trie expects.
1088
1089    Part of the reason for their existence is to provide a form
1090    of documentation as to how the different representations function.
1091
1092 */
1093
1094 /*
1095   Dumps the final compressed table form of the trie to Perl_debug_log.
1096   Used for debugging make_trie().
1097 */
1098
1099 STATIC void
1100 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1101             AV *revcharmap, U32 depth)
1102 {
1103     U32 state;
1104     SV *sv=sv_newmortal();
1105     int colwidth= widecharmap ? 6 : 4;
1106     U16 word;
1107     GET_RE_DEBUG_FLAGS_DECL;
1108
1109     PERL_ARGS_ASSERT_DUMP_TRIE;
1110
1111     PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
1112         (int)depth * 2 + 2,"",
1113         "Match","Base","Ofs" );
1114
1115     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1116         SV ** const tmp = av_fetch( revcharmap, state, 0);
1117         if ( tmp ) {
1118             PerlIO_printf( Perl_debug_log, "%*s", 
1119                 colwidth,
1120                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1121                             PL_colors[0], PL_colors[1],
1122                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1123                             PERL_PV_ESCAPE_FIRSTCHAR 
1124                 ) 
1125             );
1126         }
1127     }
1128     PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
1129         (int)depth * 2 + 2,"");
1130
1131     for( state = 0 ; state < trie->uniquecharcount ; state++ )
1132         PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
1133     PerlIO_printf( Perl_debug_log, "\n");
1134
1135     for( state = 1 ; state < trie->statecount ; state++ ) {
1136         const U32 base = trie->states[ state ].trans.base;
1137
1138         PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state);
1139
1140         if ( trie->states[ state ].wordnum ) {
1141             PerlIO_printf( Perl_debug_log, " W%4X", trie->states[ state ].wordnum );
1142         } else {
1143             PerlIO_printf( Perl_debug_log, "%6s", "" );
1144         }
1145
1146         PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
1147
1148         if ( base ) {
1149             U32 ofs = 0;
1150
1151             while( ( base + ofs  < trie->uniquecharcount ) ||
1152                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
1153                      && trie->trans[ base + ofs - trie->uniquecharcount ].check != state))
1154                     ofs++;
1155
1156             PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
1157
1158             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
1159                 if ( ( base + ofs >= trie->uniquecharcount ) &&
1160                      ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
1161                      trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
1162                 {
1163                    PerlIO_printf( Perl_debug_log, "%*"UVXf,
1164                     colwidth,
1165                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
1166                 } else {
1167                     PerlIO_printf( Perl_debug_log, "%*s",colwidth,"   ." );
1168                 }
1169             }
1170
1171             PerlIO_printf( Perl_debug_log, "]");
1172
1173         }
1174         PerlIO_printf( Perl_debug_log, "\n" );
1175     }
1176     PerlIO_printf(Perl_debug_log, "%*sword_info N:(prev,len)=", (int)depth*2, "");
1177     for (word=1; word <= trie->wordcount; word++) {
1178         PerlIO_printf(Perl_debug_log, " %d:(%d,%d)",
1179             (int)word, (int)(trie->wordinfo[word].prev),
1180             (int)(trie->wordinfo[word].len));
1181     }
1182     PerlIO_printf(Perl_debug_log, "\n" );
1183 }    
1184 /*
1185   Dumps a fully constructed but uncompressed trie in list form.
1186   List tries normally only are used for construction when the number of 
1187   possible chars (trie->uniquecharcount) is very high.
1188   Used for debugging make_trie().
1189 */
1190 STATIC void
1191 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
1192                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
1193                          U32 depth)
1194 {
1195     U32 state;
1196     SV *sv=sv_newmortal();
1197     int colwidth= widecharmap ? 6 : 4;
1198     GET_RE_DEBUG_FLAGS_DECL;
1199
1200     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
1201
1202     /* print out the table precompression.  */
1203     PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
1204         (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
1205         "------:-----+-----------------\n" );
1206     
1207     for( state=1 ; state < next_alloc ; state ++ ) {
1208         U16 charid;
1209     
1210         PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
1211             (int)depth * 2 + 2,"", (UV)state  );
1212         if ( ! trie->states[ state ].wordnum ) {
1213             PerlIO_printf( Perl_debug_log, "%5s| ","");
1214         } else {
1215             PerlIO_printf( Perl_debug_log, "W%4x| ",
1216                 trie->states[ state ].wordnum
1217             );
1218         }
1219         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
1220             SV ** const tmp = av_fetch( revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
1221             if ( tmp ) {
1222                 PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
1223                     colwidth,
1224                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1225                             PL_colors[0], PL_colors[1],
1226                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1227                             PERL_PV_ESCAPE_FIRSTCHAR 
1228                     ) ,
1229                     TRIE_LIST_ITEM(state,charid).forid,
1230                     (UV)TRIE_LIST_ITEM(state,charid).newstate
1231                 );
1232                 if (!(charid % 10)) 
1233                     PerlIO_printf(Perl_debug_log, "\n%*s| ",
1234                         (int)((depth * 2) + 14), "");
1235             }
1236         }
1237         PerlIO_printf( Perl_debug_log, "\n");
1238     }
1239 }    
1240
1241 /*
1242   Dumps a fully constructed but uncompressed trie in table form.
1243   This is the normal DFA style state transition table, with a few 
1244   twists to facilitate compression later. 
1245   Used for debugging make_trie().
1246 */
1247 STATIC void
1248 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
1249                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
1250                           U32 depth)
1251 {
1252     U32 state;
1253     U16 charid;
1254     SV *sv=sv_newmortal();
1255     int colwidth= widecharmap ? 6 : 4;
1256     GET_RE_DEBUG_FLAGS_DECL;
1257
1258     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
1259     
1260     /*
1261        print out the table precompression so that we can do a visual check
1262        that they are identical.
1263      */
1264     
1265     PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
1266
1267     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1268         SV ** const tmp = av_fetch( revcharmap, charid, 0);
1269         if ( tmp ) {
1270             PerlIO_printf( Perl_debug_log, "%*s", 
1271                 colwidth,
1272                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1273                             PL_colors[0], PL_colors[1],
1274                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1275                             PERL_PV_ESCAPE_FIRSTCHAR 
1276                 ) 
1277             );
1278         }
1279     }
1280
1281     PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
1282
1283     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
1284         PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
1285     }
1286
1287     PerlIO_printf( Perl_debug_log, "\n" );
1288
1289     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
1290
1291         PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ", 
1292             (int)depth * 2 + 2,"",
1293             (UV)TRIE_NODENUM( state ) );
1294
1295         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1296             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
1297             if (v)
1298                 PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
1299             else
1300                 PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
1301         }
1302         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1303             PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check );
1304         } else {
1305             PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n", (UV)trie->trans[ state ].check,
1306             trie->states[ TRIE_NODENUM( state ) ].wordnum );
1307         }
1308     }
1309 }
1310
1311 #endif
1312
1313
1314 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
1315   startbranch: the first branch in the whole branch sequence
1316   first      : start branch of sequence of branch-exact nodes.
1317                May be the same as startbranch
1318   last       : Thing following the last branch.
1319                May be the same as tail.
1320   tail       : item following the branch sequence
1321   count      : words in the sequence
1322   flags      : currently the OP() type we will be building one of /EXACT(|F|Fl)/
1323   depth      : indent depth
1324
1325 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
1326
1327 A trie is an N'ary tree where the branches are determined by digital
1328 decomposition of the key. IE, at the root node you look up the 1st character and
1329 follow that branch repeat until you find the end of the branches. Nodes can be
1330 marked as "accepting" meaning they represent a complete word. Eg:
1331
1332   /he|she|his|hers/
1333
1334 would convert into the following structure. Numbers represent states, letters
1335 following numbers represent valid transitions on the letter from that state, if
1336 the number is in square brackets it represents an accepting state, otherwise it
1337 will be in parenthesis.
1338
1339       +-h->+-e->[3]-+-r->(8)-+-s->[9]
1340       |    |
1341       |   (2)
1342       |    |
1343      (1)   +-i->(6)-+-s->[7]
1344       |
1345       +-s->(3)-+-h->(4)-+-e->[5]
1346
1347       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
1348
1349 This shows that when matching against the string 'hers' we will begin at state 1
1350 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
1351 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
1352 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
1353 single traverse. We store a mapping from accepting to state to which word was
1354 matched, and then when we have multiple possibilities we try to complete the
1355 rest of the regex in the order in which they occured in the alternation.
1356
1357 The only prior NFA like behaviour that would be changed by the TRIE support is
1358 the silent ignoring of duplicate alternations which are of the form:
1359
1360  / (DUPE|DUPE) X? (?{ ... }) Y /x
1361
1362 Thus EVAL blocks following a trie may be called a different number of times with
1363 and without the optimisation. With the optimisations dupes will be silently
1364 ignored. This inconsistent behaviour of EVAL type nodes is well established as
1365 the following demonstrates:
1366
1367  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
1368
1369 which prints out 'word' three times, but
1370
1371  'words'=~/(word|word|word)(?{ print $1 })S/
1372
1373 which doesnt print it out at all. This is due to other optimisations kicking in.
1374
1375 Example of what happens on a structural level:
1376
1377 The regexp /(ac|ad|ab)+/ will produce the following debug output:
1378
1379    1: CURLYM[1] {1,32767}(18)
1380    5:   BRANCH(8)
1381    6:     EXACT <ac>(16)
1382    8:   BRANCH(11)
1383    9:     EXACT <ad>(16)
1384   11:   BRANCH(14)
1385   12:     EXACT <ab>(16)
1386   16:   SUCCEED(0)
1387   17:   NOTHING(18)
1388   18: END(0)
1389
1390 This would be optimizable with startbranch=5, first=5, last=16, tail=16
1391 and should turn into:
1392
1393    1: CURLYM[1] {1,32767}(18)
1394    5:   TRIE(16)
1395         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
1396           <ac>
1397           <ad>
1398           <ab>
1399   16:   SUCCEED(0)
1400   17:   NOTHING(18)
1401   18: END(0)
1402
1403 Cases where tail != last would be like /(?foo|bar)baz/:
1404
1405    1: BRANCH(4)
1406    2:   EXACT <foo>(8)
1407    4: BRANCH(7)
1408    5:   EXACT <bar>(8)
1409    7: TAIL(8)
1410    8: EXACT <baz>(10)
1411   10: END(0)
1412
1413 which would be optimizable with startbranch=1, first=1, last=7, tail=8
1414 and would end up looking like:
1415
1416     1: TRIE(8)
1417       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
1418         <foo>
1419         <bar>
1420    7: TAIL(8)
1421    8: EXACT <baz>(10)
1422   10: END(0)
1423
1424     d = uvuni_to_utf8_flags(d, uv, 0);
1425
1426 is the recommended Unicode-aware way of saying
1427
1428     *(d++) = uv;
1429 */
1430
1431 #define TRIE_STORE_REVCHAR(val)                                            \
1432     STMT_START {                                                           \
1433         if (UTF) {                                                         \
1434             SV *zlopp = newSV(7); /* XXX: optimize me */                   \
1435             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
1436             unsigned const char *const kapow = uvuni_to_utf8(flrbbbbb, val); \
1437             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
1438             SvPOK_on(zlopp);                                               \
1439             SvUTF8_on(zlopp);                                              \
1440             av_push(revcharmap, zlopp);                                    \
1441         } else {                                                           \
1442             char ooooff = (char)val;                                           \
1443             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
1444         }                                                                  \
1445         } STMT_END
1446
1447 #define TRIE_READ_CHAR STMT_START {                                                     \
1448     wordlen++;                                                                          \
1449     if ( UTF ) {                                                                        \
1450         /* if it is UTF then it is either already folded, or does not need folding */   \
1451         uvc = utf8n_to_uvuni( (const U8*) uc, UTF8_MAXLEN, &len, uniflags);             \
1452     }                                                                                   \
1453     else if (folder == PL_fold_latin1) {                                                \
1454         /* if we use this folder we have to obey unicode rules on latin-1 data */       \
1455         if ( foldlen > 0 ) {                                                            \
1456            uvc = utf8n_to_uvuni( (const U8*) scan, UTF8_MAXLEN, &len, uniflags );       \
1457            foldlen -= len;                                                              \
1458            scan += len;                                                                 \
1459            len = 0;                                                                     \
1460         } else {                                                                        \
1461             len = 1;                                                                    \
1462             uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, FOLD_FLAGS_FULL);       \
1463             skiplen = UNISKIP(uvc);                                                     \
1464             foldlen -= skiplen;                                                         \
1465             scan = foldbuf + skiplen;                                                   \
1466         }                                                                               \
1467     } else {                                                                            \
1468         /* raw data, will be folded later if needed */                                  \
1469         uvc = (U32)*uc;                                                                 \
1470         len = 1;                                                                        \
1471     }                                                                                   \
1472 } STMT_END
1473
1474
1475
1476 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
1477     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
1478         U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
1479         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
1480     }                                                           \
1481     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
1482     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
1483     TRIE_LIST_CUR( state )++;                                   \
1484 } STMT_END
1485
1486 #define TRIE_LIST_NEW(state) STMT_START {                       \
1487     Newxz( trie->states[ state ].trans.list,               \
1488         4, reg_trie_trans_le );                                 \
1489      TRIE_LIST_CUR( state ) = 1;                                \
1490      TRIE_LIST_LEN( state ) = 4;                                \
1491 } STMT_END
1492
1493 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
1494     U16 dupe= trie->states[ state ].wordnum;                    \
1495     regnode * const noper_next = regnext( noper );              \
1496                                                                 \
1497     DEBUG_r({                                                   \
1498         /* store the word for dumping */                        \
1499         SV* tmp;                                                \
1500         if (OP(noper) != NOTHING)                               \
1501             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
1502         else                                                    \
1503             tmp = newSVpvn_utf8( "", 0, UTF );                  \
1504         av_push( trie_words, tmp );                             \
1505     });                                                         \
1506                                                                 \
1507     curword++;                                                  \
1508     trie->wordinfo[curword].prev   = 0;                         \
1509     trie->wordinfo[curword].len    = wordlen;                   \
1510     trie->wordinfo[curword].accept = state;                     \
1511                                                                 \
1512     if ( noper_next < tail ) {                                  \
1513         if (!trie->jump)                                        \
1514             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, sizeof(U16) ); \
1515         trie->jump[curword] = (U16)(noper_next - convert);      \
1516         if (!jumper)                                            \
1517             jumper = noper_next;                                \
1518         if (!nextbranch)                                        \
1519             nextbranch= regnext(cur);                           \
1520     }                                                           \
1521                                                                 \
1522     if ( dupe ) {                                               \
1523         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
1524         /* chain, so that when the bits of chain are later    */\
1525         /* linked together, the dups appear in the chain      */\
1526         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
1527         trie->wordinfo[dupe].prev = curword;                    \
1528     } else {                                                    \
1529         /* we haven't inserted this word yet.                */ \
1530         trie->states[ state ].wordnum = curword;                \
1531     }                                                           \
1532 } STMT_END
1533
1534
1535 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
1536      ( ( base + charid >=  ucharcount                                   \
1537          && base + charid < ubound                                      \
1538          && state == trie->trans[ base - ucharcount + charid ].check    \
1539          && trie->trans[ base - ucharcount + charid ].next )            \
1540            ? trie->trans[ base - ucharcount + charid ].next             \
1541            : ( state==1 ? special : 0 )                                 \
1542       )
1543
1544 #define MADE_TRIE       1
1545 #define MADE_JUMP_TRIE  2
1546 #define MADE_EXACT_TRIE 4
1547
1548 STATIC I32
1549 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth)
1550 {
1551     dVAR;
1552     /* first pass, loop through and scan words */
1553     reg_trie_data *trie;
1554     HV *widecharmap = NULL;
1555     AV *revcharmap = newAV();
1556     regnode *cur;
1557     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1558     STRLEN len = 0;
1559     UV uvc = 0;
1560     U16 curword = 0;
1561     U32 next_alloc = 0;
1562     regnode *jumper = NULL;
1563     regnode *nextbranch = NULL;
1564     regnode *convert = NULL;
1565     U32 *prev_states; /* temp array mapping each state to previous one */
1566     /* we just use folder as a flag in utf8 */
1567     const U8 * folder = NULL;
1568
1569 #ifdef DEBUGGING
1570     const U32 data_slot = add_data( pRExC_state, 4, "tuuu" );
1571     AV *trie_words = NULL;
1572     /* along with revcharmap, this only used during construction but both are
1573      * useful during debugging so we store them in the struct when debugging.
1574      */
1575 #else
1576     const U32 data_slot = add_data( pRExC_state, 2, "tu" );
1577     STRLEN trie_charcount=0;
1578 #endif
1579     SV *re_trie_maxbuff;
1580     GET_RE_DEBUG_FLAGS_DECL;
1581
1582     PERL_ARGS_ASSERT_MAKE_TRIE;
1583 #ifndef DEBUGGING
1584     PERL_UNUSED_ARG(depth);
1585 #endif
1586
1587     switch (flags) {
1588         case EXACT: break;
1589         case EXACTFA:
1590         case EXACTFU_SS:
1591         case EXACTFU_TRICKYFOLD:
1592         case EXACTFU: folder = PL_fold_latin1; break;
1593         case EXACTF:  folder = PL_fold; break;
1594         case EXACTFL: folder = PL_fold_locale; break;
1595         default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
1596     }
1597
1598     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
1599     trie->refcount = 1;
1600     trie->startstate = 1;
1601     trie->wordcount = word_count;
1602     RExC_rxi->data->data[ data_slot ] = (void*)trie;
1603     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
1604     if (flags == EXACT)
1605         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
1606     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
1607                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
1608
1609     DEBUG_r({
1610         trie_words = newAV();
1611     });
1612
1613     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
1614     if (!SvIOK(re_trie_maxbuff)) {
1615         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
1616     }
1617     DEBUG_TRIE_COMPILE_r({
1618                 PerlIO_printf( Perl_debug_log,
1619                   "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
1620                   (int)depth * 2 + 2, "", 
1621                   REG_NODE_NUM(startbranch),REG_NODE_NUM(first), 
1622                   REG_NODE_NUM(last), REG_NODE_NUM(tail),
1623                   (int)depth);
1624     });
1625    
1626    /* Find the node we are going to overwrite */
1627     if ( first == startbranch && OP( last ) != BRANCH ) {
1628         /* whole branch chain */
1629         convert = first;
1630     } else {
1631         /* branch sub-chain */
1632         convert = NEXTOPER( first );
1633     }
1634         
1635     /*  -- First loop and Setup --
1636
1637        We first traverse the branches and scan each word to determine if it
1638        contains widechars, and how many unique chars there are, this is
1639        important as we have to build a table with at least as many columns as we
1640        have unique chars.
1641
1642        We use an array of integers to represent the character codes 0..255
1643        (trie->charmap) and we use a an HV* to store Unicode characters. We use the
1644        native representation of the character value as the key and IV's for the
1645        coded index.
1646
1647        *TODO* If we keep track of how many times each character is used we can
1648        remap the columns so that the table compression later on is more
1649        efficient in terms of memory by ensuring the most common value is in the
1650        middle and the least common are on the outside.  IMO this would be better
1651        than a most to least common mapping as theres a decent chance the most
1652        common letter will share a node with the least common, meaning the node
1653        will not be compressible. With a middle is most common approach the worst
1654        case is when we have the least common nodes twice.
1655
1656      */
1657
1658     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1659         regnode *noper = NEXTOPER( cur );
1660         const U8 *uc = (U8*)STRING( noper );
1661         const U8 *e  = uc + STR_LEN( noper );
1662         STRLEN foldlen = 0;
1663         U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1664         STRLEN skiplen = 0;
1665         const U8 *scan = (U8*)NULL;
1666         U32 wordlen      = 0;         /* required init */
1667         STRLEN chars = 0;
1668         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the bitmap?*/
1669
1670         if (OP(noper) == NOTHING) {
1671             regnode *noper_next= regnext(noper);
1672             if (noper_next != tail && OP(noper_next) == flags) {
1673                 noper = noper_next;
1674                 uc= (U8*)STRING(noper);
1675                 e= uc + STR_LEN(noper);
1676                 trie->minlen= STR_LEN(noper);
1677             } else {
1678                 trie->minlen= 0;
1679                 continue;
1680             }
1681         }
1682
1683         if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
1684             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
1685                                           regardless of encoding */
1686             if (OP( noper ) == EXACTFU_SS) {
1687                 /* false positives are ok, so just set this */
1688                 TRIE_BITMAP_SET(trie,0xDF);
1689             }
1690         }
1691         for ( ; uc < e ; uc += len ) {
1692             TRIE_CHARCOUNT(trie)++;
1693             TRIE_READ_CHAR;
1694             chars++;
1695             if ( uvc < 256 ) {
1696                 if ( folder ) {
1697                     U8 folded= folder[ (U8) uvc ];
1698                     if ( !trie->charmap[ folded ] ) {
1699                         trie->charmap[ folded ]=( ++trie->uniquecharcount );
1700                         TRIE_STORE_REVCHAR( folded );
1701                     }
1702                 }
1703                 if ( !trie->charmap[ uvc ] ) {
1704                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
1705                     TRIE_STORE_REVCHAR( uvc );
1706                 }
1707                 if ( set_bit ) {
1708                     /* store the codepoint in the bitmap, and its folded
1709                      * equivalent. */
1710                     TRIE_BITMAP_SET(trie, uvc);
1711
1712                     /* store the folded codepoint */
1713                     if ( folder ) TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);
1714
1715                     if ( !UTF ) {
1716                         /* store first byte of utf8 representation of
1717                            variant codepoints */
1718                         if (! UNI_IS_INVARIANT(uvc)) {
1719                             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));
1720                         }
1721                     }
1722                     set_bit = 0; /* We've done our bit :-) */
1723                 }
1724             } else {
1725                 SV** svpp;
1726                 if ( !widecharmap )
1727                     widecharmap = newHV();
1728
1729                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
1730
1731                 if ( !svpp )
1732                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
1733
1734                 if ( !SvTRUE( *svpp ) ) {
1735                     sv_setiv( *svpp, ++trie->uniquecharcount );
1736                     TRIE_STORE_REVCHAR(uvc);
1737                 }
1738             }
1739         }
1740         if( cur == first ) {
1741             trie->minlen = chars;
1742             trie->maxlen = chars;
1743         } else if (chars < trie->minlen) {
1744             trie->minlen = chars;
1745         } else if (chars > trie->maxlen) {
1746             trie->maxlen = chars;
1747         }
1748         if (OP( noper ) == EXACTFU_SS) {
1749             /* XXX: workaround - 'ss' could match "\x{DF}" so minlen could be 1 and not 2*/
1750             if (trie->minlen > 1)
1751                 trie->minlen= 1;
1752         }
1753         if (OP( noper ) == EXACTFU_TRICKYFOLD) {
1754             /* XXX: workround - things like "\x{1FBE}\x{0308}\x{0301}" can match "\x{0390}" 
1755              *                - We assume that any such sequence might match a 2 byte string */
1756             if (trie->minlen > 2 )
1757                 trie->minlen= 2;
1758         }
1759
1760     } /* end first pass */
1761     DEBUG_TRIE_COMPILE_r(
1762         PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
1763                 (int)depth * 2 + 2,"",
1764                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
1765                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
1766                 (int)trie->minlen, (int)trie->maxlen )
1767     );
1768
1769     /*
1770         We now know what we are dealing with in terms of unique chars and
1771         string sizes so we can calculate how much memory a naive
1772         representation using a flat table  will take. If it's over a reasonable
1773         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
1774         conservative but potentially much slower representation using an array
1775         of lists.
1776
1777         At the end we convert both representations into the same compressed
1778         form that will be used in regexec.c for matching with. The latter
1779         is a form that cannot be used to construct with but has memory
1780         properties similar to the list form and access properties similar
1781         to the table form making it both suitable for fast searches and
1782         small enough that its feasable to store for the duration of a program.
1783
1784         See the comment in the code where the compressed table is produced
1785         inplace from the flat tabe representation for an explanation of how
1786         the compression works.
1787
1788     */
1789
1790
1791     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
1792     prev_states[1] = 0;
1793
1794     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1) > SvIV(re_trie_maxbuff) ) {
1795         /*
1796             Second Pass -- Array Of Lists Representation
1797
1798             Each state will be represented by a list of charid:state records
1799             (reg_trie_trans_le) the first such element holds the CUR and LEN
1800             points of the allocated array. (See defines above).
1801
1802             We build the initial structure using the lists, and then convert
1803             it into the compressed table form which allows faster lookups
1804             (but cant be modified once converted).
1805         */
1806
1807         STRLEN transcount = 1;
1808
1809         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
1810             "%*sCompiling trie using list compiler\n",
1811             (int)depth * 2 + 2, ""));
1812
1813         trie->states = (reg_trie_state *)
1814             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1815                                   sizeof(reg_trie_state) );
1816         TRIE_LIST_NEW(1);
1817         next_alloc = 2;
1818
1819         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1820
1821             regnode *noper   = NEXTOPER( cur );
1822             U8 *uc           = (U8*)STRING( noper );
1823             const U8 *e      = uc + STR_LEN( noper );
1824             U32 state        = 1;         /* required init */
1825             U16 charid       = 0;         /* sanity init */
1826             U8 *scan         = (U8*)NULL; /* sanity init */
1827             STRLEN foldlen   = 0;         /* required init */
1828             U32 wordlen      = 0;         /* required init */
1829             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1830             STRLEN skiplen   = 0;
1831
1832             if (OP(noper) == NOTHING) {
1833                 regnode *noper_next= regnext(noper);
1834                 if (noper_next != tail && OP(noper_next) == flags) {
1835                     noper = noper_next;
1836                     uc= (U8*)STRING(noper);
1837                     e= uc + STR_LEN(noper);
1838                 }
1839             }
1840
1841             if (OP(noper) != NOTHING) {
1842                 for ( ; uc < e ; uc += len ) {
1843
1844                     TRIE_READ_CHAR;
1845
1846                     if ( uvc < 256 ) {
1847                         charid = trie->charmap[ uvc ];
1848                     } else {
1849                         SV** const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1850                         if ( !svpp ) {
1851                             charid = 0;
1852                         } else {
1853                             charid=(U16)SvIV( *svpp );
1854                         }
1855                     }
1856                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
1857                     if ( charid ) {
1858
1859                         U16 check;
1860                         U32 newstate = 0;
1861
1862                         charid--;
1863                         if ( !trie->states[ state ].trans.list ) {
1864                             TRIE_LIST_NEW( state );
1865                         }
1866                         for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) {
1867                             if ( TRIE_LIST_ITEM( state, check ).forid == charid ) {
1868                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
1869                                 break;
1870                             }
1871                         }
1872                         if ( ! newstate ) {
1873                             newstate = next_alloc++;
1874                             prev_states[newstate] = state;
1875                             TRIE_LIST_PUSH( state, charid, newstate );
1876                             transcount++;
1877                         }
1878                         state = newstate;
1879                     } else {
1880                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1881                     }
1882                 }
1883             }
1884             TRIE_HANDLE_WORD(state);
1885
1886         } /* end second pass */
1887
1888         /* next alloc is the NEXT state to be allocated */
1889         trie->statecount = next_alloc; 
1890         trie->states = (reg_trie_state *)
1891             PerlMemShared_realloc( trie->states,
1892                                    next_alloc
1893                                    * sizeof(reg_trie_state) );
1894
1895         /* and now dump it out before we compress it */
1896         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
1897                                                          revcharmap, next_alloc,
1898                                                          depth+1)
1899         );
1900
1901         trie->trans = (reg_trie_trans *)
1902             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
1903         {
1904             U32 state;
1905             U32 tp = 0;
1906             U32 zp = 0;
1907
1908
1909             for( state=1 ; state < next_alloc ; state ++ ) {
1910                 U32 base=0;
1911
1912                 /*
1913                 DEBUG_TRIE_COMPILE_MORE_r(
1914                     PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
1915                 );
1916                 */
1917
1918                 if (trie->states[state].trans.list) {
1919                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
1920                     U16 maxid=minid;
1921                     U16 idx;
1922
1923                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1924                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
1925                         if ( forid < minid ) {
1926                             minid=forid;
1927                         } else if ( forid > maxid ) {
1928                             maxid=forid;
1929                         }
1930                     }
1931                     if ( transcount < tp + maxid - minid + 1) {
1932                         transcount *= 2;
1933                         trie->trans = (reg_trie_trans *)
1934                             PerlMemShared_realloc( trie->trans,
1935                                                      transcount
1936                                                      * sizeof(reg_trie_trans) );
1937                         Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans );
1938                     }
1939                     base = trie->uniquecharcount + tp - minid;
1940                     if ( maxid == minid ) {
1941                         U32 set = 0;
1942                         for ( ; zp < tp ; zp++ ) {
1943                             if ( ! trie->trans[ zp ].next ) {
1944                                 base = trie->uniquecharcount + zp - minid;
1945                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1946                                 trie->trans[ zp ].check = state;
1947                                 set = 1;
1948                                 break;
1949                             }
1950                         }
1951                         if ( !set ) {
1952                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1953                             trie->trans[ tp ].check = state;
1954                             tp++;
1955                             zp = tp;
1956                         }
1957                     } else {
1958                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1959                             const U32 tid = base -  trie->uniquecharcount + TRIE_LIST_ITEM( state, idx ).forid;
1960                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state, idx ).newstate;
1961                             trie->trans[ tid ].check = state;
1962                         }
1963                         tp += ( maxid - minid + 1 );
1964                     }
1965                     Safefree(trie->states[ state ].trans.list);
1966                 }
1967                 /*
1968                 DEBUG_TRIE_COMPILE_MORE_r(
1969                     PerlIO_printf( Perl_debug_log, " base: %d\n",base);
1970                 );
1971                 */
1972                 trie->states[ state ].trans.base=base;
1973             }
1974             trie->lasttrans = tp + 1;
1975         }
1976     } else {
1977         /*
1978            Second Pass -- Flat Table Representation.
1979
1980            we dont use the 0 slot of either trans[] or states[] so we add 1 to each.
1981            We know that we will need Charcount+1 trans at most to store the data
1982            (one row per char at worst case) So we preallocate both structures
1983            assuming worst case.
1984
1985            We then construct the trie using only the .next slots of the entry
1986            structs.
1987
1988            We use the .check field of the first entry of the node temporarily to
1989            make compression both faster and easier by keeping track of how many non
1990            zero fields are in the node.
1991
1992            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
1993            transition.
1994
1995            There are two terms at use here: state as a TRIE_NODEIDX() which is a
1996            number representing the first entry of the node, and state as a
1997            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1) and
1998            TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3) if there
1999            are 2 entrys per node. eg:
2000
2001              A B       A B
2002           1. 2 4    1. 3 7
2003           2. 0 3    3. 0 5
2004           3. 0 0    5. 0 0
2005           4. 0 0    7. 0 0
2006
2007            The table is internally in the right hand, idx form. However as we also
2008            have to deal with the states array which is indexed by nodenum we have to
2009            use TRIE_NODENUM() to convert.
2010
2011         */
2012         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
2013             "%*sCompiling trie using table compiler\n",
2014             (int)depth * 2 + 2, ""));
2015
2016         trie->trans = (reg_trie_trans *)
2017             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
2018                                   * trie->uniquecharcount + 1,
2019                                   sizeof(reg_trie_trans) );
2020         trie->states = (reg_trie_state *)
2021             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2022                                   sizeof(reg_trie_state) );
2023         next_alloc = trie->uniquecharcount + 1;
2024
2025
2026         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2027
2028             regnode *noper   = NEXTOPER( cur );
2029             const U8 *uc     = (U8*)STRING( noper );
2030             const U8 *e      = uc + STR_LEN( noper );
2031
2032             U32 state        = 1;         /* required init */
2033
2034             U16 charid       = 0;         /* sanity init */
2035             U32 accept_state = 0;         /* sanity init */
2036             U8 *scan         = (U8*)NULL; /* sanity init */
2037
2038             STRLEN foldlen   = 0;         /* required init */
2039             U32 wordlen      = 0;         /* required init */
2040             STRLEN skiplen   = 0;
2041             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2042
2043             if (OP(noper) == NOTHING) {
2044                 regnode *noper_next= regnext(noper);
2045                 if (noper_next != tail && OP(noper_next) == flags) {
2046                     noper = noper_next;
2047                     uc= (U8*)STRING(noper);
2048                     e= uc + STR_LEN(noper);
2049                 }
2050             }
2051
2052             if ( OP(noper) != NOTHING ) {
2053                 for ( ; uc < e ; uc += len ) {
2054
2055                     TRIE_READ_CHAR;
2056
2057                     if ( uvc < 256 ) {
2058                         charid = trie->charmap[ uvc ];
2059                     } else {
2060                         SV* const * const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
2061                         charid = svpp ? (U16)SvIV(*svpp) : 0;
2062                     }
2063                     if ( charid ) {
2064                         charid--;
2065                         if ( !trie->trans[ state + charid ].next ) {
2066                             trie->trans[ state + charid ].next = next_alloc;
2067                             trie->trans[ state ].check++;
2068                             prev_states[TRIE_NODENUM(next_alloc)]
2069                                     = TRIE_NODENUM(state);
2070                             next_alloc += trie->uniquecharcount;
2071                         }
2072                         state = trie->trans[ state + charid ].next;
2073                     } else {
2074                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
2075                     }
2076                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
2077                 }
2078             }
2079             accept_state = TRIE_NODENUM( state );
2080             TRIE_HANDLE_WORD(accept_state);
2081
2082         } /* end second pass */
2083
2084         /* and now dump it out before we compress it */
2085         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
2086                                                           revcharmap,
2087                                                           next_alloc, depth+1));
2088
2089         {
2090         /*
2091            * Inplace compress the table.*
2092
2093            For sparse data sets the table constructed by the trie algorithm will
2094            be mostly 0/FAIL transitions or to put it another way mostly empty.
2095            (Note that leaf nodes will not contain any transitions.)
2096
2097            This algorithm compresses the tables by eliminating most such
2098            transitions, at the cost of a modest bit of extra work during lookup:
2099
2100            - Each states[] entry contains a .base field which indicates the
2101            index in the state[] array wheres its transition data is stored.
2102
2103            - If .base is 0 there are no valid transitions from that node.
2104
2105            - If .base is nonzero then charid is added to it to find an entry in
2106            the trans array.
2107
2108            -If trans[states[state].base+charid].check!=state then the
2109            transition is taken to be a 0/Fail transition. Thus if there are fail
2110            transitions at the front of the node then the .base offset will point
2111            somewhere inside the previous nodes data (or maybe even into a node
2112            even earlier), but the .check field determines if the transition is
2113            valid.
2114
2115            XXX - wrong maybe?
2116            The following process inplace converts the table to the compressed
2117            table: We first do not compress the root node 1,and mark all its
2118            .check pointers as 1 and set its .base pointer as 1 as well. This
2119            allows us to do a DFA construction from the compressed table later,
2120            and ensures that any .base pointers we calculate later are greater
2121            than 0.
2122
2123            - We set 'pos' to indicate the first entry of the second node.
2124
2125            - We then iterate over the columns of the node, finding the first and
2126            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
2127            and set the .check pointers accordingly, and advance pos
2128            appropriately and repreat for the next node. Note that when we copy
2129            the next pointers we have to convert them from the original
2130            NODEIDX form to NODENUM form as the former is not valid post
2131            compression.
2132
2133            - If a node has no transitions used we mark its base as 0 and do not
2134            advance the pos pointer.
2135
2136            - If a node only has one transition we use a second pointer into the
2137            structure to fill in allocated fail transitions from other states.
2138            This pointer is independent of the main pointer and scans forward
2139            looking for null transitions that are allocated to a state. When it
2140            finds one it writes the single transition into the "hole".  If the
2141            pointer doesnt find one the single transition is appended as normal.
2142
2143            - Once compressed we can Renew/realloc the structures to release the
2144            excess space.
2145
2146            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
2147            specifically Fig 3.47 and the associated pseudocode.
2148
2149            demq
2150         */
2151         const U32 laststate = TRIE_NODENUM( next_alloc );
2152         U32 state, charid;
2153         U32 pos = 0, zp=0;
2154         trie->statecount = laststate;
2155
2156         for ( state = 1 ; state < laststate ; state++ ) {
2157             U8 flag = 0;
2158             const U32 stateidx = TRIE_NODEIDX( state );
2159             const U32 o_used = trie->trans[ stateidx ].check;
2160             U32 used = trie->trans[ stateidx ].check;
2161             trie->trans[ stateidx ].check = 0;
2162
2163             for ( charid = 0 ; used && charid < trie->uniquecharcount ; charid++ ) {
2164                 if ( flag || trie->trans[ stateidx + charid ].next ) {
2165                     if ( trie->trans[ stateidx + charid ].next ) {
2166                         if (o_used == 1) {
2167                             for ( ; zp < pos ; zp++ ) {
2168                                 if ( ! trie->trans[ zp ].next ) {
2169                                     break;
2170                                 }
2171                             }
2172                             trie->states[ state ].trans.base = zp + trie->uniquecharcount - charid ;
2173                             trie->trans[ zp ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2174                             trie->trans[ zp ].check = state;
2175                             if ( ++zp > pos ) pos = zp;
2176                             break;
2177                         }
2178                         used--;
2179                     }
2180                     if ( !flag ) {
2181                         flag = 1;
2182                         trie->states[ state ].trans.base = pos + trie->uniquecharcount - charid ;
2183                     }
2184                     trie->trans[ pos ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2185                     trie->trans[ pos ].check = state;
2186                     pos++;
2187                 }
2188             }
2189         }
2190         trie->lasttrans = pos + 1;
2191         trie->states = (reg_trie_state *)
2192             PerlMemShared_realloc( trie->states, laststate
2193                                    * sizeof(reg_trie_state) );
2194         DEBUG_TRIE_COMPILE_MORE_r(
2195                 PerlIO_printf( Perl_debug_log,
2196                     "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
2197                     (int)depth * 2 + 2,"",
2198                     (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1 ),
2199                     (IV)next_alloc,
2200                     (IV)pos,
2201                     ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
2202             );
2203
2204         } /* end table compress */
2205     }
2206     DEBUG_TRIE_COMPILE_MORE_r(
2207             PerlIO_printf(Perl_debug_log, "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
2208                 (int)depth * 2 + 2, "",
2209                 (UV)trie->statecount,
2210                 (UV)trie->lasttrans)
2211     );
2212     /* resize the trans array to remove unused space */
2213     trie->trans = (reg_trie_trans *)
2214         PerlMemShared_realloc( trie->trans, trie->lasttrans
2215                                * sizeof(reg_trie_trans) );
2216
2217     {   /* Modify the program and insert the new TRIE node */ 
2218         U8 nodetype =(U8)(flags & 0xFF);
2219         char *str=NULL;
2220         
2221 #ifdef DEBUGGING
2222         regnode *optimize = NULL;
2223 #ifdef RE_TRACK_PATTERN_OFFSETS
2224
2225         U32 mjd_offset = 0;
2226         U32 mjd_nodelen = 0;
2227 #endif /* RE_TRACK_PATTERN_OFFSETS */
2228 #endif /* DEBUGGING */
2229         /*
2230            This means we convert either the first branch or the first Exact,
2231            depending on whether the thing following (in 'last') is a branch
2232            or not and whther first is the startbranch (ie is it a sub part of
2233            the alternation or is it the whole thing.)
2234            Assuming its a sub part we convert the EXACT otherwise we convert
2235            the whole branch sequence, including the first.
2236          */
2237         /* Find the node we are going to overwrite */
2238         if ( first != startbranch || OP( last ) == BRANCH ) {
2239             /* branch sub-chain */
2240             NEXT_OFF( first ) = (U16)(last - first);
2241 #ifdef RE_TRACK_PATTERN_OFFSETS
2242             DEBUG_r({
2243                 mjd_offset= Node_Offset((convert));
2244                 mjd_nodelen= Node_Length((convert));
2245             });
2246 #endif
2247             /* whole branch chain */
2248         }
2249 #ifdef RE_TRACK_PATTERN_OFFSETS
2250         else {
2251             DEBUG_r({
2252                 const  regnode *nop = NEXTOPER( convert );
2253                 mjd_offset= Node_Offset((nop));
2254                 mjd_nodelen= Node_Length((nop));
2255             });
2256         }
2257         DEBUG_OPTIMISE_r(
2258             PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
2259                 (int)depth * 2 + 2, "",
2260                 (UV)mjd_offset, (UV)mjd_nodelen)
2261         );
2262 #endif
2263         /* But first we check to see if there is a common prefix we can 
2264            split out as an EXACT and put in front of the TRIE node.  */
2265         trie->startstate= 1;
2266         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
2267             U32 state;
2268             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
2269                 U32 ofs = 0;
2270                 I32 idx = -1;
2271                 U32 count = 0;
2272                 const U32 base = trie->states[ state ].trans.base;
2273
2274                 if ( trie->states[state].wordnum )
2275                         count = 1;
2276
2277                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2278                     if ( ( base + ofs >= trie->uniquecharcount ) &&
2279                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
2280                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
2281                     {
2282                         if ( ++count > 1 ) {
2283                             SV **tmp = av_fetch( revcharmap, ofs, 0);
2284                             const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
2285                             if ( state == 1 ) break;
2286                             if ( count == 2 ) {
2287                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
2288                                 DEBUG_OPTIMISE_r(
2289                                     PerlIO_printf(Perl_debug_log,
2290                                         "%*sNew Start State=%"UVuf" Class: [",
2291                                         (int)depth * 2 + 2, "",
2292                                         (UV)state));
2293                                 if (idx >= 0) {
2294                                     SV ** const tmp = av_fetch( revcharmap, idx, 0);
2295                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
2296
2297                                     TRIE_BITMAP_SET(trie,*ch);
2298                                     if ( folder )
2299                                         TRIE_BITMAP_SET(trie, folder[ *ch ]);
2300                                     DEBUG_OPTIMISE_r(
2301                                         PerlIO_printf(Perl_debug_log, "%s", (char*)ch)
2302                                     );
2303                                 }
2304                             }
2305                             TRIE_BITMAP_SET(trie,*ch);
2306                             if ( folder )
2307                                 TRIE_BITMAP_SET(trie,folder[ *ch ]);
2308                             DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
2309                         }
2310                         idx = ofs;
2311                     }
2312                 }
2313                 if ( count == 1 ) {
2314                     SV **tmp = av_fetch( revcharmap, idx, 0);
2315                     STRLEN len;
2316                     char *ch = SvPV( *tmp, len );
2317                     DEBUG_OPTIMISE_r({
2318                         SV *sv=sv_newmortal();
2319                         PerlIO_printf( Perl_debug_log,
2320                             "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
2321                             (int)depth * 2 + 2, "",
2322                             (UV)state, (UV)idx, 
2323                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6, 
2324                                 PL_colors[0], PL_colors[1],
2325                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2326                                 PERL_PV_ESCAPE_FIRSTCHAR 
2327                             )
2328                         );
2329                     });
2330                     if ( state==1 ) {
2331                         OP( convert ) = nodetype;
2332                         str=STRING(convert);
2333                         STR_LEN(convert)=0;
2334                     }
2335                     STR_LEN(convert) += len;
2336                     while (len--)
2337                         *str++ = *ch++;
2338                 } else {
2339 #ifdef DEBUGGING            
2340                     if (state>1)
2341                         DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
2342 #endif
2343                     break;
2344                 }
2345             }
2346             trie->prefixlen = (state-1);
2347             if (str) {
2348                 regnode *n = convert+NODE_SZ_STR(convert);
2349                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
2350                 trie->startstate = state;
2351                 trie->minlen -= (state - 1);
2352                 trie->maxlen -= (state - 1);
2353 #ifdef DEBUGGING
2354                /* At least the UNICOS C compiler choked on this
2355                 * being argument to DEBUG_r(), so let's just have
2356                 * it right here. */
2357                if (
2358 #ifdef PERL_EXT_RE_BUILD
2359                    1
2360 #else
2361                    DEBUG_r_TEST
2362 #endif
2363                    ) {
2364                    regnode *fix = convert;
2365                    U32 word = trie->wordcount;
2366                    mjd_nodelen++;
2367                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
2368                    while( ++fix < n ) {
2369                        Set_Node_Offset_Length(fix, 0, 0);
2370                    }
2371                    while (word--) {
2372                        SV ** const tmp = av_fetch( trie_words, word, 0 );
2373                        if (tmp) {
2374                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
2375                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
2376                            else
2377                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
2378                        }
2379                    }
2380                }
2381 #endif
2382                 if (trie->maxlen) {
2383                     convert = n;
2384                 } else {
2385                     NEXT_OFF(convert) = (U16)(tail - convert);
2386                     DEBUG_r(optimize= n);
2387                 }
2388             }
2389         }
2390         if (!jumper) 
2391             jumper = last; 
2392         if ( trie->maxlen ) {
2393             NEXT_OFF( convert ) = (U16)(tail - convert);
2394             ARG_SET( convert, data_slot );
2395             /* Store the offset to the first unabsorbed branch in 
2396                jump[0], which is otherwise unused by the jump logic. 
2397                We use this when dumping a trie and during optimisation. */
2398             if (trie->jump) 
2399                 trie->jump[0] = (U16)(nextbranch - convert);
2400             
2401             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
2402              *   and there is a bitmap
2403              *   and the first "jump target" node we found leaves enough room
2404              * then convert the TRIE node into a TRIEC node, with the bitmap
2405              * embedded inline in the opcode - this is hypothetically faster.
2406              */
2407             if ( !trie->states[trie->startstate].wordnum
2408                  && trie->bitmap
2409                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
2410             {
2411                 OP( convert ) = TRIEC;
2412                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
2413                 PerlMemShared_free(trie->bitmap);
2414                 trie->bitmap= NULL;
2415             } else 
2416                 OP( convert ) = TRIE;
2417
2418             /* store the type in the flags */
2419             convert->flags = nodetype;
2420             DEBUG_r({
2421             optimize = convert 
2422                       + NODE_STEP_REGNODE 
2423                       + regarglen[ OP( convert ) ];
2424             });
2425             /* XXX We really should free up the resource in trie now, 
2426                    as we won't use them - (which resources?) dmq */
2427         }
2428         /* needed for dumping*/
2429         DEBUG_r(if (optimize) {
2430             regnode *opt = convert;
2431
2432             while ( ++opt < optimize) {
2433                 Set_Node_Offset_Length(opt,0,0);
2434             }
2435             /* 
2436                 Try to clean up some of the debris left after the 
2437                 optimisation.
2438              */
2439             while( optimize < jumper ) {
2440                 mjd_nodelen += Node_Length((optimize));
2441                 OP( optimize ) = OPTIMIZED;
2442                 Set_Node_Offset_Length(optimize,0,0);
2443                 optimize++;
2444             }
2445             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
2446         });
2447     } /* end node insert */
2448
2449     /*  Finish populating the prev field of the wordinfo array.  Walk back
2450      *  from each accept state until we find another accept state, and if
2451      *  so, point the first word's .prev field at the second word. If the
2452      *  second already has a .prev field set, stop now. This will be the
2453      *  case either if we've already processed that word's accept state,
2454      *  or that state had multiple words, and the overspill words were
2455      *  already linked up earlier.
2456      */
2457     {
2458         U16 word;
2459         U32 state;
2460         U16 prev;
2461
2462         for (word=1; word <= trie->wordcount; word++) {
2463             prev = 0;
2464             if (trie->wordinfo[word].prev)
2465                 continue;
2466             state = trie->wordinfo[word].accept;
2467             while (state) {
2468                 state = prev_states[state];
2469                 if (!state)
2470                     break;
2471                 prev = trie->states[state].wordnum;
2472                 if (prev)
2473                     break;
2474             }
2475             trie->wordinfo[word].prev = prev;
2476         }
2477         Safefree(prev_states);
2478     }
2479
2480
2481     /* and now dump out the compressed format */
2482     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
2483
2484     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
2485 #ifdef DEBUGGING
2486     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
2487     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
2488 #else
2489     SvREFCNT_dec_NN(revcharmap);
2490 #endif
2491     return trie->jump 
2492            ? MADE_JUMP_TRIE 
2493            : trie->startstate>1 
2494              ? MADE_EXACT_TRIE 
2495              : MADE_TRIE;
2496 }
2497
2498 STATIC void
2499 S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source,  regnode *stclass, U32 depth)
2500 {
2501 /* The Trie is constructed and compressed now so we can build a fail array if it's needed
2502
2503    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
2504    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
2505    ISBN 0-201-10088-6
2506
2507    We find the fail state for each state in the trie, this state is the longest proper
2508    suffix of the current state's 'word' that is also a proper prefix of another word in our
2509    trie. State 1 represents the word '' and is thus the default fail state. This allows
2510    the DFA not to have to restart after its tried and failed a word at a given point, it
2511    simply continues as though it had been matching the other word in the first place.
2512    Consider
2513       'abcdgu'=~/abcdefg|cdgu/
2514    When we get to 'd' we are still matching the first word, we would encounter 'g' which would
2515    fail, which would bring us to the state representing 'd' in the second word where we would
2516    try 'g' and succeed, proceeding to match 'cdgu'.
2517  */
2518  /* add a fail transition */
2519     const U32 trie_offset = ARG(source);
2520     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
2521     U32 *q;
2522     const U32 ucharcount = trie->uniquecharcount;
2523     const U32 numstates = trie->statecount;
2524     const U32 ubound = trie->lasttrans + ucharcount;
2525     U32 q_read = 0;
2526     U32 q_write = 0;
2527     U32 charid;
2528     U32 base = trie->states[ 1 ].trans.base;
2529     U32 *fail;
2530     reg_ac_data *aho;
2531     const U32 data_slot = add_data( pRExC_state, 1, "T" );
2532     GET_RE_DEBUG_FLAGS_DECL;
2533
2534     PERL_ARGS_ASSERT_MAKE_TRIE_FAILTABLE;
2535 #ifndef DEBUGGING
2536     PERL_UNUSED_ARG(depth);
2537 #endif
2538
2539
2540     ARG_SET( stclass, data_slot );
2541     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
2542     RExC_rxi->data->data[ data_slot ] = (void*)aho;
2543     aho->trie=trie_offset;
2544     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
2545     Copy( trie->states, aho->states, numstates, reg_trie_state );
2546     Newxz( q, numstates, U32);
2547     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
2548     aho->refcount = 1;
2549     fail = aho->fail;
2550     /* initialize fail[0..1] to be 1 so that we always have
2551        a valid final fail state */
2552     fail[ 0 ] = fail[ 1 ] = 1;
2553
2554     for ( charid = 0; charid < ucharcount ; charid++ ) {
2555         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
2556         if ( newstate ) {
2557             q[ q_write ] = newstate;
2558             /* set to point at the root */
2559             fail[ q[ q_write++ ] ]=1;
2560         }
2561     }
2562     while ( q_read < q_write) {
2563         const U32 cur = q[ q_read++ % numstates ];
2564         base = trie->states[ cur ].trans.base;
2565
2566         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
2567             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
2568             if (ch_state) {
2569                 U32 fail_state = cur;
2570                 U32 fail_base;
2571                 do {
2572                     fail_state = fail[ fail_state ];
2573                     fail_base = aho->states[ fail_state ].trans.base;
2574                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
2575
2576                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
2577                 fail[ ch_state ] = fail_state;
2578                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
2579                 {
2580                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
2581                 }
2582                 q[ q_write++ % numstates] = ch_state;
2583             }
2584         }
2585     }
2586     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
2587        when we fail in state 1, this allows us to use the
2588        charclass scan to find a valid start char. This is based on the principle
2589        that theres a good chance the string being searched contains lots of stuff
2590        that cant be a start char.
2591      */
2592     fail[ 0 ] = fail[ 1 ] = 0;
2593     DEBUG_TRIE_COMPILE_r({
2594         PerlIO_printf(Perl_debug_log,
2595                       "%*sStclass Failtable (%"UVuf" states): 0", 
2596                       (int)(depth * 2), "", (UV)numstates
2597         );
2598         for( q_read=1; q_read<numstates; q_read++ ) {
2599             PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
2600         }
2601         PerlIO_printf(Perl_debug_log, "\n");
2602     });
2603     Safefree(q);
2604     /*RExC_seen |= REG_SEEN_TRIEDFA;*/
2605 }
2606
2607
2608 /*
2609  * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2610  * These need to be revisited when a newer toolchain becomes available.
2611  */
2612 #if defined(__sparc64__) && defined(__GNUC__)
2613 #   if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2614 #       undef  SPARC64_GCC_WORKAROUND
2615 #       define SPARC64_GCC_WORKAROUND 1
2616 #   endif
2617 #endif
2618
2619 #define DEBUG_PEEP(str,scan,depth) \
2620     DEBUG_OPTIMISE_r({if (scan){ \
2621        SV * const mysv=sv_newmortal(); \
2622        regnode *Next = regnext(scan); \
2623        regprop(RExC_rx, mysv, scan); \
2624        PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
2625        (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
2626        Next ? (REG_NODE_NUM(Next)) : 0 ); \
2627    }});
2628
2629
2630 /* The below joins as many adjacent EXACTish nodes as possible into a single
2631  * one.  The regop may be changed if the node(s) contain certain sequences that
2632  * require special handling.  The joining is only done if:
2633  * 1) there is room in the current conglomerated node to entirely contain the
2634  *    next one.
2635  * 2) they are the exact same node type
2636  *
2637  * The adjacent nodes actually may be separated by NOTHING-kind nodes, and
2638  * these get optimized out
2639  *
2640  * If a node is to match under /i (folded), the number of characters it matches
2641  * can be different than its character length if it contains a multi-character
2642  * fold.  *min_subtract is set to the total delta of the input nodes.
2643  *
2644  * And *has_exactf_sharp_s is set to indicate whether or not the node is EXACTF
2645  * and contains LATIN SMALL LETTER SHARP S
2646  *
2647  * This is as good a place as any to discuss the design of handling these
2648  * multi-character fold sequences.  It's been wrong in Perl for a very long
2649  * time.  There are three code points in Unicode whose multi-character folds
2650  * were long ago discovered to mess things up.  The previous designs for
2651  * dealing with these involved assigning a special node for them.  This
2652  * approach doesn't work, as evidenced by this example:
2653  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
2654  * Both these fold to "sss", but if the pattern is parsed to create a node that
2655  * would match just the \xDF, it won't be able to handle the case where a
2656  * successful match would have to cross the node's boundary.  The new approach
2657  * that hopefully generally solves the problem generates an EXACTFU_SS node
2658  * that is "sss".
2659  *
2660  * It turns out that there are problems with all multi-character folds, and not
2661  * just these three.  Now the code is general, for all such cases, but the
2662  * three still have some special handling.  The approach taken is:
2663  * 1)   This routine examines each EXACTFish node that could contain multi-
2664  *      character fold sequences.  It returns in *min_subtract how much to
2665  *      subtract from the the actual length of the string to get a real minimum
2666  *      match length; it is 0 if there are no multi-char folds.  This delta is
2667  *      used by the caller to adjust the min length of the match, and the delta
2668  *      between min and max, so that the optimizer doesn't reject these
2669  *      possibilities based on size constraints.
2670  * 2)   Certain of these sequences require special handling by the trie code,
2671  *      so, if found, this code changes the joined node type to special ops:
2672  *      EXACTFU_TRICKYFOLD and EXACTFU_SS.
2673  * 3)   For the sequence involving the Sharp s (\xDF), the node type EXACTFU_SS
2674  *      is used for an EXACTFU node that contains at least one "ss" sequence in
2675  *      it.  For non-UTF-8 patterns and strings, this is the only case where
2676  *      there is a possible fold length change.  That means that a regular
2677  *      EXACTFU node without UTF-8 involvement doesn't have to concern itself
2678  *      with length changes, and so can be processed faster.  regexec.c takes
2679  *      advantage of this.  Generally, an EXACTFish node that is in UTF-8 is
2680  *      pre-folded by regcomp.c.  This saves effort in regex matching.
2681  *      However, the pre-folding isn't done for non-UTF8 patterns because the
2682  *      fold of the MICRO SIGN requires UTF-8, and we don't want to slow things
2683  *      down by forcing the pattern into UTF8 unless necessary.  Also what
2684  *      EXACTF and EXACTFL nodes fold to isn't known until runtime.  The fold
2685  *      possibilities for the non-UTF8 patterns are quite simple, except for
2686  *      the sharp s.  All the ones that don't involve a UTF-8 target string are
2687  *      members of a fold-pair, and arrays are set up for all of them so that
2688  *      the other member of the pair can be found quickly.  Code elsewhere in
2689  *      this file makes sure that in EXACTFU nodes, the sharp s gets folded to
2690  *      'ss', even if the pattern isn't UTF-8.  This avoids the issues
2691  *      described in the next item.
2692  * 4)   A problem remains for the sharp s in EXACTF and EXACTFA nodes when the
2693  *      pattern isn't in UTF-8. (BTW, there cannot be an EXACTF node with a
2694  *      UTF-8 pattern.)  An assumption that the optimizer part of regexec.c
2695  *      (probably unwittingly, in Perl_regexec_flags()) makes is that a
2696  *      character in the pattern corresponds to at most a single character in
2697  *      the target string.  (And I do mean character, and not byte here, unlike
2698  *      other parts of the documentation that have never been updated to
2699  *      account for multibyte Unicode.)  sharp s in EXACTF nodes can match the
2700  *      two character string 'ss'; in EXACTFA nodes it can match
2701  *      "\x{17F}\x{17F}".  These violate the assumption, and they are the only
2702  *      instances where it is violated.  I'm reluctant to try to change the
2703  *      assumption, as the code involved is impenetrable to me (khw), so
2704  *      instead the code here punts.  This routine examines (when the pattern
2705  *      isn't UTF-8) EXACTF and EXACTFA nodes for the sharp s, and returns a
2706  *      boolean indicating whether or not the node contains a sharp s.  When it
2707  *      is true, the caller sets a flag that later causes the optimizer in this
2708  *      file to not set values for the floating and fixed string lengths, and
2709  *      thus avoids the optimizer code in regexec.c that makes the invalid
2710  *      assumption.  Thus, there is no optimization based on string lengths for
2711  *      non-UTF8-pattern EXACTF and EXACTFA nodes that contain the sharp s.
2712  *      (The reason the assumption is wrong only in these two cases is that all
2713  *      other non-UTF-8 folds are 1-1; and, for UTF-8 patterns, we pre-fold all
2714  *      other folds to their expanded versions.  We can't prefold sharp s to
2715  *      'ss' in EXACTF nodes because we don't know at compile time if it
2716  *      actually matches 'ss' or not.  It will match iff the target string is
2717  *      in UTF-8, unlike the EXACTFU nodes, where it always matches; and
2718  *      EXACTFA and EXACTFL where it never does.  In an EXACTFA node in a UTF-8
2719  *      pattern, sharp s is folded to "\x{17F}\x{17F}, avoiding the problem;
2720  *      but in a non-UTF8 pattern, folding it to that above-Latin1 string would
2721  *      require the pattern to be forced into UTF-8, the overhead of which we
2722  *      want to avoid.)
2723  */
2724
2725 #define JOIN_EXACT(scan,min_subtract,has_exactf_sharp_s, flags) \
2726     if (PL_regkind[OP(scan)] == EXACT) \
2727         join_exact(pRExC_state,(scan),(min_subtract),has_exactf_sharp_s, (flags),NULL,depth+1)
2728
2729 STATIC U32
2730 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) {
2731     /* Merge several consecutive EXACTish nodes into one. */
2732     regnode *n = regnext(scan);
2733     U32 stringok = 1;
2734     regnode *next = scan + NODE_SZ_STR(scan);
2735     U32 merged = 0;
2736     U32 stopnow = 0;
2737 #ifdef DEBUGGING
2738     regnode *stop = scan;
2739     GET_RE_DEBUG_FLAGS_DECL;
2740 #else
2741     PERL_UNUSED_ARG(depth);
2742 #endif
2743
2744     PERL_ARGS_ASSERT_JOIN_EXACT;
2745 #ifndef EXPERIMENTAL_INPLACESCAN
2746     PERL_UNUSED_ARG(flags);
2747     PERL_UNUSED_ARG(val);
2748 #endif
2749     DEBUG_PEEP("join",scan,depth);
2750
2751     /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
2752      * EXACT ones that are mergeable to the current one. */
2753     while (n
2754            && (PL_regkind[OP(n)] == NOTHING
2755                || (stringok && OP(n) == OP(scan)))
2756            && NEXT_OFF(n)
2757            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
2758     {
2759         
2760         if (OP(n) == TAIL || n > next)
2761             stringok = 0;
2762         if (PL_regkind[OP(n)] == NOTHING) {
2763             DEBUG_PEEP("skip:",n,depth);
2764             NEXT_OFF(scan) += NEXT_OFF(n);
2765             next = n + NODE_STEP_REGNODE;
2766 #ifdef DEBUGGING
2767             if (stringok)
2768                 stop = n;
2769 #endif
2770             n = regnext(n);
2771         }
2772         else if (stringok) {
2773             const unsigned int oldl = STR_LEN(scan);
2774             regnode * const nnext = regnext(n);
2775
2776             /* XXX I (khw) kind of doubt that this works on platforms where
2777              * U8_MAX is above 255 because of lots of other assumptions */
2778             /* Don't join if the sum can't fit into a single node */
2779             if (oldl + STR_LEN(n) > U8_MAX)
2780                 break;
2781             
2782             DEBUG_PEEP("merg",n,depth);
2783             merged++;
2784
2785             NEXT_OFF(scan) += NEXT_OFF(n);
2786             STR_LEN(scan) += STR_LEN(n);
2787             next = n + NODE_SZ_STR(n);
2788             /* Now we can overwrite *n : */
2789             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
2790 #ifdef DEBUGGING
2791             stop = next - 1;
2792 #endif
2793             n = nnext;
2794             if (stopnow) break;
2795         }
2796
2797 #ifdef EXPERIMENTAL_INPLACESCAN
2798         if (flags && !NEXT_OFF(n)) {
2799             DEBUG_PEEP("atch", val, depth);
2800             if (reg_off_by_arg[OP(n)]) {
2801                 ARG_SET(n, val - n);
2802             }
2803             else {
2804                 NEXT_OFF(n) = val - n;
2805             }
2806             stopnow = 1;
2807         }
2808 #endif
2809     }
2810
2811     *min_subtract = 0;
2812     *has_exactf_sharp_s = FALSE;
2813
2814     /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
2815      * can now analyze for sequences of problematic code points.  (Prior to
2816      * this final joining, sequences could have been split over boundaries, and
2817      * hence missed).  The sequences only happen in folding, hence for any
2818      * non-EXACT EXACTish node */
2819     if (OP(scan) != EXACT) {
2820         const U8 * const s0 = (U8*) STRING(scan);
2821         const U8 * s = s0;
2822         const U8 * const s_end = s0 + STR_LEN(scan);
2823
2824         /* One pass is made over the node's string looking for all the
2825          * possibilities.  to avoid some tests in the loop, there are two main
2826          * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
2827          * non-UTF-8 */
2828         if (UTF) {
2829
2830             /* Examine the string for a multi-character fold sequence.  UTF-8
2831              * patterns have all characters pre-folded by the time this code is
2832              * executed */
2833             while (s < s_end - 1) /* Can stop 1 before the end, as minimum
2834                                      length sequence we are looking for is 2 */
2835             {
2836                 int count = 0;
2837                 int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
2838                 if (! len) {    /* Not a multi-char fold: get next char */
2839                     s += UTF8SKIP(s);
2840                     continue;
2841                 }
2842
2843                 /* Nodes with 'ss' require special handling, except for EXACTFL
2844                  * and EXACTFA for which there is no multi-char fold to this */
2845                 if (len == 2 && *s == 's' && *(s+1) == 's'
2846                     && OP(scan) != EXACTFL && OP(scan) != EXACTFA)
2847                 {
2848                     count = 2;
2849                     OP(scan) = EXACTFU_SS;
2850                     s += 2;
2851                 }
2852                 else if (len == 6   /* len is the same in both ASCII and EBCDIC
2853                                        for these */
2854                          && (memEQ(s, GREEK_SMALL_LETTER_IOTA_UTF8
2855                                       COMBINING_DIAERESIS_UTF8
2856                                       COMBINING_ACUTE_ACCENT_UTF8,
2857                                    6)
2858                              || memEQ(s, GREEK_SMALL_LETTER_UPSILON_UTF8
2859                                          COMBINING_DIAERESIS_UTF8
2860                                          COMBINING_ACUTE_ACCENT_UTF8,
2861                                      6)))
2862                 {
2863                     count = 3;
2864
2865                     /* These two folds require special handling by trie's, so
2866                      * change the node type to indicate this.  If EXACTFA and
2867                      * EXACTFL were ever to be handled by trie's, this would
2868                      * have to be changed.  If this node has already been
2869                      * changed to EXACTFU_SS in this loop, leave it as is.  (I
2870                      * (khw) think it doesn't matter in regexec.c for UTF
2871                      * patterns, but no need to change it */
2872                     if (OP(scan) == EXACTFU) {
2873                         OP(scan) = EXACTFU_TRICKYFOLD;
2874                     }
2875                     s += 6;
2876                 }
2877                 else { /* Here is a generic multi-char fold. */
2878                     const U8* multi_end  = s + len;
2879
2880                     /* Count how many characters in it.  In the case of /l and
2881                      * /aa, no folds which contain ASCII code points are
2882                      * allowed, so check for those, and skip if found.  (In
2883                      * EXACTFL, no folds are allowed to any Latin1 code point,
2884                      * not just ASCII.  But there aren't any of these
2885                      * currently, nor ever likely, so don't take the time to
2886                      * test for them.  The code that generates the
2887                      * is_MULTI_foo() macros croaks should one actually get put
2888                      * into Unicode .) */
2889                     if (OP(scan) != EXACTFL && OP(scan) != EXACTFA) {
2890                         count = utf8_length(s, multi_end);
2891                         s = multi_end;
2892                     }
2893                     else {
2894                         while (s < multi_end) {
2895                             if (isASCII(*s)) {
2896                                 s++;
2897                                 goto next_iteration;
2898                             }
2899                             else {
2900                                 s += UTF8SKIP(s);
2901                             }
2902                             count++;
2903                         }
2904                     }
2905                 }
2906
2907                 /* The delta is how long the sequence is minus 1 (1 is how long
2908                  * the character that folds to the sequence is) */
2909                 *min_subtract += count - 1;
2910             next_iteration: ;
2911             }
2912         }
2913         else if (OP(scan) == EXACTFA) {
2914
2915             /* Non-UTF-8 pattern, EXACTFA node.  There can't be a multi-char
2916              * fold to the ASCII range (and there are no existing ones in the
2917              * upper latin1 range).  But, as outlined in the comments preceding
2918              * this function, we need to flag any occurrences of the sharp s */
2919             while (s < s_end) {
2920                 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
2921                     *has_exactf_sharp_s = TRUE;
2922                     break;
2923                 }
2924                 s++;
2925                 continue;
2926             }
2927         }
2928         else if (OP(scan) != EXACTFL) {
2929
2930             /* Non-UTF-8 pattern, not EXACTFA nor EXACTFL node.  Look for the
2931              * multi-char folds that are all Latin1.  (This code knows that
2932              * there are no current multi-char folds possible with EXACTFL,
2933              * relying on fold_grind.t to catch any errors if the very unlikely
2934              * event happens that some get added in future Unicode versions.)
2935              * As explained in the comments preceding this function, we look
2936              * also for the sharp s in EXACTF nodes; it can be in the final
2937              * position.  Otherwise we can stop looking 1 byte earlier because
2938              * have to find at least two characters for a multi-fold */
2939             const U8* upper = (OP(scan) == EXACTF) ? s_end : s_end -1;
2940
2941             /* The below is perhaps overboard, but this allows us to save a
2942              * test each time through the loop at the expense of a mask.  This
2943              * is because on both EBCDIC and ASCII machines, 'S' and 's' differ
2944              * by a single bit.  On ASCII they are 32 apart; on EBCDIC, they
2945              * are 64.  This uses an exclusive 'or' to find that bit and then
2946              * inverts it to form a mask, with just a single 0, in the bit
2947              * position where 'S' and 's' differ. */
2948             const U8 S_or_s_mask = (U8) ~ ('S' ^ 's');
2949             const U8 s_masked = 's' & S_or_s_mask;
2950
2951             while (s < upper) {
2952                 int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end);
2953                 if (! len) {    /* Not a multi-char fold. */
2954                     if (*s == LATIN_SMALL_LETTER_SHARP_S && OP(scan) == EXACTF)
2955                     {
2956                         *has_exactf_sharp_s = TRUE;
2957                     }
2958                     s++;
2959                     continue;
2960                 }
2961
2962                 if (len == 2
2963                     && ((*s & S_or_s_mask) == s_masked)
2964                     && ((*(s+1) & S_or_s_mask) == s_masked))
2965                 {
2966
2967                     /* EXACTF nodes need to know that the minimum length
2968                      * changed so that a sharp s in the string can match this
2969                      * ss in the pattern, but they remain EXACTF nodes, as they
2970                      * won't match this unless the target string is is UTF-8,
2971                      * which we don't know until runtime */
2972                     if (OP(scan) != EXACTF) {
2973                         OP(scan) = EXACTFU_SS;
2974                     }
2975                 }
2976
2977                 *min_subtract += len - 1;
2978                 s += len;
2979             }
2980         }
2981     }
2982
2983 #ifdef DEBUGGING
2984     /* Allow dumping but overwriting the collection of skipped
2985      * ops and/or strings with fake optimized ops */
2986     n = scan + NODE_SZ_STR(scan);
2987     while (n <= stop) {
2988         OP(n) = OPTIMIZED;
2989         FLAGS(n) = 0;
2990         NEXT_OFF(n) = 0;
2991         n++;
2992     }
2993 #endif
2994     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
2995     return stopnow;
2996 }
2997
2998 /* REx optimizer.  Converts nodes into quicker variants "in place".
2999    Finds fixed substrings.  */
3000
3001 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
3002    to the position after last scanned or to NULL. */
3003
3004 #define INIT_AND_WITHP \
3005     assert(!and_withp); \
3006     Newx(and_withp,1,struct regnode_charclass_class); \
3007     SAVEFREEPV(and_withp)
3008
3009 /* this is a chain of data about sub patterns we are processing that
3010    need to be handled separately/specially in study_chunk. Its so
3011    we can simulate recursion without losing state.  */
3012 struct scan_frame;
3013 typedef struct scan_frame {
3014     regnode *last;  /* last node to process in this frame */
3015     regnode *next;  /* next node to process when last is reached */
3016     struct scan_frame *prev; /*previous frame*/
3017     I32 stop; /* what stopparen do we use */
3018 } scan_frame;
3019
3020
3021 #define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf)
3022
3023 STATIC I32
3024 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
3025                         I32 *minlenp, I32 *deltap,
3026                         regnode *last,
3027                         scan_data_t *data,
3028                         I32 stopparen,
3029                         U8* recursed,
3030                         struct regnode_charclass_class *and_withp,
3031                         U32 flags, U32 depth)
3032                         /* scanp: Start here (read-write). */
3033                         /* deltap: Write maxlen-minlen here. */
3034                         /* last: Stop before this one. */
3035                         /* data: string data about the pattern */
3036                         /* stopparen: treat close N as END */
3037                         /* recursed: which subroutines have we recursed into */
3038                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
3039 {
3040     dVAR;
3041     I32 min = 0;    /* There must be at least this number of characters to match */
3042     I32 pars = 0, code;
3043     regnode *scan = *scanp, *next;
3044     I32 delta = 0;
3045     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
3046     int is_inf_internal = 0;            /* The studied chunk is infinite */
3047     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
3048     scan_data_t data_fake;
3049     SV *re_trie_maxbuff = NULL;
3050     regnode *first_non_open = scan;
3051     I32 stopmin = I32_MAX;
3052     scan_frame *frame = NULL;
3053     GET_RE_DEBUG_FLAGS_DECL;
3054
3055     PERL_ARGS_ASSERT_STUDY_CHUNK;
3056
3057 #ifdef DEBUGGING
3058     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
3059 #endif
3060
3061     if ( depth == 0 ) {
3062         while (first_non_open && OP(first_non_open) == OPEN)
3063             first_non_open=regnext(first_non_open);
3064     }
3065
3066
3067   fake_study_recurse:
3068     while ( scan && OP(scan) != END && scan < last ){
3069         UV min_subtract = 0;    /* How mmany chars to subtract from the minimum
3070                                    node length to get a real minimum (because
3071                                    the folded version may be shorter) */
3072         bool has_exactf_sharp_s = FALSE;
3073         /* Peephole optimizer: */
3074         DEBUG_STUDYDATA("Peep:", data,depth);
3075         DEBUG_PEEP("Peep",scan,depth);
3076
3077         /* Its not clear to khw or hv why this is done here, and not in the
3078          * clauses that deal with EXACT nodes.  khw's guess is that it's
3079          * because of a previous design */
3080         JOIN_EXACT(scan,&min_subtract, &has_exactf_sharp_s, 0);
3081
3082         /* Follow the next-chain of the current node and optimize
3083            away all the NOTHINGs from it.  */
3084         if (OP(scan) != CURLYX) {
3085             const int max = (reg_off_by_arg[OP(scan)]
3086                        ? I32_MAX
3087                        /* I32 may be smaller than U16 on CRAYs! */
3088                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
3089             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
3090             int noff;
3091             regnode *n = scan;
3092
3093             /* Skip NOTHING and LONGJMP. */
3094             while ((n = regnext(n))
3095                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
3096                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
3097                    && off + noff < max)
3098                 off += noff;
3099             if (reg_off_by_arg[OP(scan)])
3100                 ARG(scan) = off;
3101             else
3102                 NEXT_OFF(scan) = off;
3103         }
3104
3105
3106
3107         /* The principal pseudo-switch.  Cannot be a switch, since we
3108            look into several different things.  */
3109         if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
3110                    || OP(scan) == IFTHEN) {
3111             next = regnext(scan);
3112             code = OP(scan);
3113             /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
3114
3115             if (OP(next) == code || code == IFTHEN) {
3116                 /* NOTE - There is similar code to this block below for handling
3117                    TRIE nodes on a re-study.  If you change stuff here check there
3118                    too. */
3119                 I32 max1 = 0, min1 = I32_MAX, num = 0;
3120                 struct regnode_charclass_class accum;
3121                 regnode * const startbranch=scan;
3122
3123                 if (flags & SCF_DO_SUBSTR)
3124                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
3125                 if (flags & SCF_DO_STCLASS)
3126                     cl_init_zero(pRExC_state, &accum);
3127
3128                 while (OP(scan) == code) {
3129                     I32 deltanext, minnext, f = 0, fake;
3130                     struct regnode_charclass_class this_class;
3131
3132                     num++;
3133                     data_fake.flags = 0;
3134                     if (data) {
3135                         data_fake.whilem_c = data->whilem_c;
3136                         data_fake.last_closep = data->last_closep;
3137                     }
3138                     else
3139                         data_fake.last_closep = &fake;
3140
3141                     data_fake.pos_delta = delta;
3142                     next = regnext(scan);
3143                     scan = NEXTOPER(scan);
3144                     if (code != BRANCH)
3145                         scan = NEXTOPER(scan);
3146                     if (flags & SCF_DO_STCLASS) {
3147                         cl_init(pRExC_state, &this_class);
3148                         data_fake.start_class = &this_class;
3149                         f = SCF_DO_STCLASS_AND;
3150                     }
3151                     if (flags & SCF_WHILEM_VISITED_POS)
3152                         f |= SCF_WHILEM_VISITED_POS;
3153
3154                     /* we suppose the run is continuous, last=next...*/
3155                     minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
3156                                           next, &data_fake,
3157                                           stopparen, recursed, NULL, f,depth+1);
3158                     if (min1 > minnext)
3159                         min1 = minnext;
3160                     if (deltanext == I32_MAX) {
3161                         is_inf = is_inf_internal = 1;
3162                         max1 = I32_MAX;
3163                     } else if (max1 < minnext + deltanext)
3164                         max1 = minnext + deltanext;
3165                     scan = next;
3166                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3167                         pars++;
3168                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
3169                         if ( stopmin > minnext) 
3170                             stopmin = min + min1;
3171                         flags &= ~SCF_DO_SUBSTR;
3172                         if (data)
3173                             data->flags |= SCF_SEEN_ACCEPT;
3174                     }
3175                     if (data) {
3176                         if (data_fake.flags & SF_HAS_EVAL)
3177                             data->flags |= SF_HAS_EVAL;
3178                         data->whilem_c = data_fake.whilem_c;
3179                     }
3180                     if (flags & SCF_DO_STCLASS)
3181                         cl_or(pRExC_state, &accum, &this_class);
3182                 }
3183                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
3184                     min1 = 0;
3185                 if (flags & SCF_DO_SUBSTR) {
3186                     data->pos_min += min1;
3187                     if (data->pos_delta >= I32_MAX - (max1 - min1))
3188                         data->pos_delta = I32_MAX;
3189                     else
3190                         data->pos_delta += max1 - min1;
3191                     if (max1 != min1 || is_inf)
3192                         data->longest = &(data->longest_float);
3193                 }
3194                 min += min1;
3195                 if (delta == I32_MAX || I32_MAX - delta - (max1 - min1) < 0)
3196                     delta = I32_MAX;
3197                 else
3198                     delta += max1 - min1;
3199                 if (flags & SCF_DO_STCLASS_OR) {
3200                     cl_or(pRExC_state, data->start_class, &accum);
3201                     if (min1) {
3202                         cl_and(data->start_class, and_withp);
3203                         flags &= ~SCF_DO_STCLASS;
3204                     }
3205                 }
3206                 else if (flags & SCF_DO_STCLASS_AND) {
3207                     if (min1) {
3208                         cl_and(data->start_class, &accum);
3209                         flags &= ~SCF_DO_STCLASS;
3210                     }
3211                     else {
3212                         /* Switch to OR mode: cache the old value of
3213                          * data->start_class */
3214                         INIT_AND_WITHP;
3215                         StructCopy(data->start_class, and_withp,
3216                                    struct regnode_charclass_class);
3217                         flags &= ~SCF_DO_STCLASS_AND;
3218                         StructCopy(&accum, data->start_class,
3219                                    struct regnode_charclass_class);
3220                         flags |= SCF_DO_STCLASS_OR;
3221                         SET_SSC_EOS(data->start_class);
3222                     }
3223                 }
3224
3225                 if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) == BRANCH ) {
3226                 /* demq.
3227
3228                    Assuming this was/is a branch we are dealing with: 'scan' now
3229                    points at the item that follows the branch sequence, whatever
3230                    it is. We now start at the beginning of the sequence and look
3231                    for subsequences of
3232
3233                    BRANCH->EXACT=>x1
3234                    BRANCH->EXACT=>x2
3235                    tail
3236
3237                    which would be constructed from a pattern like /A|LIST|OF|WORDS/
3238
3239                    If we can find such a subsequence we need to turn the first
3240                    element into a trie and then add the subsequent branch exact
3241                    strings to the trie.
3242
3243                    We have two cases
3244
3245                      1. patterns where the whole set of branches can be converted. 
3246
3247                      2. patterns where only a subset can be converted.
3248
3249                    In case 1 we can replace the whole set with a single regop
3250                    for the trie. In case 2 we need to keep the start and end
3251                    branches so
3252
3253                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
3254                      becomes BRANCH TRIE; BRANCH X;
3255
3256                   There is an additional case, that being where there is a 
3257                   common prefix, which gets split out into an EXACT like node
3258                   preceding the TRIE node.
3259
3260                   If x(1..n)==tail then we can do a simple trie, if not we make
3261                   a "jump" trie, such that when we match the appropriate word
3262                   we "jump" to the appropriate tail node. Essentially we turn
3263                   a nested if into a case structure of sorts.
3264
3265                 */
3266
3267                     int made=0;
3268                     if (!re_trie_maxbuff) {
3269                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
3270                         if (!SvIOK(re_trie_maxbuff))
3271                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
3272                     }
3273                     if ( SvIV(re_trie_maxbuff)>=0  ) {
3274                         regnode *cur;
3275                         regnode *first = (regnode *)NULL;
3276                         regnode *last = (regnode *)NULL;
3277                         regnode *tail = scan;
3278                         U8 trietype = 0;
3279                         U32 count=0;
3280
3281 #ifdef DEBUGGING
3282                         SV * const mysv = sv_newmortal();       /* for dumping */
3283 #endif
3284                         /* var tail is used because there may be a TAIL
3285                            regop in the way. Ie, the exacts will point to the
3286                            thing following the TAIL, but the last branch will
3287                            point at the TAIL. So we advance tail. If we
3288                            have nested (?:) we may have to move through several
3289                            tails.
3290                          */
3291
3292                         while ( OP( tail ) == TAIL ) {
3293                             /* this is the TAIL generated by (?:) */
3294                             tail = regnext( tail );
3295                         }
3296
3297                         
3298                         DEBUG_TRIE_COMPILE_r({
3299                             regprop(RExC_rx, mysv, tail );
3300                             PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
3301                                 (int)depth * 2 + 2, "", 
3302                                 "Looking for TRIE'able sequences. Tail node is: ", 
3303                                 SvPV_nolen_const( mysv )
3304                             );
3305                         });
3306                         
3307                         /*
3308
3309                             Step through the branches
3310                                 cur represents each branch,
3311                                 noper is the first thing to be matched as part of that branch
3312                                 noper_next is the regnext() of that node.
3313
3314                             We normally handle a case like this /FOO[xyz]|BAR[pqr]/
3315                             via a "jump trie" but we also support building with NOJUMPTRIE,
3316                             which restricts the trie logic to structures like /FOO|BAR/.
3317
3318                             If noper is a trieable nodetype then the branch is a possible optimization
3319                             target. If we are building under NOJUMPTRIE then we require that noper_next
3320                             is the same as scan (our current position in the regex program).
3321
3322                             Once we have two or more consecutive such branches we can create a
3323                             trie of the EXACT's contents and stitch it in place into the program.
3324
3325                             If the sequence represents all of the branches in the alternation we
3326                             replace the entire thing with a single TRIE node.
3327
3328                             Otherwise when it is a subsequence we need to stitch it in place and
3329                             replace only the relevant branches. This means the first branch has
3330                             to remain as it is used by the alternation logic, and its next pointer,
3331                             and needs to be repointed at the item on the branch chain following
3332                             the last branch we have optimized away.
3333
3334                             This could be either a BRANCH, in which case the subsequence is internal,
3335                             or it could be the item following the branch sequence in which case the
3336                             subsequence is at the end (which does not necessarily mean the first node
3337                             is the start of the alternation).
3338
3339                             TRIE_TYPE(X) is a define which maps the optype to a trietype.
3340
3341                                 optype          |  trietype
3342                                 ----------------+-----------
3343                                 NOTHING         | NOTHING
3344                                 EXACT           | EXACT
3345                                 EXACTFU         | EXACTFU
3346                                 EXACTFU_SS      | EXACTFU
3347                                 EXACTFU_TRICKYFOLD | EXACTFU
3348                                 EXACTFA         | 0
3349
3350
3351                         */
3352 #define TRIE_TYPE(X) ( ( NOTHING == (X) ) ? NOTHING :   \
3353                        ( EXACT == (X) )   ? EXACT :        \
3354                        ( EXACTFU == (X) || EXACTFU_SS == (X) || EXACTFU_TRICKYFOLD == (X) ) ? EXACTFU :        \
3355                        0 )
3356
3357                         /* dont use tail as the end marker for this traverse */
3358                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
3359                             regnode * const noper = NEXTOPER( cur );
3360                             U8 noper_type = OP( noper );
3361                             U8 noper_trietype = TRIE_TYPE( noper_type );
3362 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
3363                             regnode * const noper_next = regnext( noper );
3364                             U8 noper_next_type = (noper_next && noper_next != tail) ? OP(noper_next) : 0;
3365                             U8 noper_next_trietype = (noper_next && noper_next != tail) ? TRIE_TYPE( noper_next_type ) :0;
3366 #endif
3367
3368                             DEBUG_TRIE_COMPILE_r({
3369                                 regprop(RExC_rx, mysv, cur);
3370                                 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
3371                                    (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
3372
3373                                 regprop(RExC_rx, mysv, noper);
3374                                 PerlIO_printf( Perl_debug_log, " -> %s",
3375                                     SvPV_nolen_const(mysv));
3376
3377                                 if ( noper_next ) {
3378                                   regprop(RExC_rx, mysv, noper_next );
3379                                   PerlIO_printf( Perl_debug_log,"\t=> %s\t",
3380                                     SvPV_nolen_const(mysv));
3381                                 }
3382                                 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d,tt==%s,nt==%s,nnt==%s)\n",
3383                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
3384                                    PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype] 
3385                                 );
3386                             });
3387
3388                             /* Is noper a trieable nodetype that can be merged with the
3389                              * current trie (if there is one)? */
3390                             if ( noper_trietype
3391                                   &&
3392                                   (
3393                                         ( noper_trietype == NOTHING)
3394                                         || ( trietype == NOTHING )
3395                                         || ( trietype == noper_trietype )
3396                                   )
3397 #ifdef NOJUMPTRIE
3398                                   && noper_next == tail
3399 #endif
3400                                   && count < U16_MAX)
3401                             {
3402                                 /* Handle mergable triable node
3403                                  * Either we are the first node in a new trieable sequence,
3404                                  * in which case we do some bookkeeping, otherwise we update
3405                                  * the end pointer. */
3406                                 if ( !first ) {
3407                                     first = cur;
3408                                     if ( noper_trietype == NOTHING ) {
3409 #if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
3410                                         regnode * const noper_next = regnext( noper );
3411                                         U8 noper_next_type = (noper_next && noper_next!=tail) ? OP(noper_next) : 0;
3412                                         U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
3413 #endif
3414
3415                                         if ( noper_next_trietype ) {
3416                                             trietype = noper_next_trietype;
3417                                         } else if (noper_next_type)  {
3418                                             /* a NOTHING regop is 1 regop wide. We need at least two
3419                                              * for a trie so we can't merge this in */
3420                                             first = NULL;
3421                                         }
3422                                     } else {
3423                                         trietype = noper_trietype;
3424                                     }
3425                                 } else {
3426                                     if ( trietype == NOTHING )
3427                                         trietype = noper_trietype;
3428                                     last = cur;
3429                                 }
3430                                 if (first)
3431                                     count++;
3432                             } /* end handle mergable triable node */
3433                             else {
3434                                 /* handle unmergable node -
3435                                  * noper may either be a triable node which can not be tried
3436                                  * together with the current trie, or a non triable node */
3437                                 if ( last ) {
3438                                     /* If last is set and trietype is not NOTHING then we have found
3439                                      * at least two triable branch sequences in a row of a similar
3440                                      * trietype so we can turn them into a trie. If/when we
3441                                      * allow NOTHING to start a trie sequence this condition will be
3442                                      * required, and it isn't expensive so we leave it in for now. */
3443                                     if ( trietype && trietype != NOTHING )
3444                                         make_trie( pRExC_state,
3445                                                 startbranch, first, cur, tail, count,
3446                                                 trietype, depth+1 );
3447                                     last = NULL; /* note: we clear/update first, trietype etc below, so we dont do it here */
3448                                 }
3449                                 if ( noper_trietype
3450 #ifdef NOJUMPTRIE
3451                                      && noper_next == tail
3452 #endif
3453                                 ){
3454                                     /* noper is triable, so we can start a new trie sequence */
3455                                     count = 1;
3456                                     first = cur;
3457                                     trietype = noper_trietype;
3458                                 } else if (first) {
3459                                     /* if we already saw a first but the current node is not triable then we have
3460                                      * to reset the first information. */
3461                                     count = 0;
3462                                     first = NULL;
3463                                     trietype = 0;
3464                                 }
3465                             } /* end handle unmergable node */
3466                         } /* loop over branches */
3467                         DEBUG_TRIE_COMPILE_r({
3468                             regprop(RExC_rx, mysv, cur);
3469                             PerlIO_printf( Perl_debug_log,
3470                               "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
3471                               "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3472
3473                         });
3474                         if ( last && trietype ) {
3475                             if ( trietype != NOTHING ) {
3476                                 /* the last branch of the sequence was part of a trie,
3477                                  * so we have to construct it here outside of the loop
3478                                  */
3479                                 made= make_trie( pRExC_state, startbranch, first, scan, tail, count, trietype, depth+1 );
3480 #ifdef TRIE_STUDY_OPT
3481                                 if ( ((made == MADE_EXACT_TRIE &&
3482                                      startbranch == first)
3483                                      || ( first_non_open == first )) &&
3484                                      depth==0 ) {
3485                                     flags |= SCF_TRIE_RESTUDY;
3486                                     if ( startbranch == first
3487                                          && scan == tail )
3488                                     {
3489                                         RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
3490                                     }
3491                                 }
3492 #endif
3493                             } else {
3494                                 /* at this point we know whatever we have is a NOTHING sequence/branch
3495                                  * AND if 'startbranch' is 'first' then we can turn the whole thing into a NOTHING
3496                                  */
3497                                 if ( startbranch == first ) {
3498                                     regnode *opt;
3499                                     /* the entire thing is a NOTHING sequence, something like this:
3500                                      * (?:|) So we can turn it into a plain NOTHING op. */
3501                                     DEBUG_TRIE_COMPILE_r({
3502                                         regprop(RExC_rx, mysv, cur);
3503                                         PerlIO_printf( Perl_debug_log,
3504                                           "%*s- %s (%d) <NOTHING BRANCH SEQUENCE>\n", (int)depth * 2 + 2,
3505                                           "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3506
3507                                     });
3508                                     OP(startbranch)= NOTHING;
3509                                     NEXT_OFF(startbranch)= tail - startbranch;
3510                                     for ( opt= startbranch + 1; opt < tail ; opt++ )
3511                                         OP(opt)= OPTIMIZED;
3512                                 }
3513                             }
3514                         } /* end if ( last) */
3515                     } /* TRIE_MAXBUF is non zero */
3516                     
3517                 } /* do trie */
3518                 
3519             }
3520             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
3521                 scan = NEXTOPER(NEXTOPER(scan));
3522             } else                      /* single branch is optimized. */
3523                 scan = NEXTOPER(scan);
3524             continue;
3525         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
3526             scan_frame *newframe = NULL;
3527             I32 paren;
3528             regnode *start;
3529             regnode *end;
3530
3531             if (OP(scan) != SUSPEND) {
3532             /* set the pointer */
3533                 if (OP(scan) == GOSUB) {
3534                     paren = ARG(scan);
3535                     RExC_recurse[ARG2L(scan)] = scan;
3536                     start = RExC_open_parens[paren-1];
3537                     end   = RExC_close_parens[paren-1];
3538                 } else {
3539                     paren = 0;
3540                     start = RExC_rxi->program + 1;
3541                     end   = RExC_opend;
3542                 }
3543                 if (!recursed) {
3544                     Newxz(recursed, (((RExC_npar)>>3) +1), U8);
3545                     SAVEFREEPV(recursed);
3546                 }
3547                 if (!PAREN_TEST(recursed,paren+1)) {
3548                     PAREN_SET(recursed,paren+1);
3549                     Newx(newframe,1,scan_frame);
3550                 } else {
3551                     if (flags & SCF_DO_SUBSTR) {
3552                         SCAN_COMMIT(pRExC_state,data,minlenp);
3553                         data->longest = &(data->longest_float);
3554                     }
3555                     is_inf = is_inf_internal = 1;
3556                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3557                         cl_anything(pRExC_state, data->start_class);
3558                     flags &= ~SCF_DO_STCLASS;
3559                 }
3560             } else {
3561                 Newx(newframe,1,scan_frame);
3562                 paren = stopparen;
3563                 start = scan+2;
3564                 end = regnext(scan);
3565             }
3566             if (newframe) {
3567                 assert(start);
3568                 assert(end);
3569                 SAVEFREEPV(newframe);
3570                 newframe->next = regnext(scan);
3571                 newframe->last = last;
3572                 newframe->stop = stopparen;
3573                 newframe->prev = frame;
3574
3575                 frame = newframe;
3576                 scan =  start;
3577                 stopparen = paren;
3578                 last = end;
3579
3580                 continue;
3581             }
3582         }
3583         else if (OP(scan) == EXACT) {
3584             I32 l = STR_LEN(scan);
3585             UV uc;
3586             if (UTF) {
3587                 const U8 * const s = (U8*)STRING(scan);
3588                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
3589                 l = utf8_length(s, s + l);
3590             } else {
3591                 uc = *((U8*)STRING(scan));
3592             }
3593             min += l;
3594             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
3595                 /* The code below prefers earlier match for fixed
3596                    offset, later match for variable offset.  */
3597                 if (data->last_end == -1) { /* Update the start info. */
3598                     data->last_start_min = data->pos_min;
3599                     data->last_start_max = is_inf
3600                         ? I32_MAX : data->pos_min + data->pos_delta;
3601                 }
3602                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
3603                 if (UTF)
3604                     SvUTF8_on(data->last_found);
3605                 {
3606                     SV * const sv = data->last_found;
3607                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3608                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
3609                     if (mg && mg->mg_len >= 0)
3610                         mg->mg_len += utf8_length((U8*)STRING(scan),
3611                                                   (U8*)STRING(scan)+STR_LEN(scan));
3612                 }
3613                 data->last_end = data->pos_min + l;
3614                 data->pos_min += l; /* As in the first entry. */
3615                 data->flags &= ~SF_BEFORE_EOL;
3616             }
3617             if (flags & SCF_DO_STCLASS_AND) {
3618                 /* Check whether it is compatible with what we know already! */
3619                 int compat = 1;
3620
3621
3622                 /* If compatible, we or it in below.  It is compatible if is
3623                  * in the bitmp and either 1) its bit or its fold is set, or 2)
3624                  * it's for a locale.  Even if there isn't unicode semantics
3625                  * here, at runtime there may be because of matching against a
3626                  * utf8 string, so accept a possible false positive for
3627                  * latin1-range folds */
3628                 if (uc >= 0x100 ||
3629                     (!(data->start_class->flags & ANYOF_LOCALE)
3630                     && !ANYOF_BITMAP_TEST(data->start_class, uc)
3631                     && (!(data->start_class->flags & ANYOF_LOC_FOLD)
3632                         || !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3633                     )
3634                 {
3635                     compat = 0;
3636                 }
3637                 ANYOF_CLASS_ZERO(data->start_class);
3638                 ANYOF_BITMAP_ZERO(data->start_class);
3639                 if (compat)
3640                     ANYOF_BITMAP_SET(data->start_class, uc);
3641                 else if (uc >= 0x100) {
3642                     int i;
3643
3644                     /* Some Unicode code points fold to the Latin1 range; as
3645                      * XXX temporary code, instead of figuring out if this is
3646                      * one, just assume it is and set all the start class bits
3647                      * that could be some such above 255 code point's fold
3648                      * which will generate fals positives.  As the code
3649                      * elsewhere that does compute the fold settles down, it
3650                      * can be extracted out and re-used here */
3651                     for (i = 0; i < 256; i++){
3652                         if (HAS_NONLATIN1_FOLD_CLOSURE(i)) {
3653                             ANYOF_BITMAP_SET(data->start_class, i);
3654                         }
3655                     }
3656                 }
3657                 CLEAR_SSC_EOS(data->start_class);
3658                 if (uc < 0x100)
3659                   data->start_class->flags &= ~ANYOF_UNICODE_ALL;
3660             }
3661             else if (flags & SCF_DO_STCLASS_OR) {
3662                 /* false positive possible if the class is case-folded */
3663                 if (uc < 0x100)
3664                     ANYOF_BITMAP_SET(data->start_class, uc);
3665                 else
3666                     data->start_class->flags |= ANYOF_UNICODE_ALL;
3667                 CLEAR_SSC_EOS(data->start_class);
3668                 cl_and(data->start_class, and_withp);
3669             }
3670             flags &= ~SCF_DO_STCLASS;
3671         }
3672         else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
3673             I32 l = STR_LEN(scan);
3674             UV uc = *((U8*)STRING(scan));
3675
3676             /* Search for fixed substrings supports EXACT only. */
3677             if (flags & SCF_DO_SUBSTR) {
3678                 assert(data);
3679                 SCAN_COMMIT(pRExC_state, data, minlenp);
3680             }
3681             if (UTF) {
3682                 const U8 * const s = (U8 *)STRING(scan);
3683                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
3684                 l = utf8_length(s, s + l);
3685             }
3686             if (has_exactf_sharp_s) {
3687                 RExC_seen |= REG_SEEN_EXACTF_SHARP_S;
3688             }
3689             min += l - min_subtract;
3690             assert (min >= 0);
3691             delta += min_subtract;
3692             if (flags & SCF_DO_SUBSTR) {
3693                 data->pos_min += l - min_subtract;
3694                 if (data->pos_min < 0) {
3695                     data->pos_min = 0;
3696                 }
3697                 data->pos_delta += min_subtract;
3698                 if (min_subtract) {
3699                     data->longest = &(data->longest_float);
3700                 }
3701             }
3702             if (flags & SCF_DO_STCLASS_AND) {
3703                 /* Check whether it is compatible with what we know already! */
3704                 int compat = 1;
3705                 if (uc >= 0x100 ||
3706                  (!(data->start_class->flags & ANYOF_LOCALE)
3707                   && !ANYOF_BITMAP_TEST(data->start_class, uc)
3708                   && !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3709                 {
3710                     compat = 0;
3711                 }
3712                 ANYOF_CLASS_ZERO(data->start_class);
3713                 ANYOF_BITMAP_ZERO(data->start_class);
3714                 if (compat) {
3715                     ANYOF_BITMAP_SET(data->start_class, uc);
3716                     CLEAR_SSC_EOS(data->start_class);
3717                     if (OP(scan) == EXACTFL) {
3718                         /* XXX This set is probably no longer necessary, and
3719                          * probably wrong as LOCALE now is on in the initial
3720                          * state */
3721                         data->start_class->flags |= ANYOF_LOCALE|ANYOF_LOC_FOLD;
3722                     }
3723                     else {
3724
3725                         /* Also set the other member of the fold pair.  In case
3726                          * that unicode semantics is called for at runtime, use
3727                          * the full latin1 fold.  (Can't do this for locale,
3728                          * because not known until runtime) */
3729                         ANYOF_BITMAP_SET(data->start_class, PL_fold_latin1[uc]);
3730
3731                         /* All other (EXACTFL handled above) folds except under
3732                          * /iaa that include s, S, and sharp_s also may include
3733                          * the others */
3734                         if (OP(scan) != EXACTFA) {
3735                             if (uc == 's' || uc == 'S') {
3736                                 ANYOF_BITMAP_SET(data->start_class,
3737                                                  LATIN_SMALL_LETTER_SHARP_S);
3738                             }
3739                             else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3740                                 ANYOF_BITMAP_SET(data->start_class, 's');
3741                                 ANYOF_BITMAP_SET(data->start_class, 'S');
3742                             }
3743                         }
3744                     }
3745                 }
3746                 else if (uc >= 0x100) {
3747                     int i;
3748                     for (i = 0; i < 256; i++){
3749                         if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3750                             ANYOF_BITMAP_SET(data->start_class, i);
3751                         }
3752                     }
3753                 }
3754             }
3755             else if (flags & SCF_DO_STCLASS_OR) {
3756                 if (data->start_class->flags & ANYOF_LOC_FOLD) {
3757                     /* false positive possible if the class is case-folded.
3758                        Assume that the locale settings are the same... */
3759                     if (uc < 0x100) {
3760                         ANYOF_BITMAP_SET(data->start_class, uc);
3761                         if (OP(scan) != EXACTFL) {
3762
3763                             /* And set the other member of the fold pair, but
3764                              * can't do that in locale because not known until
3765                              * run-time */
3766                             ANYOF_BITMAP_SET(data->start_class,
3767                                              PL_fold_latin1[uc]);
3768
3769                             /* All folds except under /iaa that include s, S,
3770                              * and sharp_s also may include the others */
3771                             if (OP(scan) != EXACTFA) {
3772                                 if (uc == 's' || uc == 'S') {
3773                                     ANYOF_BITMAP_SET(data->start_class,
3774                                                    LATIN_SMALL_LETTER_SHARP_S);
3775                                 }
3776                                 else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3777                                     ANYOF_BITMAP_SET(data->start_class, 's');
3778                                     ANYOF_BITMAP_SET(data->start_class, 'S');
3779                                 }
3780                             }
3781                         }
3782                     }
3783                     CLEAR_SSC_EOS(data->start_class);
3784                 }
3785                 cl_and(data->start_class, and_withp);
3786             }
3787             flags &= ~SCF_DO_STCLASS;
3788         }
3789         else if (REGNODE_VARIES(OP(scan))) {
3790             I32 mincount, maxcount, minnext, deltanext, fl = 0;
3791             I32 f = flags, pos_before = 0;
3792             regnode * const oscan = scan;
3793             struct regnode_charclass_class this_class;
3794             struct regnode_charclass_class *oclass = NULL;
3795             I32 next_is_eval = 0;
3796
3797             switch (PL_regkind[OP(scan)]) {
3798             case WHILEM:                /* End of (?:...)* . */
3799                 scan = NEXTOPER(scan);
3800                 goto finish;
3801             case PLUS:
3802                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
3803                     next = NEXTOPER(scan);
3804                     if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
3805                         mincount = 1;
3806                         maxcount = REG_INFTY;
3807                         next = regnext(scan);
3808                         scan = NEXTOPER(scan);
3809                         goto do_curly;
3810                     }
3811                 }
3812                 if (flags & SCF_DO_SUBSTR)
3813                     data->pos_min++;
3814                 min++;
3815                 /* Fall through. */
3816             case STAR:
3817                 if (flags & SCF_DO_STCLASS) {
3818                     mincount = 0;
3819                     maxcount = REG_INFTY;
3820                     next = regnext(scan);
3821                     scan = NEXTOPER(scan);
3822                     goto do_curly;
3823                 }
3824                 is_inf = is_inf_internal = 1;
3825                 scan = regnext(scan);
3826                 if (flags & SCF_DO_SUBSTR) {
3827                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
3828                     data->longest = &(data->longest_float);
3829                 }
3830                 goto optimize_curly_tail;
3831             case CURLY:
3832                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
3833                     && (scan->flags == stopparen))
3834                 {
3835                     mincount = 1;
3836                     maxcount = 1;
3837                 } else {
3838                     mincount = ARG1(scan);
3839                     maxcount = ARG2(scan);
3840                 }
3841                 next = regnext(scan);
3842                 if (OP(scan) == CURLYX) {
3843                     I32 lp = (data ? *(data->last_closep) : 0);
3844                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
3845                 }
3846                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3847                 next_is_eval = (OP(scan) == EVAL);
3848               do_curly:
3849                 if (flags & SCF_DO_SUBSTR) {
3850                     if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
3851                     pos_before = data->pos_min;
3852                 }
3853                 if (data) {
3854                     fl = data->flags;
3855                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
3856                     if (is_inf)
3857                         data->flags |= SF_IS_INF;
3858                 }
3859                 if (flags & SCF_DO_STCLASS) {
3860                     cl_init(pRExC_state, &this_class);
3861                     oclass = data->start_class;
3862                     data->start_class = &this_class;
3863                     f |= SCF_DO_STCLASS_AND;
3864                     f &= ~SCF_DO_STCLASS_OR;
3865                 }
3866                 /* Exclude from super-linear cache processing any {n,m}
3867                    regops for which the combination of input pos and regex
3868                    pos is not enough information to determine if a match
3869                    will be possible.
3870
3871                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
3872                    regex pos at the \s*, the prospects for a match depend not
3873                    only on the input position but also on how many (bar\s*)
3874                    repeats into the {4,8} we are. */
3875                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
3876                     f &= ~SCF_WHILEM_VISITED_POS;
3877
3878                 /* This will finish on WHILEM, setting scan, or on NULL: */
3879                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, 
3880                                       last, data, stopparen, recursed, NULL,
3881                                       (mincount == 0
3882                                         ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
3883
3884                 if (flags & SCF_DO_STCLASS)
3885                     data->start_class = oclass;
3886                 if (mincount == 0 || minnext == 0) {
3887                     if (flags & SCF_DO_STCLASS_OR) {
3888                         cl_or(pRExC_state, data->start_class, &this_class);
3889                     }
3890                     else if (flags & SCF_DO_STCLASS_AND) {
3891                         /* Switch to OR mode: cache the old value of
3892                          * data->start_class */
3893                         INIT_AND_WITHP;
3894                         StructCopy(data->start_class, and_withp,
3895                                    struct regnode_charclass_class);
3896                         flags &= ~SCF_DO_STCLASS_AND;
3897                         StructCopy(&this_class, data->start_class,
3898                                    struct regnode_charclass_class);
3899                         flags |= SCF_DO_STCLASS_OR;
3900                         SET_SSC_EOS(data->start_class);
3901                     }
3902                 } else {                /* Non-zero len */
3903                     if (flags & SCF_DO_STCLASS_OR) {
3904                         cl_or(pRExC_state, data->start_class, &this_class);
3905                         cl_and(data->start_class, and_withp);
3906                     }
3907                     else if (flags & SCF_DO_STCLASS_AND)
3908                         cl_and(data->start_class, &this_class);
3909                     flags &= ~SCF_DO_STCLASS;
3910                 }
3911                 if (!scan)              /* It was not CURLYX, but CURLY. */
3912                     scan = next;
3913                 if (!(flags & SCF_TRIE_DOING_RESTUDY)
3914                     /* ? quantifier ok, except for (?{ ... }) */
3915                     && (next_is_eval || !(mincount == 0 && maxcount == 1))
3916                     && (minnext == 0) && (deltanext == 0)
3917                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
3918                     && maxcount <= REG_INFTY/3) /* Complement check for big count */
3919                 {
3920                     /* Fatal warnings may leak the regexp without this: */
3921                     SAVEFREESV(RExC_rx_sv);
3922                     ckWARNreg(RExC_parse,
3923                               "Quantifier unexpected on zero-length expression");
3924                     (void)ReREFCNT_inc(RExC_rx_sv);
3925                 }
3926
3927                 min += minnext * mincount;
3928                 is_inf_internal |= deltanext == I32_MAX
3929                                      || (maxcount == REG_INFTY && minnext + deltanext > 0);
3930                 is_inf |= is_inf_internal;
3931                 if (is_inf)
3932                     delta = I32_MAX;
3933                 else
3934                     delta += (minnext + deltanext) * maxcount - minnext * mincount;
3935
3936                 /* Try powerful optimization CURLYX => CURLYN. */
3937                 if (  OP(oscan) == CURLYX && data
3938                       && data->flags & SF_IN_PAR
3939                       && !(data->flags & SF_HAS_EVAL)
3940                       && !deltanext && minnext == 1 ) {
3941                     /* Try to optimize to CURLYN.  */
3942                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
3943                     regnode * const nxt1 = nxt;
3944 #ifdef DEBUGGING
3945                     regnode *nxt2;
3946 #endif
3947
3948                     /* Skip open. */
3949                     nxt = regnext(nxt);
3950                     if (!REGNODE_SIMPLE(OP(nxt))
3951                         && !(PL_regkind[OP(nxt)] == EXACT
3952                              && STR_LEN(nxt) == 1))
3953                         goto nogo;
3954 #ifdef DEBUGGING
3955                     nxt2 = nxt;
3956 #endif
3957                     nxt = regnext(nxt);
3958                     if (OP(nxt) != CLOSE)
3959                         goto nogo;
3960                     if (RExC_open_parens) {
3961                         RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3962                         RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
3963                     }
3964                     /* Now we know that nxt2 is the only contents: */
3965                     oscan->flags = (U8)ARG(nxt);
3966                     OP(oscan) = CURLYN;
3967                     OP(nxt1) = NOTHING; /* was OPEN. */
3968
3969 #ifdef DEBUGGING
3970                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3971                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
3972                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
3973                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
3974                     OP(nxt + 1) = OPTIMIZED; /* was count. */
3975                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
3976 #endif
3977                 }
3978               nogo:
3979
3980                 /* Try optimization CURLYX => CURLYM. */
3981                 if (  OP(oscan) == CURLYX && data
3982                       && !(data->flags & SF_HAS_PAR)
3983                       && !(data->flags & SF_HAS_EVAL)
3984                       && !deltanext     /* atom is fixed width */
3985                       && minnext != 0   /* CURLYM can't handle zero width */
3986                       && ! (RExC_seen & REG_SEEN_EXACTF_SHARP_S) /* Nor \xDF */
3987                 ) {
3988                     /* XXXX How to optimize if data == 0? */
3989                     /* Optimize to a simpler form.  */
3990                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
3991                     regnode *nxt2;
3992
3993                     OP(oscan) = CURLYM;
3994                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
3995                             && (OP(nxt2) != WHILEM))
3996                         nxt = nxt2;
3997                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
3998                     /* Need to optimize away parenths. */
3999                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
4000                         /* Set the parenth number.  */
4001                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
4002
4003                         oscan->flags = (U8)ARG(nxt);
4004                         if (RExC_open_parens) {
4005                             RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
4006                             RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
4007                         }
4008                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
4009                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
4010
4011 #ifdef DEBUGGING
4012                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
4013                         OP(nxt + 1) = OPTIMIZED; /* was count. */
4014                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
4015                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
4016 #endif
4017 #if 0
4018                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
4019                             regnode *nnxt = regnext(nxt1);
4020                             if (nnxt == nxt) {
4021                                 if (reg_off_by_arg[OP(nxt1)])
4022                                     ARG_SET(nxt1, nxt2 - nxt1);
4023                                 else if (nxt2 - nxt1 < U16_MAX)
4024                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
4025                                 else
4026                                     OP(nxt) = NOTHING;  /* Cannot beautify */
4027                             }
4028                             nxt1 = nnxt;
4029                         }
4030 #endif
4031                         /* Optimize again: */
4032                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
4033                                     NULL, stopparen, recursed, NULL, 0,depth+1);
4034                     }
4035                     else
4036                         oscan->flags = 0;
4037                 }
4038                 else if ((OP(oscan) == CURLYX)
4039                          && (flags & SCF_WHILEM_VISITED_POS)
4040                          /* See the comment on a similar expression above.
4041                             However, this time it's not a subexpression
4042                             we care about, but the expression itself. */
4043                          && (maxcount == REG_INFTY)
4044                          && data && ++data->whilem_c < 16) {
4045                     /* This stays as CURLYX, we can put the count/of pair. */
4046                     /* Find WHILEM (as in regexec.c) */
4047                     regnode *nxt = oscan + NEXT_OFF(oscan);
4048
4049                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
4050                         nxt += ARG(nxt);
4051                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
4052                         | (RExC_whilem_seen << 4)); /* On WHILEM */
4053                 }
4054                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
4055                     pars++;
4056                 if (flags & SCF_DO_SUBSTR) {
4057                     SV *last_str = NULL;
4058                     int counted = mincount != 0;
4059
4060                     if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
4061 #if defined(SPARC64_GCC_WORKAROUND)
4062                         I32 b = 0;
4063                         STRLEN l = 0;
4064                         const char *s = NULL;
4065                         I32 old = 0;
4066
4067                         if (pos_before >= data->last_start_min)
4068                             b = pos_before;
4069                         else
4070                             b = data->last_start_min;
4071
4072                         l = 0;
4073                         s = SvPV_const(data->last_found, l);
4074                         old = b - data->last_start_min;
4075
4076 #else
4077                         I32 b = pos_before >= data->last_start_min
4078                             ? pos_before : data->last_start_min;
4079                         STRLEN l;
4080                         const char * const s = SvPV_const(data->last_found, l);
4081                         I32 old = b - data->last_start_min;
4082 #endif
4083
4084                         if (UTF)
4085                             old = utf8_hop((U8*)s, old) - (U8*)s;
4086                         l -= old;
4087                         /* Get the added string: */
4088                         last_str = newSVpvn_utf8(s  + old, l, UTF);
4089                         if (deltanext == 0 && pos_before == b) {
4090                             /* What was added is a constant string */
4091                             if (mincount > 1) {
4092                                 SvGROW(last_str, (mincount * l) + 1);
4093                                 repeatcpy(SvPVX(last_str) + l,
4094                                           SvPVX_const(last_str), l, mincount - 1);
4095                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
4096                                 /* Add additional parts. */
4097                                 SvCUR_set(data->last_found,
4098                                           SvCUR(data->last_found) - l);
4099                                 sv_catsv(data->last_found, last_str);
4100                                 {
4101                                     SV * sv = data->last_found;
4102                                     MAGIC *mg =
4103                                         SvUTF8(sv) && SvMAGICAL(sv) ?
4104                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
4105                                     if (mg && mg->mg_len >= 0)
4106                                         mg->mg_len += CHR_SVLEN(last_str) - l;
4107                                 }
4108                                 data->last_end += l * (mincount - 1);
4109                             }
4110                         } else {
4111                             /* start offset must point into the last copy */
4112                             data->last_start_min += minnext * (mincount - 1);
4113                             data->last_start_max += is_inf ? I32_MAX
4114                                 : (maxcount - 1) * (minnext + data->pos_delta);
4115                         }
4116                     }
4117                     /* It is counted once already... */
4118                     data->pos_min += minnext * (mincount - counted);
4119 #if 0
4120 PerlIO_printf(Perl_debug_log, "counted=%d deltanext=%d I32_MAX=%d minnext=%d maxcount=%d mincount=%d\n",
4121     counted, deltanext, I32_MAX, minnext, maxcount, mincount);
4122 if (deltanext != I32_MAX)
4123 PerlIO_printf(Perl_debug_log, "LHS=%d RHS=%d\n", -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount, I32_MAX - data->pos_delta);
4124 #endif
4125                     if (deltanext == I32_MAX || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= I32_MAX - data->pos_delta)
4126                         data->pos_delta = I32_MAX;
4127                     else
4128                         data->pos_delta += - counted * deltanext +
4129                         (minnext + deltanext) * maxcount - minnext * mincount;
4130                     if (mincount != maxcount) {
4131                          /* Cannot extend fixed substrings found inside
4132                             the group.  */
4133                         SCAN_COMMIT(pRExC_state,data,minlenp);
4134                         if (mincount && last_str) {
4135                             SV * const sv = data->last_found;
4136                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4137                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
4138
4139                             if (mg)
4140                                 mg->mg_len = -1;
4141                             sv_setsv(sv, last_str);
4142                             data->last_end = data->pos_min;
4143                             data->last_start_min =
4144                                 data->pos_min - CHR_SVLEN(last_str);
4145                             data->last_start_max = is_inf
4146                                 ? I32_MAX
4147                                 : data->pos_min + data->pos_delta
4148                                 - CHR_SVLEN(last_str);
4149                         }
4150                         data->longest = &(data->longest_float);
4151                     }
4152                     SvREFCNT_dec(last_str);
4153                 }
4154                 if (data && (fl & SF_HAS_EVAL))
4155                     data->flags |= SF_HAS_EVAL;
4156               optimize_curly_tail:
4157                 if (OP(oscan) != CURLYX) {
4158                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
4159                            && NEXT_OFF(next))
4160                         NEXT_OFF(oscan) += NEXT_OFF(next);
4161                 }
4162                 continue;
4163             default:                    /* REF, and CLUMP only? */
4164                 if (flags & SCF_DO_SUBSTR) {
4165                     SCAN_COMMIT(pRExC_state,data,minlenp);      /* Cannot expect anything... */
4166                     data->longest = &(data->longest_float);
4167                 }
4168                 is_inf = is_inf_internal = 1;
4169                 if (flags & SCF_DO_STCLASS_OR)
4170                     cl_anything(pRExC_state, data->start_class);
4171                 flags &= ~SCF_DO_STCLASS;
4172                 break;
4173             }
4174         }
4175         else if (OP(scan) == LNBREAK) {
4176             if (flags & SCF_DO_STCLASS) {
4177                 int value = 0;
4178                 CLEAR_SSC_EOS(data->start_class); /* No match on empty */
4179                 if (flags & SCF_DO_STCLASS_AND) {
4180                     for (value = 0; value < 256; value++)
4181                         if (!is_VERTWS_cp(value))
4182                             ANYOF_BITMAP_CLEAR(data->start_class, value);
4183                 }
4184                 else {
4185                     for (value = 0; value < 256; value++)
4186                         if (is_VERTWS_cp(value))
4187                             ANYOF_BITMAP_SET(data->start_class, value);
4188                 }
4189                 if (flags & SCF_DO_STCLASS_OR)
4190                     cl_and(data->start_class, and_withp);
4191                 flags &= ~SCF_DO_STCLASS;
4192             }
4193             min++;
4194             delta++;    /* Because of the 2 char string cr-lf */
4195             if (flags & SCF_DO_SUBSTR) {
4196                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
4197                 data->pos_min += 1;
4198                 data->pos_delta += 1;
4199                 data->longest = &(data->longest_float);
4200             }
4201         }
4202         else if (REGNODE_SIMPLE(OP(scan))) {
4203             int value = 0;
4204
4205             if (flags & SCF_DO_SUBSTR) {
4206                 SCAN_COMMIT(pRExC_state,data,minlenp);
4207                 data->pos_min++;
4208             }
4209             min++;
4210             if (flags & SCF_DO_STCLASS) {
4211                 int loop_max = 256;
4212                 CLEAR_SSC_EOS(data->start_class); /* No match on empty */
4213
4214                 /* Some of the logic below assumes that switching
4215                    locale on will only add false positives. */
4216                 switch (PL_regkind[OP(scan)]) {
4217                     U8 classnum;
4218
4219                 case SANY:
4220                 default:
4221 #ifdef DEBUGGING
4222                    Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan));
4223 #endif
4224                  do_default:
4225                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4226                         cl_anything(pRExC_state, data->start_class);
4227                     break;
4228                 case REG_ANY:
4229                     if (OP(scan) == SANY)
4230                         goto do_default;
4231                     if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
4232                         value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
4233                                 || ANYOF_CLASS_TEST_ANY_SET(data->start_class));
4234                         cl_anything(pRExC_state, data->start_class);
4235                     }
4236                     if (flags & SCF_DO_STCLASS_AND || !value)
4237                         ANYOF_BITMAP_CLEAR(data->start_class,'\n');
4238                     break;
4239                 case ANYOF:
4240                     if (flags & SCF_DO_STCLASS_AND)
4241                         cl_and(data->start_class,
4242                                (struct regnode_charclass_class*)scan);
4243                     else
4244                         cl_or(pRExC_state, data->start_class,
4245                               (struct regnode_charclass_class*)scan);
4246                     break;
4247                 case POSIXA:
4248                     loop_max = 128;
4249                     /* FALL THROUGH */
4250                 case POSIXL:
4251                 case POSIXD:
4252                 case POSIXU:
4253                     classnum = FLAGS(scan);
4254                     if (flags & SCF_DO_STCLASS_AND) {
4255                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
4256                             ANYOF_CLASS_CLEAR(data->start_class, classnum_to_namedclass(classnum) + 1);
4257                             for (value = 0; value < loop_max; value++) {
4258                                 if (! _generic_isCC(UNI_TO_NATIVE(value), classnum)) {
4259                                     ANYOF_BITMAP_CLEAR(data->start_class, UNI_TO_NATIVE(value));
4260                                 }
4261                             }
4262                         }
4263                     }
4264                     else {
4265                         if (data->start_class->flags & ANYOF_LOCALE) {
4266                             ANYOF_CLASS_SET(data->start_class, classnum_to_namedclass(classnum));
4267                         }
4268                         else {
4269
4270                         /* Even if under locale, set the bits for non-locale
4271                          * in case it isn't a true locale-node.  This will
4272                          * create false positives if it truly is locale */
4273                         for (value = 0; value < loop_max; value++) {
4274                             if (_generic_isCC(UNI_TO_NATIVE(value), classnum)) {
4275                                 ANYOF_BITMAP_SET(data->start_class, UNI_TO_NATIVE(value));
4276                             }
4277                         }
4278                         }
4279                     }
4280                     break;
4281                 case NPOSIXA:
4282                     loop_max = 128;
4283                     /* FALL THROUGH */
4284                 case NPOSIXL:
4285                 case NPOSIXU:
4286                 case NPOSIXD:
4287                     classnum = FLAGS(scan);
4288                     if (flags & SCF_DO_STCLASS_AND) {
4289                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
4290                             ANYOF_CLASS_CLEAR(data->start_class, classnum_to_namedclass(classnum));
4291                             for (value = 0; value < loop_max; value++) {
4292                                 if (_generic_isCC(UNI_TO_NATIVE(value), classnum)) {
4293                                     ANYOF_BITMAP_CLEAR(data->start_class, UNI_TO_NATIVE(value));
4294                                 }
4295                             }
4296                         }
4297                     }
4298                     else {
4299                         if (data->start_class->flags & ANYOF_LOCALE) {
4300                             ANYOF_CLASS_SET(data->start_class, classnum_to_namedclass(classnum) + 1);
4301                         }
4302                         else {
4303
4304                         /* Even if under locale, set the bits for non-locale in
4305                          * case it isn't a true locale-node.  This will create
4306                          * false positives if it truly is locale */
4307                         for (value = 0; value < loop_max; value++) {
4308                             if (! _generic_isCC(UNI_TO_NATIVE(value), classnum)) {
4309                                 ANYOF_BITMAP_SET(data->start_class, UNI_TO_NATIVE(value));
4310                             }
4311                         }
4312                         if (PL_regkind[OP(scan)] == NPOSIXD) {
4313                             data->start_class->flags |= ANYOF_NON_UTF8_LATIN1_ALL;
4314                         }
4315                         }
4316                     }
4317                     break;
4318                 }
4319                 if (flags & SCF_DO_STCLASS_OR)
4320                     cl_and(data->start_class, and_withp);
4321                 flags &= ~SCF_DO_STCLASS;
4322             }
4323         }
4324         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
4325             data->flags |= (OP(scan) == MEOL
4326                             ? SF_BEFORE_MEOL
4327                             : SF_BEFORE_SEOL);
4328             SCAN_COMMIT(pRExC_state, data, minlenp);
4329
4330         }
4331         else if (  PL_regkind[OP(scan)] == BRANCHJ
4332                  /* Lookbehind, or need to calculate parens/evals/stclass: */
4333                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
4334                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
4335             if ( OP(scan) == UNLESSM &&
4336                  scan->flags == 0 &&
4337                  OP(NEXTOPER(NEXTOPER(scan))) == NOTHING &&
4338                  OP(regnext(NEXTOPER(NEXTOPER(scan)))) == SUCCEED
4339             ) {
4340                 regnode *opt;
4341                 regnode *upto= regnext(scan);
4342                 DEBUG_PARSE_r({
4343                     SV * const mysv_val=sv_newmortal();
4344                     DEBUG_STUDYDATA("OPFAIL",data,depth);
4345
4346                     /*DEBUG_PARSE_MSG("opfail");*/
4347                     regprop(RExC_rx, mysv_val, upto);
4348                     PerlIO_printf(Perl_debug_log, "~ replace with OPFAIL pointed at %s (%"IVdf") offset %"IVdf"\n",
4349                                   SvPV_nolen_const(mysv_val),
4350                                   (IV)REG_NODE_NUM(upto),
4351                                   (IV)(upto - scan)
4352                     );
4353                 });
4354                 OP(scan) = OPFAIL;
4355                 NEXT_OFF(scan) = upto - scan;
4356                 for (opt= scan + 1; opt < upto ; opt++)
4357                     OP(opt) = OPTIMIZED;
4358                 scan= upto;
4359                 continue;
4360             }
4361             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY 
4362                 || OP(scan) == UNLESSM )
4363             {
4364                 /* Negative Lookahead/lookbehind
4365                    In this case we can't do fixed string optimisation.
4366                 */
4367
4368                 I32 deltanext, minnext, fake = 0;
4369                 regnode *nscan;
4370                 struct regnode_charclass_class intrnl;
4371                 int f = 0;
4372
4373                 data_fake.flags = 0;
4374                 if (data) {
4375                     data_fake.whilem_c = data->whilem_c;
4376                     data_fake.last_closep = data->last_closep;
4377                 }
4378                 else
4379                     data_fake.last_closep = &fake;
4380                 data_fake.pos_delta = delta;
4381                 if ( flags & SCF_DO_STCLASS && !scan->flags
4382                      && OP(scan) == IFMATCH ) { /* Lookahead */
4383                     cl_init(pRExC_state, &intrnl);
4384                     data_fake.start_class = &intrnl;
4385                     f |= SCF_DO_STCLASS_AND;
4386                 }
4387                 if (flags & SCF_WHILEM_VISITED_POS)
4388                     f |= SCF_WHILEM_VISITED_POS;
4389                 next = regnext(scan);
4390                 nscan = NEXTOPER(NEXTOPER(scan));
4391                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext, 
4392                     last, &data_fake, stopparen, recursed, NULL, f, depth+1);
4393                 if (scan->flags) {
4394                     if (deltanext) {
4395                         FAIL("Variable length lookbehind not implemented");
4396                     }
4397                     else if (minnext > (I32)U8_MAX) {
4398                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4399                     }
4400                     scan->flags = (U8)minnext;
4401                 }
4402                 if (data) {
4403                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4404                         pars++;
4405                     if (data_fake.flags & SF_HAS_EVAL)
4406                         data->flags |= SF_HAS_EVAL;
4407                     data->whilem_c = data_fake.whilem_c;
4408                 }
4409                 if (f & SCF_DO_STCLASS_AND) {
4410                     if (flags & SCF_DO_STCLASS_OR) {
4411                         /* OR before, AND after: ideally we would recurse with
4412                          * data_fake to get the AND applied by study of the
4413                          * remainder of the pattern, and then derecurse;
4414                          * *** HACK *** for now just treat as "no information".
4415                          * See [perl #56690].
4416                          */
4417                         cl_init(pRExC_state, data->start_class);
4418                     }  else {
4419                         /* AND before and after: combine and continue */
4420                         const int was = TEST_SSC_EOS(data->start_class);
4421
4422                         cl_and(data->start_class, &intrnl);
4423                         if (was)
4424                             SET_SSC_EOS(data->start_class);
4425                     }
4426                 }
4427             }
4428 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
4429             else {
4430                 /* Positive Lookahead/lookbehind
4431                    In this case we can do fixed string optimisation,
4432                    but we must be careful about it. Note in the case of
4433                    lookbehind the positions will be offset by the minimum
4434                    length of the pattern, something we won't know about
4435                    until after the recurse.
4436                 */
4437                 I32 deltanext, fake = 0;
4438                 regnode *nscan;
4439                 struct regnode_charclass_class intrnl;
4440                 int f = 0;
4441                 /* We use SAVEFREEPV so that when the full compile 
4442                     is finished perl will clean up the allocated 
4443                     minlens when it's all done. This way we don't
4444                     have to worry about freeing them when we know
4445                     they wont be used, which would be a pain.
4446                  */
4447                 I32 *minnextp;
4448                 Newx( minnextp, 1, I32 );
4449                 SAVEFREEPV(minnextp);
4450
4451                 if (data) {
4452                     StructCopy(data, &data_fake, scan_data_t);
4453                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
4454                         f |= SCF_DO_SUBSTR;
4455                         if (scan->flags) 
4456                             SCAN_COMMIT(pRExC_state, &data_fake,minlenp);
4457                         data_fake.last_found=newSVsv(data->last_found);
4458                     }
4459                 }
4460                 else
4461                     data_fake.last_closep = &fake;
4462                 data_fake.flags = 0;
4463                 data_fake.pos_delta = delta;
4464                 if (is_inf)
4465                     data_fake.flags |= SF_IS_INF;
4466                 if ( flags & SCF_DO_STCLASS && !scan->flags
4467                      && OP(scan) == IFMATCH ) { /* Lookahead */
4468                     cl_init(pRExC_state, &intrnl);
4469                     data_fake.start_class = &intrnl;
4470                     f |= SCF_DO_STCLASS_AND;
4471                 }
4472                 if (flags & SCF_WHILEM_VISITED_POS)
4473                     f |= SCF_WHILEM_VISITED_POS;
4474                 next = regnext(scan);
4475                 nscan = NEXTOPER(NEXTOPER(scan));
4476
4477                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext, 
4478                     last, &data_fake, stopparen, recursed, NULL, f,depth+1);
4479                 if (scan->flags) {
4480                     if (deltanext) {
4481                         FAIL("Variable length lookbehind not implemented");
4482                     }
4483                     else if (*minnextp > (I32)U8_MAX) {
4484                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4485                     }
4486                     scan->flags = (U8)*minnextp;
4487                 }
4488
4489                 *minnextp += min;
4490
4491                 if (f & SCF_DO_STCLASS_AND) {
4492                     const int was = TEST_SSC_EOS(data.start_class);
4493
4494                     cl_and(data->start_class, &intrnl);
4495                     if (was)
4496                         SET_SSC_EOS(data->start_class);
4497                 }
4498                 if (data) {
4499                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4500                         pars++;
4501                     if (data_fake.flags & SF_HAS_EVAL)
4502                         data->flags |= SF_HAS_EVAL;
4503                     data->whilem_c = data_fake.whilem_c;
4504                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
4505                         if (RExC_rx->minlen<*minnextp)
4506                             RExC_rx->minlen=*minnextp;
4507                         SCAN_COMMIT(pRExC_state, &data_fake, minnextp);
4508                         SvREFCNT_dec_NN(data_fake.last_found);
4509                         
4510                         if ( data_fake.minlen_fixed != minlenp ) 
4511                         {
4512                             data->offset_fixed= data_fake.offset_fixed;
4513                             data->minlen_fixed= data_fake.minlen_fixed;
4514                             data->lookbehind_fixed+= scan->flags;
4515                         }
4516                         if ( data_fake.minlen_float != minlenp )
4517                         {
4518                             data->minlen_float= data_fake.minlen_float;
4519                             data->offset_float_min=data_fake.offset_float_min;
4520                             data->offset_float_max=data_fake.offset_float_max;
4521                             data->lookbehind_float+= scan->flags;
4522                         }
4523                     }
4524                 }
4525             }
4526 #endif
4527         }
4528         else if (OP(scan) == OPEN) {
4529             if (stopparen != (I32)ARG(scan))
4530                 pars++;
4531         }
4532         else if (OP(scan) == CLOSE) {
4533             if (stopparen == (I32)ARG(scan)) {
4534                 break;
4535             }
4536             if ((I32)ARG(scan) == is_par) {
4537                 next = regnext(scan);
4538
4539                 if ( next && (OP(next) != WHILEM) && next < last)
4540                     is_par = 0;         /* Disable optimization */
4541             }
4542             if (data)
4543                 *(data->last_closep) = ARG(scan);
4544         }
4545         else if (OP(scan) == EVAL) {
4546                 if (data)
4547                     data->flags |= SF_HAS_EVAL;
4548         }
4549         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
4550             if (flags & SCF_DO_SUBSTR) {
4551                 SCAN_COMMIT(pRExC_state,data,minlenp);
4552                 flags &= ~SCF_DO_SUBSTR;
4553             }
4554             if (data && OP(scan)==ACCEPT) {
4555                 data->flags |= SCF_SEEN_ACCEPT;
4556                 if (stopmin > min)
4557                     stopmin = min;
4558             }
4559         }
4560         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
4561         {
4562                 if (flags & SCF_DO_SUBSTR) {
4563                     SCAN_COMMIT(pRExC_state,data,minlenp);
4564                     data->longest = &(data->longest_float);
4565                 }
4566                 is_inf = is_inf_internal = 1;
4567                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4568                     cl_anything(pRExC_state, data->start_class);
4569                 flags &= ~SCF_DO_STCLASS;
4570         }
4571         else if (OP(scan) == GPOS) {
4572             if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) &&
4573                 !(delta || is_inf || (data && data->pos_delta))) 
4574             {
4575                 if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR))
4576                     RExC_rx->extflags |= RXf_ANCH_GPOS;
4577                 if (RExC_rx->gofs < (U32)min)
4578                     RExC_rx->gofs = min;
4579             } else {
4580                 RExC_rx->extflags |= RXf_GPOS_FLOAT;
4581                 RExC_rx->gofs = 0;
4582             }       
4583         }
4584 #ifdef TRIE_STUDY_OPT
4585 #ifdef FULL_TRIE_STUDY
4586         else if (PL_regkind[OP(scan)] == TRIE) {
4587             /* NOTE - There is similar code to this block above for handling
4588                BRANCH nodes on the initial study.  If you change stuff here
4589                check there too. */
4590             regnode *trie_node= scan;
4591             regnode *tail= regnext(scan);
4592             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4593             I32 max1 = 0, min1 = I32_MAX;
4594             struct regnode_charclass_class accum;
4595
4596             if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
4597                 SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
4598             if (flags & SCF_DO_STCLASS)
4599                 cl_init_zero(pRExC_state, &accum);
4600                 
4601             if (!trie->jump) {
4602                 min1= trie->minlen;
4603                 max1= trie->maxlen;
4604             } else {
4605                 const regnode *nextbranch= NULL;
4606                 U32 word;
4607                 
4608                 for ( word=1 ; word <= trie->wordcount ; word++) 
4609                 {
4610                     I32 deltanext=0, minnext=0, f = 0, fake;
4611                     struct regnode_charclass_class this_class;
4612                     
4613                     data_fake.flags = 0;
4614                     if (data) {
4615                         data_fake.whilem_c = data->whilem_c;
4616                         data_fake.last_closep = data->last_closep;
4617                     }
4618                     else
4619                         data_fake.last_closep = &fake;
4620                     data_fake.pos_delta = delta;
4621                     if (flags & SCF_DO_STCLASS) {
4622                         cl_init(pRExC_state, &this_class);
4623                         data_fake.start_class = &this_class;
4624                         f = SCF_DO_STCLASS_AND;
4625                     }
4626                     if (flags & SCF_WHILEM_VISITED_POS)
4627                         f |= SCF_WHILEM_VISITED_POS;
4628     
4629                     if (trie->jump[word]) {
4630                         if (!nextbranch)
4631                             nextbranch = trie_node + trie->jump[0];
4632                         scan= trie_node + trie->jump[word];
4633                         /* We go from the jump point to the branch that follows
4634                            it. Note this means we need the vestigal unused branches
4635                            even though they arent otherwise used.
4636                          */
4637                         minnext = study_chunk(pRExC_state, &scan, minlenp, 
4638                             &deltanext, (regnode *)nextbranch, &data_fake, 
4639                             stopparen, recursed, NULL, f,depth+1);
4640                     }
4641                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
4642                         nextbranch= regnext((regnode*)nextbranch);
4643                     
4644                     if (min1 > (I32)(minnext + trie->minlen))
4645                         min1 = minnext + trie->minlen;
4646                     if (deltanext == I32_MAX) {
4647                         is_inf = is_inf_internal = 1;
4648                         max1 = I32_MAX;
4649                     } else if (max1 < (I32)(minnext + deltanext + trie->maxlen))
4650                         max1 = minnext + deltanext + trie->maxlen;
4651                     
4652                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4653                         pars++;
4654                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4655                         if ( stopmin > min + min1) 
4656                             stopmin = min + min1;
4657                         flags &= ~SCF_DO_SUBSTR;
4658                         if (data)
4659                             data->flags |= SCF_SEEN_ACCEPT;
4660                     }
4661                     if (data) {
4662                         if (data_fake.flags & SF_HAS_EVAL)
4663                             data->flags |= SF_HAS_EVAL;
4664                         data->whilem_c = data_fake.whilem_c;
4665                     }
4666                     if (flags & SCF_DO_STCLASS)
4667                         cl_or(pRExC_state, &accum, &this_class);
4668                 }
4669             }
4670             if (flags & SCF_DO_SUBSTR) {
4671                 data->pos_min += min1;
4672                 data->pos_delta += max1 - min1;
4673                 if (max1 != min1 || is_inf)
4674                     data->longest = &(data->longest_float);
4675             }
4676             min += min1;
4677             delta += max1 - min1;
4678             if (flags & SCF_DO_STCLASS_OR) {
4679                 cl_or(pRExC_state, data->start_class, &accum);
4680                 if (min1) {
4681                     cl_and(data->start_class, and_withp);
4682                     flags &= ~SCF_DO_STCLASS;
4683                 }
4684             }
4685             else if (flags & SCF_DO_STCLASS_AND) {
4686                 if (min1) {
4687                     cl_and(data->start_class, &accum);
4688                     flags &= ~SCF_DO_STCLASS;
4689                 }
4690                 else {
4691                     /* Switch to OR mode: cache the old value of
4692                      * data->start_class */
4693                     INIT_AND_WITHP;
4694                     StructCopy(data->start_class, and_withp,
4695                                struct regnode_charclass_class);
4696                     flags &= ~SCF_DO_STCLASS_AND;
4697                     StructCopy(&accum, data->start_class,
4698                                struct regnode_charclass_class);
4699                     flags |= SCF_DO_STCLASS_OR;
4700                     SET_SSC_EOS(data->start_class);
4701                 }
4702             }
4703             scan= tail;
4704             continue;
4705         }
4706 #else
4707         else if (PL_regkind[OP(scan)] == TRIE) {
4708             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4709             U8*bang=NULL;
4710             
4711             min += trie->minlen;
4712             delta += (trie->maxlen - trie->minlen);
4713             flags &= ~SCF_DO_STCLASS; /* xxx */
4714             if (flags & SCF_DO_SUBSTR) {
4715                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
4716                 data->pos_min += trie->minlen;
4717                 data->pos_delta += (trie->maxlen - trie->minlen);
4718                 if (trie->maxlen != trie->minlen)
4719                     data->longest = &(data->longest_float);
4720             }
4721             if (trie->jump) /* no more substrings -- for now /grr*/
4722                 flags &= ~SCF_DO_SUBSTR; 
4723         }
4724 #endif /* old or new */
4725 #endif /* TRIE_STUDY_OPT */
4726
4727         /* Else: zero-length, ignore. */
4728         scan = regnext(scan);
4729     }
4730     if (frame) {
4731         last = frame->last;
4732         scan = frame->next;
4733         stopparen = frame->stop;
4734         frame = frame->prev;
4735         goto fake_study_recurse;
4736     }
4737
4738   finish:
4739     assert(!frame);
4740     DEBUG_STUDYDATA("pre-fin:",data,depth);
4741
4742     *scanp = scan;
4743     *deltap = is_inf_internal ? I32_MAX : delta;
4744     if (flags & SCF_DO_SUBSTR && is_inf)
4745         data->pos_delta = I32_MAX - data->pos_min;
4746     if (is_par > (I32)U8_MAX)
4747         is_par = 0;
4748     if (is_par && pars==1 && data) {
4749         data->flags |= SF_IN_PAR;
4750         data->flags &= ~SF_HAS_PAR;
4751     }
4752     else if (pars && data) {
4753         data->flags |= SF_HAS_PAR;
4754         data->flags &= ~SF_IN_PAR;
4755     }
4756     if (flags & SCF_DO_STCLASS_OR)
4757         cl_and(data->start_class, and_withp);
4758     if (flags & SCF_TRIE_RESTUDY)
4759         data->flags |=  SCF_TRIE_RESTUDY;
4760     
4761     DEBUG_STUDYDATA("post-fin:",data,depth);
4762     
4763     return min < stopmin ? min : stopmin;
4764 }
4765
4766 STATIC U32
4767 S_add_data(RExC_state_t *pRExC_state, U32 n, const char *s)
4768 {
4769     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
4770
4771     PERL_ARGS_ASSERT_ADD_DATA;
4772
4773     Renewc(RExC_rxi->data,
4774            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
4775            char, struct reg_data);
4776     if(count)
4777         Renew(RExC_rxi->data->what, count + n, U8);
4778     else
4779         Newx(RExC_rxi->data->what, n, U8);
4780     RExC_rxi->data->count = count + n;
4781     Copy(s, RExC_rxi->data->what + count, n, U8);
4782     return count;
4783 }
4784
4785 /*XXX: todo make this not included in a non debugging perl */
4786 #ifndef PERL_IN_XSUB_RE
4787 void
4788 Perl_reginitcolors(pTHX)
4789 {
4790     dVAR;
4791     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
4792     if (s) {
4793         char *t = savepv(s);
4794         int i = 0;
4795         PL_colors[0] = t;
4796         while (++i < 6) {
4797             t = strchr(t, '\t');
4798             if (t) {
4799                 *t = '\0';
4800                 PL_colors[i] = ++t;
4801             }
4802             else
4803                 PL_colors[i] = t = (char *)"";
4804         }
4805     } else {
4806         int i = 0;
4807         while (i < 6)
4808             PL_colors[i++] = (char *)"";
4809     }
4810     PL_colorset = 1;
4811 }
4812 #endif
4813
4814
4815 #ifdef TRIE_STUDY_OPT
4816 #define CHECK_RESTUDY_GOTO_butfirst(dOsomething)            \
4817     STMT_START {                                            \
4818         if (                                                \
4819               (data.flags & SCF_TRIE_RESTUDY)               \
4820               && ! restudied++                              \
4821         ) {                                                 \
4822             dOsomething;                                    \
4823             goto reStudy;                                   \
4824         }                                                   \
4825     } STMT_END
4826 #else
4827 #define CHECK_RESTUDY_GOTO_butfirst
4828 #endif        
4829
4830 /*
4831  * pregcomp - compile a regular expression into internal code
4832  *
4833  * Decides which engine's compiler to call based on the hint currently in
4834  * scope
4835  */
4836
4837 #ifndef PERL_IN_XSUB_RE 
4838
4839 /* return the currently in-scope regex engine (or the default if none)  */
4840
4841 regexp_engine const *
4842 Perl_current_re_engine(pTHX)
4843 {
4844     dVAR;
4845
4846     if (IN_PERL_COMPILETIME) {
4847         HV * const table = GvHV(PL_hintgv);
4848         SV **ptr;
4849
4850         if (!table)
4851             return &PL_core_reg_engine;
4852         ptr = hv_fetchs(table, "regcomp", FALSE);
4853         if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
4854             return &PL_core_reg_engine;
4855         return INT2PTR(regexp_engine*,SvIV(*ptr));
4856     }
4857     else {
4858         SV *ptr;
4859         if (!PL_curcop->cop_hints_hash)
4860             return &PL_core_reg_engine;
4861         ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
4862         if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
4863             return &PL_core_reg_engine;
4864         return INT2PTR(regexp_engine*,SvIV(ptr));
4865     }
4866 }
4867
4868
4869 REGEXP *
4870 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
4871 {
4872     dVAR;
4873     regexp_engine const *eng = current_re_engine();
4874     GET_RE_DEBUG_FLAGS_DECL;
4875
4876     PERL_ARGS_ASSERT_PREGCOMP;
4877
4878     /* Dispatch a request to compile a regexp to correct regexp engine. */
4879     DEBUG_COMPILE_r({
4880         PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
4881                         PTR2UV(eng));
4882     });
4883     return CALLREGCOMP_ENG(eng, pattern, flags);
4884 }
4885 #endif
4886
4887 /* public(ish) entry point for the perl core's own regex compiling code.
4888  * It's actually a wrapper for Perl_re_op_compile that only takes an SV
4889  * pattern rather than a list of OPs, and uses the internal engine rather
4890  * than the current one */
4891
4892 REGEXP *
4893 Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
4894 {
4895     SV *pat = pattern; /* defeat constness! */
4896     PERL_ARGS_ASSERT_RE_COMPILE;
4897     return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
4898 #ifdef PERL_IN_XSUB_RE
4899                                 &my_reg_engine,
4900 #else
4901                                 &PL_core_reg_engine,
4902 #endif
4903                                 NULL, NULL, rx_flags, 0);
4904 }
4905
4906
4907 /* upgrade pattern pat_p of length plen_p to UTF8, and if there are code
4908  * blocks, recalculate the indices. Update pat_p and plen_p in-place to
4909  * point to the realloced string and length.
4910  *
4911  * This is essentially a copy of Perl_bytes_to_utf8() with the code index
4912  * stuff added */
4913
4914 static void
4915 S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state,
4916                     char **pat_p, STRLEN *plen_p, int num_code_blocks)
4917 {
4918     U8 *const src = (U8*)*pat_p;
4919     U8 *dst;
4920     int n=0;
4921     STRLEN s = 0, d = 0;
4922     bool do_end = 0;
4923     GET_RE_DEBUG_FLAGS_DECL;
4924
4925     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
4926         "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
4927
4928     Newx(dst, *plen_p * 2 + 1, U8);
4929
4930     while (s < *plen_p) {
4931         const UV uv = NATIVE_TO_ASCII(src[s]);
4932         if (UNI_IS_INVARIANT(uv))
4933             dst[d]   = (U8)UTF_TO_NATIVE(uv);
4934         else {
4935             dst[d++] = (U8)UTF8_EIGHT_BIT_HI(uv);
4936             dst[d]   = (U8)UTF8_EIGHT_BIT_LO(uv);
4937         }
4938         if (n < num_code_blocks) {
4939             if (!do_end && pRExC_state->code_blocks[n].start == s) {
4940                 pRExC_state->code_blocks[n].start = d;
4941                 assert(dst[d] == '(');
4942                 do_end = 1;
4943             }
4944             else if (do_end && pRExC_state->code_blocks[n].end == s) {
4945                 pRExC_state->code_blocks[n].end = d;
4946                 assert(dst[d] == ')');
4947                 do_end = 0;
4948                 n++;
4949             }
4950         }
4951         s++;
4952         d++;
4953     }
4954     dst[d] = '\0';
4955     *plen_p = d;
4956     *pat_p = (char*) dst;
4957     SAVEFREEPV(*pat_p);
4958     RExC_orig_utf8 = RExC_utf8 = 1;
4959 }
4960
4961
4962
4963 /* S_concat_pat(): concatenate a list of args to the pattern string pat,
4964  * while recording any code block indices, and handling overloading,
4965  * nested qr// objects etc.  If pat is null, it will allocate a new
4966  * string, or just return the first arg, if there's only one.
4967  *
4968  * Returns the malloced/updated pat.
4969  * patternp and pat_count is the array of SVs to be concatted;
4970  * oplist is the optional list of ops that generated the SVs;
4971  * recompile_p is a pointer to a boolean that will be set if
4972  *   the regex will need to be recompiled.
4973  * delim, if non-null is an SV that will be inserted between each element
4974  */
4975
4976 static SV*
4977 S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
4978                 SV *pat, SV ** const patternp, int pat_count,
4979                 OP *oplist, bool *recompile_p, SV *delim)
4980 {
4981     SV **svp;
4982     int n = 0;
4983     bool use_delim = FALSE;
4984     bool alloced = FALSE;
4985
4986     /* if we know we have at least two args, create an empty string,
4987      * then concatenate args to that. For no args, return an empty string */
4988     if (!pat && pat_count != 1) {
4989         pat = newSVpvn("", 0);
4990         SAVEFREESV(pat);
4991         alloced = TRUE;
4992     }
4993
4994     for (svp = patternp; svp < patternp + pat_count; svp++) {
4995         SV *sv;
4996         SV *rx  = NULL;
4997         STRLEN orig_patlen = 0;
4998         bool code = 0;
4999         SV *msv = use_delim ? delim : *svp;
5000
5001         /* if we've got a delimiter, we go round the loop twice for each
5002          * svp slot (except the last), using the delimiter the second
5003          * time round */
5004         if (use_delim) {
5005             svp--;
5006             use_delim = FALSE;
5007         }
5008         else if (delim)
5009             use_delim = TRUE;
5010
5011         if (SvTYPE(msv) == SVt_PVAV) {
5012             /* we've encountered an interpolated array within
5013              * the pattern, e.g. /...@a..../. Expand the list of elements,
5014              * then recursively append elements.
5015              * The code in this block is based on S_pushav() */
5016
5017             AV *const av = (AV*)msv;
5018             const I32 maxarg = AvFILL(av) + 1;
5019             SV **array;
5020
5021             if (oplist) {
5022                 assert(oplist->op_type == OP_PADAV
5023                     || oplist->op_type == OP_RV2AV); 
5024                 oplist = oplist->op_sibling;;
5025             }
5026
5027             if (SvRMAGICAL(av)) {
5028                 U32 i;
5029
5030                 Newx(array, maxarg, SV*);
5031                 SAVEFREEPV(array);
5032                 for (i=0; i < (U32)maxarg; i++) {
5033                     SV ** const svp = av_fetch(av, i, FALSE);
5034                     array[i] = svp ? *svp : &PL_sv_undef;
5035                 }
5036             }
5037             else
5038                 array = AvARRAY(av);
5039
5040             pat = S_concat_pat(aTHX_ pRExC_state, pat,
5041                                 array, maxarg, NULL, recompile_p,
5042                                 /* $" */
5043                                 GvSV((gv_fetchpvs("\"", GV_ADDMULTI, SVt_PV))));
5044
5045             continue;
5046         }
5047
5048
5049         /* we make the assumption here that each op in the list of
5050          * op_siblings maps to one SV pushed onto the stack,
5051          * except for code blocks, with have both an OP_NULL and
5052          * and OP_CONST.
5053          * This allows us to match up the list of SVs against the
5054          * list of OPs to find the next code block.
5055          *
5056          * Note that       PUSHMARK PADSV PADSV ..
5057          * is optimised to
5058          *                 PADRANGE PADSV  PADSV  ..
5059          * so the alignment still works. */
5060
5061         if (oplist) {
5062             if (oplist->op_type == OP_NULL
5063                 && (oplist->op_flags & OPf_SPECIAL))
5064             {
5065                 assert(n < pRExC_state->num_code_blocks);
5066                 pRExC_state->code_blocks[n].start = pat ? SvCUR(pat) : 0;
5067                 pRExC_state->code_blocks[n].block = oplist;
5068                 pRExC_state->code_blocks[n].src_regex = NULL;
5069                 n++;
5070                 code = 1;
5071                 oplist = oplist->op_sibling; /* skip CONST */
5072                 assert(oplist);
5073             }
5074             oplist = oplist->op_sibling;;
5075         }
5076
5077         /* apply magic and QR overloading to arg */
5078
5079         SvGETMAGIC(msv);
5080         if (SvROK(msv) && SvAMAGIC(msv)) {
5081             SV *sv = AMG_CALLunary(msv, regexp_amg);
5082             if (sv) {
5083                 if (SvROK(sv))
5084                     sv = SvRV(sv);
5085                 if (SvTYPE(sv) != SVt_REGEXP)
5086                     Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
5087                 msv = sv;
5088             }
5089         }
5090
5091         /* try concatenation overload ... */
5092         if (pat && (SvAMAGIC(pat) || SvAMAGIC(msv)) &&
5093                 (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
5094         {
5095             sv_setsv(pat, sv);
5096             /* overloading involved: all bets are off over literal
5097              * code. Pretend we haven't seen it */
5098             pRExC_state->num_code_blocks -= n;
5099             n = 0;
5100         }
5101         else  {
5102             /* ... or failing that, try "" overload */
5103             while (SvAMAGIC(msv)
5104                     && (sv = AMG_CALLunary(msv, string_amg))
5105                     && sv != msv
5106                     &&  !(   SvROK(msv)
5107                           && SvROK(sv)
5108                           && SvRV(msv) == SvRV(sv))
5109             ) {
5110                 msv = sv;
5111                 SvGETMAGIC(msv);
5112             }
5113             if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
5114                 msv = SvRV(msv);
5115
5116             if (pat) {
5117                 /* this is a partially unrolled
5118                  *     sv_catsv_nomg(pat, msv);
5119                  * that allows us to adjust code block indices if
5120                  * needed */
5121                 STRLEN dlen;
5122                 char *dst = SvPV_force_nomg(pat, dlen);
5123                 orig_patlen = dlen;
5124                 if (SvUTF8(msv) && !SvUTF8(pat)) {
5125                     S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &dst, &dlen, n);
5126                     sv_setpvn(pat, dst, dlen);
5127                     SvUTF8_on(pat);
5128                 }
5129                 sv_catsv_nomg(pat, msv);
5130                 rx = msv;
5131             }
5132             else
5133                 pat = msv;
5134
5135             if (code)
5136                 pRExC_state->code_blocks[n-1].end = SvCUR(pat)-1;
5137         }
5138
5139         /* extract any code blocks within any embedded qr//'s */
5140         if (rx && SvTYPE(rx) == SVt_REGEXP
5141             && RX_ENGINE((REGEXP*)rx)->op_comp)
5142         {
5143
5144             RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
5145             if (ri->num_code_blocks) {
5146                 int i;
5147                 /* the presence of an embedded qr// with code means
5148                  * we should always recompile: the text of the
5149                  * qr// may not have changed, but it may be a
5150                  * different closure than last time */
5151                 *recompile_p = 1;
5152                 Renew(pRExC_state->code_blocks,
5153                     pRExC_state->num_code_blocks + ri->num_code_blocks,
5154                     struct reg_code_block);
5155                 pRExC_state->num_code_blocks += ri->num_code_blocks;
5156
5157                 for (i=0; i < ri->num_code_blocks; i++) {
5158                     struct reg_code_block *src, *dst;
5159                     STRLEN offset =  orig_patlen
5160                         + ReANY((REGEXP *)rx)->pre_prefix;
5161                     assert(n < pRExC_state->num_code_blocks);
5162                     src = &ri->code_blocks[i];
5163                     dst = &pRExC_state->code_blocks[n];
5164                     dst->start      = src->start + offset;
5165                     dst->end        = src->end   + offset;
5166                     dst->block      = src->block;
5167                     dst->src_regex  = (REGEXP*) SvREFCNT_inc( (SV*)
5168                                             src->src_regex
5169                                                 ? src->src_regex
5170                                                 : (REGEXP*)rx);
5171                     n++;
5172                 }
5173             }
5174         }
5175     }
5176     /* avoid calling magic multiple times on a single element e.g. =~ $qr */
5177     if (alloced)
5178         SvSETMAGIC(pat);
5179
5180     return pat;
5181 }
5182
5183
5184
5185 /* see if there are any run-time code blocks in the pattern.
5186  * False positives are allowed */
5187
5188 static bool
5189 S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
5190                     char *pat, STRLEN plen)
5191 {
5192     int n = 0;
5193     STRLEN s;
5194
5195     for (s = 0; s < plen; s++) {
5196         if (n < pRExC_state->num_code_blocks
5197             && s == pRExC_state->code_blocks[n].start)
5198         {
5199             s = pRExC_state->code_blocks[n].end;
5200             n++;
5201             continue;
5202         }
5203         /* TODO ideally should handle [..], (#..), /#.../x to reduce false
5204          * positives here */
5205         if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' &&
5206             (pat[s+2] == '{'
5207                 || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{'))
5208         )
5209             return 1;
5210     }
5211     return 0;
5212 }
5213
5214 /* Handle run-time code blocks. We will already have compiled any direct
5215  * or indirect literal code blocks. Now, take the pattern 'pat' and make a
5216  * copy of it, but with any literal code blocks blanked out and
5217  * appropriate chars escaped; then feed it into
5218  *
5219  *    eval "qr'modified_pattern'"
5220  *
5221  * For example,
5222  *
5223  *       a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
5224  *
5225  * becomes
5226  *
5227  *    qr'a\\bc_______________________def\'ghi\\\\jkl(?{"this is runtime"})mno'
5228  *
5229  * After eval_sv()-ing that, grab any new code blocks from the returned qr
5230  * and merge them with any code blocks of the original regexp.
5231  *
5232  * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
5233  * instead, just save the qr and return FALSE; this tells our caller that
5234  * the original pattern needs upgrading to utf8.
5235  */
5236
5237 static bool
5238 S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
5239     char *pat, STRLEN plen)
5240 {
5241     SV *qr;
5242
5243     GET_RE_DEBUG_FLAGS_DECL;
5244
5245     if (pRExC_state->runtime_code_qr) {
5246         /* this is the second time we've been called; this should
5247          * only happen if the main pattern got upgraded to utf8
5248          * during compilation; re-use the qr we compiled first time
5249          * round (which should be utf8 too)
5250          */
5251         qr = pRExC_state->runtime_code_qr;
5252         pRExC_state->runtime_code_qr = NULL;
5253         assert(RExC_utf8 && SvUTF8(qr));
5254     }
5255     else {
5256         int n = 0;
5257         STRLEN s;
5258         char *p, *newpat;
5259         int newlen = plen + 6; /* allow for "qr''x\0" extra chars */
5260         SV *sv, *qr_ref;
5261         dSP;
5262
5263         /* determine how many extra chars we need for ' and \ escaping */
5264         for (s = 0; s < plen; s++) {
5265             if (pat[s] == '\'' || pat[s] == '\\')
5266                 newlen++;
5267         }
5268
5269         Newx(newpat, newlen, char);
5270         p = newpat;
5271         *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
5272
5273         for (s = 0; s < plen; s++) {
5274             if (n < pRExC_state->num_code_blocks
5275                 && s == pRExC_state->code_blocks[n].start)
5276             {
5277                 /* blank out literal code block */
5278                 assert(pat[s] == '(');
5279                 while (s <= pRExC_state->code_blocks[n].end) {
5280                     *p++ = '_';
5281                     s++;
5282                 }
5283                 s--;
5284                 n++;
5285                 continue;
5286             }
5287             if (pat[s] == '\'' || pat[s] == '\\')
5288                 *p++ = '\\';
5289             *p++ = pat[s];
5290         }
5291         *p++ = '\'';
5292         if (pRExC_state->pm_flags & RXf_PMf_EXTENDED)
5293             *p++ = 'x';
5294         *p++ = '\0';
5295         DEBUG_COMPILE_r({
5296             PerlIO_printf(Perl_debug_log,
5297                 "%sre-parsing pattern for runtime code:%s %s\n",
5298                 PL_colors[4],PL_colors[5],newpat);
5299         });
5300
5301         sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
5302         Safefree(newpat);
5303
5304         ENTER;
5305         SAVETMPS;
5306         save_re_context();
5307         PUSHSTACKi(PERLSI_REQUIRE);
5308         /* G_RE_REPARSING causes the toker to collapse \\ into \ when
5309          * parsing qr''; normally only q'' does this. It also alters
5310          * hints handling */
5311         eval_sv(sv, G_SCALAR|G_RE_REPARSING);
5312         SvREFCNT_dec_NN(sv);
5313         SPAGAIN;
5314         qr_ref = POPs;
5315         PUTBACK;
5316         {
5317             SV * const errsv = ERRSV;
5318             if (SvTRUE_NN(errsv))
5319             {
5320                 Safefree(pRExC_state->code_blocks);
5321                 /* use croak_sv ? */
5322                 Perl_croak_nocontext("%s", SvPV_nolen_const(errsv));
5323             }
5324         }
5325         assert(SvROK(qr_ref));
5326         qr = SvRV(qr_ref);
5327         assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
5328         /* the leaving below frees the tmp qr_ref.
5329          * Give qr a life of its own */
5330         SvREFCNT_inc(qr);
5331         POPSTACK;
5332         FREETMPS;
5333         LEAVE;
5334
5335     }
5336
5337     if (!RExC_utf8 && SvUTF8(qr)) {
5338         /* first time through; the pattern got upgraded; save the
5339          * qr for the next time through */
5340         assert(!pRExC_state->runtime_code_qr);
5341         pRExC_state->runtime_code_qr = qr;
5342         return 0;
5343     }
5344
5345
5346     /* extract any code blocks within the returned qr//  */
5347
5348
5349     /* merge the main (r1) and run-time (r2) code blocks into one */
5350     {
5351         RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
5352         struct reg_code_block *new_block, *dst;
5353         RExC_state_t * const r1 = pRExC_state; /* convenient alias */
5354         int i1 = 0, i2 = 0;
5355
5356         if (!r2->num_code_blocks) /* we guessed wrong */
5357         {
5358             SvREFCNT_dec_NN(qr);
5359             return 1;
5360         }
5361
5362         Newx(new_block,
5363             r1->num_code_blocks + r2->num_code_blocks,
5364             struct reg_code_block);
5365         dst = new_block;
5366
5367         while (    i1 < r1->num_code_blocks
5368                 || i2 < r2->num_code_blocks)
5369         {
5370             struct reg_code_block *src;
5371             bool is_qr = 0;
5372
5373             if (i1 == r1->num_code_blocks) {
5374                 src = &r2->code_blocks[i2++];
5375                 is_qr = 1;
5376             }
5377             else if (i2 == r2->num_code_blocks)
5378                 src = &r1->code_blocks[i1++];
5379             else if (  r1->code_blocks[i1].start
5380                      < r2->code_blocks[i2].start)
5381             {
5382                 src = &r1->code_blocks[i1++];
5383                 assert(src->end < r2->code_blocks[i2].start);
5384             }
5385             else {
5386                 assert(  r1->code_blocks[i1].start
5387                        > r2->code_blocks[i2].start);
5388                 src = &r2->code_blocks[i2++];
5389                 is_qr = 1;
5390                 assert(src->end < r1->code_blocks[i1].start);
5391             }
5392
5393             assert(pat[src->start] == '(');
5394             assert(pat[src->end]   == ')');
5395             dst->start      = src->start;
5396             dst->end        = src->end;
5397             dst->block      = src->block;
5398             dst->src_regex  = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
5399                                     : src->src_regex;
5400             dst++;
5401         }
5402         r1->num_code_blocks += r2->num_code_blocks;
5403         Safefree(r1->code_blocks);
5404         r1->code_blocks = new_block;
5405     }
5406
5407     SvREFCNT_dec_NN(qr);
5408     return 1;
5409 }
5410
5411
5412 STATIC bool
5413 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)
5414 {
5415     /* This is the common code for setting up the floating and fixed length
5416      * string data extracted from Perl_re_op_compile() below.  Returns a boolean
5417      * as to whether succeeded or not */
5418
5419     I32 t,ml;
5420
5421     if (! (longest_length
5422            || (eol /* Can't have SEOL and MULTI */
5423                && (! meol || (RExC_flags & RXf_PMf_MULTILINE)))
5424           )
5425             /* See comments for join_exact for why REG_SEEN_EXACTF_SHARP_S */
5426         || (RExC_seen & REG_SEEN_EXACTF_SHARP_S))
5427     {
5428         return FALSE;
5429     }
5430
5431     /* copy the information about the longest from the reg_scan_data
5432         over to the program. */
5433     if (SvUTF8(sv_longest)) {
5434         *rx_utf8 = sv_longest;
5435         *rx_substr = NULL;
5436     } else {
5437         *rx_substr = sv_longest;
5438         *rx_utf8 = NULL;
5439     }
5440     /* end_shift is how many chars that must be matched that
5441         follow this item. We calculate it ahead of time as once the
5442         lookbehind offset is added in we lose the ability to correctly
5443         calculate it.*/
5444     ml = minlen ? *(minlen) : (I32)longest_length;
5445     *rx_end_shift = ml - offset
5446         - longest_length + (SvTAIL(sv_longest) != 0)
5447         + lookbehind;
5448
5449     t = (eol/* Can't have SEOL and MULTI */
5450          && (! meol || (RExC_flags & RXf_PMf_MULTILINE)));
5451     fbm_compile(sv_longest, t ? FBMcf_TAIL : 0);
5452
5453     return TRUE;
5454 }
5455
5456 /*
5457  * Perl_re_op_compile - the perl internal RE engine's function to compile a
5458  * regular expression into internal code.
5459  * The pattern may be passed either as:
5460  *    a list of SVs (patternp plus pat_count)
5461  *    a list of OPs (expr)
5462  * If both are passed, the SV list is used, but the OP list indicates
5463  * which SVs are actually pre-compiled code blocks
5464  *
5465  * The SVs in the list have magic and qr overloading applied to them (and
5466  * the list may be modified in-place with replacement SVs in the latter
5467  * case).
5468  *
5469  * If the pattern hasn't changed from old_re, then old_re will be
5470  * returned.
5471  *
5472  * eng is the current engine. If that engine has an op_comp method, then
5473  * handle directly (i.e. we assume that op_comp was us); otherwise, just
5474  * do the initial concatenation of arguments and pass on to the external
5475  * engine.
5476  *
5477  * If is_bare_re is not null, set it to a boolean indicating whether the
5478  * arg list reduced (after overloading) to a single bare regex which has
5479  * been returned (i.e. /$qr/).
5480  *
5481  * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
5482  *
5483  * pm_flags contains the PMf_* flags, typically based on those from the
5484  * pm_flags field of the related PMOP. Currently we're only interested in
5485  * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL.
5486  *
5487  * We can't allocate space until we know how big the compiled form will be,
5488  * but we can't compile it (and thus know how big it is) until we've got a
5489  * place to put the code.  So we cheat:  we compile it twice, once with code
5490  * generation turned off and size counting turned on, and once "for real".
5491  * This also means that we don't allocate space until we are sure that the
5492  * thing really will compile successfully, and we never have to move the
5493  * code and thus invalidate pointers into it.  (Note that it has to be in
5494  * one piece because free() must be able to free it all.) [NB: not true in perl]
5495  *
5496  * Beware that the optimization-preparation code in here knows about some
5497  * of the structure of the compiled regexp.  [I'll say.]
5498  */
5499
5500 REGEXP *
5501 Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
5502                     OP *expr, const regexp_engine* eng, REGEXP *old_re,
5503                      bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags)
5504 {
5505     dVAR;
5506     REGEXP *rx;
5507     struct regexp *r;
5508     regexp_internal *ri;
5509     STRLEN plen;
5510     char *exp;
5511     regnode *scan;
5512     I32 flags;
5513     I32 minlen = 0;
5514     U32 rx_flags;
5515     SV *pat;
5516     SV *code_blocksv = NULL;
5517     SV** new_patternp = patternp;
5518
5519     /* these are all flags - maybe they should be turned
5520      * into a single int with different bit masks */
5521     I32 sawlookahead = 0;
5522     I32 sawplus = 0;
5523     I32 sawopen = 0;
5524     I32 sawminmod = 0;
5525
5526     regex_charset initial_charset = get_regex_charset(orig_rx_flags);
5527     bool recompile = 0;
5528     bool runtime_code = 0;
5529     scan_data_t data;
5530     RExC_state_t RExC_state;
5531     RExC_state_t * const pRExC_state = &RExC_state;
5532 #ifdef TRIE_STUDY_OPT    
5533     int restudied = 0;
5534     RExC_state_t copyRExC_state;
5535 #endif    
5536     GET_RE_DEBUG_FLAGS_DECL;
5537
5538     PERL_ARGS_ASSERT_RE_OP_COMPILE;
5539
5540     DEBUG_r(if (!PL_colorset) reginitcolors());
5541
5542 #ifndef PERL_IN_XSUB_RE
5543     /* Initialize these here instead of as-needed, as is quick and avoids
5544      * having to test them each time otherwise */
5545     if (! PL_AboveLatin1) {
5546         PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
5547         PL_ASCII = _new_invlist_C_array(ASCII_invlist);
5548         PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
5549
5550         PL_L1Posix_ptrs[_CC_ALPHANUMERIC]
5551                                 = _new_invlist_C_array(L1PosixAlnum_invlist);
5552         PL_Posix_ptrs[_CC_ALPHANUMERIC]
5553                                 = _new_invlist_C_array(PosixAlnum_invlist);
5554
5555         PL_L1Posix_ptrs[_CC_ALPHA]
5556                                 = _new_invlist_C_array(L1PosixAlpha_invlist);
5557         PL_Posix_ptrs[_CC_ALPHA] = _new_invlist_C_array(PosixAlpha_invlist);
5558
5559         PL_Posix_ptrs[_CC_BLANK] = _new_invlist_C_array(PosixBlank_invlist);
5560         PL_XPosix_ptrs[_CC_BLANK] = _new_invlist_C_array(XPosixBlank_invlist);
5561
5562         /* Cased is the same as Alpha in the ASCII range */
5563         PL_L1Posix_ptrs[_CC_CASED] =  _new_invlist_C_array(L1Cased_invlist);
5564         PL_Posix_ptrs[_CC_CASED] =  _new_invlist_C_array(PosixAlpha_invlist);
5565
5566         PL_Posix_ptrs[_CC_CNTRL] = _new_invlist_C_array(PosixCntrl_invlist);
5567         PL_XPosix_ptrs[_CC_CNTRL] = _new_invlist_C_array(XPosixCntrl_invlist);
5568
5569         PL_Posix_ptrs[_CC_DIGIT] = _new_invlist_C_array(PosixDigit_invlist);
5570         PL_L1Posix_ptrs[_CC_DIGIT] = _new_invlist_C_array(PosixDigit_invlist);
5571
5572         PL_L1Posix_ptrs[_CC_GRAPH] = _new_invlist_C_array(L1PosixGraph_invlist);
5573         PL_Posix_ptrs[_CC_GRAPH] = _new_invlist_C_array(PosixGraph_invlist);
5574
5575         PL_L1Posix_ptrs[_CC_LOWER] = _new_invlist_C_array(L1PosixLower_invlist);
5576         PL_Posix_ptrs[_CC_LOWER] = _new_invlist_C_array(PosixLower_invlist);
5577
5578         PL_L1Posix_ptrs[_CC_PRINT] = _new_invlist_C_array(L1PosixPrint_invlist);
5579         PL_Posix_ptrs[_CC_PRINT] = _new_invlist_C_array(PosixPrint_invlist);
5580
5581         PL_L1Posix_ptrs[_CC_PUNCT] = _new_invlist_C_array(L1PosixPunct_invlist);
5582         PL_Posix_ptrs[_CC_PUNCT] = _new_invlist_C_array(PosixPunct_invlist);
5583
5584         PL_Posix_ptrs[_CC_SPACE] = _new_invlist_C_array(PerlSpace_invlist);
5585         PL_XPosix_ptrs[_CC_SPACE] = _new_invlist_C_array(XPerlSpace_invlist);
5586         PL_Posix_ptrs[_CC_PSXSPC] = _new_invlist_C_array(PosixSpace_invlist);
5587         PL_XPosix_ptrs[_CC_PSXSPC] = _new_invlist_C_array(XPosixSpace_invlist);
5588
5589         PL_L1Posix_ptrs[_CC_UPPER] = _new_invlist_C_array(L1PosixUpper_invlist);
5590         PL_Posix_ptrs[_CC_UPPER] = _new_invlist_C_array(PosixUpper_invlist);
5591
5592         PL_XPosix_ptrs[_CC_VERTSPACE] = _new_invlist_C_array(VertSpace_invlist);
5593
5594         PL_Posix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(PosixWord_invlist);
5595         PL_L1Posix_ptrs[_CC_WORDCHAR]
5596                                 = _new_invlist_C_array(L1PosixWord_invlist);
5597
5598         PL_Posix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(PosixXDigit_invlist);
5599         PL_XPosix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(XPosixXDigit_invlist);
5600
5601         PL_HasMultiCharFold = _new_invlist_C_array(_Perl_Multi_Char_Folds_invlist);
5602     }
5603 #endif
5604
5605     pRExC_state->code_blocks = NULL;
5606     pRExC_state->num_code_blocks = 0;
5607
5608     if (is_bare_re)
5609         *is_bare_re = FALSE;
5610
5611     if (expr && (expr->op_type == OP_LIST ||
5612                 (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
5613         /* allocate code_blocks if needed */
5614         OP *o;
5615         int ncode = 0;
5616
5617         for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling)
5618             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
5619                 ncode++; /* count of DO blocks */
5620         if (ncode) {
5621             pRExC_state->num_code_blocks = ncode;
5622             Newx(pRExC_state->code_blocks, ncode, struct reg_code_block);
5623         }
5624     }
5625
5626     if (!pat_count) {
5627         /* compile-time pattern with just OP_CONSTs and DO blocks */
5628
5629         int n;
5630         OP *o;
5631
5632         /* find how many CONSTs there are */
5633         assert(expr);
5634         n = 0;
5635         if (expr->op_type == OP_CONST)
5636             n = 1;
5637         else
5638             for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
5639                 if (o->op_type == OP_CONST)
5640                     n++;
5641             }
5642
5643         /* fake up an SV array */
5644
5645         assert(!new_patternp);
5646         Newx(new_patternp, n, SV*);
5647         SAVEFREEPV(new_patternp);
5648         pat_count = n;
5649
5650         n = 0;
5651         if (expr->op_type == OP_CONST)
5652             new_patternp[n] = cSVOPx_sv(expr);
5653         else
5654             for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
5655                 if (o->op_type == OP_CONST)
5656                     new_patternp[n++] = cSVOPo_sv;
5657             }
5658
5659     }
5660
5661     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
5662         "Assembling pattern from %d elements%s\n", pat_count,
5663             orig_rx_flags & RXf_SPLIT ? " for split" : ""));
5664
5665     /* set expr to the first arg op */
5666
5667     if (pRExC_state->num_code_blocks
5668          && expr->op_type != OP_CONST)
5669     {
5670             expr = cLISTOPx(expr)->op_first;
5671             assert(   expr->op_type == OP_PUSHMARK
5672                    || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK)
5673                    || expr->op_type == OP_PADRANGE);
5674             expr = expr->op_sibling;
5675     }
5676
5677     pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count,
5678                         expr, &recompile, NULL);
5679
5680     /* handle bare (possibly after overloading) regex: foo =~ $re */
5681     {
5682         SV *re = pat;
5683         if (SvROK(re))
5684             re = SvRV(re);
5685         if (SvTYPE(re) == SVt_REGEXP) {
5686             if (is_bare_re)
5687                 *is_bare_re = TRUE;
5688             SvREFCNT_inc(re);
5689             Safefree(pRExC_state->code_blocks);
5690             DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
5691                 "Precompiled pattern%s\n",
5692                     orig_rx_flags & RXf_SPLIT ? " for split" : ""));
5693
5694             return (REGEXP*)re;
5695         }
5696     }
5697
5698     exp = SvPV_nomg(pat, plen);
5699
5700     if (!eng->op_comp) {
5701         if ((SvUTF8(pat) && IN_BYTES)
5702                 || SvGMAGICAL(pat) || SvAMAGIC(pat))
5703         {
5704             /* make a temporary copy; either to convert to bytes,
5705              * or to avoid repeating get-magic / overloaded stringify */
5706             pat = newSVpvn_flags(exp, plen, SVs_TEMP |
5707                                         (IN_BYTES ? 0 : SvUTF8(pat)));
5708         }
5709         Safefree(pRExC_state->code_blocks);
5710         return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
5711     }
5712
5713     /* ignore the utf8ness if the pattern is 0 length */
5714     RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
5715     RExC_uni_semantics = 0;
5716     RExC_contains_locale = 0;
5717     pRExC_state->runtime_code_qr = NULL;
5718
5719     DEBUG_COMPILE_r({
5720             SV *dsv= sv_newmortal();
5721             RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, 60);
5722             PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
5723                           PL_colors[4],PL_colors[5],s);
5724         });
5725
5726   redo_first_pass:
5727     /* we jump here if we upgrade the pattern to utf8 and have to
5728      * recompile */
5729
5730     if ((pm_flags & PMf_USE_RE_EVAL)
5731                 /* this second condition covers the non-regex literal case,
5732                  * i.e.  $foo =~ '(?{})'. */
5733                 || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
5734     )
5735         runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen);
5736
5737     /* return old regex if pattern hasn't changed */
5738     /* XXX: note in the below we have to check the flags as well as the pattern.
5739      *
5740      * Things get a touch tricky as we have to compare the utf8 flag independently
5741      * from the compile flags.
5742      */
5743
5744     if (   old_re
5745         && !recompile
5746         && !!RX_UTF8(old_re) == !!RExC_utf8
5747         && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) )
5748         && RX_PRECOMP(old_re)
5749         && RX_PRELEN(old_re) == plen
5750         && memEQ(RX_PRECOMP(old_re), exp, plen)
5751         && !runtime_code /* with runtime code, always recompile */ )
5752     {
5753         Safefree(pRExC_state->code_blocks);
5754         return old_re;
5755     }
5756
5757     rx_flags = orig_rx_flags;
5758
5759     if (initial_charset == REGEX_LOCALE_CHARSET) {
5760         RExC_contains_locale = 1;
5761     }
5762     else if (RExC_utf8 && initial_charset == REGEX_DEPENDS_CHARSET) {
5763
5764         /* Set to use unicode semantics if the pattern is in utf8 and has the
5765          * 'depends' charset specified, as it means unicode when utf8  */
5766         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
5767     }
5768
5769     RExC_precomp = exp;
5770     RExC_flags = rx_flags;
5771     RExC_pm_flags = pm_flags;
5772
5773     if (runtime_code) {
5774         if (TAINTING_get && TAINT_get)
5775             Perl_croak(aTHX_ "Eval-group in insecure regular expression");
5776
5777         if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
5778             /* whoops, we have a non-utf8 pattern, whilst run-time code
5779              * got compiled as utf8. Try again with a utf8 pattern */
5780             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
5781                                     pRExC_state->num_code_blocks);
5782             goto redo_first_pass;
5783         }
5784     }
5785     assert(!pRExC_state->runtime_code_qr);
5786
5787     RExC_sawback = 0;
5788
5789     RExC_seen = 0;
5790     RExC_in_lookbehind = 0;
5791     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
5792     RExC_extralen = 0;
5793     RExC_override_recoding = 0;
5794     RExC_in_multi_char_class = 0;
5795
5796     /* First pass: determine size, legality. */
5797     RExC_parse = exp;
5798     RExC_start = exp;
5799     RExC_end = exp + plen;
5800     RExC_naughty = 0;
5801     RExC_npar = 1;
5802     RExC_nestroot = 0;
5803     RExC_size = 0L;
5804     RExC_emit = &RExC_emit_dummy;
5805     RExC_whilem_seen = 0;
5806     RExC_open_parens = NULL;
5807     RExC_close_parens = NULL;
5808     RExC_opend = NULL;
5809     RExC_paren_names = NULL;
5810 #ifdef DEBUGGING
5811     RExC_paren_name_list = NULL;
5812 #endif
5813     RExC_recurse = NULL;
5814     RExC_recurse_count = 0;
5815     pRExC_state->code_index = 0;
5816
5817 #if 0 /* REGC() is (currently) a NOP at the first pass.
5818        * Clever compilers notice this and complain. --jhi */
5819     REGC((U8)REG_MAGIC, (char*)RExC_emit);
5820 #endif
5821     DEBUG_PARSE_r(
5822         PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n");
5823         RExC_lastnum=0;
5824         RExC_lastparse=NULL;
5825     );
5826     /* reg may croak on us, not giving us a chance to free
5827        pRExC_state->code_blocks.  We cannot SAVEFREEPV it now, as we may
5828        need it to survive as long as the regexp (qr/(?{})/).
5829        We must check that code_blocksv is not already set, because we may
5830        have jumped back to restart the sizing pass. */
5831     if (pRExC_state->code_blocks && !code_blocksv) {
5832         code_blocksv = newSV_type(SVt_PV);
5833         SAVEFREESV(code_blocksv);
5834         SvPV_set(code_blocksv, (char *)pRExC_state->code_blocks);
5835         SvLEN_set(code_blocksv, 1); /*sufficient to make sv_clear free it*/
5836     }
5837     if (reg(pRExC_state, 0, &flags,1) == NULL) {
5838         /* It's possible to write a regexp in ascii that represents Unicode
5839         codepoints outside of the byte range, such as via \x{100}. If we
5840         detect such a sequence we have to convert the entire pattern to utf8
5841         and then recompile, as our sizing calculation will have been based
5842         on 1 byte == 1 character, but we will need to use utf8 to encode
5843         at least some part of the pattern, and therefore must convert the whole
5844         thing.
5845         -- dmq */
5846         if (flags & RESTART_UTF8) {
5847             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
5848                                     pRExC_state->num_code_blocks);
5849             goto redo_first_pass;
5850         }
5851         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for sizing pass, flags=%#"UVxf"", (UV) flags);
5852     }
5853     if (code_blocksv)
5854         SvLEN_set(code_blocksv,0); /* no you can't have it, sv_clear */
5855
5856     DEBUG_PARSE_r({
5857         PerlIO_printf(Perl_debug_log, 
5858             "Required size %"IVdf" nodes\n"
5859             "Starting second pass (creation)\n", 
5860             (IV)RExC_size);
5861         RExC_lastnum=0; 
5862         RExC_lastparse=NULL; 
5863     });
5864
5865     /* The first pass could have found things that force Unicode semantics */
5866     if ((RExC_utf8 || RExC_uni_semantics)
5867          && get_regex_charset(rx_flags) == REGEX_DEPENDS_CHARSET)
5868     {
5869         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
5870     }
5871
5872     /* Small enough for pointer-storage convention?
5873        If extralen==0, this means that we will not need long jumps. */
5874     if (RExC_size >= 0x10000L && RExC_extralen)
5875         RExC_size += RExC_extralen;
5876     else
5877         RExC_extralen = 0;
5878     if (RExC_whilem_seen > 15)
5879         RExC_whilem_seen = 15;
5880
5881     /* Allocate space and zero-initialize. Note, the two step process 
5882        of zeroing when in debug mode, thus anything assigned has to 
5883        happen after that */
5884     rx = (REGEXP*) newSV_type(SVt_REGEXP);
5885     r = ReANY(rx);
5886     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
5887          char, regexp_internal);
5888     if ( r == NULL || ri == NULL )
5889         FAIL("Regexp out of space");
5890 #ifdef DEBUGGING
5891     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
5892     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char);
5893 #else 
5894     /* bulk initialize base fields with 0. */
5895     Zero(ri, sizeof(regexp_internal), char);        
5896 #endif
5897
5898     /* non-zero initialization begins here */
5899     RXi_SET( r, ri );
5900     r->engine= eng;
5901     r->extflags = rx_flags;
5902     RXp_COMPFLAGS(r) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK;
5903
5904     if (pm_flags & PMf_IS_QR) {
5905         ri->code_blocks = pRExC_state->code_blocks;
5906         ri->num_code_blocks = pRExC_state->num_code_blocks;
5907     }
5908     else
5909     {
5910         int n;
5911         for (n = 0; n < pRExC_state->num_code_blocks; n++)
5912             if (pRExC_state->code_blocks[n].src_regex)
5913                 SAVEFREESV(pRExC_state->code_blocks[n].src_regex);
5914         SAVEFREEPV(pRExC_state->code_blocks);
5915     }
5916
5917     {
5918         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
5919         bool has_charset = (get_regex_charset(r->extflags) != REGEX_DEPENDS_CHARSET);
5920
5921         /* The caret is output if there are any defaults: if not all the STD
5922          * flags are set, or if no character set specifier is needed */
5923         bool has_default =
5924                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
5925                     || ! has_charset);
5926         bool has_runon = ((RExC_seen & REG_SEEN_RUN_ON_COMMENT)==REG_SEEN_RUN_ON_COMMENT);
5927         U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD)
5928                             >> RXf_PMf_STD_PMMOD_SHIFT);
5929         const char *fptr = STD_PAT_MODS;        /*"msix"*/
5930         char *p;
5931         /* Allocate for the worst case, which is all the std flags are turned
5932          * on.  If more precision is desired, we could do a population count of
5933          * the flags set.  This could be done with a small lookup table, or by
5934          * shifting, masking and adding, or even, when available, assembly
5935          * language for a machine-language population count.
5936          * We never output a minus, as all those are defaults, so are
5937          * covered by the caret */
5938         const STRLEN wraplen = plen + has_p + has_runon
5939             + has_default       /* If needs a caret */
5940
5941                 /* If needs a character set specifier */
5942             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
5943             + (sizeof(STD_PAT_MODS) - 1)
5944             + (sizeof("(?:)") - 1);
5945
5946         Newx(p, wraplen + 1, char); /* +1 for the ending NUL */
5947         r->xpv_len_u.xpvlenu_pv = p;
5948         if (RExC_utf8)
5949             SvFLAGS(rx) |= SVf_UTF8;
5950         *p++='('; *p++='?';
5951
5952         /* If a default, cover it using the caret */
5953         if (has_default) {
5954             *p++= DEFAULT_PAT_MOD;
5955         }
5956         if (has_charset) {
5957             STRLEN len;
5958             const char* const name = get_regex_charset_name(r->extflags, &len);
5959             Copy(name, p, len, char);
5960             p += len;
5961         }
5962         if (has_p)
5963             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
5964         {
5965             char ch;
5966             while((ch = *fptr++)) {
5967                 if(reganch & 1)
5968                     *p++ = ch;
5969                 reganch >>= 1;
5970             }
5971         }
5972
5973         *p++ = ':';
5974         Copy(RExC_precomp, p, plen, char);
5975         assert ((RX_WRAPPED(rx) - p) < 16);
5976         r->pre_prefix = p - RX_WRAPPED(rx);
5977         p += plen;
5978         if (has_runon)
5979             *p++ = '\n';
5980         *p++ = ')';
5981         *p = 0;
5982         SvCUR_set(rx, p - RX_WRAPPED(rx));
5983     }
5984
5985     r->intflags = 0;
5986     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
5987     
5988     if (RExC_seen & REG_SEEN_RECURSE) {
5989         Newxz(RExC_open_parens, RExC_npar,regnode *);
5990         SAVEFREEPV(RExC_open_parens);
5991         Newxz(RExC_close_parens,RExC_npar,regnode *);
5992         SAVEFREEPV(RExC_close_parens);
5993     }
5994
5995     /* Useful during FAIL. */
5996 #ifdef RE_TRACK_PATTERN_OFFSETS
5997     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
5998     DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
5999                           "%s %"UVuf" bytes for offset annotations.\n",
6000                           ri->u.offsets ? "Got" : "Couldn't get",
6001                           (UV)((2*RExC_size+1) * sizeof(U32))));
6002 #endif
6003     SetProgLen(ri,RExC_size);
6004     RExC_rx_sv = rx;
6005     RExC_rx = r;
6006     RExC_rxi = ri;
6007
6008     /* Second pass: emit code. */
6009     RExC_flags = rx_flags;      /* don't let top level (?i) bleed */
6010     RExC_pm_flags = pm_flags;
6011     RExC_parse = exp;
6012     RExC_end = exp + plen;
6013     RExC_naughty = 0;
6014     RExC_npar = 1;
6015     RExC_emit_start = ri->program;
6016     RExC_emit = ri->program;
6017     RExC_emit_bound = ri->program + RExC_size + 1;
6018     pRExC_state->code_index = 0;
6019
6020     REGC((U8)REG_MAGIC, (char*) RExC_emit++);
6021     if (reg(pRExC_state, 0, &flags,1) == NULL) {
6022         ReREFCNT_dec(rx);   
6023         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for generation pass, flags=%#"UVxf"", (UV) flags);
6024     }
6025     /* XXXX To minimize changes to RE engine we always allocate
6026        3-units-long substrs field. */
6027     Newx(r->substrs, 1, struct reg_substr_data);
6028     if (RExC_recurse_count) {
6029         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
6030         SAVEFREEPV(RExC_recurse);
6031     }
6032
6033 reStudy:
6034     r->minlen = minlen = sawlookahead = sawplus = sawopen = sawminmod = 0;
6035     Zero(r->substrs, 1, struct reg_substr_data);
6036
6037 #ifdef TRIE_STUDY_OPT
6038     if (!restudied) {
6039         StructCopy(&zero_scan_data, &data, scan_data_t);
6040         copyRExC_state = RExC_state;
6041     } else {
6042         U32 seen=RExC_seen;
6043         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
6044         
6045         RExC_state = copyRExC_state;
6046         if (seen & REG_TOP_LEVEL_BRANCHES) 
6047             RExC_seen |= REG_TOP_LEVEL_BRANCHES;
6048         else
6049             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES;
6050         StructCopy(&zero_scan_data, &data, scan_data_t);
6051     }
6052 #else
6053     StructCopy(&zero_scan_data, &data, scan_data_t);
6054 #endif    
6055
6056     /* Dig out information for optimizations. */
6057     r->extflags = RExC_flags; /* was pm_op */
6058     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
6059  
6060     if (UTF)
6061         SvUTF8_on(rx);  /* Unicode in it? */
6062     ri->regstclass = NULL;
6063     if (RExC_naughty >= 10)     /* Probably an expensive pattern. */
6064         r->intflags |= PREGf_NAUGHTY;
6065     scan = ri->program + 1;             /* First BRANCH. */
6066
6067     /* testing for BRANCH here tells us whether there is "must appear"
6068        data in the pattern. If there is then we can use it for optimisations */
6069     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /*  Only one top-level choice. */
6070         I32 fake;
6071         STRLEN longest_float_length, longest_fixed_length;
6072         struct regnode_charclass_class ch_class; /* pointed to by data */
6073         int stclass_flag;
6074         I32 last_close = 0; /* pointed to by data */
6075         regnode *first= scan;
6076         regnode *first_next= regnext(first);
6077         /*
6078          * Skip introductions and multiplicators >= 1
6079          * so that we can extract the 'meat' of the pattern that must 
6080          * match in the large if() sequence following.
6081          * NOTE that EXACT is NOT covered here, as it is normally
6082          * picked up by the optimiser separately. 
6083          *
6084          * This is unfortunate as the optimiser isnt handling lookahead
6085          * properly currently.
6086          *
6087          */
6088         while ((OP(first) == OPEN && (sawopen = 1)) ||
6089                /* An OR of *one* alternative - should not happen now. */
6090             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
6091             /* for now we can't handle lookbehind IFMATCH*/
6092             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
6093             (OP(first) == PLUS) ||
6094             (OP(first) == MINMOD) ||
6095                /* An {n,m} with n>0 */
6096             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
6097             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
6098         {
6099                 /* 
6100                  * the only op that could be a regnode is PLUS, all the rest
6101                  * will be regnode_1 or regnode_2.
6102                  *
6103                  * (yves doesn't think this is true)
6104                  */
6105                 if (OP(first) == PLUS)
6106                     sawplus = 1;
6107                 else {
6108                     if (OP(first) == MINMOD)
6109                         sawminmod = 1;
6110                     first += regarglen[OP(first)];
6111                 }
6112                 first = NEXTOPER(first);
6113                 first_next= regnext(first);
6114         }
6115
6116         /* Starting-point info. */
6117       again:
6118         DEBUG_PEEP("first:",first,0);
6119         /* Ignore EXACT as we deal with it later. */
6120         if (PL_regkind[OP(first)] == EXACT) {
6121             if (OP(first) == EXACT)
6122                 NOOP;   /* Empty, get anchored substr later. */
6123             else
6124                 ri->regstclass = first;
6125         }
6126 #ifdef TRIE_STCLASS
6127         else if (PL_regkind[OP(first)] == TRIE &&
6128                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0) 
6129         {
6130             regnode *trie_op;
6131             /* this can happen only on restudy */
6132             if ( OP(first) == TRIE ) {
6133                 struct regnode_1 *trieop = (struct regnode_1 *)
6134                     PerlMemShared_calloc(1, sizeof(struct regnode_1));
6135                 StructCopy(first,trieop,struct regnode_1);
6136                 trie_op=(regnode *)trieop;
6137             } else {
6138                 struct regnode_charclass *trieop = (struct regnode_charclass *)
6139                     PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
6140                 StructCopy(first,trieop,struct regnode_charclass);
6141                 trie_op=(regnode *)trieop;
6142             }
6143             OP(trie_op)+=2;
6144             make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
6145             ri->regstclass = trie_op;
6146         }
6147 #endif
6148         else if (REGNODE_SIMPLE(OP(first)))
6149             ri->regstclass = first;
6150         else if (PL_regkind[OP(first)] == BOUND ||
6151                  PL_regkind[OP(first)] == NBOUND)
6152             ri->regstclass = first;
6153         else if (PL_regkind[OP(first)] == BOL) {
6154             r->extflags |= (OP(first) == MBOL
6155                            ? RXf_ANCH_MBOL
6156                            : (OP(first) == SBOL
6157                               ? RXf_ANCH_SBOL
6158                               : RXf_ANCH_BOL));
6159             first = NEXTOPER(first);
6160             goto again;
6161         }
6162         else if (OP(first) == GPOS) {
6163             r->extflags |= RXf_ANCH_GPOS;
6164             first = NEXTOPER(first);
6165             goto again;
6166         }
6167         else if ((!sawopen || !RExC_sawback) &&
6168             (OP(first) == STAR &&
6169             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
6170             !(r->extflags & RXf_ANCH) && !pRExC_state->num_code_blocks)
6171         {
6172             /* turn .* into ^.* with an implied $*=1 */
6173             const int type =
6174                 (OP(NEXTOPER(first)) == REG_ANY)
6175                     ? RXf_ANCH_MBOL
6176                     : RXf_ANCH_SBOL;
6177             r->extflags |= type;
6178             r->intflags |= PREGf_IMPLICIT;
6179             first = NEXTOPER(first);
6180             goto again;
6181         }
6182         if (sawplus && !sawminmod && !sawlookahead && (!sawopen || !RExC_sawback)
6183             && !pRExC_state->num_code_blocks) /* May examine pos and $& */
6184             /* x+ must match at the 1st pos of run of x's */
6185             r->intflags |= PREGf_SKIP;
6186
6187         /* Scan is after the zeroth branch, first is atomic matcher. */
6188 #ifdef TRIE_STUDY_OPT
6189         DEBUG_PARSE_r(
6190             if (!restudied)
6191                 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
6192                               (IV)(first - scan + 1))
6193         );
6194 #else
6195         DEBUG_PARSE_r(
6196             PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
6197                 (IV)(first - scan + 1))
6198         );
6199 #endif
6200
6201
6202         /*
6203         * If there's something expensive in the r.e., find the
6204         * longest literal string that must appear and make it the
6205         * regmust.  Resolve ties in favor of later strings, since
6206         * the regstart check works with the beginning of the r.e.
6207         * and avoiding duplication strengthens checking.  Not a
6208         * strong reason, but sufficient in the absence of others.
6209         * [Now we resolve ties in favor of the earlier string if
6210         * it happens that c_offset_min has been invalidated, since the
6211         * earlier string may buy us something the later one won't.]
6212         */
6213
6214         data.longest_fixed = newSVpvs("");
6215         data.longest_float = newSVpvs("");
6216         data.last_found = newSVpvs("");
6217         data.longest = &(data.longest_fixed);
6218         ENTER_with_name("study_chunk");
6219         SAVEFREESV(data.longest_fixed);
6220         SAVEFREESV(data.longest_float);
6221         SAVEFREESV(data.last_found);
6222         first = scan;
6223         if (!ri->regstclass) {
6224             cl_init(pRExC_state, &ch_class);
6225             data.start_class = &ch_class;
6226             stclass_flag = SCF_DO_STCLASS_AND;
6227         } else                          /* XXXX Check for BOUND? */
6228             stclass_flag = 0;
6229         data.last_closep = &last_close;
6230         
6231         minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */
6232             &data, -1, NULL, NULL,
6233             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag
6234                           | (restudied ? SCF_TRIE_DOING_RESTUDY : 0),
6235             0);
6236
6237
6238         CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
6239
6240
6241         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
6242              && data.last_start_min == 0 && data.last_end > 0
6243              && !RExC_seen_zerolen
6244              && !(RExC_seen & REG_SEEN_VERBARG)
6245              && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
6246             r->extflags |= RXf_CHECK_ALL;
6247         scan_commit(pRExC_state, &data,&minlen,0);
6248
6249         longest_float_length = CHR_SVLEN(data.longest_float);
6250
6251         if (! ((SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
6252                    && data.offset_fixed == data.offset_float_min
6253                    && SvCUR(data.longest_fixed) == SvCUR(data.longest_float)))
6254             && S_setup_longest (aTHX_ pRExC_state,
6255                                     data.longest_float,
6256                                     &(r->float_utf8),
6257                                     &(r->float_substr),
6258                                     &(r->float_end_shift),
6259                                     data.lookbehind_float,
6260                                     data.offset_float_min,
6261                                     data.minlen_float,
6262                                     longest_float_length,
6263                                     cBOOL(data.flags & SF_FL_BEFORE_EOL),
6264                                     cBOOL(data.flags & SF_FL_BEFORE_MEOL)))
6265         {
6266             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
6267             r->float_max_offset = data.offset_float_max;
6268             if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
6269                 r->float_max_offset -= data.lookbehind_float;
6270             SvREFCNT_inc_simple_void_NN(data.longest_float);
6271         }
6272         else {
6273             r->float_substr = r->float_utf8 = NULL;
6274             longest_float_length = 0;
6275         }
6276
6277         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
6278
6279         if (S_setup_longest (aTHX_ pRExC_state,
6280                                 data.longest_fixed,
6281                                 &(r->anchored_utf8),
6282                                 &(r->anchored_substr),
6283                                 &(r->anchored_end_shift),
6284                                 data.lookbehind_fixed,
6285                                 data.offset_fixed,
6286                                 data.minlen_fixed,
6287                                 longest_fixed_length,
6288                                 cBOOL(data.flags & SF_FIX_BEFORE_EOL),
6289                                 cBOOL(data.flags & SF_FIX_BEFORE_MEOL)))
6290         {
6291             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
6292             SvREFCNT_inc_simple_void_NN(data.longest_fixed);
6293         }
6294         else {
6295             r->anchored_substr = r->anchored_utf8 = NULL;
6296             longest_fixed_length = 0;
6297         }
6298         LEAVE_with_name("study_chunk");
6299
6300         if (ri->regstclass
6301             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
6302             ri->regstclass = NULL;
6303
6304         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
6305             && stclass_flag
6306             && ! TEST_SSC_EOS(data.start_class)
6307             && !cl_is_anything(data.start_class))
6308         {
6309             const U32 n = add_data(pRExC_state, 1, "f");
6310             OP(data.start_class) = ANYOF_SYNTHETIC;
6311
6312             Newx(RExC_rxi->data->data[n], 1,
6313                 struct regnode_charclass_class);
6314             StructCopy(data.start_class,
6315                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
6316                        struct regnode_charclass_class);
6317             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
6318             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
6319             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
6320                       regprop(r, sv, (regnode*)data.start_class);
6321                       PerlIO_printf(Perl_debug_log,
6322                                     "synthetic stclass \"%s\".\n",
6323                                     SvPVX_const(sv));});
6324         }
6325
6326         /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
6327         if (longest_fixed_length > longest_float_length) {
6328             r->check_end_shift = r->anchored_end_shift;
6329             r->check_substr = r->anchored_substr;
6330             r->check_utf8 = r->anchored_utf8;
6331             r->check_offset_min = r->check_offset_max = r->anchored_offset;
6332             if (r->extflags & RXf_ANCH_SINGLE)
6333                 r->extflags |= RXf_NOSCAN;
6334         }
6335         else {
6336             r->check_end_shift = r->float_end_shift;
6337             r->check_substr = r->float_substr;
6338             r->check_utf8 = r->float_utf8;
6339             r->check_offset_min = r->float_min_offset;
6340             r->check_offset_max = r->float_max_offset;
6341         }
6342         /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
6343            This should be changed ASAP!  */
6344         if ((r->check_substr || r->check_utf8) && !(r->extflags & RXf_ANCH_GPOS)) {
6345             r->extflags |= RXf_USE_INTUIT;
6346             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
6347                 r->extflags |= RXf_INTUIT_TAIL;
6348         }
6349         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
6350         if ( (STRLEN)minlen < longest_float_length )
6351             minlen= longest_float_length;
6352         if ( (STRLEN)minlen < longest_fixed_length )
6353             minlen= longest_fixed_length;     
6354         */
6355     }
6356     else {
6357         /* Several toplevels. Best we can is to set minlen. */
6358         I32 fake;
6359         struct regnode_charclass_class ch_class;
6360         I32 last_close = 0;
6361
6362         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
6363
6364         scan = ri->program + 1;
6365         cl_init(pRExC_state, &ch_class);
6366         data.start_class = &ch_class;
6367         data.last_closep = &last_close;
6368
6369         
6370         minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
6371             &data, -1, NULL, NULL,
6372             SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS
6373                               |(restudied ? SCF_TRIE_DOING_RESTUDY : 0),
6374             0);
6375         
6376         CHECK_RESTUDY_GOTO_butfirst(NOOP);
6377
6378         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
6379                 = r->float_substr = r->float_utf8 = NULL;
6380
6381         if (! TEST_SSC_EOS(data.start_class)
6382             && !cl_is_anything(data.start_class))
6383         {
6384             const U32 n = add_data(pRExC_state, 1, "f");
6385             OP(data.start_class) = ANYOF_SYNTHETIC;
6386
6387             Newx(RExC_rxi->data->data[n], 1,
6388                 struct regnode_charclass_class);
6389             StructCopy(data.start_class,
6390                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
6391                        struct regnode_charclass_class);
6392             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
6393             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
6394             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
6395                       regprop(r, sv, (regnode*)data.start_class);
6396                       PerlIO_printf(Perl_debug_log,
6397                                     "synthetic stclass \"%s\".\n",
6398                                     SvPVX_const(sv));});
6399         }
6400     }
6401
6402     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
6403        the "real" pattern. */
6404     DEBUG_OPTIMISE_r({
6405         PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n",
6406                       (IV)minlen, (IV)r->minlen);
6407     });
6408     r->minlenret = minlen;
6409     if (r->minlen < minlen) 
6410         r->minlen = minlen;
6411     
6412     if (RExC_seen & REG_SEEN_GPOS)
6413         r->extflags |= RXf_GPOS_SEEN;
6414     if (RExC_seen & REG_SEEN_LOOKBEHIND)
6415         r->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the lookbehind */
6416     if (pRExC_state->num_code_blocks)
6417         r->extflags |= RXf_EVAL_SEEN;
6418     if (RExC_seen & REG_SEEN_CANY)
6419         r->extflags |= RXf_CANY_SEEN;
6420     if (RExC_seen & REG_SEEN_VERBARG)
6421     {
6422         r->intflags |= PREGf_VERBARG_SEEN;
6423         r->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */
6424     }
6425     if (RExC_seen & REG_SEEN_CUTGROUP)
6426         r->intflags |= PREGf_CUTGROUP_SEEN;
6427     if (pm_flags & PMf_USE_RE_EVAL)
6428         r->intflags |= PREGf_USE_RE_EVAL;
6429     if (RExC_paren_names)
6430         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
6431     else
6432         RXp_PAREN_NAMES(r) = NULL;
6433
6434     {
6435         regnode *first = ri->program + 1;
6436         U8 fop = OP(first);
6437         regnode *next = NEXTOPER(first);
6438         U8 nop = OP(next);
6439
6440         if (PL_regkind[fop] == NOTHING && nop == END)
6441             r->extflags |= RXf_NULL;
6442         else if (PL_regkind[fop] == BOL && nop == END)
6443             r->extflags |= RXf_START_ONLY;
6444         else if (fop == PLUS && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE && OP(regnext(first)) == END)
6445             r->extflags |= RXf_WHITE;
6446         else if ( r->extflags & RXf_SPLIT && fop == EXACT && STR_LEN(first) == 1 && *(STRING(first)) == ' ' && OP(regnext(first)) == END )
6447             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
6448
6449     }
6450 #ifdef DEBUGGING
6451     if (RExC_paren_names) {
6452         ri->name_list_idx = add_data( pRExC_state, 1, "a" );
6453         ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list);
6454     } else
6455 #endif
6456         ri->name_list_idx = 0;
6457
6458     if (RExC_recurse_count) {
6459         for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
6460             const regnode *scan = RExC_recurse[RExC_recurse_count-1];
6461             ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
6462         }
6463     }
6464     Newxz(r->offs, RExC_npar, regexp_paren_pair);
6465     /* assume we don't need to swap parens around before we match */
6466
6467     DEBUG_DUMP_r({
6468         PerlIO_printf(Perl_debug_log,"Final program:\n");
6469         regdump(r);
6470     });
6471 #ifdef RE_TRACK_PATTERN_OFFSETS
6472     DEBUG_OFFSETS_r(if (ri->u.offsets) {
6473         const U32 len = ri->u.offsets[0];
6474         U32 i;
6475         GET_RE_DEBUG_FLAGS_DECL;
6476         PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
6477         for (i = 1; i <= len; i++) {
6478             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
6479                 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
6480                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
6481             }
6482         PerlIO_printf(Perl_debug_log, "\n");
6483     });
6484 #endif
6485
6486 #ifdef USE_ITHREADS
6487     /* under ithreads the ?pat? PMf_USED flag on the pmop is simulated
6488      * by setting the regexp SV to readonly-only instead. If the
6489      * pattern's been recompiled, the USEDness should remain. */
6490     if (old_re && SvREADONLY(old_re))
6491         SvREADONLY_on(rx);
6492 #endif
6493     return rx;
6494 }
6495
6496
6497 SV*
6498 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
6499                     const U32 flags)
6500 {
6501     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
6502
6503     PERL_UNUSED_ARG(value);
6504
6505     if (flags & RXapif_FETCH) {
6506         return reg_named_buff_fetch(rx, key, flags);
6507     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
6508         Perl_croak_no_modify();
6509         return NULL;
6510     } else if (flags & RXapif_EXISTS) {
6511         return reg_named_buff_exists(rx, key, flags)
6512             ? &PL_sv_yes
6513             : &PL_sv_no;
6514     } else if (flags & RXapif_REGNAMES) {
6515         return reg_named_buff_all(rx, flags);
6516     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
6517         return reg_named_buff_scalar(rx, flags);
6518     } else {
6519         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
6520         return NULL;
6521     }
6522 }
6523
6524 SV*
6525 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
6526                          const U32 flags)
6527 {
6528     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
6529     PERL_UNUSED_ARG(lastkey);
6530
6531     if (flags & RXapif_FIRSTKEY)
6532         return reg_named_buff_firstkey(rx, flags);
6533     else if (flags & RXapif_NEXTKEY)
6534         return reg_named_buff_nextkey(rx, flags);
6535     else {
6536         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter", (int)flags);
6537         return NULL;
6538     }
6539 }
6540
6541 SV*
6542 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
6543                           const U32 flags)
6544 {
6545     AV *retarray = NULL;
6546     SV *ret;
6547     struct regexp *const rx = ReANY(r);
6548
6549     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
6550
6551     if (flags & RXapif_ALL)
6552         retarray=newAV();
6553
6554     if (rx && RXp_PAREN_NAMES(rx)) {
6555         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
6556         if (he_str) {
6557             IV i;
6558             SV* sv_dat=HeVAL(he_str);
6559             I32 *nums=(I32*)SvPVX(sv_dat);
6560             for ( i=0; i<SvIVX(sv_dat); i++ ) {
6561                 if ((I32)(rx->nparens) >= nums[i]
6562                     && rx->offs[nums[i]].start != -1
6563                     && rx->offs[nums[i]].end != -1)
6564                 {
6565                     ret = newSVpvs("");
6566                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
6567                     if (!retarray)
6568                         return ret;
6569                 } else {
6570                     if (retarray)
6571                         ret = newSVsv(&PL_sv_undef);
6572                 }
6573                 if (retarray)
6574                     av_push(retarray, ret);
6575             }
6576             if (retarray)
6577                 return newRV_noinc(MUTABLE_SV(retarray));
6578         }
6579     }
6580     return NULL;
6581 }
6582
6583 bool
6584 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
6585                            const U32 flags)
6586 {
6587     struct regexp *const rx = ReANY(r);
6588
6589     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
6590
6591     if (rx && RXp_PAREN_NAMES(rx)) {
6592         if (flags & RXapif_ALL) {
6593             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
6594         } else {
6595             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
6596             if (sv) {
6597                 SvREFCNT_dec_NN(sv);
6598                 return TRUE;
6599             } else {
6600                 return FALSE;
6601             }
6602         }
6603     } else {
6604         return FALSE;
6605     }
6606 }
6607
6608 SV*
6609 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
6610 {
6611     struct regexp *const rx = ReANY(r);
6612
6613     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
6614
6615     if ( rx && RXp_PAREN_NAMES(rx) ) {
6616         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
6617
6618         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
6619     } else {
6620         return FALSE;
6621     }
6622 }
6623
6624 SV*
6625 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
6626 {
6627     struct regexp *const rx = ReANY(r);
6628     GET_RE_DEBUG_FLAGS_DECL;
6629
6630     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
6631
6632     if (rx && RXp_PAREN_NAMES(rx)) {
6633         HV *hv = RXp_PAREN_NAMES(rx);
6634         HE *temphe;
6635         while ( (temphe = hv_iternext_flags(hv,0)) ) {
6636             IV i;
6637             IV parno = 0;
6638             SV* sv_dat = HeVAL(temphe);
6639             I32 *nums = (I32*)SvPVX(sv_dat);
6640             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
6641                 if ((I32)(rx->lastparen) >= nums[i] &&
6642                     rx->offs[nums[i]].start != -1 &&
6643                     rx->offs[nums[i]].end != -1)
6644                 {
6645                     parno = nums[i];
6646                     break;
6647                 }
6648             }
6649             if (parno || flags & RXapif_ALL) {
6650                 return newSVhek(HeKEY_hek(temphe));
6651             }
6652         }
6653     }
6654     return NULL;
6655 }
6656
6657 SV*
6658 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
6659 {
6660     SV *ret;
6661     AV *av;
6662     I32 length;
6663     struct regexp *const rx = ReANY(r);
6664
6665     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
6666
6667     if (rx && RXp_PAREN_NAMES(rx)) {
6668         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
6669             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
6670         } else if (flags & RXapif_ONE) {
6671             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
6672             av = MUTABLE_AV(SvRV(ret));
6673             length = av_len(av);
6674             SvREFCNT_dec_NN(ret);
6675             return newSViv(length + 1);
6676         } else {
6677             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", (int)flags);
6678             return NULL;
6679         }
6680     }
6681     return &PL_sv_undef;
6682 }
6683
6684 SV*
6685 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
6686 {
6687     struct regexp *const rx = ReANY(r);
6688     AV *av = newAV();
6689
6690     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
6691
6692     if (rx && RXp_PAREN_NAMES(rx)) {
6693         HV *hv= RXp_PAREN_NAMES(rx);
6694         HE *temphe;
6695         (void)hv_iterinit(hv);
6696         while ( (temphe = hv_iternext_flags(hv,0)) ) {
6697             IV i;
6698             IV parno = 0;
6699             SV* sv_dat = HeVAL(temphe);
6700             I32 *nums = (I32*)SvPVX(sv_dat);
6701             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
6702                 if ((I32)(rx->lastparen) >= nums[i] &&
6703                     rx->offs[nums[i]].start != -1 &&
6704                     rx->offs[nums[i]].end != -1)
6705                 {
6706                     parno = nums[i];
6707                     break;
6708                 }
6709             }
6710             if (parno || flags & RXapif_ALL) {
6711                 av_push(av, newSVhek(HeKEY_hek(temphe)));
6712             }
6713         }
6714     }
6715
6716     return newRV_noinc(MUTABLE_SV(av));
6717 }
6718
6719 void
6720 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
6721                              SV * const sv)
6722 {
6723     struct regexp *const rx = ReANY(r);
6724     char *s = NULL;
6725     I32 i = 0;
6726     I32 s1, t1;
6727     I32 n = paren;
6728
6729     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
6730         
6731     if ( (    n == RX_BUFF_IDX_CARET_PREMATCH
6732            || n == RX_BUFF_IDX_CARET_FULLMATCH
6733            || n == RX_BUFF_IDX_CARET_POSTMATCH
6734          )
6735          && !(rx->extflags & RXf_PMf_KEEPCOPY)
6736     )
6737         goto ret_undef;
6738
6739     if (!rx->subbeg)
6740         goto ret_undef;
6741
6742     if (n == RX_BUFF_IDX_CARET_FULLMATCH)
6743         /* no need to distinguish between them any more */
6744         n = RX_BUFF_IDX_FULLMATCH;
6745
6746     if ((n == RX_BUFF_IDX_PREMATCH || n == RX_BUFF_IDX_CARET_PREMATCH)
6747         && rx->offs[0].start != -1)
6748     {
6749         /* $`, ${^PREMATCH} */
6750         i = rx->offs[0].start;
6751         s = rx->subbeg;
6752     }
6753     else 
6754     if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
6755         && rx->offs[0].end != -1)
6756     {
6757         /* $', ${^POSTMATCH} */
6758         s = rx->subbeg - rx->suboffset + rx->offs[0].end;
6759         i = rx->sublen + rx->suboffset - rx->offs[0].end;
6760     } 
6761     else
6762     if ( 0 <= n && n <= (I32)rx->nparens &&
6763         (s1 = rx->offs[n].start) != -1 &&
6764         (t1 = rx->offs[n].end) != -1)
6765     {
6766         /* $&, ${^MATCH},  $1 ... */
6767         i = t1 - s1;
6768         s = rx->subbeg + s1 - rx->suboffset;
6769     } else {
6770         goto ret_undef;
6771     }          
6772
6773     assert(s >= rx->subbeg);
6774     assert(rx->sublen >= (s - rx->subbeg) + i );
6775     if (i >= 0) {
6776 #if NO_TAINT_SUPPORT
6777         sv_setpvn(sv, s, i);
6778 #else
6779         const int oldtainted = TAINT_get;
6780         TAINT_NOT;
6781         sv_setpvn(sv, s, i);
6782         TAINT_set(oldtainted);
6783 #endif
6784         if ( (rx->extflags & RXf_CANY_SEEN)
6785             ? (RXp_MATCH_UTF8(rx)
6786                         && (!i || is_utf8_string((U8*)s, i)))
6787             : (RXp_MATCH_UTF8(rx)) )
6788         {
6789             SvUTF8_on(sv);
6790         }
6791         else
6792             SvUTF8_off(sv);
6793         if (TAINTING_get) {
6794             if (RXp_MATCH_TAINTED(rx)) {
6795                 if (SvTYPE(sv) >= SVt_PVMG) {
6796                     MAGIC* const mg = SvMAGIC(sv);
6797                     MAGIC* mgt;
6798                     TAINT;
6799                     SvMAGIC_set(sv, mg->mg_moremagic);
6800                     SvTAINT(sv);
6801                     if ((mgt = SvMAGIC(sv))) {
6802                         mg->mg_moremagic = mgt;
6803                         SvMAGIC_set(sv, mg);
6804                     }
6805                 } else {
6806                     TAINT;
6807                     SvTAINT(sv);
6808                 }
6809             } else 
6810                 SvTAINTED_off(sv);
6811         }
6812     } else {
6813       ret_undef:
6814         sv_setsv(sv,&PL_sv_undef);
6815         return;
6816     }
6817 }
6818
6819 void
6820 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
6821                                                          SV const * const value)
6822 {
6823     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
6824
6825     PERL_UNUSED_ARG(rx);
6826     PERL_UNUSED_ARG(paren);
6827     PERL_UNUSED_ARG(value);
6828
6829     if (!PL_localizing)
6830         Perl_croak_no_modify();
6831 }
6832
6833 I32
6834 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
6835                               const I32 paren)
6836 {
6837     struct regexp *const rx = ReANY(r);
6838     I32 i;
6839     I32 s1, t1;
6840
6841     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
6842
6843     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
6844     switch (paren) {
6845       case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */
6846          if (!(rx->extflags & RXf_PMf_KEEPCOPY))
6847             goto warn_undef;
6848         /*FALLTHROUGH*/
6849
6850       case RX_BUFF_IDX_PREMATCH:       /* $` */
6851         if (rx->offs[0].start != -1) {
6852                         i = rx->offs[0].start;
6853                         if (i > 0) {
6854                                 s1 = 0;
6855                                 t1 = i;
6856                                 goto getlen;
6857                         }
6858             }
6859         return 0;
6860
6861       case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */
6862          if (!(rx->extflags & RXf_PMf_KEEPCOPY))
6863             goto warn_undef;
6864       case RX_BUFF_IDX_POSTMATCH:       /* $' */
6865             if (rx->offs[0].end != -1) {
6866                         i = rx->sublen - rx->offs[0].end;
6867                         if (i > 0) {
6868                                 s1 = rx->offs[0].end;
6869                                 t1 = rx->sublen;
6870                                 goto getlen;
6871                         }
6872             }
6873         return 0;
6874
6875       case RX_BUFF_IDX_CARET_FULLMATCH: /* ${^MATCH} */
6876          if (!(rx->extflags & RXf_PMf_KEEPCOPY))
6877             goto warn_undef;
6878         /*FALLTHROUGH*/
6879
6880       /* $& / ${^MATCH}, $1, $2, ... */
6881       default:
6882             if (paren <= (I32)rx->nparens &&
6883             (s1 = rx->offs[paren].start) != -1 &&
6884             (t1 = rx->offs[paren].end) != -1)
6885             {
6886             i = t1 - s1;
6887             goto getlen;
6888         } else {
6889           warn_undef:
6890             if (ckWARN(WARN_UNINITIALIZED))
6891                 report_uninit((const SV *)sv);
6892             return 0;
6893         }
6894     }
6895   getlen:
6896     if (i > 0 && RXp_MATCH_UTF8(rx)) {
6897         const char * const s = rx->subbeg - rx->suboffset + s1;
6898         const U8 *ep;
6899         STRLEN el;
6900
6901         i = t1 - s1;
6902         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
6903                         i = el;
6904     }
6905     return i;
6906 }
6907
6908 SV*
6909 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
6910 {
6911     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
6912         PERL_UNUSED_ARG(rx);
6913         if (0)
6914             return NULL;
6915         else
6916             return newSVpvs("Regexp");
6917 }
6918
6919 /* Scans the name of a named buffer from the pattern.
6920  * If flags is REG_RSN_RETURN_NULL returns null.
6921  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
6922  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
6923  * to the parsed name as looked up in the RExC_paren_names hash.
6924  * If there is an error throws a vFAIL().. type exception.
6925  */
6926
6927 #define REG_RSN_RETURN_NULL    0
6928 #define REG_RSN_RETURN_NAME    1
6929 #define REG_RSN_RETURN_DATA    2
6930
6931 STATIC SV*
6932 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
6933 {
6934     char *name_start = RExC_parse;
6935
6936     PERL_ARGS_ASSERT_REG_SCAN_NAME;
6937
6938     if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
6939          /* skip IDFIRST by using do...while */
6940         if (UTF)
6941             do {
6942                 RExC_parse += UTF8SKIP(RExC_parse);
6943             } while (isWORDCHAR_utf8((U8*)RExC_parse));
6944         else
6945             do {
6946                 RExC_parse++;
6947             } while (isWORDCHAR(*RExC_parse));
6948     } else {
6949         RExC_parse++; /* so the <- from the vFAIL is after the offending character */
6950         vFAIL("Group name must start with a non-digit word character");
6951     }
6952     if ( flags ) {
6953         SV* sv_name
6954             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
6955                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
6956         if ( flags == REG_RSN_RETURN_NAME)
6957             return sv_name;
6958         else if (flags==REG_RSN_RETURN_DATA) {
6959             HE *he_str = NULL;
6960             SV *sv_dat = NULL;
6961             if ( ! sv_name )      /* should not happen*/
6962                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
6963             if (RExC_paren_names)
6964                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
6965             if ( he_str )
6966                 sv_dat = HeVAL(he_str);
6967             if ( ! sv_dat )
6968                 vFAIL("Reference to nonexistent named group");
6969             return sv_dat;
6970         }
6971         else {
6972             Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
6973                        (unsigned long) flags);
6974         }
6975         assert(0); /* NOT REACHED */
6976     }
6977     return NULL;
6978 }
6979
6980 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
6981     int rem=(int)(RExC_end - RExC_parse);                       \
6982     int cut;                                                    \
6983     int num;                                                    \
6984     int iscut=0;                                                \
6985     if (rem>10) {                                               \
6986         rem=10;                                                 \
6987         iscut=1;                                                \
6988     }                                                           \
6989     cut=10-rem;                                                 \
6990     if (RExC_lastparse!=RExC_parse)                             \
6991         PerlIO_printf(Perl_debug_log," >%.*s%-*s",              \
6992             rem, RExC_parse,                                    \
6993             cut + 4,                                            \
6994             iscut ? "..." : "<"                                 \
6995         );                                                      \
6996     else                                                        \
6997         PerlIO_printf(Perl_debug_log,"%16s","");                \
6998                                                                 \
6999     if (SIZE_ONLY)                                              \
7000        num = RExC_size + 1;                                     \
7001     else                                                        \
7002        num=REG_NODE_NUM(RExC_emit);                             \
7003     if (RExC_lastnum!=num)                                      \
7004        PerlIO_printf(Perl_debug_log,"|%4d",num);                \
7005     else                                                        \
7006        PerlIO_printf(Perl_debug_log,"|%4s","");                 \
7007     PerlIO_printf(Perl_debug_log,"|%*s%-4s",                    \
7008         (int)((depth*2)), "",                                   \
7009         (funcname)                                              \
7010     );                                                          \
7011     RExC_lastnum=num;                                           \
7012     RExC_lastparse=RExC_parse;                                  \
7013 })
7014
7015
7016
7017 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
7018     DEBUG_PARSE_MSG((funcname));                            \
7019     PerlIO_printf(Perl_debug_log,"%4s","\n");               \
7020 })
7021 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({           \
7022     DEBUG_PARSE_MSG((funcname));                            \
7023     PerlIO_printf(Perl_debug_log,fmt "\n",args);               \
7024 })
7025
7026 /* This section of code defines the inversion list object and its methods.  The
7027  * interfaces are highly subject to change, so as much as possible is static to
7028  * this file.  An inversion list is here implemented as a malloc'd C UV array
7029  * as an SVt_INVLIST scalar.
7030  *
7031  * An inversion list for Unicode is an array of code points, sorted by ordinal
7032  * number.  The zeroth element is the first code point in the list.  The 1th
7033  * element is the first element beyond that not in the list.  In other words,
7034  * the first range is
7035  *  invlist[0]..(invlist[1]-1)
7036  * The other ranges follow.  Thus every element whose index is divisible by two
7037  * marks the beginning of a range that is in the list, and every element not
7038  * divisible by two marks the beginning of a range not in the list.  A single
7039  * element inversion list that contains the single code point N generally
7040  * consists of two elements
7041  *  invlist[0] == N
7042  *  invlist[1] == N+1
7043  * (The exception is when N is the highest representable value on the
7044  * machine, in which case the list containing just it would be a single
7045  * element, itself.  By extension, if the last range in the list extends to
7046  * infinity, then the first element of that range will be in the inversion list
7047  * at a position that is divisible by two, and is the final element in the
7048  * list.)
7049  * Taking the complement (inverting) an inversion list is quite simple, if the
7050  * first element is 0, remove it; otherwise add a 0 element at the beginning.
7051  * This implementation reserves an element at the beginning of each inversion
7052  * list to always contain 0; there is an additional flag in the header which
7053  * indicates if the list begins at the 0, or is offset to begin at the next
7054  * element.
7055  *
7056  * More about inversion lists can be found in "Unicode Demystified"
7057  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
7058  * More will be coming when functionality is added later.
7059  *
7060  * The inversion list data structure is currently implemented as an SV pointing
7061  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
7062  * array of UV whose memory management is automatically handled by the existing
7063  * facilities for SV's.
7064  *
7065  * Some of the methods should always be private to the implementation, and some
7066  * should eventually be made public */
7067
7068 /* The header definitions are in F<inline_invlist.c> */
7069
7070 PERL_STATIC_INLINE UV*
7071 S__invlist_array_init(pTHX_ SV* const invlist, const bool will_have_0)
7072 {
7073     /* Returns a pointer to the first element in the inversion list's array.
7074      * This is called upon initialization of an inversion list.  Where the
7075      * array begins depends on whether the list has the code point U+0000 in it
7076      * or not.  The other parameter tells it whether the code that follows this
7077      * call is about to put a 0 in the inversion list or not.  The first
7078      * element is either the element reserved for 0, if TRUE, or the element
7079      * after it, if FALSE */
7080
7081     bool* offset = get_invlist_offset_addr(invlist);
7082     UV* zero_addr = (UV *) SvPVX(invlist);
7083
7084     PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
7085
7086     /* Must be empty */
7087     assert(! _invlist_len(invlist));
7088
7089     *zero_addr = 0;
7090
7091     /* 1^1 = 0; 1^0 = 1 */
7092     *offset = 1 ^ will_have_0;
7093     return zero_addr + *offset;
7094 }
7095
7096 PERL_STATIC_INLINE UV*
7097 S_invlist_array(pTHX_ SV* const invlist)
7098 {
7099     /* Returns the pointer to the inversion list's array.  Every time the
7100      * length changes, this needs to be called in case malloc or realloc moved
7101      * it */
7102
7103     PERL_ARGS_ASSERT_INVLIST_ARRAY;
7104
7105     /* Must not be empty.  If these fail, you probably didn't check for <len>
7106      * being non-zero before trying to get the array */
7107     assert(_invlist_len(invlist));
7108
7109     /* The very first element always contains zero, The array begins either
7110      * there, or if the inversion list is offset, at the element after it.
7111      * The offset header field determines which; it contains 0 or 1 to indicate
7112      * how much additionally to add */
7113     assert(0 == *(SvPVX(invlist)));
7114     return ((UV *) SvPVX(invlist) + *get_invlist_offset_addr(invlist));
7115 }
7116
7117 PERL_STATIC_INLINE void
7118 S_invlist_set_len(pTHX_ SV* const invlist, const UV len, const bool offset)
7119 {
7120     /* Sets the current number of elements stored in the inversion list.
7121      * Updates SvCUR correspondingly */
7122
7123     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
7124
7125     SvCUR_set(invlist,
7126               (len == 0)
7127                ? 0
7128                : TO_INTERNAL_SIZE(len + offset));
7129     assert(SvLEN(invlist) == 0 || SvCUR(invlist) <= SvLEN(invlist));
7130 }
7131
7132 PERL_STATIC_INLINE IV*
7133 S_get_invlist_previous_index_addr(pTHX_ SV* invlist)
7134 {
7135     /* Return the address of the IV that is reserved to hold the cached index
7136      * */
7137
7138     PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR;
7139
7140     return &(((XINVLIST*) SvANY(invlist))->prev_index);
7141 }
7142
7143 PERL_STATIC_INLINE IV
7144 S_invlist_previous_index(pTHX_ SV* const invlist)
7145 {
7146     /* Returns cached index of previous search */
7147
7148     PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX;
7149
7150     return *get_invlist_previous_index_addr(invlist);
7151 }
7152
7153 PERL_STATIC_INLINE void
7154 S_invlist_set_previous_index(pTHX_ SV* const invlist, const IV index)
7155 {
7156     /* Caches <index> for later retrieval */
7157
7158     PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX;
7159
7160     assert(index == 0 || index < (int) _invlist_len(invlist));
7161
7162     *get_invlist_previous_index_addr(invlist) = index;
7163 }
7164
7165 PERL_STATIC_INLINE UV
7166 S_invlist_max(pTHX_ SV* const invlist)
7167 {
7168     /* Returns the maximum number of elements storable in the inversion list's
7169      * array, without having to realloc() */
7170
7171     PERL_ARGS_ASSERT_INVLIST_MAX;
7172
7173     /* Assumes worst case, in which the 0 element is not counted in the
7174      * inversion list, so subtracts 1 for that */
7175     return SvLEN(invlist) == 0  /* This happens under _new_invlist_C_array */
7176            ? FROM_INTERNAL_SIZE(SvCUR(invlist)) - 1
7177            : FROM_INTERNAL_SIZE(SvLEN(invlist)) - 1;
7178 }
7179
7180 #ifndef PERL_IN_XSUB_RE
7181 SV*
7182 Perl__new_invlist(pTHX_ IV initial_size)
7183 {
7184
7185     /* Return a pointer to a newly constructed inversion list, with enough
7186      * space to store 'initial_size' elements.  If that number is negative, a
7187      * system default is used instead */
7188
7189     SV* new_list;
7190
7191     if (initial_size < 0) {
7192         initial_size = 10;
7193     }
7194
7195     /* Allocate the initial space */
7196     new_list = newSV_type(SVt_INVLIST);
7197
7198     /* First 1 is in case the zero element isn't in the list; second 1 is for
7199      * trailing NUL */
7200     SvGROW(new_list, TO_INTERNAL_SIZE(initial_size + 1) + 1);
7201     invlist_set_len(new_list, 0, 0);
7202
7203     /* Force iterinit() to be used to get iteration to work */
7204     *get_invlist_iter_addr(new_list) = (STRLEN) UV_MAX;
7205
7206     *get_invlist_previous_index_addr(new_list) = 0;
7207
7208     return new_list;
7209 }
7210 #endif
7211
7212 STATIC SV*
7213 S__new_invlist_C_array(pTHX_ const UV* const list)
7214 {
7215     /* Return a pointer to a newly constructed inversion list, initialized to
7216      * point to <list>, which has to be in the exact correct inversion list
7217      * form, including internal fields.  Thus this is a dangerous routine that
7218      * should not be used in the wrong hands.  The passed in 'list' contains
7219      * several header fields at the beginning that are not part of the
7220      * inversion list body proper */
7221
7222     const STRLEN length = (STRLEN) list[0];
7223     const UV version_id =          list[1];
7224     const bool offset   =    cBOOL(list[2]);
7225 #define HEADER_LENGTH 3
7226     /* If any of the above changes in any way, you must change HEADER_LENGTH
7227      * (if appropriate) and regenerate INVLIST_VERSION_ID by running
7228      *      perl -E 'say int(rand 2**31-1)'
7229      */
7230 #define INVLIST_VERSION_ID 148565664 /* This is a combination of a version and
7231                                         data structure type, so that one being
7232                                         passed in can be validated to be an
7233                                         inversion list of the correct vintage.
7234                                        */
7235
7236     SV* invlist = newSV_type(SVt_INVLIST);
7237
7238     PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
7239
7240     if (version_id != INVLIST_VERSION_ID) {
7241         Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
7242     }
7243
7244     /* The generated array passed in includes header elements that aren't part
7245      * of the list proper, so start it just after them */
7246     SvPV_set(invlist, (char *) (list + HEADER_LENGTH));
7247
7248     SvLEN_set(invlist, 0);  /* Means we own the contents, and the system
7249                                shouldn't touch it */
7250
7251     *(get_invlist_offset_addr(invlist)) = offset;
7252
7253     /* The 'length' passed to us is the physical number of elements in the
7254      * inversion list.  But if there is an offset the logical number is one
7255      * less than that */
7256     invlist_set_len(invlist, length  - offset, offset);
7257
7258     invlist_set_previous_index(invlist, 0);
7259
7260     /* Initialize the iteration pointer. */
7261     invlist_iterfinish(invlist);
7262
7263     return invlist;
7264 }
7265
7266 STATIC void
7267 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
7268 {
7269     /* Grow the maximum size of an inversion list */
7270
7271     PERL_ARGS_ASSERT_INVLIST_EXTEND;
7272
7273     /* Add one to account for the zero element at the beginning which may not
7274      * be counted by the calling parameters */
7275     SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max + 1));
7276 }
7277
7278 PERL_STATIC_INLINE void
7279 S_invlist_trim(pTHX_ SV* const invlist)
7280 {
7281     PERL_ARGS_ASSERT_INVLIST_TRIM;
7282
7283     /* Change the length of the inversion list to how many entries it currently
7284      * has */
7285     SvPV_shrink_to_cur((SV *) invlist);
7286 }
7287
7288 #define _invlist_union_complement_2nd(a, b, output) _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
7289
7290 STATIC void
7291 S__append_range_to_invlist(pTHX_ SV* const invlist, const UV start, const UV end)
7292 {
7293    /* Subject to change or removal.  Append the range from 'start' to 'end' at
7294     * the end of the inversion list.  The range must be above any existing
7295     * ones. */
7296
7297     UV* array;
7298     UV max = invlist_max(invlist);
7299     UV len = _invlist_len(invlist);
7300     bool offset;
7301
7302     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
7303
7304     if (len == 0) { /* Empty lists must be initialized */
7305         offset = start != 0;
7306         array = _invlist_array_init(invlist, ! offset);
7307     }
7308     else {
7309         /* Here, the existing list is non-empty. The current max entry in the
7310          * list is generally the first value not in the set, except when the
7311          * set extends to the end of permissible values, in which case it is
7312          * the first entry in that final set, and so this call is an attempt to
7313          * append out-of-order */
7314
7315         UV final_element = len - 1;
7316         array = invlist_array(invlist);
7317         if (array[final_element] > start
7318             || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
7319         {
7320             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",
7321                        array[final_element], start,
7322                        ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
7323         }
7324
7325         /* Here, it is a legal append.  If the new range begins with the first
7326          * value not in the set, it is extending the set, so the new first
7327          * value not in the set is one greater than the newly extended range.
7328          * */
7329         offset = *get_invlist_offset_addr(invlist);
7330         if (array[final_element] == start) {
7331             if (end != UV_MAX) {
7332                 array[final_element] = end + 1;
7333             }
7334             else {
7335                 /* But if the end is the maximum representable on the machine,
7336                  * just let the range that this would extend to have no end */
7337                 invlist_set_len(invlist, len - 1, offset);
7338             }
7339             return;
7340         }
7341     }
7342
7343     /* Here the new range doesn't extend any existing set.  Add it */
7344
7345     len += 2;   /* Includes an element each for the start and end of range */
7346
7347     /* If wll overflow the existing space, extend, which may cause the array to
7348      * be moved */
7349     if (max < len) {
7350         invlist_extend(invlist, len);
7351
7352         /* Have to set len here to avoid assert failure in invlist_array() */
7353         invlist_set_len(invlist, len, offset);
7354
7355         array = invlist_array(invlist);
7356     }
7357     else {
7358         invlist_set_len(invlist, len, offset);
7359     }
7360
7361     /* The next item on the list starts the range, the one after that is
7362      * one past the new range.  */
7363     array[len - 2] = start;
7364     if (end != UV_MAX) {
7365         array[len - 1] = end + 1;
7366     }
7367     else {
7368         /* But if the end is the maximum representable on the machine, just let
7369          * the range have no end */
7370         invlist_set_len(invlist, len - 1, offset);
7371     }
7372 }
7373
7374 #ifndef PERL_IN_XSUB_RE
7375
7376 IV
7377 Perl__invlist_search(pTHX_ SV* const invlist, const UV cp)
7378 {
7379     /* Searches the inversion list for the entry that contains the input code
7380      * point <cp>.  If <cp> is not in the list, -1 is returned.  Otherwise, the
7381      * return value is the index into the list's array of the range that
7382      * contains <cp> */
7383
7384     IV low = 0;
7385     IV mid;
7386     IV high = _invlist_len(invlist);
7387     const IV highest_element = high - 1;
7388     const UV* array;
7389
7390     PERL_ARGS_ASSERT__INVLIST_SEARCH;
7391
7392     /* If list is empty, return failure. */
7393     if (high == 0) {
7394         return -1;
7395     }
7396
7397     /* (We can't get the array unless we know the list is non-empty) */
7398     array = invlist_array(invlist);
7399
7400     mid = invlist_previous_index(invlist);
7401     assert(mid >=0 && mid <= highest_element);
7402
7403     /* <mid> contains the cache of the result of the previous call to this
7404      * function (0 the first time).  See if this call is for the same result,
7405      * or if it is for mid-1.  This is under the theory that calls to this
7406      * function will often be for related code points that are near each other.
7407      * And benchmarks show that caching gives better results.  We also test
7408      * here if the code point is within the bounds of the list.  These tests
7409      * replace others that would have had to be made anyway to make sure that
7410      * the array bounds were not exceeded, and these give us extra information
7411      * at the same time */
7412     if (cp >= array[mid]) {
7413         if (cp >= array[highest_element]) {
7414             return highest_element;
7415         }
7416
7417         /* Here, array[mid] <= cp < array[highest_element].  This means that
7418          * the final element is not the answer, so can exclude it; it also
7419          * means that <mid> is not the final element, so can refer to 'mid + 1'
7420          * safely */
7421         if (cp < array[mid + 1]) {
7422             return mid;
7423         }
7424         high--;
7425         low = mid + 1;
7426     }
7427     else { /* cp < aray[mid] */
7428         if (cp < array[0]) { /* Fail if outside the array */
7429             return -1;
7430         }
7431         high = mid;
7432         if (cp >= array[mid - 1]) {
7433             goto found_entry;
7434         }
7435     }
7436
7437     /* Binary search.  What we are looking for is <i> such that
7438      *  array[i] <= cp < array[i+1]
7439      * The loop below converges on the i+1.  Note that there may not be an
7440      * (i+1)th element in the array, and things work nonetheless */
7441     while (low < high) {
7442         mid = (low + high) / 2;
7443         assert(mid <= highest_element);
7444         if (array[mid] <= cp) { /* cp >= array[mid] */
7445             low = mid + 1;
7446
7447             /* We could do this extra test to exit the loop early.
7448             if (cp < array[low]) {
7449                 return mid;
7450             }
7451             */
7452         }
7453         else { /* cp < array[mid] */
7454             high = mid;
7455         }
7456     }
7457
7458   found_entry:
7459     high--;
7460     invlist_set_previous_index(invlist, high);
7461     return high;
7462 }
7463
7464 void
7465 Perl__invlist_populate_swatch(pTHX_ SV* const invlist, const UV start, const UV end, U8* swatch)
7466 {
7467     /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
7468      * but is used when the swash has an inversion list.  This makes this much
7469      * faster, as it uses a binary search instead of a linear one.  This is
7470      * intimately tied to that function, and perhaps should be in utf8.c,
7471      * except it is intimately tied to inversion lists as well.  It assumes
7472      * that <swatch> is all 0's on input */
7473
7474     UV current = start;
7475     const IV len = _invlist_len(invlist);
7476     IV i;
7477     const UV * array;
7478
7479     PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
7480
7481     if (len == 0) { /* Empty inversion list */
7482         return;
7483     }
7484
7485     array = invlist_array(invlist);
7486
7487     /* Find which element it is */
7488     i = _invlist_search(invlist, start);
7489
7490     /* We populate from <start> to <end> */
7491     while (current < end) {
7492         UV upper;
7493
7494         /* The inversion list gives the results for every possible code point
7495          * after the first one in the list.  Only those ranges whose index is
7496          * even are ones that the inversion list matches.  For the odd ones,
7497          * and if the initial code point is not in the list, we have to skip
7498          * forward to the next element */
7499         if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
7500             i++;
7501             if (i >= len) { /* Finished if beyond the end of the array */
7502                 return;
7503             }
7504             current = array[i];
7505             if (current >= end) {   /* Finished if beyond the end of what we
7506                                        are populating */
7507                 if (LIKELY(end < UV_MAX)) {
7508                     return;
7509                 }
7510
7511                 /* We get here when the upper bound is the maximum
7512                  * representable on the machine, and we are looking for just
7513                  * that code point.  Have to special case it */
7514                 i = len;
7515                 goto join_end_of_list;
7516             }
7517         }
7518         assert(current >= start);
7519
7520         /* The current range ends one below the next one, except don't go past
7521          * <end> */
7522         i++;
7523         upper = (i < len && array[i] < end) ? array[i] : end;
7524
7525         /* Here we are in a range that matches.  Populate a bit in the 3-bit U8
7526          * for each code point in it */
7527         for (; current < upper; current++) {
7528             const STRLEN offset = (STRLEN)(current - start);
7529             swatch[offset >> 3] |= 1 << (offset & 7);
7530         }
7531
7532     join_end_of_list:
7533
7534         /* Quit if at the end of the list */
7535         if (i >= len) {
7536
7537             /* But first, have to deal with the highest possible code point on
7538              * the platform.  The previous code assumes that <end> is one
7539              * beyond where we want to populate, but that is impossible at the
7540              * platform's infinity, so have to handle it specially */
7541             if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
7542             {
7543                 const STRLEN offset = (STRLEN)(end - start);
7544                 swatch[offset >> 3] |= 1 << (offset & 7);
7545             }
7546             return;
7547         }
7548
7549         /* Advance to the next range, which will be for code points not in the
7550          * inversion list */
7551         current = array[i];
7552     }
7553
7554     return;
7555 }
7556
7557 void
7558 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, const bool complement_b, SV** output)
7559 {
7560     /* Take the union of two inversion lists and point <output> to it.  *output
7561      * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
7562      * the reference count to that list will be decremented.  The first list,
7563      * <a>, may be NULL, in which case a copy of the second list is returned.
7564      * If <complement_b> is TRUE, the union is taken of the complement
7565      * (inversion) of <b> instead of b itself.
7566      *
7567      * The basis for this comes from "Unicode Demystified" Chapter 13 by
7568      * Richard Gillam, published by Addison-Wesley, and explained at some
7569      * length there.  The preface says to incorporate its examples into your
7570      * code at your own risk.
7571      *
7572      * The algorithm is like a merge sort.
7573      *
7574      * XXX A potential performance improvement is to keep track as we go along
7575      * if only one of the inputs contributes to the result, meaning the other
7576      * is a subset of that one.  In that case, we can skip the final copy and
7577      * return the larger of the input lists, but then outside code might need
7578      * to keep track of whether to free the input list or not */
7579
7580     const UV* array_a;    /* a's array */
7581     const UV* array_b;
7582     UV len_a;       /* length of a's array */
7583     UV len_b;
7584
7585     SV* u;                      /* the resulting union */
7586     UV* array_u;
7587     UV len_u;
7588
7589     UV i_a = 0;             /* current index into a's array */
7590     UV i_b = 0;
7591     UV i_u = 0;
7592
7593     /* running count, as explained in the algorithm source book; items are
7594      * stopped accumulating and are output when the count changes to/from 0.
7595      * The count is incremented when we start a range that's in the set, and
7596      * decremented when we start a range that's not in the set.  So its range
7597      * is 0 to 2.  Only when the count is zero is something not in the set.
7598      */
7599     UV count = 0;
7600
7601     PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
7602     assert(a != b);
7603
7604     /* If either one is empty, the union is the other one */
7605     if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
7606         if (*output == a) {
7607             if (a != NULL) {
7608                 SvREFCNT_dec_NN(a);
7609             }
7610         }
7611         if (*output != b) {
7612             *output = invlist_clone(b);
7613             if (complement_b) {
7614                 _invlist_invert(*output);
7615             }
7616         } /* else *output already = b; */
7617         return;
7618     }
7619     else if ((len_b = _invlist_len(b)) == 0) {
7620         if (*output == b) {
7621             SvREFCNT_dec_NN(b);
7622         }
7623
7624         /* The complement of an empty list is a list that has everything in it,
7625          * so the union with <a> includes everything too */
7626         if (complement_b) {
7627             if (a == *output) {
7628                 SvREFCNT_dec_NN(a);
7629             }
7630             *output = _new_invlist(1);
7631             _append_range_to_invlist(*output, 0, UV_MAX);
7632         }
7633         else if (*output != a) {
7634             *output = invlist_clone(a);
7635         }
7636         /* else *output already = a; */
7637         return;
7638     }
7639
7640     /* Here both lists exist and are non-empty */
7641     array_a = invlist_array(a);
7642     array_b = invlist_array(b);
7643
7644     /* If are to take the union of 'a' with the complement of b, set it
7645      * up so are looking at b's complement. */
7646     if (complement_b) {
7647
7648         /* To complement, we invert: if the first element is 0, remove it.  To
7649          * do this, we just pretend the array starts one later */
7650         if (array_b[0] == 0) {
7651             array_b++;
7652             len_b--;
7653         }
7654         else {
7655
7656             /* But if the first element is not zero, we pretend the list starts
7657              * at the 0 that is always stored immediately before the array. */
7658             array_b--;
7659             len_b++;
7660         }
7661     }
7662
7663     /* Size the union for the worst case: that the sets are completely
7664      * disjoint */
7665     u = _new_invlist(len_a + len_b);
7666
7667     /* Will contain U+0000 if either component does */
7668     array_u = _invlist_array_init(u, (len_a > 0 && array_a[0] == 0)
7669                                       || (len_b > 0 && array_b[0] == 0));
7670
7671     /* Go through each list item by item, stopping when exhausted one of
7672      * them */
7673     while (i_a < len_a && i_b < len_b) {
7674         UV cp;      /* The element to potentially add to the union's array */
7675         bool cp_in_set;   /* is it in the the input list's set or not */
7676
7677         /* We need to take one or the other of the two inputs for the union.
7678          * Since we are merging two sorted lists, we take the smaller of the
7679          * next items.  In case of a tie, we take the one that is in its set
7680          * first.  If we took one not in the set first, it would decrement the
7681          * count, possibly to 0 which would cause it to be output as ending the
7682          * range, and the next time through we would take the same number, and
7683          * output it again as beginning the next range.  By doing it the
7684          * opposite way, there is no possibility that the count will be
7685          * momentarily decremented to 0, and thus the two adjoining ranges will
7686          * be seamlessly merged.  (In a tie and both are in the set or both not
7687          * in the set, it doesn't matter which we take first.) */
7688         if (array_a[i_a] < array_b[i_b]
7689             || (array_a[i_a] == array_b[i_b]
7690                 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
7691         {
7692             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
7693             cp= array_a[i_a++];
7694         }
7695         else {
7696             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
7697             cp = array_b[i_b++];
7698         }
7699
7700         /* Here, have chosen which of the two inputs to look at.  Only output
7701          * if the running count changes to/from 0, which marks the
7702          * beginning/end of a range in that's in the set */
7703         if (cp_in_set) {
7704             if (count == 0) {
7705                 array_u[i_u++] = cp;
7706             }
7707             count++;
7708         }
7709         else {
7710             count--;
7711             if (count == 0) {
7712                 array_u[i_u++] = cp;
7713             }
7714         }
7715     }
7716
7717     /* Here, we are finished going through at least one of the lists, which
7718      * means there is something remaining in at most one.  We check if the list
7719      * that hasn't been exhausted is positioned such that we are in the middle
7720      * of a range in its set or not.  (i_a and i_b point to the element beyond
7721      * the one we care about.) If in the set, we decrement 'count'; if 0, there
7722      * is potentially more to output.
7723      * There are four cases:
7724      *  1) Both weren't in their sets, count is 0, and remains 0.  What's left
7725      *     in the union is entirely from the non-exhausted set.
7726      *  2) Both were in their sets, count is 2.  Nothing further should
7727      *     be output, as everything that remains will be in the exhausted
7728      *     list's set, hence in the union; decrementing to 1 but not 0 insures
7729      *     that
7730      *  3) the exhausted was in its set, non-exhausted isn't, count is 1.
7731      *     Nothing further should be output because the union includes
7732      *     everything from the exhausted set.  Not decrementing ensures that.
7733      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1;
7734      *     decrementing to 0 insures that we look at the remainder of the
7735      *     non-exhausted set */
7736     if ((i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
7737         || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
7738     {
7739         count--;
7740     }
7741
7742     /* The final length is what we've output so far, plus what else is about to
7743      * be output.  (If 'count' is non-zero, then the input list we exhausted
7744      * has everything remaining up to the machine's limit in its set, and hence
7745      * in the union, so there will be no further output. */
7746     len_u = i_u;
7747     if (count == 0) {
7748         /* At most one of the subexpressions will be non-zero */
7749         len_u += (len_a - i_a) + (len_b - i_b);
7750     }
7751
7752     /* Set result to final length, which can change the pointer to array_u, so
7753      * re-find it */
7754     if (len_u != _invlist_len(u)) {
7755         invlist_set_len(u, len_u, *get_invlist_offset_addr(u));
7756         invlist_trim(u);
7757         array_u = invlist_array(u);
7758     }
7759
7760     /* When 'count' is 0, the list that was exhausted (if one was shorter than
7761      * the other) ended with everything above it not in its set.  That means
7762      * that the remaining part of the union is precisely the same as the
7763      * non-exhausted list, so can just copy it unchanged.  (If both list were
7764      * exhausted at the same time, then the operations below will be both 0.)
7765      */
7766     if (count == 0) {
7767         IV copy_count; /* At most one will have a non-zero copy count */
7768         if ((copy_count = len_a - i_a) > 0) {
7769             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
7770         }
7771         else if ((copy_count = len_b - i_b) > 0) {
7772             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
7773         }
7774     }
7775
7776     /*  We may be removing a reference to one of the inputs */
7777     if (a == *output || b == *output) {
7778         assert(! invlist_is_iterating(*output));
7779         SvREFCNT_dec_NN(*output);
7780     }
7781
7782     *output = u;
7783     return;
7784 }
7785
7786 void
7787 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, const bool complement_b, SV** i)
7788 {
7789     /* Take the intersection of two inversion lists and point <i> to it.  *i
7790      * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
7791      * the reference count to that list will be decremented.
7792      * If <complement_b> is TRUE, the result will be the intersection of <a>
7793      * and the complement (or inversion) of <b> instead of <b> directly.
7794      *
7795      * The basis for this comes from "Unicode Demystified" Chapter 13 by
7796      * Richard Gillam, published by Addison-Wesley, and explained at some
7797      * length there.  The preface says to incorporate its examples into your
7798      * code at your own risk.  In fact, it had bugs
7799      *
7800      * The algorithm is like a merge sort, and is essentially the same as the
7801      * union above
7802      */
7803
7804     const UV* array_a;          /* a's array */
7805     const UV* array_b;
7806     UV len_a;   /* length of a's array */
7807     UV len_b;
7808
7809     SV* r;                   /* the resulting intersection */
7810     UV* array_r;
7811     UV len_r;
7812
7813     UV i_a = 0;             /* current index into a's array */
7814     UV i_b = 0;
7815     UV i_r = 0;
7816
7817     /* running count, as explained in the algorithm source book; items are
7818      * stopped accumulating and are output when the count changes to/from 2.
7819      * The count is incremented when we start a range that's in the set, and
7820      * decremented when we start a range that's not in the set.  So its range
7821      * is 0 to 2.  Only when the count is 2 is something in the intersection.
7822      */
7823     UV count = 0;
7824
7825     PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
7826     assert(a != b);
7827
7828     /* Special case if either one is empty */
7829     len_a = _invlist_len(a);
7830     if ((len_a == 0) || ((len_b = _invlist_len(b)) == 0)) {
7831
7832         if (len_a != 0 && complement_b) {
7833
7834             /* Here, 'a' is not empty, therefore from the above 'if', 'b' must
7835              * be empty.  Here, also we are using 'b's complement, which hence
7836              * must be every possible code point.  Thus the intersection is
7837              * simply 'a'. */
7838             if (*i != a) {
7839                 *i = invlist_clone(a);
7840
7841                 if (*i == b) {
7842                     SvREFCNT_dec_NN(b);
7843                 }
7844             }
7845             /* else *i is already 'a' */
7846             return;
7847         }
7848
7849         /* Here, 'a' or 'b' is empty and not using the complement of 'b'.  The
7850          * intersection must be empty */
7851         if (*i == a) {
7852             SvREFCNT_dec_NN(a);
7853         }
7854         else if (*i == b) {
7855             SvREFCNT_dec_NN(b);
7856         }
7857         *i = _new_invlist(0);
7858         return;
7859     }
7860
7861     /* Here both lists exist and are non-empty */
7862     array_a = invlist_array(a);
7863     array_b = invlist_array(b);
7864
7865     /* If are to take the intersection of 'a' with the complement of b, set it
7866      * up so are looking at b's complement. */
7867     if (complement_b) {
7868
7869         /* To complement, we invert: if the first element is 0, remove it.  To
7870          * do this, we just pretend the array starts one later */
7871         if (array_b[0] == 0) {
7872             array_b++;
7873             len_b--;
7874         }
7875         else {
7876
7877             /* But if the first element is not zero, we pretend the list starts
7878              * at the 0 that is always stored immediately before the array. */
7879             array_b--;
7880             len_b++;
7881         }
7882     }
7883
7884     /* Size the intersection for the worst case: that the intersection ends up
7885      * fragmenting everything to be completely disjoint */
7886     r= _new_invlist(len_a + len_b);
7887
7888     /* Will contain U+0000 iff both components do */
7889     array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
7890                                      && len_b > 0 && array_b[0] == 0);
7891
7892     /* Go through each list item by item, stopping when exhausted one of
7893      * them */
7894     while (i_a < len_a && i_b < len_b) {
7895         UV cp;      /* The element to potentially add to the intersection's
7896                        array */
7897         bool cp_in_set; /* Is it in the input list's set or not */
7898
7899         /* We need to take one or the other of the two inputs for the
7900          * intersection.  Since we are merging two sorted lists, we take the
7901          * smaller of the next items.  In case of a tie, we take the one that
7902          * is not in its set first (a difference from the union algorithm).  If
7903          * we took one in the set first, it would increment the count, possibly
7904          * to 2 which would cause it to be output as starting a range in the
7905          * intersection, and the next time through we would take that same
7906          * number, and output it again as ending the set.  By doing it the
7907          * opposite of this, there is no possibility that the count will be
7908          * momentarily incremented to 2.  (In a tie and both are in the set or
7909          * both not in the set, it doesn't matter which we take first.) */
7910         if (array_a[i_a] < array_b[i_b]
7911             || (array_a[i_a] == array_b[i_b]
7912                 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
7913         {
7914             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
7915             cp= array_a[i_a++];
7916         }
7917         else {
7918             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
7919             cp= array_b[i_b++];
7920         }
7921
7922         /* Here, have chosen which of the two inputs to look at.  Only output
7923          * if the running count changes to/from 2, which marks the
7924          * beginning/end of a range that's in the intersection */
7925         if (cp_in_set) {
7926             count++;
7927             if (count == 2) {
7928                 array_r[i_r++] = cp;
7929             }
7930         }
7931         else {
7932             if (count == 2) {
7933                 array_r[i_r++] = cp;
7934             }
7935             count--;
7936         }
7937     }
7938
7939     /* Here, we are finished going through at least one of the lists, which
7940      * means there is something remaining in at most one.  We check if the list
7941      * that has been exhausted is positioned such that we are in the middle
7942      * of a range in its set or not.  (i_a and i_b point to elements 1 beyond
7943      * the ones we care about.)  There are four cases:
7944      *  1) Both weren't in their sets, count is 0, and remains 0.  There's
7945      *     nothing left in the intersection.
7946      *  2) Both were in their sets, count is 2 and perhaps is incremented to
7947      *     above 2.  What should be output is exactly that which is in the
7948      *     non-exhausted set, as everything it has is also in the intersection
7949      *     set, and everything it doesn't have can't be in the intersection
7950      *  3) The exhausted was in its set, non-exhausted isn't, count is 1, and
7951      *     gets incremented to 2.  Like the previous case, the intersection is
7952      *     everything that remains in the non-exhausted set.
7953      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1, and
7954      *     remains 1.  And the intersection has nothing more. */
7955     if ((i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
7956         || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
7957     {
7958         count++;
7959     }
7960
7961     /* The final length is what we've output so far plus what else is in the
7962      * intersection.  At most one of the subexpressions below will be non-zero */
7963     len_r = i_r;
7964     if (count >= 2) {
7965         len_r += (len_a - i_a) + (len_b - i_b);
7966     }
7967
7968     /* Set result to final length, which can change the pointer to array_r, so
7969      * re-find it */
7970     if (len_r != _invlist_len(r)) {
7971         invlist_set_len(r, len_r, *get_invlist_offset_addr(r));
7972         invlist_trim(r);
7973         array_r = invlist_array(r);
7974     }
7975
7976     /* Finish outputting any remaining */
7977     if (count >= 2) { /* At most one will have a non-zero copy count */
7978         IV copy_count;
7979         if ((copy_count = len_a - i_a) > 0) {
7980             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
7981         }
7982         else if ((copy_count = len_b - i_b) > 0) {
7983             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
7984         }
7985     }
7986
7987     /*  We may be removing a reference to one of the inputs */
7988     if (a == *i || b == *i) {
7989         assert(! invlist_is_iterating(*i));
7990         SvREFCNT_dec_NN(*i);
7991     }
7992
7993     *i = r;
7994     return;
7995 }
7996
7997 SV*
7998 Perl__add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end)
7999 {
8000     /* Add the range from 'start' to 'end' inclusive to the inversion list's
8001      * set.  A pointer to the inversion list is returned.  This may actually be
8002      * a new list, in which case the passed in one has been destroyed.  The
8003      * passed in inversion list can be NULL, in which case a new one is created
8004      * with just the one range in it */
8005
8006     SV* range_invlist;
8007     UV len;
8008
8009     if (invlist == NULL) {
8010         invlist = _new_invlist(2);
8011         len = 0;
8012     }
8013     else {
8014         len = _invlist_len(invlist);
8015     }
8016
8017     /* If comes after the final entry actually in the list, can just append it
8018      * to the end, */
8019     if (len == 0
8020         || (! ELEMENT_RANGE_MATCHES_INVLIST(len - 1)
8021             && start >= invlist_array(invlist)[len - 1]))
8022     {
8023         _append_range_to_invlist(invlist, start, end);
8024         return invlist;
8025     }
8026
8027     /* Here, can't just append things, create and return a new inversion list
8028      * which is the union of this range and the existing inversion list */
8029     range_invlist = _new_invlist(2);
8030     _append_range_to_invlist(range_invlist, start, end);
8031
8032     _invlist_union(invlist, range_invlist, &invlist);
8033
8034     /* The temporary can be freed */
8035     SvREFCNT_dec_NN(range_invlist);
8036
8037     return invlist;
8038 }
8039
8040 #endif
8041
8042 PERL_STATIC_INLINE SV*
8043 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
8044     return _add_range_to_invlist(invlist, cp, cp);
8045 }
8046
8047 #ifndef PERL_IN_XSUB_RE
8048 void
8049 Perl__invlist_invert(pTHX_ SV* const invlist)
8050 {
8051     /* Complement the input inversion list.  This adds a 0 if the list didn't
8052      * have a zero; removes it otherwise.  As described above, the data
8053      * structure is set up so that this is very efficient */
8054
8055     PERL_ARGS_ASSERT__INVLIST_INVERT;
8056
8057     assert(! invlist_is_iterating(invlist));
8058
8059     /* The inverse of matching nothing is matching everything */
8060     if (_invlist_len(invlist) == 0) {
8061         _append_range_to_invlist(invlist, 0, UV_MAX);
8062         return;
8063     }
8064
8065     *get_invlist_offset_addr(invlist) = ! *get_invlist_offset_addr(invlist);
8066 }
8067
8068 void
8069 Perl__invlist_invert_prop(pTHX_ SV* const invlist)
8070 {
8071     /* Complement the input inversion list (which must be a Unicode property,
8072      * all of which don't match above the Unicode maximum code point.)  And
8073      * Perl has chosen to not have the inversion match above that either.  This
8074      * adds a 0x110000 if the list didn't end with it, and removes it if it did
8075      */
8076
8077     UV len;
8078     UV* array;
8079
8080     PERL_ARGS_ASSERT__INVLIST_INVERT_PROP;
8081
8082     _invlist_invert(invlist);
8083
8084     len = _invlist_len(invlist);
8085
8086     if (len != 0) { /* If empty do nothing */
8087         array = invlist_array(invlist);
8088         if (array[len - 1] != PERL_UNICODE_MAX + 1) {
8089             /* Add 0x110000.  First, grow if necessary */
8090             len++;
8091             if (invlist_max(invlist) < len) {
8092                 invlist_extend(invlist, len);
8093                 array = invlist_array(invlist);
8094             }
8095             invlist_set_len(invlist, len, *get_invlist_offset_addr(invlist));
8096             array[len - 1] = PERL_UNICODE_MAX + 1;
8097         }
8098         else {  /* Remove the 0x110000 */
8099             invlist_set_len(invlist, len - 1, *get_invlist_offset_addr(invlist));
8100         }
8101     }
8102
8103     return;
8104 }
8105 #endif
8106
8107 PERL_STATIC_INLINE SV*
8108 S_invlist_clone(pTHX_ SV* const invlist)
8109 {
8110
8111     /* Return a new inversion list that is a copy of the input one, which is
8112      * unchanged */
8113
8114     /* Need to allocate extra space to accommodate Perl's addition of a
8115      * trailing NUL to SvPV's, since it thinks they are always strings */
8116     SV* new_invlist = _new_invlist(_invlist_len(invlist) + 1);
8117     STRLEN physical_length = SvCUR(invlist);
8118     bool offset = *(get_invlist_offset_addr(invlist));
8119
8120     PERL_ARGS_ASSERT_INVLIST_CLONE;
8121
8122     *(get_invlist_offset_addr(new_invlist)) = offset;
8123     invlist_set_len(new_invlist, _invlist_len(invlist), offset);
8124     Copy(SvPVX(invlist), SvPVX(new_invlist), physical_length, char);
8125
8126     return new_invlist;
8127 }
8128
8129 PERL_STATIC_INLINE STRLEN*
8130 S_get_invlist_iter_addr(pTHX_ SV* invlist)
8131 {
8132     /* Return the address of the UV that contains the current iteration
8133      * position */
8134
8135     PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
8136
8137     return &(((XINVLIST*) SvANY(invlist))->iterator);
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) = (STRLEN) 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     STRLEN* 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 = (STRLEN) 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)) < (STRLEN) 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, const 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     const UV* array_a = invlist_array(a);
8314     const 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 */
8337
8338             array_b++;
8339             len_b--;
8340         }
8341         else {
8342
8343             /* But if the first element is not zero, we pretend the list starts
8344              * at the 0 that is always stored immediately before the array. */
8345             array_b--;
8346             len_b++;
8347             array_b[0] = 0;
8348         }
8349     }
8350
8351     /* Make sure that the lengths are the same, as well as the final element
8352      * before looping through the remainder.  (Thus we test the length, final,
8353      * and first elements right off the bat) */
8354     if (len_a != len_b || array_a[len_a-1] != array_b[len_a-1]) {
8355         retval = FALSE;
8356     }
8357     else for (i = 0; i < len_a - 1; i++) {
8358         if (array_a[i] != array_b[i]) {
8359             retval = FALSE;
8360             break;
8361         }
8362     }
8363
8364     return retval;
8365 }
8366 #endif
8367
8368 #undef HEADER_LENGTH
8369 #undef TO_INTERNAL_SIZE
8370 #undef FROM_INTERNAL_SIZE
8371 #undef INVLIST_VERSION_ID
8372
8373 /* End of inversion list object */
8374
8375 STATIC void
8376 S_parse_lparen_question_flags(pTHX_ struct RExC_state_t *pRExC_state)
8377 {
8378     /* This parses the flags that are in either the '(?foo)' or '(?foo:bar)'
8379      * constructs, and updates RExC_flags with them.  On input, RExC_parse
8380      * should point to the first flag; it is updated on output to point to the
8381      * final ')' or ':'.  There needs to be at least one flag, or this will
8382      * abort */
8383
8384     /* for (?g), (?gc), and (?o) warnings; warning
8385        about (?c) will warn about (?g) -- japhy    */
8386
8387 #define WASTED_O  0x01
8388 #define WASTED_G  0x02
8389 #define WASTED_C  0x04
8390 #define WASTED_GC (WASTED_G|WASTED_C)
8391     I32 wastedflags = 0x00;
8392     U32 posflags = 0, negflags = 0;
8393     U32 *flagsp = &posflags;
8394     char has_charset_modifier = '\0';
8395     regex_charset cs;
8396     bool has_use_defaults = FALSE;
8397     const char* const seqstart = RExC_parse - 1; /* Point to the '?' */
8398
8399     PERL_ARGS_ASSERT_PARSE_LPAREN_QUESTION_FLAGS;
8400
8401     /* '^' as an initial flag sets certain defaults */
8402     if (UCHARAT(RExC_parse) == '^') {
8403         RExC_parse++;
8404         has_use_defaults = TRUE;
8405         STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
8406         set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
8407                                         ? REGEX_UNICODE_CHARSET
8408                                         : REGEX_DEPENDS_CHARSET);
8409     }
8410
8411     cs = get_regex_charset(RExC_flags);
8412     if (cs == REGEX_DEPENDS_CHARSET
8413         && (RExC_utf8 || RExC_uni_semantics))
8414     {
8415         cs = REGEX_UNICODE_CHARSET;
8416     }
8417
8418     while (*RExC_parse) {
8419         /* && strchr("iogcmsx", *RExC_parse) */
8420         /* (?g), (?gc) and (?o) are useless here
8421            and must be globally applied -- japhy */
8422         switch (*RExC_parse) {
8423
8424             /* Code for the imsx flags */
8425             CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
8426
8427             case LOCALE_PAT_MOD:
8428                 if (has_charset_modifier) {
8429                     goto excess_modifier;
8430                 }
8431                 else if (flagsp == &negflags) {
8432                     goto neg_modifier;
8433                 }
8434                 cs = REGEX_LOCALE_CHARSET;
8435                 has_charset_modifier = LOCALE_PAT_MOD;
8436                 RExC_contains_locale = 1;
8437                 break;
8438             case UNICODE_PAT_MOD:
8439                 if (has_charset_modifier) {
8440                     goto excess_modifier;
8441                 }
8442                 else if (flagsp == &negflags) {
8443                     goto neg_modifier;
8444                 }
8445                 cs = REGEX_UNICODE_CHARSET;
8446                 has_charset_modifier = UNICODE_PAT_MOD;
8447                 break;
8448             case ASCII_RESTRICT_PAT_MOD:
8449                 if (flagsp == &negflags) {
8450                     goto neg_modifier;
8451                 }
8452                 if (has_charset_modifier) {
8453                     if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
8454                         goto excess_modifier;
8455                     }
8456                     /* Doubled modifier implies more restricted */
8457                     cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
8458                 }
8459                 else {
8460                     cs = REGEX_ASCII_RESTRICTED_CHARSET;
8461                 }
8462                 has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
8463                 break;
8464             case DEPENDS_PAT_MOD:
8465                 if (has_use_defaults) {
8466                     goto fail_modifiers;
8467                 }
8468                 else if (flagsp == &negflags) {
8469                     goto neg_modifier;
8470                 }
8471                 else if (has_charset_modifier) {
8472                     goto excess_modifier;
8473                 }
8474
8475                 /* The dual charset means unicode semantics if the
8476                  * pattern (or target, not known until runtime) are
8477                  * utf8, or something in the pattern indicates unicode
8478                  * semantics */
8479                 cs = (RExC_utf8 || RExC_uni_semantics)
8480                      ? REGEX_UNICODE_CHARSET
8481                      : REGEX_DEPENDS_CHARSET;
8482                 has_charset_modifier = DEPENDS_PAT_MOD;
8483                 break;
8484             excess_modifier:
8485                 RExC_parse++;
8486                 if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
8487                     vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
8488                 }
8489                 else if (has_charset_modifier == *(RExC_parse - 1)) {
8490                     vFAIL2("Regexp modifier \"%c\" may not appear twice", *(RExC_parse - 1));
8491                 }
8492                 else {
8493                     vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
8494                 }
8495                 /*NOTREACHED*/
8496             neg_modifier:
8497                 RExC_parse++;
8498                 vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", *(RExC_parse - 1));
8499                 /*NOTREACHED*/
8500             case ONCE_PAT_MOD: /* 'o' */
8501             case GLOBAL_PAT_MOD: /* 'g' */
8502                 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
8503                     const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
8504                     if (! (wastedflags & wflagbit) ) {
8505                         wastedflags |= wflagbit;
8506                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
8507                         vWARN5(
8508                             RExC_parse + 1,
8509                             "Useless (%s%c) - %suse /%c modifier",
8510                             flagsp == &negflags ? "?-" : "?",
8511                             *RExC_parse,
8512                             flagsp == &negflags ? "don't " : "",
8513                             *RExC_parse
8514                         );
8515                     }
8516                 }
8517                 break;
8518
8519             case CONTINUE_PAT_MOD: /* 'c' */
8520                 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
8521                     if (! (wastedflags & WASTED_C) ) {
8522                         wastedflags |= WASTED_GC;
8523                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
8524                         vWARN3(
8525                             RExC_parse + 1,
8526                             "Useless (%sc) - %suse /gc modifier",
8527                             flagsp == &negflags ? "?-" : "?",
8528                             flagsp == &negflags ? "don't " : ""
8529                         );
8530                     }
8531                 }
8532                 break;
8533             case KEEPCOPY_PAT_MOD: /* 'p' */
8534                 if (flagsp == &negflags) {
8535                     if (SIZE_ONLY)
8536                         ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
8537                 } else {
8538                     *flagsp |= RXf_PMf_KEEPCOPY;
8539                 }
8540                 break;
8541             case '-':
8542                 /* A flag is a default iff it is following a minus, so
8543                  * if there is a minus, it means will be trying to
8544                  * re-specify a default which is an error */
8545                 if (has_use_defaults || flagsp == &negflags) {
8546                     goto fail_modifiers;
8547                 }
8548                 flagsp = &negflags;
8549                 wastedflags = 0;  /* reset so (?g-c) warns twice */
8550                 break;
8551             case ':':
8552             case ')':
8553                 RExC_flags |= posflags;
8554                 RExC_flags &= ~negflags;
8555                 set_regex_charset(&RExC_flags, cs);
8556                 return;
8557                 /*NOTREACHED*/
8558             default:
8559             fail_modifiers:
8560                 RExC_parse++;
8561                 vFAIL3("Sequence (%.*s...) not recognized",
8562                        RExC_parse-seqstart, seqstart);
8563                 /*NOTREACHED*/
8564         }
8565
8566         ++RExC_parse;
8567     }
8568 }
8569
8570 /*
8571  - reg - regular expression, i.e. main body or parenthesized thing
8572  *
8573  * Caller must absorb opening parenthesis.
8574  *
8575  * Combining parenthesis handling with the base level of regular expression
8576  * is a trifle forced, but the need to tie the tails of the branches to what
8577  * follows makes it hard to avoid.
8578  */
8579 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
8580 #ifdef DEBUGGING
8581 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
8582 #else
8583 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
8584 #endif
8585
8586 /* Returns NULL, setting *flagp to TRYAGAIN at the end of (?) that only sets
8587    flags. Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan
8588    needs to be restarted.
8589    Otherwise would only return NULL if regbranch() returns NULL, which
8590    cannot happen.  */
8591 STATIC regnode *
8592 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
8593     /* paren: Parenthesized? 0=top; 1,2=inside '(': changed to letter.
8594      * 2 is like 1, but indicates that nextchar() has been called to advance
8595      * RExC_parse beyond the '('.  Things like '(?' are indivisible tokens, and
8596      * this flag alerts us to the need to check for that */
8597 {
8598     dVAR;
8599     regnode *ret;               /* Will be the head of the group. */
8600     regnode *br;
8601     regnode *lastbr;
8602     regnode *ender = NULL;
8603     I32 parno = 0;
8604     I32 flags;
8605     U32 oregflags = RExC_flags;
8606     bool have_branch = 0;
8607     bool is_open = 0;
8608     I32 freeze_paren = 0;
8609     I32 after_freeze = 0;
8610
8611     char * parse_start = RExC_parse; /* MJD */
8612     char * const oregcomp_parse = RExC_parse;
8613
8614     GET_RE_DEBUG_FLAGS_DECL;
8615
8616     PERL_ARGS_ASSERT_REG;
8617     DEBUG_PARSE("reg ");
8618
8619     *flagp = 0;                         /* Tentatively. */
8620
8621
8622     /* Make an OPEN node, if parenthesized. */
8623     if (paren) {
8624
8625         /* Under /x, space and comments can be gobbled up between the '(' and
8626          * here (if paren ==2).  The forms '(*VERB' and '(?...' disallow such
8627          * intervening space, as the sequence is a token, and a token should be
8628          * indivisible */
8629         bool has_intervening_patws = paren == 2 && *(RExC_parse - 1) != '(';
8630
8631         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
8632             char *start_verb = RExC_parse;
8633             STRLEN verb_len = 0;
8634             char *start_arg = NULL;
8635             unsigned char op = 0;
8636             int argok = 1;
8637             int internal_argval = 0; /* internal_argval is only useful if !argok */
8638
8639             if (has_intervening_patws && SIZE_ONLY) {
8640                 ckWARNregdep(RExC_parse + 1, "In '(*VERB...)', splitting the initial '(*' is deprecated");
8641             }
8642             while ( *RExC_parse && *RExC_parse != ')' ) {
8643                 if ( *RExC_parse == ':' ) {
8644                     start_arg = RExC_parse + 1;
8645                     break;
8646                 }
8647                 RExC_parse++;
8648             }
8649             ++start_verb;
8650             verb_len = RExC_parse - start_verb;
8651             if ( start_arg ) {
8652                 RExC_parse++;
8653                 while ( *RExC_parse && *RExC_parse != ')' ) 
8654                     RExC_parse++;
8655                 if ( *RExC_parse != ')' ) 
8656                     vFAIL("Unterminated verb pattern argument");
8657                 if ( RExC_parse == start_arg )
8658                     start_arg = NULL;
8659             } else {
8660                 if ( *RExC_parse != ')' )
8661                     vFAIL("Unterminated verb pattern");
8662             }
8663             
8664             switch ( *start_verb ) {
8665             case 'A':  /* (*ACCEPT) */
8666                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
8667                     op = ACCEPT;
8668                     internal_argval = RExC_nestroot;
8669                 }
8670                 break;
8671             case 'C':  /* (*COMMIT) */
8672                 if ( memEQs(start_verb,verb_len,"COMMIT") )
8673                     op = COMMIT;
8674                 break;
8675             case 'F':  /* (*FAIL) */
8676                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
8677                     op = OPFAIL;
8678                     argok = 0;
8679                 }
8680                 break;
8681             case ':':  /* (*:NAME) */
8682             case 'M':  /* (*MARK:NAME) */
8683                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
8684                     op = MARKPOINT;
8685                     argok = -1;
8686                 }
8687                 break;
8688             case 'P':  /* (*PRUNE) */
8689                 if ( memEQs(start_verb,verb_len,"PRUNE") )
8690                     op = PRUNE;
8691                 break;
8692             case 'S':   /* (*SKIP) */  
8693                 if ( memEQs(start_verb,verb_len,"SKIP") ) 
8694                     op = SKIP;
8695                 break;
8696             case 'T':  /* (*THEN) */
8697                 /* [19:06] <TimToady> :: is then */
8698                 if ( memEQs(start_verb,verb_len,"THEN") ) {
8699                     op = CUTGROUP;
8700                     RExC_seen |= REG_SEEN_CUTGROUP;
8701                 }
8702                 break;
8703             }
8704             if ( ! op ) {
8705                 RExC_parse++;
8706                 vFAIL3("Unknown verb pattern '%.*s'",
8707                     verb_len, start_verb);
8708             }
8709             if ( argok ) {
8710                 if ( start_arg && internal_argval ) {
8711                     vFAIL3("Verb pattern '%.*s' may not have an argument",
8712                         verb_len, start_verb); 
8713                 } else if ( argok < 0 && !start_arg ) {
8714                     vFAIL3("Verb pattern '%.*s' has a mandatory argument",
8715                         verb_len, start_verb);    
8716                 } else {
8717                     ret = reganode(pRExC_state, op, internal_argval);
8718                     if ( ! internal_argval && ! SIZE_ONLY ) {
8719                         if (start_arg) {
8720                             SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
8721                             ARG(ret) = add_data( pRExC_state, 1, "S" );
8722                             RExC_rxi->data->data[ARG(ret)]=(void*)sv;
8723                             ret->flags = 0;
8724                         } else {
8725                             ret->flags = 1; 
8726                         }
8727                     }               
8728                 }
8729                 if (!internal_argval)
8730                     RExC_seen |= REG_SEEN_VERBARG;
8731             } else if ( start_arg ) {
8732                 vFAIL3("Verb pattern '%.*s' may not have an argument",
8733                         verb_len, start_verb);    
8734             } else {
8735                 ret = reg_node(pRExC_state, op);
8736             }
8737             nextchar(pRExC_state);
8738             return ret;
8739         }
8740         else if (*RExC_parse == '?') { /* (?...) */
8741             bool is_logical = 0;
8742             const char * const seqstart = RExC_parse;
8743             if (has_intervening_patws && SIZE_ONLY) {
8744                 ckWARNregdep(RExC_parse + 1, "In '(?...)', splitting the initial '(?' is deprecated");
8745             }
8746
8747             RExC_parse++;
8748             paren = *RExC_parse++;
8749             ret = NULL;                 /* For look-ahead/behind. */
8750             switch (paren) {
8751
8752             case 'P':   /* (?P...) variants for those used to PCRE/Python */
8753                 paren = *RExC_parse++;
8754                 if ( paren == '<')         /* (?P<...>) named capture */
8755                     goto named_capture;
8756                 else if (paren == '>') {   /* (?P>name) named recursion */
8757                     goto named_recursion;
8758                 }
8759                 else if (paren == '=') {   /* (?P=...)  named backref */
8760                     /* this pretty much dupes the code for \k<NAME> in regatom(), if
8761                        you change this make sure you change that */
8762                     char* name_start = RExC_parse;
8763                     U32 num = 0;
8764                     SV *sv_dat = reg_scan_name(pRExC_state,
8765                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8766                     if (RExC_parse == name_start || *RExC_parse != ')')
8767                         vFAIL2("Sequence %.3s... not terminated",parse_start);
8768
8769                     if (!SIZE_ONLY) {
8770                         num = add_data( pRExC_state, 1, "S" );
8771                         RExC_rxi->data->data[num]=(void*)sv_dat;
8772                         SvREFCNT_inc_simple_void(sv_dat);
8773                     }
8774                     RExC_sawback = 1;
8775                     ret = reganode(pRExC_state,
8776                                    ((! FOLD)
8777                                      ? NREF
8778                                      : (ASCII_FOLD_RESTRICTED)
8779                                        ? NREFFA
8780                                        : (AT_LEAST_UNI_SEMANTICS)
8781                                          ? NREFFU
8782                                          : (LOC)
8783                                            ? NREFFL
8784                                            : NREFF),
8785                                     num);
8786                     *flagp |= HASWIDTH;
8787
8788                     Set_Node_Offset(ret, parse_start+1);
8789                     Set_Node_Cur_Length(ret, parse_start);
8790
8791                     nextchar(pRExC_state);
8792                     return ret;
8793                 }
8794                 RExC_parse++;
8795                 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8796                 /*NOTREACHED*/
8797             case '<':           /* (?<...) */
8798                 if (*RExC_parse == '!')
8799                     paren = ',';
8800                 else if (*RExC_parse != '=') 
8801               named_capture:
8802                 {               /* (?<...>) */
8803                     char *name_start;
8804                     SV *svname;
8805                     paren= '>';
8806             case '\'':          /* (?'...') */
8807                     name_start= RExC_parse;
8808                     svname = reg_scan_name(pRExC_state,
8809                         SIZE_ONLY ?  /* reverse test from the others */
8810                         REG_RSN_RETURN_NAME : 
8811                         REG_RSN_RETURN_NULL);
8812                     if (RExC_parse == name_start) {
8813                         RExC_parse++;
8814                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8815                         /*NOTREACHED*/
8816                     }
8817                     if (*RExC_parse != paren)
8818                         vFAIL2("Sequence (?%c... not terminated",
8819                             paren=='>' ? '<' : paren);
8820                     if (SIZE_ONLY) {
8821                         HE *he_str;
8822                         SV *sv_dat = NULL;
8823                         if (!svname) /* shouldn't happen */
8824                             Perl_croak(aTHX_
8825                                 "panic: reg_scan_name returned NULL");
8826                         if (!RExC_paren_names) {
8827                             RExC_paren_names= newHV();
8828                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
8829 #ifdef DEBUGGING
8830                             RExC_paren_name_list= newAV();
8831                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
8832 #endif
8833                         }
8834                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
8835                         if ( he_str )
8836                             sv_dat = HeVAL(he_str);
8837                         if ( ! sv_dat ) {
8838                             /* croak baby croak */
8839                             Perl_croak(aTHX_
8840                                 "panic: paren_name hash element allocation failed");
8841                         } else if ( SvPOK(sv_dat) ) {
8842                             /* (?|...) can mean we have dupes so scan to check
8843                                its already been stored. Maybe a flag indicating
8844                                we are inside such a construct would be useful,
8845                                but the arrays are likely to be quite small, so
8846                                for now we punt -- dmq */
8847                             IV count = SvIV(sv_dat);
8848                             I32 *pv = (I32*)SvPVX(sv_dat);
8849                             IV i;
8850                             for ( i = 0 ; i < count ; i++ ) {
8851                                 if ( pv[i] == RExC_npar ) {
8852                                     count = 0;
8853                                     break;
8854                                 }
8855                             }
8856                             if ( count ) {
8857                                 pv = (I32*)SvGROW(sv_dat, SvCUR(sv_dat) + sizeof(I32)+1);
8858                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
8859                                 pv[count] = RExC_npar;
8860                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
8861                             }
8862                         } else {
8863                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
8864                             sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
8865                             SvIOK_on(sv_dat);
8866                             SvIV_set(sv_dat, 1);
8867                         }
8868 #ifdef DEBUGGING
8869                         /* Yes this does cause a memory leak in debugging Perls */
8870                         if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
8871                             SvREFCNT_dec_NN(svname);
8872 #endif
8873
8874                         /*sv_dump(sv_dat);*/
8875                     }
8876                     nextchar(pRExC_state);
8877                     paren = 1;
8878                     goto capturing_parens;
8879                 }
8880                 RExC_seen |= REG_SEEN_LOOKBEHIND;
8881                 RExC_in_lookbehind++;
8882                 RExC_parse++;
8883             case '=':           /* (?=...) */
8884                 RExC_seen_zerolen++;
8885                 break;
8886             case '!':           /* (?!...) */
8887                 RExC_seen_zerolen++;
8888                 if (*RExC_parse == ')') {
8889                     ret=reg_node(pRExC_state, OPFAIL);
8890                     nextchar(pRExC_state);
8891                     return ret;
8892                 }
8893                 break;
8894             case '|':           /* (?|...) */
8895                 /* branch reset, behave like a (?:...) except that
8896                    buffers in alternations share the same numbers */
8897                 paren = ':'; 
8898                 after_freeze = freeze_paren = RExC_npar;
8899                 break;
8900             case ':':           /* (?:...) */
8901             case '>':           /* (?>...) */
8902                 break;
8903             case '$':           /* (?$...) */
8904             case '@':           /* (?@...) */
8905                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
8906                 break;
8907             case '#':           /* (?#...) */
8908                 /* XXX As soon as we disallow separating the '?' and '*' (by
8909                  * spaces or (?#...) comment), it is believed that this case
8910                  * will be unreachable and can be removed.  See
8911                  * [perl #117327] */
8912                 while (*RExC_parse && *RExC_parse != ')')
8913                     RExC_parse++;
8914                 if (*RExC_parse != ')')
8915                     FAIL("Sequence (?#... not terminated");
8916                 nextchar(pRExC_state);
8917                 *flagp = TRYAGAIN;
8918                 return NULL;
8919             case '0' :           /* (?0) */
8920             case 'R' :           /* (?R) */
8921                 if (*RExC_parse != ')')
8922                     FAIL("Sequence (?R) not terminated");
8923                 ret = reg_node(pRExC_state, GOSTART);
8924                 *flagp |= POSTPONED;
8925                 nextchar(pRExC_state);
8926                 return ret;
8927                 /*notreached*/
8928             { /* named and numeric backreferences */
8929                 I32 num;
8930             case '&':            /* (?&NAME) */
8931                 parse_start = RExC_parse - 1;
8932               named_recursion:
8933                 {
8934                     SV *sv_dat = reg_scan_name(pRExC_state,
8935                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8936                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
8937                 }
8938                 goto gen_recurse_regop;
8939                 assert(0); /* NOT REACHED */
8940             case '+':
8941                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
8942                     RExC_parse++;
8943                     vFAIL("Illegal pattern");
8944                 }
8945                 goto parse_recursion;
8946                 /* NOT REACHED*/
8947             case '-': /* (?-1) */
8948                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
8949                     RExC_parse--; /* rewind to let it be handled later */
8950                     goto parse_flags;
8951                 } 
8952                 /*FALLTHROUGH */
8953             case '1': case '2': case '3': case '4': /* (?1) */
8954             case '5': case '6': case '7': case '8': case '9':
8955                 RExC_parse--;
8956               parse_recursion:
8957                 num = atoi(RExC_parse);
8958                 parse_start = RExC_parse - 1; /* MJD */
8959                 if (*RExC_parse == '-')
8960                     RExC_parse++;
8961                 while (isDIGIT(*RExC_parse))
8962                         RExC_parse++;
8963                 if (*RExC_parse!=')') 
8964                     vFAIL("Expecting close bracket");
8965
8966               gen_recurse_regop:
8967                 if ( paren == '-' ) {
8968                     /*
8969                     Diagram of capture buffer numbering.
8970                     Top line is the normal capture buffer numbers
8971                     Bottom line is the negative indexing as from
8972                     the X (the (?-2))
8973
8974                     +   1 2    3 4 5 X          6 7
8975                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
8976                     -   5 4    3 2 1 X          x x
8977
8978                     */
8979                     num = RExC_npar + num;
8980                     if (num < 1)  {
8981                         RExC_parse++;
8982                         vFAIL("Reference to nonexistent group");
8983                     }
8984                 } else if ( paren == '+' ) {
8985                     num = RExC_npar + num - 1;
8986                 }
8987
8988                 ret = reganode(pRExC_state, GOSUB, num);
8989                 if (!SIZE_ONLY) {
8990                     if (num > (I32)RExC_rx->nparens) {
8991                         RExC_parse++;
8992                         vFAIL("Reference to nonexistent group");
8993                     }
8994                     ARG2L_SET( ret, RExC_recurse_count++);
8995                     RExC_emit++;
8996                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
8997                         "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
8998                 } else {
8999                     RExC_size++;
9000                 }
9001                 RExC_seen |= REG_SEEN_RECURSE;
9002                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
9003                 Set_Node_Offset(ret, parse_start); /* MJD */
9004
9005                 *flagp |= POSTPONED;
9006                 nextchar(pRExC_state);
9007                 return ret;
9008             } /* named and numeric backreferences */
9009             assert(0); /* NOT REACHED */
9010
9011             case '?':           /* (??...) */
9012                 is_logical = 1;
9013                 if (*RExC_parse != '{') {
9014                     RExC_parse++;
9015                     vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
9016                     /*NOTREACHED*/
9017                 }
9018                 *flagp |= POSTPONED;
9019                 paren = *RExC_parse++;
9020                 /* FALL THROUGH */
9021             case '{':           /* (?{...}) */
9022             {
9023                 U32 n = 0;
9024                 struct reg_code_block *cb;
9025
9026                 RExC_seen_zerolen++;
9027
9028                 if (   !pRExC_state->num_code_blocks
9029                     || pRExC_state->code_index >= pRExC_state->num_code_blocks
9030                     || pRExC_state->code_blocks[pRExC_state->code_index].start
9031                         != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
9032                             - RExC_start)
9033                 ) {
9034                     if (RExC_pm_flags & PMf_USE_RE_EVAL)
9035                         FAIL("panic: Sequence (?{...}): no code block found\n");
9036                     FAIL("Eval-group not allowed at runtime, use re 'eval'");
9037                 }
9038                 /* this is a pre-compiled code block (?{...}) */
9039                 cb = &pRExC_state->code_blocks[pRExC_state->code_index];
9040                 RExC_parse = RExC_start + cb->end;
9041                 if (!SIZE_ONLY) {
9042                     OP *o = cb->block;
9043                     if (cb->src_regex) {
9044                         n = add_data(pRExC_state, 2, "rl");
9045                         RExC_rxi->data->data[n] =
9046                             (void*)SvREFCNT_inc((SV*)cb->src_regex);
9047                         RExC_rxi->data->data[n+1] = (void*)o;
9048                     }
9049                     else {
9050                         n = add_data(pRExC_state, 1,
9051                                (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l");
9052                         RExC_rxi->data->data[n] = (void*)o;
9053                     }
9054                 }
9055                 pRExC_state->code_index++;
9056                 nextchar(pRExC_state);
9057
9058                 if (is_logical) {
9059                     regnode *eval;
9060                     ret = reg_node(pRExC_state, LOGICAL);
9061                     eval = reganode(pRExC_state, EVAL, n);
9062                     if (!SIZE_ONLY) {
9063                         ret->flags = 2;
9064                         /* for later propagation into (??{}) return value */
9065                         eval->flags = (U8) (RExC_flags & RXf_PMf_COMPILETIME);
9066                     }
9067                     REGTAIL(pRExC_state, ret, eval);
9068                     /* deal with the length of this later - MJD */
9069                     return ret;
9070                 }
9071                 ret = reganode(pRExC_state, EVAL, n);
9072                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
9073                 Set_Node_Offset(ret, parse_start);
9074                 return ret;
9075             }
9076             case '(':           /* (?(?{...})...) and (?(?=...)...) */
9077             {
9078                 int is_define= 0;
9079                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
9080                     if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
9081                         || RExC_parse[1] == '<'
9082                         || RExC_parse[1] == '{') { /* Lookahead or eval. */
9083                         I32 flag;
9084                         regnode *tail;
9085
9086                         ret = reg_node(pRExC_state, LOGICAL);
9087                         if (!SIZE_ONLY)
9088                             ret->flags = 1;
9089                         
9090                         tail = reg(pRExC_state, 1, &flag, depth+1);
9091                         if (flag & RESTART_UTF8) {
9092                             *flagp = RESTART_UTF8;
9093                             return NULL;
9094                         }
9095                         REGTAIL(pRExC_state, ret, tail);
9096                         goto insert_if;
9097                     }
9098                 }
9099                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
9100                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
9101                 {
9102                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
9103                     char *name_start= RExC_parse++;
9104                     U32 num = 0;
9105                     SV *sv_dat=reg_scan_name(pRExC_state,
9106                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
9107                     if (RExC_parse == name_start || *RExC_parse != ch)
9108                         vFAIL2("Sequence (?(%c... not terminated",
9109                             (ch == '>' ? '<' : ch));
9110                     RExC_parse++;
9111                     if (!SIZE_ONLY) {
9112                         num = add_data( pRExC_state, 1, "S" );
9113                         RExC_rxi->data->data[num]=(void*)sv_dat;
9114                         SvREFCNT_inc_simple_void(sv_dat);
9115                     }
9116                     ret = reganode(pRExC_state,NGROUPP,num);
9117                     goto insert_if_check_paren;
9118                 }
9119                 else if (RExC_parse[0] == 'D' &&
9120                          RExC_parse[1] == 'E' &&
9121                          RExC_parse[2] == 'F' &&
9122                          RExC_parse[3] == 'I' &&
9123                          RExC_parse[4] == 'N' &&
9124                          RExC_parse[5] == 'E')
9125                 {
9126                     ret = reganode(pRExC_state,DEFINEP,0);
9127                     RExC_parse +=6 ;
9128                     is_define = 1;
9129                     goto insert_if_check_paren;
9130                 }
9131                 else if (RExC_parse[0] == 'R') {
9132                     RExC_parse++;
9133                     parno = 0;
9134                     if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
9135                         parno = atoi(RExC_parse++);
9136                         while (isDIGIT(*RExC_parse))
9137                             RExC_parse++;
9138                     } else if (RExC_parse[0] == '&') {
9139                         SV *sv_dat;
9140                         RExC_parse++;
9141                         sv_dat = reg_scan_name(pRExC_state,
9142                             SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
9143                         parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
9144                     }
9145                     ret = reganode(pRExC_state,INSUBP,parno); 
9146                     goto insert_if_check_paren;
9147                 }
9148                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
9149                     /* (?(1)...) */
9150                     char c;
9151                     parno = atoi(RExC_parse++);
9152
9153                     while (isDIGIT(*RExC_parse))
9154                         RExC_parse++;
9155                     ret = reganode(pRExC_state, GROUPP, parno);
9156
9157                  insert_if_check_paren:
9158                     if ((c = *nextchar(pRExC_state)) != ')')
9159                         vFAIL("Switch condition not recognized");
9160                   insert_if:
9161                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
9162                     br = regbranch(pRExC_state, &flags, 1,depth+1);
9163                     if (br == NULL) {
9164                         if (flags & RESTART_UTF8) {
9165                             *flagp = RESTART_UTF8;
9166                             return NULL;
9167                         }
9168                         FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"",
9169                               (UV) flags);
9170                     } else
9171                         REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
9172                     c = *nextchar(pRExC_state);
9173                     if (flags&HASWIDTH)
9174                         *flagp |= HASWIDTH;
9175                     if (c == '|') {
9176                         if (is_define) 
9177                             vFAIL("(?(DEFINE)....) does not allow branches");
9178                         lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
9179                         if (!regbranch(pRExC_state, &flags, 1,depth+1)) {
9180                             if (flags & RESTART_UTF8) {
9181                                 *flagp = RESTART_UTF8;
9182                                 return NULL;
9183                             }
9184                             FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"",
9185                                   (UV) flags);
9186                         }
9187                         REGTAIL(pRExC_state, ret, lastbr);
9188                         if (flags&HASWIDTH)
9189                             *flagp |= HASWIDTH;
9190                         c = *nextchar(pRExC_state);
9191                     }
9192                     else
9193                         lastbr = NULL;
9194                     if (c != ')')
9195                         vFAIL("Switch (?(condition)... contains too many branches");
9196                     ender = reg_node(pRExC_state, TAIL);
9197                     REGTAIL(pRExC_state, br, ender);
9198                     if (lastbr) {
9199                         REGTAIL(pRExC_state, lastbr, ender);
9200                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
9201                     }
9202                     else
9203                         REGTAIL(pRExC_state, ret, ender);
9204                     RExC_size++; /* XXX WHY do we need this?!!
9205                                     For large programs it seems to be required
9206                                     but I can't figure out why. -- dmq*/
9207                     return ret;
9208                 }
9209                 else {
9210                     vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
9211                 }
9212             }
9213             case '[':           /* (?[ ... ]) */
9214                 return handle_regex_sets(pRExC_state, NULL, flagp, depth,
9215                                          oregcomp_parse);
9216             case 0:
9217                 RExC_parse--; /* for vFAIL to print correctly */
9218                 vFAIL("Sequence (? incomplete");
9219                 break;
9220             default: /* e.g., (?i) */
9221                 --RExC_parse;
9222               parse_flags:
9223                 parse_lparen_question_flags(pRExC_state);
9224                 if (UCHARAT(RExC_parse) != ':') {
9225                     nextchar(pRExC_state);
9226                     *flagp = TRYAGAIN;
9227                     return NULL;
9228                 }
9229                 paren = ':';
9230                 nextchar(pRExC_state);
9231                 ret = NULL;
9232                 goto parse_rest;
9233             } /* end switch */
9234         }
9235         else {                  /* (...) */
9236           capturing_parens:
9237             parno = RExC_npar;
9238             RExC_npar++;
9239             
9240             ret = reganode(pRExC_state, OPEN, parno);
9241             if (!SIZE_ONLY ){
9242                 if (!RExC_nestroot) 
9243                     RExC_nestroot = parno;
9244                 if (RExC_seen & REG_SEEN_RECURSE
9245                     && !RExC_open_parens[parno-1])
9246                 {
9247                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
9248                         "Setting open paren #%"IVdf" to %d\n", 
9249                         (IV)parno, REG_NODE_NUM(ret)));
9250                     RExC_open_parens[parno-1]= ret;
9251                 }
9252             }
9253             Set_Node_Length(ret, 1); /* MJD */
9254             Set_Node_Offset(ret, RExC_parse); /* MJD */
9255             is_open = 1;
9256         }
9257     }
9258     else                        /* ! paren */
9259         ret = NULL;
9260    
9261    parse_rest:
9262     /* Pick up the branches, linking them together. */
9263     parse_start = RExC_parse;   /* MJD */
9264     br = regbranch(pRExC_state, &flags, 1,depth+1);
9265
9266     /*     branch_len = (paren != 0); */
9267
9268     if (br == NULL) {
9269         if (flags & RESTART_UTF8) {
9270             *flagp = RESTART_UTF8;
9271             return NULL;
9272         }
9273         FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"", (UV) flags);
9274     }
9275     if (*RExC_parse == '|') {
9276         if (!SIZE_ONLY && RExC_extralen) {
9277             reginsert(pRExC_state, BRANCHJ, br, depth+1);
9278         }
9279         else {                  /* MJD */
9280             reginsert(pRExC_state, BRANCH, br, depth+1);
9281             Set_Node_Length(br, paren != 0);
9282             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
9283         }
9284         have_branch = 1;
9285         if (SIZE_ONLY)
9286             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
9287     }
9288     else if (paren == ':') {
9289         *flagp |= flags&SIMPLE;
9290     }
9291     if (is_open) {                              /* Starts with OPEN. */
9292         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
9293     }
9294     else if (paren != '?')              /* Not Conditional */
9295         ret = br;
9296     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
9297     lastbr = br;
9298     while (*RExC_parse == '|') {
9299         if (!SIZE_ONLY && RExC_extralen) {
9300             ender = reganode(pRExC_state, LONGJMP,0);
9301             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
9302         }
9303         if (SIZE_ONLY)
9304             RExC_extralen += 2;         /* Account for LONGJMP. */
9305         nextchar(pRExC_state);
9306         if (freeze_paren) {
9307             if (RExC_npar > after_freeze)
9308                 after_freeze = RExC_npar;
9309             RExC_npar = freeze_paren;       
9310         }
9311         br = regbranch(pRExC_state, &flags, 0, depth+1);
9312
9313         if (br == NULL) {
9314             if (flags & RESTART_UTF8) {
9315                 *flagp = RESTART_UTF8;
9316                 return NULL;
9317             }
9318             FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"", (UV) flags);
9319         }
9320         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
9321         lastbr = br;
9322         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
9323     }
9324
9325     if (have_branch || paren != ':') {
9326         /* Make a closing node, and hook it on the end. */
9327         switch (paren) {
9328         case ':':
9329             ender = reg_node(pRExC_state, TAIL);
9330             break;
9331         case 1: case 2:
9332             ender = reganode(pRExC_state, CLOSE, parno);
9333             if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
9334                 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
9335                         "Setting close paren #%"IVdf" to %d\n", 
9336                         (IV)parno, REG_NODE_NUM(ender)));
9337                 RExC_close_parens[parno-1]= ender;
9338                 if (RExC_nestroot == parno) 
9339                     RExC_nestroot = 0;
9340             }       
9341             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
9342             Set_Node_Length(ender,1); /* MJD */
9343             break;
9344         case '<':
9345         case ',':
9346         case '=':
9347         case '!':
9348             *flagp &= ~HASWIDTH;
9349             /* FALL THROUGH */
9350         case '>':
9351             ender = reg_node(pRExC_state, SUCCEED);
9352             break;
9353         case 0:
9354             ender = reg_node(pRExC_state, END);
9355             if (!SIZE_ONLY) {
9356                 assert(!RExC_opend); /* there can only be one! */
9357                 RExC_opend = ender;
9358             }
9359             break;
9360         }
9361         DEBUG_PARSE_r(if (!SIZE_ONLY) {
9362             SV * const mysv_val1=sv_newmortal();
9363             SV * const mysv_val2=sv_newmortal();
9364             DEBUG_PARSE_MSG("lsbr");
9365             regprop(RExC_rx, mysv_val1, lastbr);
9366             regprop(RExC_rx, mysv_val2, ender);
9367             PerlIO_printf(Perl_debug_log, "~ tying lastbr %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
9368                           SvPV_nolen_const(mysv_val1),
9369                           (IV)REG_NODE_NUM(lastbr),
9370                           SvPV_nolen_const(mysv_val2),
9371                           (IV)REG_NODE_NUM(ender),
9372                           (IV)(ender - lastbr)
9373             );
9374         });
9375         REGTAIL(pRExC_state, lastbr, ender);
9376
9377         if (have_branch && !SIZE_ONLY) {
9378             char is_nothing= 1;
9379             if (depth==1)
9380                 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
9381
9382             /* Hook the tails of the branches to the closing node. */
9383             for (br = ret; br; br = regnext(br)) {
9384                 const U8 op = PL_regkind[OP(br)];
9385                 if (op == BRANCH) {
9386                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
9387                     if (OP(NEXTOPER(br)) != NOTHING || regnext(NEXTOPER(br)) != ender)
9388                         is_nothing= 0;
9389                 }
9390                 else if (op == BRANCHJ) {
9391                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
9392                     /* for now we always disable this optimisation * /
9393                     if (OP(NEXTOPER(NEXTOPER(br))) != NOTHING || regnext(NEXTOPER(NEXTOPER(br))) != ender)
9394                     */
9395                         is_nothing= 0;
9396                 }
9397             }
9398             if (is_nothing) {
9399                 br= PL_regkind[OP(ret)] != BRANCH ? regnext(ret) : ret;
9400                 DEBUG_PARSE_r(if (!SIZE_ONLY) {
9401                     SV * const mysv_val1=sv_newmortal();
9402                     SV * const mysv_val2=sv_newmortal();
9403                     DEBUG_PARSE_MSG("NADA");
9404                     regprop(RExC_rx, mysv_val1, ret);
9405                     regprop(RExC_rx, mysv_val2, ender);
9406                     PerlIO_printf(Perl_debug_log, "~ converting ret %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
9407                                   SvPV_nolen_const(mysv_val1),
9408                                   (IV)REG_NODE_NUM(ret),
9409                                   SvPV_nolen_const(mysv_val2),
9410                                   (IV)REG_NODE_NUM(ender),
9411                                   (IV)(ender - ret)
9412                     );
9413                 });
9414                 OP(br)= NOTHING;
9415                 if (OP(ender) == TAIL) {
9416                     NEXT_OFF(br)= 0;
9417                     RExC_emit= br + 1;
9418                 } else {
9419                     regnode *opt;
9420                     for ( opt= br + 1; opt < ender ; opt++ )
9421                         OP(opt)= OPTIMIZED;
9422                     NEXT_OFF(br)= ender - br;
9423                 }
9424             }
9425         }
9426     }
9427
9428     {
9429         const char *p;
9430         static const char parens[] = "=!<,>";
9431
9432         if (paren && (p = strchr(parens, paren))) {
9433             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
9434             int flag = (p - parens) > 1;
9435
9436             if (paren == '>')
9437                 node = SUSPEND, flag = 0;
9438             reginsert(pRExC_state, node,ret, depth+1);
9439             Set_Node_Cur_Length(ret, parse_start);
9440             Set_Node_Offset(ret, parse_start + 1);
9441             ret->flags = flag;
9442             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
9443         }
9444     }
9445
9446     /* Check for proper termination. */
9447     if (paren) {
9448         /* restore original flags, but keep (?p) */
9449         RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY);
9450         if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
9451             RExC_parse = oregcomp_parse;
9452             vFAIL("Unmatched (");
9453         }
9454     }
9455     else if (!paren && RExC_parse < RExC_end) {
9456         if (*RExC_parse == ')') {
9457             RExC_parse++;
9458             vFAIL("Unmatched )");
9459         }
9460         else
9461             FAIL("Junk on end of regexp");      /* "Can't happen". */
9462         assert(0); /* NOTREACHED */
9463     }
9464
9465     if (RExC_in_lookbehind) {
9466         RExC_in_lookbehind--;
9467     }
9468     if (after_freeze > RExC_npar)
9469         RExC_npar = after_freeze;
9470     return(ret);
9471 }
9472
9473 /*
9474  - regbranch - one alternative of an | operator
9475  *
9476  * Implements the concatenation operator.
9477  *
9478  * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
9479  * restarted.
9480  */
9481 STATIC regnode *
9482 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
9483 {
9484     dVAR;
9485     regnode *ret;
9486     regnode *chain = NULL;
9487     regnode *latest;
9488     I32 flags = 0, c = 0;
9489     GET_RE_DEBUG_FLAGS_DECL;
9490
9491     PERL_ARGS_ASSERT_REGBRANCH;
9492
9493     DEBUG_PARSE("brnc");
9494
9495     if (first)
9496         ret = NULL;
9497     else {
9498         if (!SIZE_ONLY && RExC_extralen)
9499             ret = reganode(pRExC_state, BRANCHJ,0);
9500         else {
9501             ret = reg_node(pRExC_state, BRANCH);
9502             Set_Node_Length(ret, 1);
9503         }
9504     }
9505
9506     if (!first && SIZE_ONLY)
9507         RExC_extralen += 1;                     /* BRANCHJ */
9508
9509     *flagp = WORST;                     /* Tentatively. */
9510
9511     RExC_parse--;
9512     nextchar(pRExC_state);
9513     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
9514         flags &= ~TRYAGAIN;
9515         latest = regpiece(pRExC_state, &flags,depth+1);
9516         if (latest == NULL) {
9517             if (flags & TRYAGAIN)
9518                 continue;
9519             if (flags & RESTART_UTF8) {
9520                 *flagp = RESTART_UTF8;
9521                 return NULL;
9522             }
9523             FAIL2("panic: regpiece returned NULL, flags=%#"UVxf"", (UV) flags);
9524         }
9525         else if (ret == NULL)
9526             ret = latest;
9527         *flagp |= flags&(HASWIDTH|POSTPONED);
9528         if (chain == NULL)      /* First piece. */
9529             *flagp |= flags&SPSTART;
9530         else {
9531             RExC_naughty++;
9532             REGTAIL(pRExC_state, chain, latest);
9533         }
9534         chain = latest;
9535         c++;
9536     }
9537     if (chain == NULL) {        /* Loop ran zero times. */
9538         chain = reg_node(pRExC_state, NOTHING);
9539         if (ret == NULL)
9540             ret = chain;
9541     }
9542     if (c == 1) {
9543         *flagp |= flags&SIMPLE;
9544     }
9545
9546     return ret;
9547 }
9548
9549 /*
9550  - regpiece - something followed by possible [*+?]
9551  *
9552  * Note that the branching code sequences used for ? and the general cases
9553  * of * and + are somewhat optimized:  they use the same NOTHING node as
9554  * both the endmarker for their branch list and the body of the last branch.
9555  * It might seem that this node could be dispensed with entirely, but the
9556  * endmarker role is not redundant.
9557  *
9558  * Returns NULL, setting *flagp to TRYAGAIN if regatom() returns NULL with
9559  * TRYAGAIN.
9560  * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
9561  * restarted.
9562  */
9563 STATIC regnode *
9564 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
9565 {
9566     dVAR;
9567     regnode *ret;
9568     char op;
9569     char *next;
9570     I32 flags;
9571     const char * const origparse = RExC_parse;
9572     I32 min;
9573     I32 max = REG_INFTY;
9574 #ifdef RE_TRACK_PATTERN_OFFSETS
9575     char *parse_start;
9576 #endif
9577     const char *maxpos = NULL;
9578
9579     /* Save the original in case we change the emitted regop to a FAIL. */
9580     regnode * const orig_emit = RExC_emit;
9581
9582     GET_RE_DEBUG_FLAGS_DECL;
9583
9584     PERL_ARGS_ASSERT_REGPIECE;
9585
9586     DEBUG_PARSE("piec");
9587
9588     ret = regatom(pRExC_state, &flags,depth+1);
9589     if (ret == NULL) {
9590         if (flags & (TRYAGAIN|RESTART_UTF8))
9591             *flagp |= flags & (TRYAGAIN|RESTART_UTF8);
9592         else
9593             FAIL2("panic: regatom returned NULL, flags=%#"UVxf"", (UV) flags);
9594         return(NULL);
9595     }
9596
9597     op = *RExC_parse;
9598
9599     if (op == '{' && regcurly(RExC_parse, FALSE)) {
9600         maxpos = NULL;
9601 #ifdef RE_TRACK_PATTERN_OFFSETS
9602         parse_start = RExC_parse; /* MJD */
9603 #endif
9604         next = RExC_parse + 1;
9605         while (isDIGIT(*next) || *next == ',') {
9606             if (*next == ',') {
9607                 if (maxpos)
9608                     break;
9609                 else
9610                     maxpos = next;
9611             }
9612             next++;
9613         }
9614         if (*next == '}') {             /* got one */
9615             if (!maxpos)
9616                 maxpos = next;
9617             RExC_parse++;
9618             min = atoi(RExC_parse);
9619             if (*maxpos == ',')
9620                 maxpos++;
9621             else
9622                 maxpos = RExC_parse;
9623             max = atoi(maxpos);
9624             if (!max && *maxpos != '0')
9625                 max = REG_INFTY;                /* meaning "infinity" */
9626             else if (max >= REG_INFTY)
9627                 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
9628             RExC_parse = next;
9629             nextchar(pRExC_state);
9630             if (max < min) {    /* If can't match, warn and optimize to fail
9631                                    unconditionally */
9632                 if (SIZE_ONLY) {
9633                     ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
9634
9635                     /* We can't back off the size because we have to reserve
9636                      * enough space for all the things we are about to throw
9637                      * away, but we can shrink it by the ammount we are about
9638                      * to re-use here */
9639                     RExC_size = PREVOPER(RExC_size) - regarglen[(U8)OPFAIL];
9640                 }
9641                 else {
9642                     RExC_emit = orig_emit;
9643                 }
9644                 ret = reg_node(pRExC_state, OPFAIL);
9645                 return ret;
9646             }
9647
9648         do_curly:
9649             if ((flags&SIMPLE)) {
9650                 RExC_naughty += 2 + RExC_naughty / 2;
9651                 reginsert(pRExC_state, CURLY, ret, depth+1);
9652                 Set_Node_Offset(ret, parse_start+1); /* MJD */
9653                 Set_Node_Cur_Length(ret, parse_start);
9654             }
9655             else {
9656                 regnode * const w = reg_node(pRExC_state, WHILEM);
9657
9658                 w->flags = 0;
9659                 REGTAIL(pRExC_state, ret, w);
9660                 if (!SIZE_ONLY && RExC_extralen) {
9661                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
9662                     reginsert(pRExC_state, NOTHING,ret, depth+1);
9663                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
9664                 }
9665                 reginsert(pRExC_state, CURLYX,ret, depth+1);
9666                                 /* MJD hk */
9667                 Set_Node_Offset(ret, parse_start+1);
9668                 Set_Node_Length(ret,
9669                                 op == '{' ? (RExC_parse - parse_start) : 1);
9670
9671                 if (!SIZE_ONLY && RExC_extralen)
9672                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
9673                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
9674                 if (SIZE_ONLY)
9675                     RExC_whilem_seen++, RExC_extralen += 3;
9676                 RExC_naughty += 4 + RExC_naughty;       /* compound interest */
9677             }
9678             ret->flags = 0;
9679
9680             if (min > 0)
9681                 *flagp = WORST;
9682             if (max > 0)
9683                 *flagp |= HASWIDTH;
9684             if (!SIZE_ONLY) {
9685                 ARG1_SET(ret, (U16)min);
9686                 ARG2_SET(ret, (U16)max);
9687             }
9688
9689             goto nest_check;
9690         }
9691     }
9692
9693     if (!ISMULT1(op)) {
9694         *flagp = flags;
9695         return(ret);
9696     }
9697
9698 #if 0                           /* Now runtime fix should be reliable. */
9699
9700     /* if this is reinstated, don't forget to put this back into perldiag:
9701
9702             =item Regexp *+ operand could be empty at {#} in regex m/%s/
9703
9704            (F) The part of the regexp subject to either the * or + quantifier
9705            could match an empty string. The {#} shows in the regular
9706            expression about where the problem was discovered.
9707
9708     */
9709
9710     if (!(flags&HASWIDTH) && op != '?')
9711       vFAIL("Regexp *+ operand could be empty");
9712 #endif
9713
9714 #ifdef RE_TRACK_PATTERN_OFFSETS
9715     parse_start = RExC_parse;
9716 #endif
9717     nextchar(pRExC_state);
9718
9719     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
9720
9721     if (op == '*' && (flags&SIMPLE)) {
9722         reginsert(pRExC_state, STAR, ret, depth+1);
9723         ret->flags = 0;
9724         RExC_naughty += 4;
9725     }
9726     else if (op == '*') {
9727         min = 0;
9728         goto do_curly;
9729     }
9730     else if (op == '+' && (flags&SIMPLE)) {
9731         reginsert(pRExC_state, PLUS, ret, depth+1);
9732         ret->flags = 0;
9733         RExC_naughty += 3;
9734     }
9735     else if (op == '+') {
9736         min = 1;
9737         goto do_curly;
9738     }
9739     else if (op == '?') {
9740         min = 0; max = 1;
9741         goto do_curly;
9742     }
9743   nest_check:
9744     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
9745         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
9746         ckWARN3reg(RExC_parse,
9747                    "%.*s matches null string many times",
9748                    (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
9749                    origparse);
9750         (void)ReREFCNT_inc(RExC_rx_sv);
9751     }
9752
9753     if (RExC_parse < RExC_end && *RExC_parse == '?') {
9754         nextchar(pRExC_state);
9755         reginsert(pRExC_state, MINMOD, ret, depth+1);
9756         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
9757     }
9758     else
9759     if (RExC_parse < RExC_end && *RExC_parse == '+') {
9760         regnode *ender;
9761         nextchar(pRExC_state);
9762         ender = reg_node(pRExC_state, SUCCEED);
9763         REGTAIL(pRExC_state, ret, ender);
9764         reginsert(pRExC_state, SUSPEND, ret, depth+1);
9765         ret->flags = 0;
9766         ender = reg_node(pRExC_state, TAIL);
9767         REGTAIL(pRExC_state, ret, ender);
9768     }
9769
9770     if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
9771         RExC_parse++;
9772         vFAIL("Nested quantifiers");
9773     }
9774
9775     return(ret);
9776 }
9777
9778 STATIC bool
9779 S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, UV *valuep, I32 *flagp, U32 depth, bool in_char_class,
9780         const bool strict   /* Apply stricter parsing rules? */
9781     )
9782 {
9783    
9784  /* This is expected to be called by a parser routine that has recognized '\N'
9785    and needs to handle the rest. RExC_parse is expected to point at the first
9786    char following the N at the time of the call.  On successful return,
9787    RExC_parse has been updated to point to just after the sequence identified
9788    by this routine, and <*flagp> has been updated.
9789
9790    The \N may be inside (indicated by the boolean <in_char_class>) or outside a
9791    character class.
9792
9793    \N may begin either a named sequence, or if outside a character class, mean
9794    to match a non-newline.  For non single-quoted regexes, the tokenizer has
9795    attempted to decide which, and in the case of a named sequence, converted it
9796    into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...},
9797    where c1... are the characters in the sequence.  For single-quoted regexes,
9798    the tokenizer passes the \N sequence through unchanged; this code will not
9799    attempt to determine this nor expand those, instead raising a syntax error.
9800    The net effect is that if the beginning of the passed-in pattern isn't '{U+'
9801    or there is no '}', it signals that this \N occurrence means to match a
9802    non-newline.
9803
9804    Only the \N{U+...} form should occur in a character class, for the same
9805    reason that '.' inside a character class means to just match a period: it
9806    just doesn't make sense.
9807
9808    The function raises an error (via vFAIL), and doesn't return for various
9809    syntax errors.  Otherwise it returns TRUE and sets <node_p> or <valuep> on
9810    success; it returns FALSE otherwise. Returns FALSE, setting *flagp to
9811    RESTART_UTF8 if the sizing scan needs to be restarted. Such a restart is
9812    only possible if node_p is non-NULL.
9813
9814
9815    If <valuep> is non-null, it means the caller can accept an input sequence
9816    consisting of a just a single code point; <*valuep> is set to that value
9817    if the input is such.
9818
9819    If <node_p> is non-null it signifies that the caller can accept any other
9820    legal sequence (i.e., one that isn't just a single code point).  <*node_p>
9821    is set as follows:
9822     1) \N means not-a-NL: points to a newly created REG_ANY node;
9823     2) \N{}:              points to a new NOTHING node;
9824     3) otherwise:         points to a new EXACT node containing the resolved
9825                           string.
9826    Note that FALSE is returned for single code point sequences if <valuep> is
9827    null.
9828  */
9829
9830     char * endbrace;    /* '}' following the name */
9831     char* p;
9832     char *endchar;      /* Points to '.' or '}' ending cur char in the input
9833                            stream */
9834     bool has_multiple_chars; /* true if the input stream contains a sequence of
9835                                 more than one character */
9836
9837     GET_RE_DEBUG_FLAGS_DECL;
9838  
9839     PERL_ARGS_ASSERT_GROK_BSLASH_N;
9840
9841     GET_RE_DEBUG_FLAGS;
9842
9843     assert(cBOOL(node_p) ^ cBOOL(valuep));  /* Exactly one should be set */
9844
9845     /* The [^\n] meaning of \N ignores spaces and comments under the /x
9846      * modifier.  The other meaning does not */
9847     p = (RExC_flags & RXf_PMf_EXTENDED)
9848         ? regwhite( pRExC_state, RExC_parse )
9849         : RExC_parse;
9850
9851     /* Disambiguate between \N meaning a named character versus \N meaning
9852      * [^\n].  The former is assumed when it can't be the latter. */
9853     if (*p != '{' || regcurly(p, FALSE)) {
9854         RExC_parse = p;
9855         if (! node_p) {
9856             /* no bare \N in a charclass */
9857             if (in_char_class) {
9858                 vFAIL("\\N in a character class must be a named character: \\N{...}");
9859             }
9860             return FALSE;
9861         }
9862         nextchar(pRExC_state);
9863         *node_p = reg_node(pRExC_state, REG_ANY);
9864         *flagp |= HASWIDTH|SIMPLE;
9865         RExC_naughty++;
9866         RExC_parse--;
9867         Set_Node_Length(*node_p, 1); /* MJD */
9868         return TRUE;
9869     }
9870
9871     /* Here, we have decided it should be a named character or sequence */
9872
9873     /* The test above made sure that the next real character is a '{', but
9874      * under the /x modifier, it could be separated by space (or a comment and
9875      * \n) and this is not allowed (for consistency with \x{...} and the
9876      * tokenizer handling of \N{NAME}). */
9877     if (*RExC_parse != '{') {
9878         vFAIL("Missing braces on \\N{}");
9879     }
9880
9881     RExC_parse++;       /* Skip past the '{' */
9882
9883     if (! (endbrace = strchr(RExC_parse, '}')) /* no trailing brace */
9884         || ! (endbrace == RExC_parse            /* nothing between the {} */
9885               || (endbrace - RExC_parse >= 2    /* U+ (bad hex is checked below */
9886                   && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg) */
9887     {
9888         if (endbrace) RExC_parse = endbrace;    /* position msg's '<--HERE' */
9889         vFAIL("\\N{NAME} must be resolved by the lexer");
9890     }
9891
9892     if (endbrace == RExC_parse) {   /* empty: \N{} */
9893         bool ret = TRUE;
9894         if (node_p) {
9895             *node_p = reg_node(pRExC_state,NOTHING);
9896         }
9897         else if (in_char_class) {
9898             if (SIZE_ONLY && in_char_class) {
9899                 if (strict) {
9900                     RExC_parse++;   /* Position after the "}" */
9901                     vFAIL("Zero length \\N{}");
9902                 }
9903                 else {
9904                     ckWARNreg(RExC_parse,
9905                               "Ignoring zero length \\N{} in character class");
9906                 }
9907             }
9908             ret = FALSE;
9909         }
9910         else {
9911             return FALSE;
9912         }
9913         nextchar(pRExC_state);
9914         return ret;
9915     }
9916
9917     RExC_uni_semantics = 1; /* Unicode named chars imply Unicode semantics */
9918     RExC_parse += 2;    /* Skip past the 'U+' */
9919
9920     endchar = RExC_parse + strcspn(RExC_parse, ".}");
9921
9922     /* Code points are separated by dots.  If none, there is only one code
9923      * point, and is terminated by the brace */
9924     has_multiple_chars = (endchar < endbrace);
9925
9926     if (valuep && (! has_multiple_chars || in_char_class)) {
9927         /* We only pay attention to the first char of
9928         multichar strings being returned in char classes. I kinda wonder
9929         if this makes sense as it does change the behaviour
9930         from earlier versions, OTOH that behaviour was broken
9931         as well. XXX Solution is to recharacterize as
9932         [rest-of-class]|multi1|multi2... */
9933
9934         STRLEN length_of_hex = (STRLEN)(endchar - RExC_parse);
9935         I32 grok_hex_flags = PERL_SCAN_ALLOW_UNDERSCORES
9936             | PERL_SCAN_DISALLOW_PREFIX
9937             | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
9938
9939         *valuep = grok_hex(RExC_parse, &length_of_hex, &grok_hex_flags, NULL);
9940
9941         /* The tokenizer should have guaranteed validity, but it's possible to
9942          * bypass it by using single quoting, so check */
9943         if (length_of_hex == 0
9944             || length_of_hex != (STRLEN)(endchar - RExC_parse) )
9945         {
9946             RExC_parse += length_of_hex;        /* Includes all the valid */
9947             RExC_parse += (RExC_orig_utf8)      /* point to after 1st invalid */
9948                             ? UTF8SKIP(RExC_parse)
9949                             : 1;
9950             /* Guard against malformed utf8 */
9951             if (RExC_parse >= endchar) {
9952                 RExC_parse = endchar;
9953             }
9954             vFAIL("Invalid hexadecimal number in \\N{U+...}");
9955         }
9956
9957         if (in_char_class && has_multiple_chars) {
9958             if (strict) {
9959                 RExC_parse = endbrace;
9960                 vFAIL("\\N{} in character class restricted to one character");
9961             }
9962             else {
9963                 ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
9964             }
9965         }
9966
9967         RExC_parse = endbrace + 1;
9968     }
9969     else if (! node_p || ! has_multiple_chars) {
9970
9971         /* Here, the input is legal, but not according to the caller's
9972          * options.  We fail without advancing the parse, so that the
9973          * caller can try again */
9974         RExC_parse = p;
9975         return FALSE;
9976     }
9977     else {
9978
9979         /* What is done here is to convert this to a sub-pattern of the form
9980          * (?:\x{char1}\x{char2}...)
9981          * and then call reg recursively.  That way, it retains its atomicness,
9982          * while not having to worry about special handling that some code
9983          * points may have.  toke.c has converted the original Unicode values
9984          * to native, so that we can just pass on the hex values unchanged.  We
9985          * do have to set a flag to keep recoding from happening in the
9986          * recursion */
9987
9988         SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP);
9989         STRLEN len;
9990         char *orig_end = RExC_end;
9991         I32 flags;
9992
9993         while (RExC_parse < endbrace) {
9994
9995             /* Convert to notation the rest of the code understands */
9996             sv_catpv(substitute_parse, "\\x{");
9997             sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
9998             sv_catpv(substitute_parse, "}");
9999
10000             /* Point to the beginning of the next character in the sequence. */
10001             RExC_parse = endchar + 1;
10002             endchar = RExC_parse + strcspn(RExC_parse, ".}");
10003         }
10004         sv_catpv(substitute_parse, ")");
10005
10006         RExC_parse = SvPV(substitute_parse, len);
10007
10008         /* Don't allow empty number */
10009         if (len < 8) {
10010             vFAIL("Invalid hexadecimal number in \\N{U+...}");
10011         }
10012         RExC_end = RExC_parse + len;
10013
10014         /* The values are Unicode, and therefore not subject to recoding */
10015         RExC_override_recoding = 1;
10016
10017         if (!(*node_p = reg(pRExC_state, 1, &flags, depth+1))) {
10018             if (flags & RESTART_UTF8) {
10019                 *flagp = RESTART_UTF8;
10020                 return FALSE;
10021             }
10022             FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#"UVxf"",
10023                   (UV) flags);
10024         } 
10025         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
10026
10027         RExC_parse = endbrace;
10028         RExC_end = orig_end;
10029         RExC_override_recoding = 0;
10030
10031         nextchar(pRExC_state);
10032     }
10033
10034     return TRUE;
10035 }
10036
10037
10038 /*
10039  * reg_recode
10040  *
10041  * It returns the code point in utf8 for the value in *encp.
10042  *    value: a code value in the source encoding
10043  *    encp:  a pointer to an Encode object
10044  *
10045  * If the result from Encode is not a single character,
10046  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
10047  */
10048 STATIC UV
10049 S_reg_recode(pTHX_ const char value, SV **encp)
10050 {
10051     STRLEN numlen = 1;
10052     SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP);
10053     const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
10054     const STRLEN newlen = SvCUR(sv);
10055     UV uv = UNICODE_REPLACEMENT;
10056
10057     PERL_ARGS_ASSERT_REG_RECODE;
10058
10059     if (newlen)
10060         uv = SvUTF8(sv)
10061              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
10062              : *(U8*)s;
10063
10064     if (!newlen || numlen != newlen) {
10065         uv = UNICODE_REPLACEMENT;
10066         *encp = NULL;
10067     }
10068     return uv;
10069 }
10070
10071 PERL_STATIC_INLINE U8
10072 S_compute_EXACTish(pTHX_ RExC_state_t *pRExC_state)
10073 {
10074     U8 op;
10075
10076     PERL_ARGS_ASSERT_COMPUTE_EXACTISH;
10077
10078     if (! FOLD) {
10079         return EXACT;
10080     }
10081
10082     op = get_regex_charset(RExC_flags);
10083     if (op >= REGEX_ASCII_RESTRICTED_CHARSET) {
10084         op--; /* /a is same as /u, and map /aa's offset to what /a's would have
10085                  been, so there is no hole */
10086     }
10087
10088     return op + EXACTF;
10089 }
10090
10091 PERL_STATIC_INLINE void
10092 S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state, regnode *node, I32* flagp, STRLEN len, UV code_point)
10093 {
10094     /* This knows the details about sizing an EXACTish node, setting flags for
10095      * it (by setting <*flagp>, and potentially populating it with a single
10096      * character.
10097      *
10098      * If <len> (the length in bytes) is non-zero, this function assumes that
10099      * the node has already been populated, and just does the sizing.  In this
10100      * case <code_point> should be the final code point that has already been
10101      * placed into the node.  This value will be ignored except that under some
10102      * circumstances <*flagp> is set based on it.
10103      *
10104      * If <len> is zero, the function assumes that the node is to contain only
10105      * the single character given by <code_point> and calculates what <len>
10106      * should be.  In pass 1, it sizes the node appropriately.  In pass 2, it
10107      * additionally will populate the node's STRING with <code_point>, if <len>
10108      * is 0.  In both cases <*flagp> is appropriately set
10109      *
10110      * It knows that under FOLD, the Latin Sharp S and UTF characters above
10111      * 255, must be folded (the former only when the rules indicate it can
10112      * match 'ss') */
10113
10114     bool len_passed_in = cBOOL(len != 0);
10115     U8 character[UTF8_MAXBYTES_CASE+1];
10116
10117     PERL_ARGS_ASSERT_ALLOC_MAYBE_POPULATE_EXACT;
10118
10119     if (! len_passed_in) {
10120         if (UTF) {
10121             if (FOLD && (! LOC || code_point > 255)) {
10122                 _to_uni_fold_flags(NATIVE_TO_UNI(code_point),
10123                                    character,
10124                                    &len,
10125                                    FOLD_FLAGS_FULL | ((LOC)
10126                                                      ? FOLD_FLAGS_LOCALE
10127                                                      : (ASCII_FOLD_RESTRICTED)
10128                                                        ? FOLD_FLAGS_NOMIX_ASCII
10129                                                        : 0));
10130             }
10131             else {
10132                 uvchr_to_utf8( character, code_point);
10133                 len = UTF8SKIP(character);
10134             }
10135         }
10136         else if (! FOLD
10137                  || code_point != LATIN_SMALL_LETTER_SHARP_S
10138                  || ASCII_FOLD_RESTRICTED
10139                  || ! AT_LEAST_UNI_SEMANTICS)
10140         {
10141             *character = (U8) code_point;
10142             len = 1;
10143         }
10144         else {
10145             *character = 's';
10146             *(character + 1) = 's';
10147             len = 2;
10148         }
10149     }
10150
10151     if (SIZE_ONLY) {
10152         RExC_size += STR_SZ(len);
10153     }
10154     else {
10155         RExC_emit += STR_SZ(len);
10156         STR_LEN(node) = len;
10157         if (! len_passed_in) {
10158             Copy((char *) character, STRING(node), len, char);
10159         }
10160     }
10161
10162     *flagp |= HASWIDTH;
10163
10164     /* A single character node is SIMPLE, except for the special-cased SHARP S
10165      * under /di. */
10166     if ((len == 1 || (UTF && len == UNISKIP(code_point)))
10167         && (code_point != LATIN_SMALL_LETTER_SHARP_S
10168             || ! FOLD || ! DEPENDS_SEMANTICS))
10169     {
10170         *flagp |= SIMPLE;
10171     }
10172 }
10173
10174 /*
10175  - regatom - the lowest level
10176
10177    Try to identify anything special at the start of the pattern. If there
10178    is, then handle it as required. This may involve generating a single regop,
10179    such as for an assertion; or it may involve recursing, such as to
10180    handle a () structure.
10181
10182    If the string doesn't start with something special then we gobble up
10183    as much literal text as we can.
10184
10185    Once we have been able to handle whatever type of thing started the
10186    sequence, we return.
10187
10188    Note: we have to be careful with escapes, as they can be both literal
10189    and special, and in the case of \10 and friends, context determines which.
10190
10191    A summary of the code structure is:
10192
10193    switch (first_byte) {
10194         cases for each special:
10195             handle this special;
10196             break;
10197         case '\\':
10198             switch (2nd byte) {
10199                 cases for each unambiguous special:
10200                     handle this special;
10201                     break;
10202                 cases for each ambigous special/literal:
10203                     disambiguate;
10204                     if (special)  handle here
10205                     else goto defchar;
10206                 default: // unambiguously literal:
10207                     goto defchar;
10208             }
10209         default:  // is a literal char
10210             // FALL THROUGH
10211         defchar:
10212             create EXACTish node for literal;
10213             while (more input and node isn't full) {
10214                 switch (input_byte) {
10215                    cases for each special;
10216                        make sure parse pointer is set so that the next call to
10217                            regatom will see this special first
10218                        goto loopdone; // EXACTish node terminated by prev. char
10219                    default:
10220                        append char to EXACTISH node;
10221                 }
10222                 get next input byte;
10223             }
10224         loopdone:
10225    }
10226    return the generated node;
10227
10228    Specifically there are two separate switches for handling
10229    escape sequences, with the one for handling literal escapes requiring
10230    a dummy entry for all of the special escapes that are actually handled
10231    by the other.
10232
10233    Returns NULL, setting *flagp to TRYAGAIN if reg() returns NULL with
10234    TRYAGAIN.  
10235    Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
10236    restarted.
10237    Otherwise does not return NULL.
10238 */
10239
10240 STATIC regnode *
10241 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
10242 {
10243     dVAR;
10244     regnode *ret = NULL;
10245     I32 flags = 0;
10246     char *parse_start = RExC_parse;
10247     U8 op;
10248     int invert = 0;
10249
10250     GET_RE_DEBUG_FLAGS_DECL;
10251
10252     *flagp = WORST;             /* Tentatively. */
10253
10254     DEBUG_PARSE("atom");
10255
10256     PERL_ARGS_ASSERT_REGATOM;
10257
10258 tryagain:
10259     switch ((U8)*RExC_parse) {
10260     case '^':
10261         RExC_seen_zerolen++;
10262         nextchar(pRExC_state);
10263         if (RExC_flags & RXf_PMf_MULTILINE)
10264             ret = reg_node(pRExC_state, MBOL);
10265         else if (RExC_flags & RXf_PMf_SINGLELINE)
10266             ret = reg_node(pRExC_state, SBOL);
10267         else
10268             ret = reg_node(pRExC_state, BOL);
10269         Set_Node_Length(ret, 1); /* MJD */
10270         break;
10271     case '$':
10272         nextchar(pRExC_state);
10273         if (*RExC_parse)
10274             RExC_seen_zerolen++;
10275         if (RExC_flags & RXf_PMf_MULTILINE)
10276             ret = reg_node(pRExC_state, MEOL);
10277         else if (RExC_flags & RXf_PMf_SINGLELINE)
10278             ret = reg_node(pRExC_state, SEOL);
10279         else
10280             ret = reg_node(pRExC_state, EOL);
10281         Set_Node_Length(ret, 1); /* MJD */
10282         break;
10283     case '.':
10284         nextchar(pRExC_state);
10285         if (RExC_flags & RXf_PMf_SINGLELINE)
10286             ret = reg_node(pRExC_state, SANY);
10287         else
10288             ret = reg_node(pRExC_state, REG_ANY);
10289         *flagp |= HASWIDTH|SIMPLE;
10290         RExC_naughty++;
10291         Set_Node_Length(ret, 1); /* MJD */
10292         break;
10293     case '[':
10294     {
10295         char * const oregcomp_parse = ++RExC_parse;
10296         ret = regclass(pRExC_state, flagp,depth+1,
10297                        FALSE, /* means parse the whole char class */
10298                        TRUE, /* allow multi-char folds */
10299                        FALSE, /* don't silence non-portable warnings. */
10300                        NULL);
10301         if (*RExC_parse != ']') {
10302             RExC_parse = oregcomp_parse;
10303             vFAIL("Unmatched [");
10304         }
10305         if (ret == NULL) {
10306             if (*flagp & RESTART_UTF8)
10307                 return NULL;
10308             FAIL2("panic: regclass returned NULL to regatom, flags=%#"UVxf"",
10309                   (UV) *flagp);
10310         }
10311         nextchar(pRExC_state);
10312         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
10313         break;
10314     }
10315     case '(':
10316         nextchar(pRExC_state);
10317         ret = reg(pRExC_state, 2, &flags,depth+1);
10318         if (ret == NULL) {
10319                 if (flags & TRYAGAIN) {
10320                     if (RExC_parse == RExC_end) {
10321                          /* Make parent create an empty node if needed. */
10322                         *flagp |= TRYAGAIN;
10323                         return(NULL);
10324                     }
10325                     goto tryagain;
10326                 }
10327                 if (flags & RESTART_UTF8) {
10328                     *flagp = RESTART_UTF8;
10329                     return NULL;
10330                 }
10331                 FAIL2("panic: reg returned NULL to regatom, flags=%#"UVxf"", (UV) flags);
10332         }
10333         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
10334         break;
10335     case '|':
10336     case ')':
10337         if (flags & TRYAGAIN) {
10338             *flagp |= TRYAGAIN;
10339             return NULL;
10340         }
10341         vFAIL("Internal urp");
10342                                 /* Supposed to be caught earlier. */
10343         break;
10344     case '{':
10345         if (!regcurly(RExC_parse, FALSE)) {
10346             RExC_parse++;
10347             goto defchar;
10348         }
10349         /* FALL THROUGH */
10350     case '?':
10351     case '+':
10352     case '*':
10353         RExC_parse++;
10354         vFAIL("Quantifier follows nothing");
10355         break;
10356     case '\\':
10357         /* Special Escapes
10358
10359            This switch handles escape sequences that resolve to some kind
10360            of special regop and not to literal text. Escape sequnces that
10361            resolve to literal text are handled below in the switch marked
10362            "Literal Escapes".
10363
10364            Every entry in this switch *must* have a corresponding entry
10365            in the literal escape switch. However, the opposite is not
10366            required, as the default for this switch is to jump to the
10367            literal text handling code.
10368         */
10369         switch ((U8)*++RExC_parse) {
10370             U8 arg;
10371         /* Special Escapes */
10372         case 'A':
10373             RExC_seen_zerolen++;
10374             ret = reg_node(pRExC_state, SBOL);
10375             *flagp |= SIMPLE;
10376             goto finish_meta_pat;
10377         case 'G':
10378             ret = reg_node(pRExC_state, GPOS);
10379             RExC_seen |= REG_SEEN_GPOS;
10380             *flagp |= SIMPLE;
10381             goto finish_meta_pat;
10382         case 'K':
10383             RExC_seen_zerolen++;
10384             ret = reg_node(pRExC_state, KEEPS);
10385             *flagp |= SIMPLE;
10386             /* XXX:dmq : disabling in-place substitution seems to
10387              * be necessary here to avoid cases of memory corruption, as
10388              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
10389              */
10390             RExC_seen |= REG_SEEN_LOOKBEHIND;
10391             goto finish_meta_pat;
10392         case 'Z':
10393             ret = reg_node(pRExC_state, SEOL);
10394             *flagp |= SIMPLE;
10395             RExC_seen_zerolen++;                /* Do not optimize RE away */
10396             goto finish_meta_pat;
10397         case 'z':
10398             ret = reg_node(pRExC_state, EOS);
10399             *flagp |= SIMPLE;
10400             RExC_seen_zerolen++;                /* Do not optimize RE away */
10401             goto finish_meta_pat;
10402         case 'C':
10403             ret = reg_node(pRExC_state, CANY);
10404             RExC_seen |= REG_SEEN_CANY;
10405             *flagp |= HASWIDTH|SIMPLE;
10406             goto finish_meta_pat;
10407         case 'X':
10408             ret = reg_node(pRExC_state, CLUMP);
10409             *flagp |= HASWIDTH;
10410             goto finish_meta_pat;
10411
10412         case 'W':
10413             invert = 1;
10414             /* FALLTHROUGH */
10415         case 'w':
10416             arg = ANYOF_WORDCHAR;
10417             goto join_posix;
10418
10419         case 'b':
10420             RExC_seen_zerolen++;
10421             RExC_seen |= REG_SEEN_LOOKBEHIND;
10422             op = BOUND + get_regex_charset(RExC_flags);
10423             if (op > BOUNDA) {  /* /aa is same as /a */
10424                 op = BOUNDA;
10425             }
10426             ret = reg_node(pRExC_state, op);
10427             FLAGS(ret) = get_regex_charset(RExC_flags);
10428             *flagp |= SIMPLE;
10429             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
10430                 ckWARNdep(RExC_parse, "\"\\b{\" is deprecated; use \"\\b\\{\" or \"\\b[{]\" instead");
10431             }
10432             goto finish_meta_pat;
10433         case 'B':
10434             RExC_seen_zerolen++;
10435             RExC_seen |= REG_SEEN_LOOKBEHIND;
10436             op = NBOUND + get_regex_charset(RExC_flags);
10437             if (op > NBOUNDA) { /* /aa is same as /a */
10438                 op = NBOUNDA;
10439             }
10440             ret = reg_node(pRExC_state, op);
10441             FLAGS(ret) = get_regex_charset(RExC_flags);
10442             *flagp |= SIMPLE;
10443             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
10444                 ckWARNdep(RExC_parse, "\"\\B{\" is deprecated; use \"\\B\\{\" or \"\\B[{]\" instead");
10445             }
10446             goto finish_meta_pat;
10447
10448         case 'D':
10449             invert = 1;
10450             /* FALLTHROUGH */
10451         case 'd':
10452             arg = ANYOF_DIGIT;
10453             goto join_posix;
10454
10455         case 'R':
10456             ret = reg_node(pRExC_state, LNBREAK);
10457             *flagp |= HASWIDTH|SIMPLE;
10458             goto finish_meta_pat;
10459
10460         case 'H':
10461             invert = 1;
10462             /* FALLTHROUGH */
10463         case 'h':
10464             arg = ANYOF_BLANK;
10465             op = POSIXU;
10466             goto join_posix_op_known;
10467
10468         case 'V':
10469             invert = 1;
10470             /* FALLTHROUGH */
10471         case 'v':
10472             arg = ANYOF_VERTWS;
10473             op = POSIXU;
10474             goto join_posix_op_known;
10475
10476         case 'S':
10477             invert = 1;
10478             /* FALLTHROUGH */
10479         case 's':
10480             arg = ANYOF_SPACE;
10481
10482         join_posix:
10483
10484             op = POSIXD + get_regex_charset(RExC_flags);
10485             if (op > POSIXA) {  /* /aa is same as /a */
10486                 op = POSIXA;
10487             }
10488
10489         join_posix_op_known:
10490
10491             if (invert) {
10492                 op += NPOSIXD - POSIXD;
10493             }
10494
10495             ret = reg_node(pRExC_state, op);
10496             if (! SIZE_ONLY) {
10497                 FLAGS(ret) = namedclass_to_classnum(arg);
10498             }
10499
10500             *flagp |= HASWIDTH|SIMPLE;
10501             /* FALL THROUGH */
10502
10503          finish_meta_pat:           
10504             nextchar(pRExC_state);
10505             Set_Node_Length(ret, 2); /* MJD */
10506             break;          
10507         case 'p':
10508         case 'P':
10509             {
10510 #ifdef DEBUGGING
10511                 char* parse_start = RExC_parse - 2;
10512 #endif
10513
10514                 RExC_parse--;
10515
10516                 ret = regclass(pRExC_state, flagp,depth+1,
10517                                TRUE, /* means just parse this element */
10518                                FALSE, /* don't allow multi-char folds */
10519                                FALSE, /* don't silence non-portable warnings.
10520                                          It would be a bug if these returned
10521                                          non-portables */
10522                                NULL);
10523                 /* regclass() can only return RESTART_UTF8 if multi-char folds
10524                    are allowed.  */
10525                 if (!ret)
10526                     FAIL2("panic: regclass returned NULL to regatom, flags=%#"UVxf"",
10527                           (UV) *flagp);
10528
10529                 RExC_parse--;
10530
10531                 Set_Node_Offset(ret, parse_start + 2);
10532                 Set_Node_Cur_Length(ret, parse_start);
10533                 nextchar(pRExC_state);
10534             }
10535             break;
10536         case 'N': 
10537             /* Handle \N and \N{NAME} with multiple code points here and not
10538              * below because it can be multicharacter. join_exact() will join
10539              * them up later on.  Also this makes sure that things like
10540              * /\N{BLAH}+/ and \N{BLAH} being multi char Just Happen. dmq.
10541              * The options to the grok function call causes it to fail if the
10542              * sequence is just a single code point.  We then go treat it as
10543              * just another character in the current EXACT node, and hence it
10544              * gets uniform treatment with all the other characters.  The
10545              * special treatment for quantifiers is not needed for such single
10546              * character sequences */
10547             ++RExC_parse;
10548             if (! grok_bslash_N(pRExC_state, &ret, NULL, flagp, depth, FALSE,
10549                                 FALSE /* not strict */ )) {
10550                 if (*flagp & RESTART_UTF8)
10551                     return NULL;
10552                 RExC_parse--;
10553                 goto defchar;
10554             }
10555             break;
10556         case 'k':    /* Handle \k<NAME> and \k'NAME' */
10557         parse_named_seq:
10558         {   
10559             char ch= RExC_parse[1];         
10560             if (ch != '<' && ch != '\'' && ch != '{') {
10561                 RExC_parse++;
10562                 vFAIL2("Sequence %.2s... not terminated",parse_start);
10563             } else {
10564                 /* this pretty much dupes the code for (?P=...) in reg(), if
10565                    you change this make sure you change that */
10566                 char* name_start = (RExC_parse += 2);
10567                 U32 num = 0;
10568                 SV *sv_dat = reg_scan_name(pRExC_state,
10569                     SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
10570                 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
10571                 if (RExC_parse == name_start || *RExC_parse != ch)
10572                     vFAIL2("Sequence %.3s... not terminated",parse_start);
10573
10574                 if (!SIZE_ONLY) {
10575                     num = add_data( pRExC_state, 1, "S" );
10576                     RExC_rxi->data->data[num]=(void*)sv_dat;
10577                     SvREFCNT_inc_simple_void(sv_dat);
10578                 }
10579
10580                 RExC_sawback = 1;
10581                 ret = reganode(pRExC_state,
10582                                ((! FOLD)
10583                                  ? NREF
10584                                  : (ASCII_FOLD_RESTRICTED)
10585                                    ? NREFFA
10586                                    : (AT_LEAST_UNI_SEMANTICS)
10587                                      ? NREFFU
10588                                      : (LOC)
10589                                        ? NREFFL
10590                                        : NREFF),
10591                                 num);
10592                 *flagp |= HASWIDTH;
10593
10594                 /* override incorrect value set in reganode MJD */
10595                 Set_Node_Offset(ret, parse_start+1);
10596                 Set_Node_Cur_Length(ret, parse_start);
10597                 nextchar(pRExC_state);
10598
10599             }
10600             break;
10601         }
10602         case 'g': 
10603         case '1': case '2': case '3': case '4':
10604         case '5': case '6': case '7': case '8': case '9':
10605             {
10606                 I32 num;
10607                 bool isg = *RExC_parse == 'g';
10608                 bool isrel = 0; 
10609                 bool hasbrace = 0;
10610                 if (isg) {
10611                     RExC_parse++;
10612                     if (*RExC_parse == '{') {
10613                         RExC_parse++;
10614                         hasbrace = 1;
10615                     }
10616                     if (*RExC_parse == '-') {
10617                         RExC_parse++;
10618                         isrel = 1;
10619                     }
10620                     if (hasbrace && !isDIGIT(*RExC_parse)) {
10621                         if (isrel) RExC_parse--;
10622                         RExC_parse -= 2;                            
10623                         goto parse_named_seq;
10624                 }   }
10625                 num = atoi(RExC_parse);
10626                 if (isg && num == 0) {
10627                     if (*RExC_parse == '0') {
10628                         vFAIL("Reference to invalid group 0");
10629                     }
10630                     else {
10631                         vFAIL("Unterminated \\g... pattern");
10632                     }
10633                 }
10634                 if (isrel) {
10635                     num = RExC_npar - num;
10636                     if (num < 1)
10637                         vFAIL("Reference to nonexistent or unclosed group");
10638                 }
10639                 if (!isg && num > 9 && num >= RExC_npar && *RExC_parse != '8' && *RExC_parse != '9')
10640                     /* Probably a character specified in octal, e.g. \35 */
10641                     goto defchar;
10642                 else {
10643 #ifdef RE_TRACK_PATTERN_OFFSETS
10644                     char * const parse_start = RExC_parse - 1; /* MJD */
10645 #endif
10646                     while (isDIGIT(*RExC_parse))
10647                         RExC_parse++;
10648                     if (hasbrace) {
10649                         if (*RExC_parse != '}') 
10650                             vFAIL("Unterminated \\g{...} pattern");
10651                         RExC_parse++;
10652                     }    
10653                     if (!SIZE_ONLY) {
10654                         if (num > (I32)RExC_rx->nparens)
10655                             vFAIL("Reference to nonexistent group");
10656                     }
10657                     RExC_sawback = 1;
10658                     ret = reganode(pRExC_state,
10659                                    ((! FOLD)
10660                                      ? REF
10661                                      : (ASCII_FOLD_RESTRICTED)
10662                                        ? REFFA
10663                                        : (AT_LEAST_UNI_SEMANTICS)
10664                                          ? REFFU
10665                                          : (LOC)
10666                                            ? REFFL
10667                                            : REFF),
10668                                     num);
10669                     *flagp |= HASWIDTH;
10670
10671                     /* override incorrect value set in reganode MJD */
10672                     Set_Node_Offset(ret, parse_start+1);
10673                     Set_Node_Cur_Length(ret, parse_start);
10674                     RExC_parse--;
10675                     nextchar(pRExC_state);
10676                 }
10677             }
10678             break;
10679         case '\0':
10680             if (RExC_parse >= RExC_end)
10681                 FAIL("Trailing \\");
10682             /* FALL THROUGH */
10683         default:
10684             /* Do not generate "unrecognized" warnings here, we fall
10685                back into the quick-grab loop below */
10686             parse_start--;
10687             goto defchar;
10688         }
10689         break;
10690
10691     case '#':
10692         if (RExC_flags & RXf_PMf_EXTENDED) {
10693             if ( reg_skipcomment( pRExC_state ) )
10694                 goto tryagain;
10695         }
10696         /* FALL THROUGH */
10697
10698     default:
10699
10700             parse_start = RExC_parse - 1;
10701
10702             RExC_parse++;
10703
10704         defchar: {
10705             STRLEN len = 0;
10706             UV ender;
10707             char *p;
10708             char *s;
10709 #define MAX_NODE_STRING_SIZE 127
10710             char foldbuf[MAX_NODE_STRING_SIZE+UTF8_MAXBYTES_CASE];
10711             char *s0;
10712             U8 upper_parse = MAX_NODE_STRING_SIZE;
10713             STRLEN foldlen;
10714             U8 node_type;
10715             bool next_is_quantifier;
10716             char * oldp = NULL;
10717
10718             /* If a folding node contains only code points that don't
10719              * participate in folds, it can be changed into an EXACT node,
10720              * which allows the optimizer more things to look for */
10721             bool maybe_exact;
10722
10723             ender = 0;
10724             node_type = compute_EXACTish(pRExC_state);
10725             ret = reg_node(pRExC_state, node_type);
10726
10727             /* In pass1, folded, we use a temporary buffer instead of the
10728              * actual node, as the node doesn't exist yet */
10729             s = (SIZE_ONLY && FOLD) ? foldbuf : STRING(ret);
10730
10731             s0 = s;
10732
10733         reparse:
10734
10735             /* We do the EXACTFish to EXACT node only if folding, and not if in
10736              * locale, as whether a character folds or not isn't known until
10737              * runtime */
10738             maybe_exact = FOLD && ! LOC;
10739
10740             /* XXX The node can hold up to 255 bytes, yet this only goes to
10741              * 127.  I (khw) do not know why.  Keeping it somewhat less than
10742              * 255 allows us to not have to worry about overflow due to
10743              * converting to utf8 and fold expansion, but that value is
10744              * 255-UTF8_MAXBYTES_CASE.  join_exact() may join adjacent nodes
10745              * split up by this limit into a single one using the real max of
10746              * 255.  Even at 127, this breaks under rare circumstances.  If
10747              * folding, we do not want to split a node at a character that is a
10748              * non-final in a multi-char fold, as an input string could just
10749              * happen to want to match across the node boundary.  The join
10750              * would solve that problem if the join actually happens.  But a
10751              * series of more than two nodes in a row each of 127 would cause
10752              * the first join to succeed to get to 254, but then there wouldn't
10753              * be room for the next one, which could at be one of those split
10754              * multi-char folds.  I don't know of any fool-proof solution.  One
10755              * could back off to end with only a code point that isn't such a
10756              * non-final, but it is possible for there not to be any in the
10757              * entire node. */
10758             for (p = RExC_parse - 1;
10759                  len < upper_parse && p < RExC_end;
10760                  len++)
10761             {
10762                 oldp = p;
10763
10764                 if (RExC_flags & RXf_PMf_EXTENDED)
10765                     p = regwhite( pRExC_state, p );
10766                 switch ((U8)*p) {
10767                 case '^':
10768                 case '$':
10769                 case '.':
10770                 case '[':
10771                 case '(':
10772                 case ')':
10773                 case '|':
10774                     goto loopdone;
10775                 case '\\':
10776                     /* Literal Escapes Switch
10777
10778                        This switch is meant to handle escape sequences that
10779                        resolve to a literal character.
10780
10781                        Every escape sequence that represents something
10782                        else, like an assertion or a char class, is handled
10783                        in the switch marked 'Special Escapes' above in this
10784                        routine, but also has an entry here as anything that
10785                        isn't explicitly mentioned here will be treated as
10786                        an unescaped equivalent literal.
10787                     */
10788
10789                     switch ((U8)*++p) {
10790                     /* These are all the special escapes. */
10791                     case 'A':             /* Start assertion */
10792                     case 'b': case 'B':   /* Word-boundary assertion*/
10793                     case 'C':             /* Single char !DANGEROUS! */
10794                     case 'd': case 'D':   /* digit class */
10795                     case 'g': case 'G':   /* generic-backref, pos assertion */
10796                     case 'h': case 'H':   /* HORIZWS */
10797                     case 'k': case 'K':   /* named backref, keep marker */
10798                     case 'p': case 'P':   /* Unicode property */
10799                               case 'R':   /* LNBREAK */
10800                     case 's': case 'S':   /* space class */
10801                     case 'v': case 'V':   /* VERTWS */
10802                     case 'w': case 'W':   /* word class */
10803                     case 'X':             /* eXtended Unicode "combining character sequence" */
10804                     case 'z': case 'Z':   /* End of line/string assertion */
10805                         --p;
10806                         goto loopdone;
10807
10808                     /* Anything after here is an escape that resolves to a
10809                        literal. (Except digits, which may or may not)
10810                      */
10811                     case 'n':
10812                         ender = '\n';
10813                         p++;
10814                         break;
10815                     case 'N': /* Handle a single-code point named character. */
10816                         /* The options cause it to fail if a multiple code
10817                          * point sequence.  Handle those in the switch() above
10818                          * */
10819                         RExC_parse = p + 1;
10820                         if (! grok_bslash_N(pRExC_state, NULL, &ender,
10821                                             flagp, depth, FALSE,
10822                                             FALSE /* not strict */ ))
10823                         {
10824                             if (*flagp & RESTART_UTF8)
10825                                 FAIL("panic: grok_bslash_N set RESTART_UTF8");
10826                             RExC_parse = p = oldp;
10827                             goto loopdone;
10828                         }
10829                         p = RExC_parse;
10830                         if (ender > 0xff) {
10831                             REQUIRE_UTF8;
10832                         }
10833                         break;
10834                     case 'r':
10835                         ender = '\r';
10836                         p++;
10837                         break;
10838                     case 't':
10839                         ender = '\t';
10840                         p++;
10841                         break;
10842                     case 'f':
10843                         ender = '\f';
10844                         p++;
10845                         break;
10846                     case 'e':
10847                           ender = ASCII_TO_NATIVE('\033');
10848                         p++;
10849                         break;
10850                     case 'a':
10851                           ender = ASCII_TO_NATIVE('\007');
10852                         p++;
10853                         break;
10854                     case 'o':
10855                         {
10856                             UV result;
10857                             const char* error_msg;
10858
10859                             bool valid = grok_bslash_o(&p,
10860                                                        &result,
10861                                                        &error_msg,
10862                                                        TRUE, /* out warnings */
10863                                                        FALSE, /* not strict */
10864                                                        TRUE, /* Output warnings
10865                                                                 for non-
10866                                                                 portables */
10867                                                        UTF);
10868                             if (! valid) {
10869                                 RExC_parse = p; /* going to die anyway; point
10870                                                    to exact spot of failure */
10871                                 vFAIL(error_msg);
10872                             }
10873                             ender = result;
10874                             if (PL_encoding && ender < 0x100) {
10875                                 goto recode_encoding;
10876                             }
10877                             if (ender > 0xff) {
10878                                 REQUIRE_UTF8;
10879                             }
10880                             break;
10881                         }
10882                     case 'x':
10883                         {
10884                             UV result = UV_MAX; /* initialize to erroneous
10885                                                    value */
10886                             const char* error_msg;
10887
10888                             bool valid = grok_bslash_x(&p,
10889                                                        &result,
10890                                                        &error_msg,
10891                                                        TRUE, /* out warnings */
10892                                                        FALSE, /* not strict */
10893                                                        TRUE, /* Output warnings
10894                                                                 for non-
10895                                                                 portables */
10896                                                        UTF);
10897                             if (! valid) {
10898                                 RExC_parse = p; /* going to die anyway; point
10899                                                    to exact spot of failure */
10900                                 vFAIL(error_msg);
10901                             }
10902                             ender = result;
10903
10904                             if (PL_encoding && ender < 0x100) {
10905                                 goto recode_encoding;
10906                             }
10907                             if (ender > 0xff) {
10908                                 REQUIRE_UTF8;
10909                             }
10910                             break;
10911                         }
10912                     case 'c':
10913                         p++;
10914                         ender = grok_bslash_c(*p++, UTF, SIZE_ONLY);
10915                         break;
10916                     case '8': case '9': /* must be a backreference */
10917                         --p;
10918                         goto loopdone;
10919                     case '1': case '2': case '3':case '4':
10920                     case '5': case '6': case '7':
10921                         /* When we parse backslash escapes there is ambiguity between
10922                          * backreferences and octal escapes. Any escape from \1 - \9 is
10923                          * a backreference, any multi-digit escape which does not start with
10924                          * 0 and which when evaluated as decimal could refer to an already
10925                          * parsed capture buffer is a backslash. Anything else is octal.
10926                          *
10927                          * Note this implies that \118 could be interpreted as 118 OR as
10928                          * "\11" . "8" depending on whether there were 118 capture buffers
10929                          * defined already in the pattern.
10930                          */
10931                         if ( !isDIGIT(p[1]) || atoi(p) <= RExC_npar )
10932                         {  /* Not to be treated as an octal constant, go
10933                                    find backref */
10934                             --p;
10935                             goto loopdone;
10936                         }
10937                     case '0':
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                         if (PL_encoding && ender < 0x100)
10957                             goto recode_encoding;
10958                         break;
10959                     recode_encoding:
10960                         if (! RExC_override_recoding) {
10961                             SV* enc = PL_encoding;
10962                             ender = reg_recode((const char)(U8)ender, &enc);
10963                             if (!enc && SIZE_ONLY)
10964                                 ckWARNreg(p, "Invalid escape in the specified encoding");
10965                             REQUIRE_UTF8;
10966                         }
10967                         break;
10968                     case '\0':
10969                         if (p >= RExC_end)
10970                             FAIL("Trailing \\");
10971                         /* FALL THROUGH */
10972                     default:
10973                         if (!SIZE_ONLY&& isALPHANUMERIC(*p)) {
10974                             /* Include any { following the alpha to emphasize
10975                              * that it could be part of an escape at some point
10976                              * in the future */
10977                             int len = (isALPHA(*p) && *(p + 1) == '{') ? 2 : 1;
10978                             ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
10979                         }
10980                         goto normal_default;
10981                     } /* End of switch on '\' */
10982                     break;
10983                 default:    /* A literal character */
10984
10985                     if (! SIZE_ONLY
10986                         && RExC_flags & RXf_PMf_EXTENDED
10987                         && ckWARN_d(WARN_DEPRECATED)
10988                         && is_PATWS_non_low(p, UTF))
10989                     {
10990                         vWARN_dep(p + ((UTF) ? UTF8SKIP(p) : 1),
10991                                 "Escape literal pattern white space under /x");
10992                     }
10993
10994                   normal_default:
10995                     if (UTF8_IS_START(*p) && UTF) {
10996                         STRLEN numlen;
10997                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
10998                                                &numlen, UTF8_ALLOW_DEFAULT);
10999                         p += numlen;
11000                     }
11001                     else
11002                         ender = (U8) *p++;
11003                     break;
11004                 } /* End of switch on the literal */
11005
11006                 /* Here, have looked at the literal character and <ender>
11007                  * contains its ordinal, <p> points to the character after it
11008                  */
11009
11010                 if ( RExC_flags & RXf_PMf_EXTENDED)
11011                     p = regwhite( pRExC_state, p );
11012
11013                 /* If the next thing is a quantifier, it applies to this
11014                  * character only, which means that this character has to be in
11015                  * its own node and can't just be appended to the string in an
11016                  * existing node, so if there are already other characters in
11017                  * the node, close the node with just them, and set up to do
11018                  * this character again next time through, when it will be the
11019                  * only thing in its new node */
11020                 if ((next_is_quantifier = (p < RExC_end && ISMULT2(p))) && len)
11021                 {
11022                     p = oldp;
11023                     goto loopdone;
11024                 }
11025
11026                 if (! FOLD) {
11027                     if (UTF) {
11028                         const STRLEN unilen = reguni(pRExC_state, ender, s);
11029                         if (unilen > 0) {
11030                            s   += unilen;
11031                            len += unilen;
11032                         }
11033
11034                         /* The loop increments <len> each time, as all but this
11035                          * path (and one other) through it add a single byte to
11036                          * the EXACTish node.  But this one has changed len to
11037                          * be the correct final value, so subtract one to
11038                          * cancel out the increment that follows */
11039                         len--;
11040                     }
11041                     else {
11042                         REGC((char)ender, s++);
11043                     }
11044                 }
11045                 else /* FOLD */
11046                      if (! ( UTF
11047                         /* See comments for join_exact() as to why we fold this
11048                          * non-UTF at compile time */
11049                         || (node_type == EXACTFU
11050                             && ender == LATIN_SMALL_LETTER_SHARP_S)))
11051                 {
11052                     *(s++) = (char) ender;
11053                     maybe_exact &= ! IS_IN_SOME_FOLD_L1(ender);
11054                 }
11055                 else {  /* UTF */
11056
11057                     /* Prime the casefolded buffer.  Locale rules, which apply
11058                      * only to code points < 256, aren't known until execution,
11059                      * so for them, just output the original character using
11060                      * utf8.  If we start to fold non-UTF patterns, be sure to
11061                      * update join_exact() */
11062                     if (LOC && ender < 256) {
11063                         if (UNI_IS_INVARIANT(ender)) {
11064                             *s = (U8) ender;
11065                             foldlen = 1;
11066                         } else {
11067                             *s = UTF8_TWO_BYTE_HI(ender);
11068                             *(s + 1) = UTF8_TWO_BYTE_LO(ender);
11069                             foldlen = 2;
11070                         }
11071                     }
11072                     else {
11073                         UV folded = _to_uni_fold_flags(
11074                                        ender,
11075                                        (U8 *) s,
11076                                        &foldlen,
11077                                        FOLD_FLAGS_FULL
11078                                        | ((LOC) ?  FOLD_FLAGS_LOCALE
11079                                                 : (ASCII_FOLD_RESTRICTED)
11080                                                   ? FOLD_FLAGS_NOMIX_ASCII
11081                                                   : 0)
11082                                         );
11083
11084                         /* If this node only contains non-folding code points
11085                          * so far, see if this new one is also non-folding */
11086                         if (maybe_exact) {
11087                             if (folded != ender) {
11088                                 maybe_exact = FALSE;
11089                             }
11090                             else {
11091                                 /* Here the fold is the original; we have
11092                                  * to check further to see if anything
11093                                  * folds to it */
11094                                 if (! PL_utf8_foldable) {
11095                                     SV* swash = swash_init("utf8",
11096                                                        "_Perl_Any_Folds",
11097                                                        &PL_sv_undef, 1, 0);
11098                                     PL_utf8_foldable =
11099                                                 _get_swash_invlist(swash);
11100                                     SvREFCNT_dec_NN(swash);
11101                                 }
11102                                 if (_invlist_contains_cp(PL_utf8_foldable,
11103                                                          ender))
11104                                 {
11105                                     maybe_exact = FALSE;
11106                                 }
11107                             }
11108                         }
11109                         ender = folded;
11110                     }
11111                     s += foldlen;
11112
11113                     /* The loop increments <len> each time, as all but this
11114                      * path (and one other) through it add a single byte to the
11115                      * EXACTish node.  But this one has changed len to be the
11116                      * correct final value, so subtract one to cancel out the
11117                      * increment that follows */
11118                     len += foldlen - 1;
11119                 }
11120
11121                 if (next_is_quantifier) {
11122
11123                     /* Here, the next input is a quantifier, and to get here,
11124                      * the current character is the only one in the node.
11125                      * Also, here <len> doesn't include the final byte for this
11126                      * character */
11127                     len++;
11128                     goto loopdone;
11129                 }
11130
11131             } /* End of loop through literal characters */
11132
11133             /* Here we have either exhausted the input or ran out of room in
11134              * the node.  (If we encountered a character that can't be in the
11135              * node, transfer is made directly to <loopdone>, and so we
11136              * wouldn't have fallen off the end of the loop.)  In the latter
11137              * case, we artificially have to split the node into two, because
11138              * we just don't have enough space to hold everything.  This
11139              * creates a problem if the final character participates in a
11140              * multi-character fold in the non-final position, as a match that
11141              * should have occurred won't, due to the way nodes are matched,
11142              * and our artificial boundary.  So back off until we find a non-
11143              * problematic character -- one that isn't at the beginning or
11144              * middle of such a fold.  (Either it doesn't participate in any
11145              * folds, or appears only in the final position of all the folds it
11146              * does participate in.)  A better solution with far fewer false
11147              * positives, and that would fill the nodes more completely, would
11148              * be to actually have available all the multi-character folds to
11149              * test against, and to back-off only far enough to be sure that
11150              * this node isn't ending with a partial one.  <upper_parse> is set
11151              * further below (if we need to reparse the node) to include just
11152              * up through that final non-problematic character that this code
11153              * identifies, so when it is set to less than the full node, we can
11154              * skip the rest of this */
11155             if (FOLD && p < RExC_end && upper_parse == MAX_NODE_STRING_SIZE) {
11156
11157                 const STRLEN full_len = len;
11158
11159                 assert(len >= MAX_NODE_STRING_SIZE);
11160
11161                 /* Here, <s> points to the final byte of the final character.
11162                  * Look backwards through the string until find a non-
11163                  * problematic character */
11164
11165                 if (! UTF) {
11166
11167                     /* These two have no multi-char folds to non-UTF characters
11168                      */
11169                     if (ASCII_FOLD_RESTRICTED || LOC) {
11170                         goto loopdone;
11171                     }
11172
11173                     while (--s >= s0 && IS_NON_FINAL_FOLD(*s)) { }
11174                     len = s - s0 + 1;
11175                 }
11176                 else {
11177                     if (!  PL_NonL1NonFinalFold) {
11178                         PL_NonL1NonFinalFold = _new_invlist_C_array(
11179                                         NonL1_Perl_Non_Final_Folds_invlist);
11180                     }
11181
11182                     /* Point to the first byte of the final character */
11183                     s = (char *) utf8_hop((U8 *) s, -1);
11184
11185                     while (s >= s0) {   /* Search backwards until find
11186                                            non-problematic char */
11187                         if (UTF8_IS_INVARIANT(*s)) {
11188
11189                             /* There are no ascii characters that participate
11190                              * in multi-char folds under /aa.  In EBCDIC, the
11191                              * non-ascii invariants are all control characters,
11192                              * so don't ever participate in any folds. */
11193                             if (ASCII_FOLD_RESTRICTED
11194                                 || ! IS_NON_FINAL_FOLD(*s))
11195                             {
11196                                 break;
11197                             }
11198                         }
11199                         else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
11200
11201                             /* No Latin1 characters participate in multi-char
11202                              * folds under /l */
11203                             if (LOC
11204                                 || ! IS_NON_FINAL_FOLD(TWO_BYTE_UTF8_TO_UNI(
11205                                                                 *s, *(s+1))))
11206                             {
11207                                 break;
11208                             }
11209                         }
11210                         else if (! _invlist_contains_cp(
11211                                         PL_NonL1NonFinalFold,
11212                                         valid_utf8_to_uvchr((U8 *) s, NULL)))
11213                         {
11214                             break;
11215                         }
11216
11217                         /* Here, the current character is problematic in that
11218                          * it does occur in the non-final position of some
11219                          * fold, so try the character before it, but have to
11220                          * special case the very first byte in the string, so
11221                          * we don't read outside the string */
11222                         s = (s == s0) ? s -1 : (char *) utf8_hop((U8 *) s, -1);
11223                     } /* End of loop backwards through the string */
11224
11225                     /* If there were only problematic characters in the string,
11226                      * <s> will point to before s0, in which case the length
11227                      * should be 0, otherwise include the length of the
11228                      * non-problematic character just found */
11229                     len = (s < s0) ? 0 : s - s0 + UTF8SKIP(s);
11230                 }
11231
11232                 /* Here, have found the final character, if any, that is
11233                  * non-problematic as far as ending the node without splitting
11234                  * it across a potential multi-char fold.  <len> contains the
11235                  * number of bytes in the node up-to and including that
11236                  * character, or is 0 if there is no such character, meaning
11237                  * the whole node contains only problematic characters.  In
11238                  * this case, give up and just take the node as-is.  We can't
11239                  * do any better */
11240                 if (len == 0) {
11241                     len = full_len;
11242                 } else {
11243
11244                     /* Here, the node does contain some characters that aren't
11245                      * problematic.  If one such is the final character in the
11246                      * node, we are done */
11247                     if (len == full_len) {
11248                         goto loopdone;
11249                     }
11250                     else if (len + ((UTF) ? UTF8SKIP(s) : 1) == full_len) {
11251
11252                         /* If the final character is problematic, but the
11253                          * penultimate is not, back-off that last character to
11254                          * later start a new node with it */
11255                         p = oldp;
11256                         goto loopdone;
11257                     }
11258
11259                     /* Here, the final non-problematic character is earlier
11260                      * in the input than the penultimate character.  What we do
11261                      * is reparse from the beginning, going up only as far as
11262                      * this final ok one, thus guaranteeing that the node ends
11263                      * in an acceptable character.  The reason we reparse is
11264                      * that we know how far in the character is, but we don't
11265                      * know how to correlate its position with the input parse.
11266                      * An alternate implementation would be to build that
11267                      * correlation as we go along during the original parse,
11268                      * but that would entail extra work for every node, whereas
11269                      * this code gets executed only when the string is too
11270                      * large for the node, and the final two characters are
11271                      * problematic, an infrequent occurrence.  Yet another
11272                      * possible strategy would be to save the tail of the
11273                      * string, and the next time regatom is called, initialize
11274                      * with that.  The problem with this is that unless you
11275                      * back off one more character, you won't be guaranteed
11276                      * regatom will get called again, unless regbranch,
11277                      * regpiece ... are also changed.  If you do back off that
11278                      * extra character, so that there is input guaranteed to
11279                      * force calling regatom, you can't handle the case where
11280                      * just the first character in the node is acceptable.  I
11281                      * (khw) decided to try this method which doesn't have that
11282                      * pitfall; if performance issues are found, we can do a
11283                      * combination of the current approach plus that one */
11284                     upper_parse = len;
11285                     len = 0;
11286                     s = s0;
11287                     goto reparse;
11288                 }
11289             }   /* End of verifying node ends with an appropriate char */
11290
11291         loopdone:   /* Jumped to when encounters something that shouldn't be in
11292                        the node */
11293
11294             /* I (khw) don't know if you can get here with zero length, but the
11295              * old code handled this situation by creating a zero-length EXACT
11296              * node.  Might as well be NOTHING instead */
11297             if (len == 0) {
11298                 OP(ret) = NOTHING;
11299             }
11300             else{
11301
11302                 /* If 'maybe_exact' is still set here, means there are no
11303                  * code points in the node that participate in folds */
11304                 if (FOLD && maybe_exact) {
11305                     OP(ret) = EXACT;
11306                 }
11307                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, len, ender);
11308             }
11309
11310             RExC_parse = p - 1;
11311             Set_Node_Cur_Length(ret, parse_start);
11312             nextchar(pRExC_state);
11313             {
11314                 /* len is STRLEN which is unsigned, need to copy to signed */
11315                 IV iv = len;
11316                 if (iv < 0)
11317                     vFAIL("Internal disaster");
11318             }
11319
11320         } /* End of label 'defchar:' */
11321         break;
11322     } /* End of giant switch on input character */
11323
11324     return(ret);
11325 }
11326
11327 STATIC char *
11328 S_regwhite( RExC_state_t *pRExC_state, char *p )
11329 {
11330     const char *e = RExC_end;
11331
11332     PERL_ARGS_ASSERT_REGWHITE;
11333
11334     while (p < e) {
11335         if (isSPACE(*p))
11336             ++p;
11337         else if (*p == '#') {
11338             bool ended = 0;
11339             do {
11340                 if (*p++ == '\n') {
11341                     ended = 1;
11342                     break;
11343                 }
11344             } while (p < e);
11345             if (!ended)
11346                 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
11347         }
11348         else
11349             break;
11350     }
11351     return p;
11352 }
11353
11354 STATIC char *
11355 S_regpatws( RExC_state_t *pRExC_state, char *p , const bool recognize_comment )
11356 {
11357     /* Returns the next non-pattern-white space, non-comment character (the
11358      * latter only if 'recognize_comment is true) in the string p, which is
11359      * ended by RExC_end.  If there is no line break ending a comment,
11360      * RExC_seen has added the REG_SEEN_RUN_ON_COMMENT flag; */
11361     const char *e = RExC_end;
11362
11363     PERL_ARGS_ASSERT_REGPATWS;
11364
11365     while (p < e) {
11366         STRLEN len;
11367         if ((len = is_PATWS_safe(p, e, UTF))) {
11368             p += len;
11369         }
11370         else if (recognize_comment && *p == '#') {
11371             bool ended = 0;
11372             do {
11373                 p++;
11374                 if (is_LNBREAK_safe(p, e, UTF)) {
11375                     ended = 1;
11376                     break;
11377                 }
11378             } while (p < e);
11379             if (!ended)
11380                 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
11381         }
11382         else
11383             break;
11384     }
11385     return p;
11386 }
11387
11388 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
11389    Character classes ([:foo:]) can also be negated ([:^foo:]).
11390    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
11391    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
11392    but trigger failures because they are currently unimplemented. */
11393
11394 #define POSIXCC_DONE(c)   ((c) == ':')
11395 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
11396 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
11397
11398 PERL_STATIC_INLINE I32
11399 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value, const bool strict)
11400 {
11401     dVAR;
11402     I32 namedclass = OOB_NAMEDCLASS;
11403
11404     PERL_ARGS_ASSERT_REGPPOSIXCC;
11405
11406     if (value == '[' && RExC_parse + 1 < RExC_end &&
11407         /* I smell either [: or [= or [. -- POSIX has been here, right? */
11408         POSIXCC(UCHARAT(RExC_parse)))
11409     {
11410         const char c = UCHARAT(RExC_parse);
11411         char* const s = RExC_parse++;
11412
11413         while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
11414             RExC_parse++;
11415         if (RExC_parse == RExC_end) {
11416             if (strict) {
11417
11418                 /* Try to give a better location for the error (than the end of
11419                  * the string) by looking for the matching ']' */
11420                 RExC_parse = s;
11421                 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
11422                     RExC_parse++;
11423                 }
11424                 vFAIL2("Unmatched '%c' in POSIX class", c);
11425             }
11426             /* Grandfather lone [:, [=, [. */
11427             RExC_parse = s;
11428         }
11429         else {
11430             const char* const t = RExC_parse++; /* skip over the c */
11431             assert(*t == c);
11432
11433             if (UCHARAT(RExC_parse) == ']') {
11434                 const char *posixcc = s + 1;
11435                 RExC_parse++; /* skip over the ending ] */
11436
11437                 if (*s == ':') {
11438                     const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
11439                     const I32 skip = t - posixcc;
11440
11441                     /* Initially switch on the length of the name.  */
11442                     switch (skip) {
11443                     case 4:
11444                         if (memEQ(posixcc, "word", 4)) /* this is not POSIX,
11445                                                           this is the Perl \w
11446                                                         */
11447                             namedclass = ANYOF_WORDCHAR;
11448                         break;
11449                     case 5:
11450                         /* Names all of length 5.  */
11451                         /* alnum alpha ascii blank cntrl digit graph lower
11452                            print punct space upper  */
11453                         /* Offset 4 gives the best switch position.  */
11454                         switch (posixcc[4]) {
11455                         case 'a':
11456                             if (memEQ(posixcc, "alph", 4)) /* alpha */
11457                                 namedclass = ANYOF_ALPHA;
11458                             break;
11459                         case 'e':
11460                             if (memEQ(posixcc, "spac", 4)) /* space */
11461                                 namedclass = ANYOF_PSXSPC;
11462                             break;
11463                         case 'h':
11464                             if (memEQ(posixcc, "grap", 4)) /* graph */
11465                                 namedclass = ANYOF_GRAPH;
11466                             break;
11467                         case 'i':
11468                             if (memEQ(posixcc, "asci", 4)) /* ascii */
11469                                 namedclass = ANYOF_ASCII;
11470                             break;
11471                         case 'k':
11472                             if (memEQ(posixcc, "blan", 4)) /* blank */
11473                                 namedclass = ANYOF_BLANK;
11474                             break;
11475                         case 'l':
11476                             if (memEQ(posixcc, "cntr", 4)) /* cntrl */
11477                                 namedclass = ANYOF_CNTRL;
11478                             break;
11479                         case 'm':
11480                             if (memEQ(posixcc, "alnu", 4)) /* alnum */
11481                                 namedclass = ANYOF_ALPHANUMERIC;
11482                             break;
11483                         case 'r':
11484                             if (memEQ(posixcc, "lowe", 4)) /* lower */
11485                                 namedclass = (FOLD) ? ANYOF_CASED : ANYOF_LOWER;
11486                             else if (memEQ(posixcc, "uppe", 4)) /* upper */
11487                                 namedclass = (FOLD) ? ANYOF_CASED : ANYOF_UPPER;
11488                             break;
11489                         case 't':
11490                             if (memEQ(posixcc, "digi", 4)) /* digit */
11491                                 namedclass = ANYOF_DIGIT;
11492                             else if (memEQ(posixcc, "prin", 4)) /* print */
11493                                 namedclass = ANYOF_PRINT;
11494                             else if (memEQ(posixcc, "punc", 4)) /* punct */
11495                                 namedclass = ANYOF_PUNCT;
11496                             break;
11497                         }
11498                         break;
11499                     case 6:
11500                         if (memEQ(posixcc, "xdigit", 6))
11501                             namedclass = ANYOF_XDIGIT;
11502                         break;
11503                     }
11504
11505                     if (namedclass == OOB_NAMEDCLASS)
11506                         Simple_vFAIL3("POSIX class [:%.*s:] unknown",
11507                                       t - s - 1, s + 1);
11508
11509                     /* The #defines are structured so each complement is +1 to
11510                      * the normal one */
11511                     if (complement) {
11512                         namedclass++;
11513                     }
11514                     assert (posixcc[skip] == ':');
11515                     assert (posixcc[skip+1] == ']');
11516                 } else if (!SIZE_ONLY) {
11517                     /* [[=foo=]] and [[.foo.]] are still future. */
11518
11519                     /* adjust RExC_parse so the warning shows after
11520                        the class closes */
11521                     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
11522                         RExC_parse++;
11523                     vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
11524                 }
11525             } else {
11526                 /* Maternal grandfather:
11527                  * "[:" ending in ":" but not in ":]" */
11528                 if (strict) {
11529                     vFAIL("Unmatched '[' in POSIX class");
11530                 }
11531
11532                 /* Grandfather lone [:, [=, [. */
11533                 RExC_parse = s;
11534             }
11535         }
11536     }
11537
11538     return namedclass;
11539 }
11540
11541 STATIC bool
11542 S_could_it_be_a_POSIX_class(pTHX_ RExC_state_t *pRExC_state)
11543 {
11544     /* This applies some heuristics at the current parse position (which should
11545      * be at a '[') to see if what follows might be intended to be a [:posix:]
11546      * class.  It returns true if it really is a posix class, of course, but it
11547      * also can return true if it thinks that what was intended was a posix
11548      * class that didn't quite make it.
11549      *
11550      * It will return true for
11551      *      [:alphanumerics:
11552      *      [:alphanumerics]  (as long as the ] isn't followed immediately by a
11553      *                         ')' indicating the end of the (?[
11554      *      [:any garbage including %^&$ punctuation:]
11555      *
11556      * This is designed to be called only from S_handle_regex_sets; it could be
11557      * easily adapted to be called from the spot at the beginning of regclass()
11558      * that checks to see in a normal bracketed class if the surrounding []
11559      * have been omitted ([:word:] instead of [[:word:]]).  But doing so would
11560      * change long-standing behavior, so I (khw) didn't do that */
11561     char* p = RExC_parse + 1;
11562     char first_char = *p;
11563
11564     PERL_ARGS_ASSERT_COULD_IT_BE_A_POSIX_CLASS;
11565
11566     assert(*(p - 1) == '[');
11567
11568     if (! POSIXCC(first_char)) {
11569         return FALSE;
11570     }
11571
11572     p++;
11573     while (p < RExC_end && isWORDCHAR(*p)) p++;
11574
11575     if (p >= RExC_end) {
11576         return FALSE;
11577     }
11578
11579     if (p - RExC_parse > 2    /* Got at least 1 word character */
11580         && (*p == first_char
11581             || (*p == ']' && p + 1 < RExC_end && *(p + 1) != ')')))
11582     {
11583         return TRUE;
11584     }
11585
11586     p = (char *) memchr(RExC_parse, ']', RExC_end - RExC_parse);
11587
11588     return (p
11589             && p - RExC_parse > 2 /* [:] evaluates to colon;
11590                                       [::] is a bad posix class. */
11591             && first_char == *(p - 1));
11592 }
11593
11594 STATIC regnode *
11595 S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist, I32 *flagp, U32 depth,
11596                    char * const oregcomp_parse)
11597 {
11598     /* Handle the (?[...]) construct to do set operations */
11599
11600     U8 curchar;
11601     UV start, end;      /* End points of code point ranges */
11602     SV* result_string;
11603     char *save_end, *save_parse;
11604     SV* final;
11605     STRLEN len;
11606     regnode* node;
11607     AV* stack;
11608     const bool save_fold = FOLD;
11609
11610     GET_RE_DEBUG_FLAGS_DECL;
11611
11612     PERL_ARGS_ASSERT_HANDLE_REGEX_SETS;
11613
11614     if (LOC) {
11615         vFAIL("(?[...]) not valid in locale");
11616     }
11617     RExC_uni_semantics = 1;
11618
11619     /* This will return only an ANYOF regnode, or (unlikely) something smaller
11620      * (such as EXACT).  Thus we can skip most everything if just sizing.  We
11621      * call regclass to handle '[]' so as to not have to reinvent its parsing
11622      * rules here (throwing away the size it computes each time).  And, we exit
11623      * upon an unescaped ']' that isn't one ending a regclass.  To do both
11624      * these things, we need to realize that something preceded by a backslash
11625      * is escaped, so we have to keep track of backslashes */
11626     if (SIZE_ONLY) {
11627         UV depth = 0; /* how many nested (?[...]) constructs */
11628
11629         Perl_ck_warner_d(aTHX_
11630             packWARN(WARN_EXPERIMENTAL__REGEX_SETS),
11631             "The regex_sets feature is experimental" REPORT_LOCATION,
11632             (int) (RExC_parse - RExC_precomp) , RExC_precomp, RExC_parse);
11633
11634         while (RExC_parse < RExC_end) {
11635             SV* current = NULL;
11636             RExC_parse = regpatws(pRExC_state, RExC_parse,
11637                                 TRUE); /* means recognize comments */
11638             switch (*RExC_parse) {
11639                 case '?':
11640                     if (RExC_parse[1] == '[') depth++, RExC_parse++;
11641                     /* FALL THROUGH */
11642                 default:
11643                     break;
11644                 case '\\':
11645                     /* Skip the next byte (which could cause us to end up in
11646                      * the middle of a UTF-8 character, but since none of those
11647                      * are confusable with anything we currently handle in this
11648                      * switch (invariants all), it's safe.  We'll just hit the
11649                      * default: case next time and keep on incrementing until
11650                      * we find one of the invariants we do handle. */
11651                     RExC_parse++;
11652                     break;
11653                 case '[':
11654                 {
11655                     /* If this looks like it is a [:posix:] class, leave the
11656                      * parse pointer at the '[' to fool regclass() into
11657                      * thinking it is part of a '[[:posix:]]'.  That function
11658                      * will use strict checking to force a syntax error if it
11659                      * doesn't work out to a legitimate class */
11660                     bool is_posix_class
11661                                     = could_it_be_a_POSIX_class(pRExC_state);
11662                     if (! is_posix_class) {
11663                         RExC_parse++;
11664                     }
11665
11666                     /* regclass() can only return RESTART_UTF8 if multi-char
11667                        folds are allowed.  */
11668                     if (!regclass(pRExC_state, flagp,depth+1,
11669                                   is_posix_class, /* parse the whole char
11670                                                      class only if not a
11671                                                      posix class */
11672                                   FALSE, /* don't allow multi-char folds */
11673                                   TRUE, /* silence non-portable warnings. */
11674                                   &current))
11675                         FAIL2("panic: regclass returned NULL to handle_sets, flags=%#"UVxf"",
11676                               (UV) *flagp);
11677
11678                     /* function call leaves parse pointing to the ']', except
11679                      * if we faked it */
11680                     if (is_posix_class) {
11681                         RExC_parse--;
11682                     }
11683
11684                     SvREFCNT_dec(current);   /* In case it returned something */
11685                     break;
11686                 }
11687
11688                 case ']':
11689                     if (depth--) break;
11690                     RExC_parse++;
11691                     if (RExC_parse < RExC_end
11692                         && *RExC_parse == ')')
11693                     {
11694                         node = reganode(pRExC_state, ANYOF, 0);
11695                         RExC_size += ANYOF_SKIP;
11696                         nextchar(pRExC_state);
11697                         Set_Node_Length(node,
11698                                 RExC_parse - oregcomp_parse + 1); /* MJD */
11699                         return node;
11700                     }
11701                     goto no_close;
11702             }
11703             RExC_parse++;
11704         }
11705
11706         no_close:
11707         FAIL("Syntax error in (?[...])");
11708     }
11709
11710     /* Pass 2 only after this.  Everything in this construct is a
11711      * metacharacter.  Operands begin with either a '\' (for an escape
11712      * sequence), or a '[' for a bracketed character class.  Any other
11713      * character should be an operator, or parenthesis for grouping.  Both
11714      * types of operands are handled by calling regclass() to parse them.  It
11715      * is called with a parameter to indicate to return the computed inversion
11716      * list.  The parsing here is implemented via a stack.  Each entry on the
11717      * stack is a single character representing one of the operators, or the
11718      * '('; or else a pointer to an operand inversion list. */
11719
11720 #define IS_OPERAND(a)  (! SvIOK(a))
11721
11722     /* The stack starts empty.  It is a syntax error if the first thing parsed
11723      * is a binary operator; everything else is pushed on the stack.  When an
11724      * operand is parsed, the top of the stack is examined.  If it is a binary
11725      * operator, the item before it should be an operand, and both are replaced
11726      * by the result of doing that operation on the new operand and the one on
11727      * the stack.   Thus a sequence of binary operands is reduced to a single
11728      * one before the next one is parsed.
11729      *
11730      * A unary operator may immediately follow a binary in the input, for
11731      * example
11732      *      [a] + ! [b]
11733      * When an operand is parsed and the top of the stack is a unary operator,
11734      * the operation is performed, and then the stack is rechecked to see if
11735      * this new operand is part of a binary operation; if so, it is handled as
11736      * above.
11737      *
11738      * A '(' is simply pushed on the stack; it is valid only if the stack is
11739      * empty, or the top element of the stack is an operator or another '('
11740      * (for which the parenthesized expression will become an operand).  By the
11741      * time the corresponding ')' is parsed everything in between should have
11742      * been parsed and evaluated to a single operand (or else is a syntax
11743      * error), and is handled as a regular operand */
11744
11745     sv_2mortal((SV *)(stack = newAV()));
11746
11747     while (RExC_parse < RExC_end) {
11748         I32 top_index = av_tindex(stack);
11749         SV** top_ptr;
11750         SV* current = NULL;
11751
11752         /* Skip white space */
11753         RExC_parse = regpatws(pRExC_state, RExC_parse,
11754                                 TRUE); /* means recognize comments */
11755         if (RExC_parse >= RExC_end) {
11756             Perl_croak(aTHX_ "panic: Read past end of '(?[ ])'");
11757         }
11758         if ((curchar = UCHARAT(RExC_parse)) == ']') {
11759             break;
11760         }
11761
11762         switch (curchar) {
11763
11764             case '?':
11765                 if (av_tindex(stack) >= 0   /* This makes sure that we can
11766                                                safely subtract 1 from
11767                                                RExC_parse in the next clause.
11768                                                If we have something on the
11769                                                stack, we have parsed something
11770                                              */
11771                     && UCHARAT(RExC_parse - 1) == '('
11772                     && RExC_parse < RExC_end)
11773                 {
11774                     /* If is a '(?', could be an embedded '(?flags:(?[...])'.
11775                      * This happens when we have some thing like
11776                      *
11777                      *   my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
11778                      *   ...
11779                      *   qr/(?[ \p{Digit} & $thai_or_lao ])/;
11780                      *
11781                      * Here we would be handling the interpolated
11782                      * '$thai_or_lao'.  We handle this by a recursive call to
11783                      * ourselves which returns the inversion list the
11784                      * interpolated expression evaluates to.  We use the flags
11785                      * from the interpolated pattern. */
11786                     U32 save_flags = RExC_flags;
11787                     const char * const save_parse = ++RExC_parse;
11788
11789                     parse_lparen_question_flags(pRExC_state);
11790
11791                     if (RExC_parse == save_parse  /* Makes sure there was at
11792                                                      least one flag (or this
11793                                                      embedding wasn't compiled)
11794                                                    */
11795                         || RExC_parse >= RExC_end - 4
11796                         || UCHARAT(RExC_parse) != ':'
11797                         || UCHARAT(++RExC_parse) != '('
11798                         || UCHARAT(++RExC_parse) != '?'
11799                         || UCHARAT(++RExC_parse) != '[')
11800                     {
11801
11802                         /* In combination with the above, this moves the
11803                          * pointer to the point just after the first erroneous
11804                          * character (or if there are no flags, to where they
11805                          * should have been) */
11806                         if (RExC_parse >= RExC_end - 4) {
11807                             RExC_parse = RExC_end;
11808                         }
11809                         else if (RExC_parse != save_parse) {
11810                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
11811                         }
11812                         vFAIL("Expecting '(?flags:(?[...'");
11813                     }
11814                     RExC_parse++;
11815                     (void) handle_regex_sets(pRExC_state, &current, flagp,
11816                                                     depth+1, oregcomp_parse);
11817
11818                     /* Here, 'current' contains the embedded expression's
11819                      * inversion list, and RExC_parse points to the trailing
11820                      * ']'; the next character should be the ')' which will be
11821                      * paired with the '(' that has been put on the stack, so
11822                      * the whole embedded expression reduces to '(operand)' */
11823                     RExC_parse++;
11824
11825                     RExC_flags = save_flags;
11826                     goto handle_operand;
11827                 }
11828                 /* FALL THROUGH */
11829
11830             default:
11831                 RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
11832                 vFAIL("Unexpected character");
11833
11834             case '\\':
11835                 /* regclass() can only return RESTART_UTF8 if multi-char
11836                    folds are allowed.  */
11837                 if (!regclass(pRExC_state, flagp,depth+1,
11838                               TRUE, /* means parse just the next thing */
11839                               FALSE, /* don't allow multi-char folds */
11840                               FALSE, /* don't silence non-portable warnings.  */
11841                               &current))
11842                     FAIL2("panic: regclass returned NULL to handle_sets, flags=%#"UVxf"",
11843                           (UV) *flagp);
11844                 /* regclass() will return with parsing just the \ sequence,
11845                  * leaving the parse pointer at the next thing to parse */
11846                 RExC_parse--;
11847                 goto handle_operand;
11848
11849             case '[':   /* Is a bracketed character class */
11850             {
11851                 bool is_posix_class = could_it_be_a_POSIX_class(pRExC_state);
11852
11853                 if (! is_posix_class) {
11854                     RExC_parse++;
11855                 }
11856
11857                 /* regclass() can only return RESTART_UTF8 if multi-char
11858                    folds are allowed.  */
11859                 if(!regclass(pRExC_state, flagp,depth+1,
11860                              is_posix_class, /* parse the whole char class
11861                                                 only if not a posix class */
11862                              FALSE, /* don't allow multi-char folds */
11863                              FALSE, /* don't silence non-portable warnings.  */
11864                              &current))
11865                     FAIL2("panic: regclass returned NULL to handle_sets, flags=%#"UVxf"",
11866                           (UV) *flagp);
11867                 /* function call leaves parse pointing to the ']', except if we
11868                  * faked it */
11869                 if (is_posix_class) {
11870                     RExC_parse--;
11871                 }
11872
11873                 goto handle_operand;
11874             }
11875
11876             case '&':
11877             case '|':
11878             case '+':
11879             case '-':
11880             case '^':
11881                 if (top_index < 0
11882                     || ( ! (top_ptr = av_fetch(stack, top_index, FALSE)))
11883                     || ! IS_OPERAND(*top_ptr))
11884                 {
11885                     RExC_parse++;
11886                     vFAIL2("Unexpected binary operator '%c' with no preceding operand", curchar);
11887                 }
11888                 av_push(stack, newSVuv(curchar));
11889                 break;
11890
11891             case '!':
11892                 av_push(stack, newSVuv(curchar));
11893                 break;
11894
11895             case '(':
11896                 if (top_index >= 0) {
11897                     top_ptr = av_fetch(stack, top_index, FALSE);
11898                     assert(top_ptr);
11899                     if (IS_OPERAND(*top_ptr)) {
11900                         RExC_parse++;
11901                         vFAIL("Unexpected '(' with no preceding operator");
11902                     }
11903                 }
11904                 av_push(stack, newSVuv(curchar));
11905                 break;
11906
11907             case ')':
11908             {
11909                 SV* lparen;
11910                 if (top_index < 1
11911                     || ! (current = av_pop(stack))
11912                     || ! IS_OPERAND(current)
11913                     || ! (lparen = av_pop(stack))
11914                     || IS_OPERAND(lparen)
11915                     || SvUV(lparen) != '(')
11916                 {
11917                     SvREFCNT_dec(current);
11918                     RExC_parse++;
11919                     vFAIL("Unexpected ')'");
11920                 }
11921                 top_index -= 2;
11922                 SvREFCNT_dec_NN(lparen);
11923
11924                 /* FALL THROUGH */
11925             }
11926
11927               handle_operand:
11928
11929                 /* Here, we have an operand to process, in 'current' */
11930
11931                 if (top_index < 0) {    /* Just push if stack is empty */
11932                     av_push(stack, current);
11933                 }
11934                 else {
11935                     SV* top = av_pop(stack);
11936                     SV *prev = NULL;
11937                     char current_operator;
11938
11939                     if (IS_OPERAND(top)) {
11940                         SvREFCNT_dec_NN(top);
11941                         SvREFCNT_dec_NN(current);
11942                         vFAIL("Operand with no preceding operator");
11943                     }
11944                     current_operator = (char) SvUV(top);
11945                     switch (current_operator) {
11946                         case '(':   /* Push the '(' back on followed by the new
11947                                        operand */
11948                             av_push(stack, top);
11949                             av_push(stack, current);
11950                             SvREFCNT_inc(top);  /* Counters the '_dec' done
11951                                                    just after the 'break', so
11952                                                    it doesn't get wrongly freed
11953                                                  */
11954                             break;
11955
11956                         case '!':
11957                             _invlist_invert(current);
11958
11959                             /* Unlike binary operators, the top of the stack,
11960                              * now that this unary one has been popped off, may
11961                              * legally be an operator, and we now have operand
11962                              * for it. */
11963                             top_index--;
11964                             SvREFCNT_dec_NN(top);
11965                             goto handle_operand;
11966
11967                         case '&':
11968                             prev = av_pop(stack);
11969                             _invlist_intersection(prev,
11970                                                    current,
11971                                                    &current);
11972                             av_push(stack, current);
11973                             break;
11974
11975                         case '|':
11976                         case '+':
11977                             prev = av_pop(stack);
11978                             _invlist_union(prev, current, &current);
11979                             av_push(stack, current);
11980                             break;
11981
11982                         case '-':
11983                             prev = av_pop(stack);;
11984                             _invlist_subtract(prev, current, &current);
11985                             av_push(stack, current);
11986                             break;
11987
11988                         case '^':   /* The union minus the intersection */
11989                         {
11990                             SV* i = NULL;
11991                             SV* u = NULL;
11992                             SV* element;
11993
11994                             prev = av_pop(stack);
11995                             _invlist_union(prev, current, &u);
11996                             _invlist_intersection(prev, current, &i);
11997                             /* _invlist_subtract will overwrite current
11998                                 without freeing what it already contains */
11999                             element = current;
12000                             _invlist_subtract(u, i, &current);
12001                             av_push(stack, current);
12002                             SvREFCNT_dec_NN(i);
12003                             SvREFCNT_dec_NN(u);
12004                             SvREFCNT_dec_NN(element);
12005                             break;
12006                         }
12007
12008                         default:
12009                             Perl_croak(aTHX_ "panic: Unexpected item on '(?[ ])' stack");
12010                 }
12011                 SvREFCNT_dec_NN(top);
12012                 SvREFCNT_dec(prev);
12013             }
12014         }
12015
12016         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
12017     }
12018
12019     if (av_tindex(stack) < 0   /* Was empty */
12020         || ((final = av_pop(stack)) == NULL)
12021         || ! IS_OPERAND(final)
12022         || av_tindex(stack) >= 0)  /* More left on stack */
12023     {
12024         vFAIL("Incomplete expression within '(?[ ])'");
12025     }
12026
12027     /* Here, 'final' is the resultant inversion list from evaluating the
12028      * expression.  Return it if so requested */
12029     if (return_invlist) {
12030         *return_invlist = final;
12031         return END;
12032     }
12033
12034     /* Otherwise generate a resultant node, based on 'final'.  regclass() is
12035      * expecting a string of ranges and individual code points */
12036     invlist_iterinit(final);
12037     result_string = newSVpvs("");
12038     while (invlist_iternext(final, &start, &end)) {
12039         if (start == end) {
12040             Perl_sv_catpvf(aTHX_ result_string, "\\x{%"UVXf"}", start);
12041         }
12042         else {
12043             Perl_sv_catpvf(aTHX_ result_string, "\\x{%"UVXf"}-\\x{%"UVXf"}",
12044                                                      start,          end);
12045         }
12046     }
12047
12048     save_parse = RExC_parse;
12049     RExC_parse = SvPV(result_string, len);
12050     save_end = RExC_end;
12051     RExC_end = RExC_parse + len;
12052
12053     /* We turn off folding around the call, as the class we have constructed
12054      * already has all folding taken into consideration, and we don't want
12055      * regclass() to add to that */
12056     RExC_flags &= ~RXf_PMf_FOLD;
12057     /* regclass() can only return RESTART_UTF8 if multi-char folds are allowed.
12058      */
12059     node = regclass(pRExC_state, flagp,depth+1,
12060                     FALSE, /* means parse the whole char class */
12061                     FALSE, /* don't allow multi-char folds */
12062                     TRUE, /* silence non-portable warnings.  The above may very
12063                              well have generated non-portable code points, but
12064                              they're valid on this machine */
12065                     NULL);
12066     if (!node)
12067         FAIL2("panic: regclass returned NULL to handle_sets, flags=%#"UVxf,
12068                     PTR2UV(flagp));
12069     if (save_fold) {
12070         RExC_flags |= RXf_PMf_FOLD;
12071     }
12072     RExC_parse = save_parse + 1;
12073     RExC_end = save_end;
12074     SvREFCNT_dec_NN(final);
12075     SvREFCNT_dec_NN(result_string);
12076
12077     nextchar(pRExC_state);
12078     Set_Node_Length(node, RExC_parse - oregcomp_parse + 1); /* MJD */
12079     return node;
12080 }
12081 #undef IS_OPERAND
12082
12083 /* The names of properties whose definitions are not known at compile time are
12084  * stored in this SV, after a constant heading.  So if the length has been
12085  * changed since initialization, then there is a run-time definition. */
12086 #define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION (SvCUR(listsv) != initial_listsv_len)
12087
12088 STATIC regnode *
12089 S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
12090                  const bool stop_at_1,  /* Just parse the next thing, don't
12091                                            look for a full character class */
12092                  bool allow_multi_folds,
12093                  const bool silence_non_portable,   /* Don't output warnings
12094                                                        about too large
12095                                                        characters */
12096                  SV** ret_invlist)  /* Return an inversion list, not a node */
12097 {
12098     /* parse a bracketed class specification.  Most of these will produce an
12099      * ANYOF node; but something like [a] will produce an EXACT node; [aA], an
12100      * EXACTFish node; [[:ascii:]], a POSIXA node; etc.  It is more complex
12101      * under /i with multi-character folds: it will be rewritten following the
12102      * paradigm of this example, where the <multi-fold>s are characters which
12103      * fold to multiple character sequences:
12104      *      /[abc\x{multi-fold1}def\x{multi-fold2}ghi]/i
12105      * gets effectively rewritten as:
12106      *      /(?:\x{multi-fold1}|\x{multi-fold2}|[abcdefghi]/i
12107      * reg() gets called (recursively) on the rewritten version, and this
12108      * function will return what it constructs.  (Actually the <multi-fold>s
12109      * aren't physically removed from the [abcdefghi], it's just that they are
12110      * ignored in the recursion by means of a flag:
12111      * <RExC_in_multi_char_class>.)
12112      *
12113      * ANYOF nodes contain a bit map for the first 256 characters, with the
12114      * corresponding bit set if that character is in the list.  For characters
12115      * above 255, a range list or swash is used.  There are extra bits for \w,
12116      * etc. in locale ANYOFs, as what these match is not determinable at
12117      * compile time
12118      *
12119      * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs
12120      * to be restarted.  This can only happen if ret_invlist is non-NULL.
12121      */
12122
12123     dVAR;
12124     UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE;
12125     IV range = 0;
12126     UV value = OOB_UNICODE, save_value = OOB_UNICODE;
12127     regnode *ret;
12128     STRLEN numlen;
12129     IV namedclass = OOB_NAMEDCLASS;
12130     char *rangebegin = NULL;
12131     bool need_class = 0;
12132     SV *listsv = NULL;
12133     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
12134                                       than just initialized.  */
12135     SV* properties = NULL;    /* Code points that match \p{} \P{} */
12136     SV* posixes = NULL;     /* Code points that match classes like, [:word:],
12137                                extended beyond the Latin1 range */
12138     UV element_count = 0;   /* Number of distinct elements in the class.
12139                                Optimizations may be possible if this is tiny */
12140     AV * multi_char_matches = NULL; /* Code points that fold to more than one
12141                                        character; used under /i */
12142     UV n;
12143     char * stop_ptr = RExC_end;    /* where to stop parsing */
12144     const bool skip_white = cBOOL(ret_invlist); /* ignore unescaped white
12145                                                    space? */
12146     const bool strict = cBOOL(ret_invlist); /* Apply strict parsing rules? */
12147
12148     /* Unicode properties are stored in a swash; this holds the current one
12149      * being parsed.  If this swash is the only above-latin1 component of the
12150      * character class, an optimization is to pass it directly on to the
12151      * execution engine.  Otherwise, it is set to NULL to indicate that there
12152      * are other things in the class that have to be dealt with at execution
12153      * time */
12154     SV* swash = NULL;           /* Code points that match \p{} \P{} */
12155
12156     /* Set if a component of this character class is user-defined; just passed
12157      * on to the engine */
12158     bool has_user_defined_property = FALSE;
12159
12160     /* inversion list of code points this node matches only when the target
12161      * string is in UTF-8.  (Because is under /d) */
12162     SV* depends_list = NULL;
12163
12164     /* inversion list of code points this node matches.  For much of the
12165      * function, it includes only those that match regardless of the utf8ness
12166      * of the target string */
12167     SV* cp_list = NULL;
12168
12169 #ifdef EBCDIC
12170     /* In a range, counts how many 0-2 of the ends of it came from literals,
12171      * not escapes.  Thus we can tell if 'A' was input vs \x{C1} */
12172     UV literal_endpoint = 0;
12173 #endif
12174     bool invert = FALSE;    /* Is this class to be complemented */
12175
12176     /* Is there any thing like \W or [:^digit:] that matches above the legal
12177      * Unicode range? */
12178     bool runtime_posix_matches_above_Unicode = FALSE;
12179
12180     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
12181         case we need to change the emitted regop to an EXACT. */
12182     const char * orig_parse = RExC_parse;
12183     const I32 orig_size = RExC_size;
12184     GET_RE_DEBUG_FLAGS_DECL;
12185
12186     PERL_ARGS_ASSERT_REGCLASS;
12187 #ifndef DEBUGGING
12188     PERL_UNUSED_ARG(depth);
12189 #endif
12190
12191     DEBUG_PARSE("clas");
12192
12193     /* Assume we are going to generate an ANYOF node. */
12194     ret = reganode(pRExC_state, ANYOF, 0);
12195
12196     if (SIZE_ONLY) {
12197         RExC_size += ANYOF_SKIP;
12198         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
12199     }
12200     else {
12201         ANYOF_FLAGS(ret) = 0;
12202
12203         RExC_emit += ANYOF_SKIP;
12204         if (LOC) {
12205             ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
12206         }
12207         listsv = newSVpvs_flags("# comment\n", SVs_TEMP);
12208         initial_listsv_len = SvCUR(listsv);
12209         SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated.  */
12210     }
12211
12212     if (skip_white) {
12213         RExC_parse = regpatws(pRExC_state, RExC_parse,
12214                               FALSE /* means don't recognize comments */);
12215     }
12216
12217     if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
12218         RExC_parse++;
12219         invert = TRUE;
12220         allow_multi_folds = FALSE;
12221         RExC_naughty++;
12222         if (skip_white) {
12223             RExC_parse = regpatws(pRExC_state, RExC_parse,
12224                                   FALSE /* means don't recognize comments */);
12225         }
12226     }
12227
12228     /* Check that they didn't say [:posix:] instead of [[:posix:]] */
12229     if (!SIZE_ONLY && RExC_parse < RExC_end && POSIXCC(UCHARAT(RExC_parse))) {
12230         const char *s = RExC_parse;
12231         const char  c = *s++;
12232
12233         while (isWORDCHAR(*s))
12234             s++;
12235         if (*s && c == *s && s[1] == ']') {
12236             SAVEFREESV(RExC_rx_sv);
12237             ckWARN3reg(s+2,
12238                        "POSIX syntax [%c %c] belongs inside character classes",
12239                        c, c);
12240             (void)ReREFCNT_inc(RExC_rx_sv);
12241         }
12242     }
12243
12244     /* If the caller wants us to just parse a single element, accomplish this
12245      * by faking the loop ending condition */
12246     if (stop_at_1 && RExC_end > RExC_parse) {
12247         stop_ptr = RExC_parse + 1;
12248     }
12249
12250     /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */
12251     if (UCHARAT(RExC_parse) == ']')
12252         goto charclassloop;
12253
12254 parseit:
12255     while (1) {
12256         if  (RExC_parse >= stop_ptr) {
12257             break;
12258         }
12259
12260         if (skip_white) {
12261             RExC_parse = regpatws(pRExC_state, RExC_parse,
12262                                   FALSE /* means don't recognize comments */);
12263         }
12264
12265         if  (UCHARAT(RExC_parse) == ']') {
12266             break;
12267         }
12268
12269     charclassloop:
12270
12271         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
12272         save_value = value;
12273         save_prevvalue = prevvalue;
12274
12275         if (!range) {
12276             rangebegin = RExC_parse;
12277             element_count++;
12278         }
12279         if (UTF) {
12280             value = utf8n_to_uvchr((U8*)RExC_parse,
12281                                    RExC_end - RExC_parse,
12282                                    &numlen, UTF8_ALLOW_DEFAULT);
12283             RExC_parse += numlen;
12284         }
12285         else
12286             value = UCHARAT(RExC_parse++);
12287
12288         if (value == '['
12289             && RExC_parse < RExC_end
12290             && POSIXCC(UCHARAT(RExC_parse)))
12291         {
12292             namedclass = regpposixcc(pRExC_state, value, strict);
12293         }
12294         else if (value == '\\') {
12295             if (UTF) {
12296                 value = utf8n_to_uvchr((U8*)RExC_parse,
12297                                    RExC_end - RExC_parse,
12298                                    &numlen, UTF8_ALLOW_DEFAULT);
12299                 RExC_parse += numlen;
12300             }
12301             else
12302                 value = UCHARAT(RExC_parse++);
12303
12304             /* Some compilers cannot handle switching on 64-bit integer
12305              * values, therefore value cannot be an UV.  Yes, this will
12306              * be a problem later if we want switch on Unicode.
12307              * A similar issue a little bit later when switching on
12308              * namedclass. --jhi */
12309
12310             /* If the \ is escaping white space when white space is being
12311              * skipped, it means that that white space is wanted literally, and
12312              * is already in 'value'.  Otherwise, need to translate the escape
12313              * into what it signifies. */
12314             if (! skip_white || ! is_PATWS_cp(value)) switch ((I32)value) {
12315
12316             case 'w':   namedclass = ANYOF_WORDCHAR;    break;
12317             case 'W':   namedclass = ANYOF_NWORDCHAR;   break;
12318             case 's':   namedclass = ANYOF_SPACE;       break;
12319             case 'S':   namedclass = ANYOF_NSPACE;      break;
12320             case 'd':   namedclass = ANYOF_DIGIT;       break;
12321             case 'D':   namedclass = ANYOF_NDIGIT;      break;
12322             case 'v':   namedclass = ANYOF_VERTWS;      break;
12323             case 'V':   namedclass = ANYOF_NVERTWS;     break;
12324             case 'h':   namedclass = ANYOF_HORIZWS;     break;
12325             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
12326             case 'N':  /* Handle \N{NAME} in class */
12327                 {
12328                     /* We only pay attention to the first char of 
12329                     multichar strings being returned. I kinda wonder
12330                     if this makes sense as it does change the behaviour
12331                     from earlier versions, OTOH that behaviour was broken
12332                     as well. */
12333                     if (! grok_bslash_N(pRExC_state, NULL, &value, flagp, depth,
12334                                       TRUE, /* => charclass */
12335                                       strict))
12336                     {
12337                         if (*flagp & RESTART_UTF8)
12338                             FAIL("panic: grok_bslash_N set RESTART_UTF8");
12339                         goto parseit;
12340                     }
12341                 }
12342                 break;
12343             case 'p':
12344             case 'P':
12345                 {
12346                 char *e;
12347
12348                 /* We will handle any undefined properties ourselves */
12349                 U8 swash_init_flags = _CORE_SWASH_INIT_RETURN_IF_UNDEF;
12350
12351                 if (RExC_parse >= RExC_end)
12352                     vFAIL2("Empty \\%c{}", (U8)value);
12353                 if (*RExC_parse == '{') {
12354                     const U8 c = (U8)value;
12355                     e = strchr(RExC_parse++, '}');
12356                     if (!e)
12357                         vFAIL2("Missing right brace on \\%c{}", c);
12358                     while (isSPACE(UCHARAT(RExC_parse)))
12359                         RExC_parse++;
12360                     if (e == RExC_parse)
12361                         vFAIL2("Empty \\%c{}", c);
12362                     n = e - RExC_parse;
12363                     while (isSPACE(UCHARAT(RExC_parse + n - 1)))
12364                         n--;
12365                 }
12366                 else {
12367                     e = RExC_parse;
12368                     n = 1;
12369                 }
12370                 if (!SIZE_ONLY) {
12371                     SV* invlist;
12372                     char* name;
12373
12374                     if (UCHARAT(RExC_parse) == '^') {
12375                          RExC_parse++;
12376                          n--;
12377                          /* toggle.  (The rhs xor gets the single bit that
12378                           * differs between P and p; the other xor inverts just
12379                           * that bit) */
12380                          value ^= 'P' ^ 'p';
12381
12382                          while (isSPACE(UCHARAT(RExC_parse))) {
12383                               RExC_parse++;
12384                               n--;
12385                          }
12386                     }
12387                     /* Try to get the definition of the property into
12388                      * <invlist>.  If /i is in effect, the effective property
12389                      * will have its name be <__NAME_i>.  The design is
12390                      * discussed in commit
12391                      * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
12392                     Newx(name, n + sizeof("_i__\n"), char);
12393
12394                     sprintf(name, "%s%.*s%s\n",
12395                                     (FOLD) ? "__" : "",
12396                                     (int)n,
12397                                     RExC_parse,
12398                                     (FOLD) ? "_i" : ""
12399                     );
12400
12401                     /* Look up the property name, and get its swash and
12402                      * inversion list, if the property is found  */
12403                     if (swash) {
12404                         SvREFCNT_dec_NN(swash);
12405                     }
12406                     swash = _core_swash_init("utf8", name, &PL_sv_undef,
12407                                              1, /* binary */
12408                                              0, /* not tr/// */
12409                                              NULL, /* No inversion list */
12410                                              &swash_init_flags
12411                                             );
12412                     if (! swash || ! (invlist = _get_swash_invlist(swash))) {
12413                         if (swash) {
12414                             SvREFCNT_dec_NN(swash);
12415                             swash = NULL;
12416                         }
12417
12418                         /* Here didn't find it.  It could be a user-defined
12419                          * property that will be available at run-time.  If we
12420                          * accept only compile-time properties, is an error;
12421                          * otherwise add it to the list for run-time look up */
12422                         if (ret_invlist) {
12423                             RExC_parse = e + 1;
12424                             vFAIL3("Property '%.*s' is unknown", (int) n, name);
12425                         }
12426                         Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s\n",
12427                                         (value == 'p' ? '+' : '!'),
12428                                         name);
12429                         has_user_defined_property = TRUE;
12430
12431                         /* We don't know yet, so have to assume that the
12432                          * property could match something in the Latin1 range,
12433                          * hence something that isn't utf8.  Note that this
12434                          * would cause things in <depends_list> to match
12435                          * inappropriately, except that any \p{}, including
12436                          * this one forces Unicode semantics, which means there
12437                          * is <no depends_list> */
12438                         ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
12439                     }
12440                     else {
12441
12442                         /* Here, did get the swash and its inversion list.  If
12443                          * the swash is from a user-defined property, then this
12444                          * whole character class should be regarded as such */
12445                         has_user_defined_property =
12446                                     (swash_init_flags
12447                                      & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY);
12448
12449                         /* Invert if asking for the complement */
12450                         if (value == 'P') {
12451                             _invlist_union_complement_2nd(properties,
12452                                                           invlist,
12453                                                           &properties);
12454
12455                             /* The swash can't be used as-is, because we've
12456                              * inverted things; delay removing it to here after
12457                              * have copied its invlist above */
12458                             SvREFCNT_dec_NN(swash);
12459                             swash = NULL;
12460                         }
12461                         else {
12462                             _invlist_union(properties, invlist, &properties);
12463                         }
12464                     }
12465                     Safefree(name);
12466                 }
12467                 RExC_parse = e + 1;
12468                 namedclass = ANYOF_UNIPROP;  /* no official name, but it's
12469                                                 named */
12470
12471                 /* \p means they want Unicode semantics */
12472                 RExC_uni_semantics = 1;
12473                 }
12474                 break;
12475             case 'n':   value = '\n';                   break;
12476             case 'r':   value = '\r';                   break;
12477             case 't':   value = '\t';                   break;
12478             case 'f':   value = '\f';                   break;
12479             case 'b':   value = '\b';                   break;
12480             case 'e':   value = ASCII_TO_NATIVE('\033');break;
12481             case 'a':   value = ASCII_TO_NATIVE('\007');break;
12482             case 'o':
12483                 RExC_parse--;   /* function expects to be pointed at the 'o' */
12484                 {
12485                     const char* error_msg;
12486                     bool valid = grok_bslash_o(&RExC_parse,
12487                                                &value,
12488                                                &error_msg,
12489                                                SIZE_ONLY,   /* warnings in pass
12490                                                                1 only */
12491                                                strict,
12492                                                silence_non_portable,
12493                                                UTF);
12494                     if (! valid) {
12495                         vFAIL(error_msg);
12496                     }
12497                 }
12498                 if (PL_encoding && value < 0x100) {
12499                     goto recode_encoding;
12500                 }
12501                 break;
12502             case 'x':
12503                 RExC_parse--;   /* function expects to be pointed at the 'x' */
12504                 {
12505                     const char* error_msg;
12506                     bool valid = grok_bslash_x(&RExC_parse,
12507                                                &value,
12508                                                &error_msg,
12509                                                TRUE, /* Output warnings */
12510                                                strict,
12511                                                silence_non_portable,
12512                                                UTF);
12513                     if (! valid) {
12514                         vFAIL(error_msg);
12515                     }
12516                 }
12517                 if (PL_encoding && value < 0x100)
12518                     goto recode_encoding;
12519                 break;
12520             case 'c':
12521                 value = grok_bslash_c(*RExC_parse++, UTF, SIZE_ONLY);
12522                 break;
12523             case '0': case '1': case '2': case '3': case '4':
12524             case '5': case '6': case '7':
12525                 {
12526                     /* Take 1-3 octal digits */
12527                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
12528                     numlen = (strict) ? 4 : 3;
12529                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
12530                     RExC_parse += numlen;
12531                     if (numlen != 3) {
12532                         if (strict) {
12533                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
12534                             vFAIL("Need exactly 3 octal digits");
12535                         }
12536                         else if (! SIZE_ONLY /* like \08, \178 */
12537                                  && numlen < 3
12538                                  && RExC_parse < RExC_end
12539                                  && isDIGIT(*RExC_parse)
12540                                  && ckWARN(WARN_REGEXP))
12541                         {
12542                             SAVEFREESV(RExC_rx_sv);
12543                             reg_warn_non_literal_string(
12544                                  RExC_parse + 1,
12545                                  form_short_octal_warning(RExC_parse, numlen));
12546                             (void)ReREFCNT_inc(RExC_rx_sv);
12547                         }
12548                     }
12549                     if (PL_encoding && value < 0x100)
12550                         goto recode_encoding;
12551                     break;
12552                 }
12553             recode_encoding:
12554                 if (! RExC_override_recoding) {
12555                     SV* enc = PL_encoding;
12556                     value = reg_recode((const char)(U8)value, &enc);
12557                     if (!enc) {
12558                         if (strict) {
12559                             vFAIL("Invalid escape in the specified encoding");
12560                         }
12561                         else if (SIZE_ONLY) {
12562                             ckWARNreg(RExC_parse,
12563                                   "Invalid escape in the specified encoding");
12564                         }
12565                     }
12566                     break;
12567                 }
12568             default:
12569                 /* Allow \_ to not give an error */
12570                 if (!SIZE_ONLY && isWORDCHAR(value) && value != '_') {
12571                     if (strict) {
12572                         vFAIL2("Unrecognized escape \\%c in character class",
12573                                (int)value);
12574                     }
12575                     else {
12576                         SAVEFREESV(RExC_rx_sv);
12577                         ckWARN2reg(RExC_parse,
12578                             "Unrecognized escape \\%c in character class passed through",
12579                             (int)value);
12580                         (void)ReREFCNT_inc(RExC_rx_sv);
12581                     }
12582                 }
12583                 break;
12584             }   /* End of switch on char following backslash */
12585         } /* end of handling backslash escape sequences */
12586 #ifdef EBCDIC
12587         else
12588             literal_endpoint++;
12589 #endif
12590
12591         /* Here, we have the current token in 'value' */
12592
12593         /* What matches in a locale is not known until runtime.  This includes
12594          * what the Posix classes (like \w, [:space:]) match.  Room must be
12595          * reserved (one time per class) to store such classes, either if Perl
12596          * is compiled so that locale nodes always should have this space, or
12597          * if there is such class info to be stored.  The space will contain a
12598          * bit for each named class that is to be matched against.  This isn't
12599          * needed for \p{} and pseudo-classes, as they are not affected by
12600          * locale, and hence are dealt with separately */
12601         if (LOC
12602             && ! need_class
12603             && (ANYOF_LOCALE == ANYOF_CLASS
12604                 || (namedclass > OOB_NAMEDCLASS && namedclass < ANYOF_MAX)))
12605         {
12606             need_class = 1;
12607             if (SIZE_ONLY) {
12608                 RExC_size += ANYOF_CLASS_SKIP - ANYOF_SKIP;
12609             }
12610             else {
12611                 RExC_emit += ANYOF_CLASS_SKIP - ANYOF_SKIP;
12612                 ANYOF_CLASS_ZERO(ret);
12613             }
12614             ANYOF_FLAGS(ret) |= ANYOF_CLASS;
12615         }
12616
12617         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
12618
12619             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
12620              * literal, as is the character that began the false range, i.e.
12621              * the 'a' in the examples */
12622             if (range) {
12623                 if (!SIZE_ONLY) {
12624                     const int w = (RExC_parse >= rangebegin)
12625                                   ? RExC_parse - rangebegin
12626                                   : 0;
12627                     if (strict) {
12628                         vFAIL4("False [] range \"%*.*s\"", w, w, rangebegin);
12629                     }
12630                     else {
12631                         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
12632                         ckWARN4reg(RExC_parse,
12633                                 "False [] range \"%*.*s\"",
12634                                 w, w, rangebegin);
12635                         (void)ReREFCNT_inc(RExC_rx_sv);
12636                         cp_list = add_cp_to_invlist(cp_list, '-');
12637                         cp_list = add_cp_to_invlist(cp_list, prevvalue);
12638                     }
12639                 }
12640
12641                 range = 0; /* this was not a true range */
12642                 element_count += 2; /* So counts for three values */
12643             }
12644
12645             if (! SIZE_ONLY) {
12646                 U8 classnum = namedclass_to_classnum(namedclass);
12647                 if (namedclass >= ANYOF_MAX) {  /* If a special class */
12648                     if (namedclass != ANYOF_UNIPROP) { /* UNIPROP = \p and \P */
12649
12650                         /* Here, should be \h, \H, \v, or \V.  Neither /d nor
12651                          * /l make a difference in what these match.  There
12652                          * would be problems if these characters had folds
12653                          * other than themselves, as cp_list is subject to
12654                          * folding. */
12655                         if (classnum != _CC_VERTSPACE) {
12656                             assert(   namedclass == ANYOF_HORIZWS
12657                                    || namedclass == ANYOF_NHORIZWS);
12658
12659                             /* It turns out that \h is just a synonym for
12660                              * XPosixBlank */
12661                             classnum = _CC_BLANK;
12662                         }
12663
12664                         _invlist_union_maybe_complement_2nd(
12665                                 cp_list,
12666                                 PL_XPosix_ptrs[classnum],
12667                                 cBOOL(namedclass % 2), /* Complement if odd
12668                                                           (NHORIZWS, NVERTWS)
12669                                                         */
12670                                 &cp_list);
12671                     }
12672                 }
12673                 else if (classnum == _CC_ASCII) {
12674 #ifdef HAS_ISASCII
12675                     if (LOC) {
12676                         ANYOF_CLASS_SET(ret, namedclass);
12677                     }
12678                     else
12679 #endif  /* Not isascii(); just use the hard-coded definition for it */
12680                         _invlist_union_maybe_complement_2nd(
12681                                 posixes,
12682                                 PL_ASCII,
12683                                 cBOOL(namedclass % 2), /* Complement if odd
12684                                                           (NASCII) */
12685                                 &posixes);
12686                 }
12687                 else {  /* Garden variety class */
12688
12689                     /* The ascii range inversion list */
12690                     SV* ascii_source = PL_Posix_ptrs[classnum];
12691
12692                     /* The full Latin1 range inversion list */
12693                     SV* l1_source = PL_L1Posix_ptrs[classnum];
12694
12695                     /* This code is structured into two major clauses.  The
12696                      * first is for classes whose complete definitions may not
12697                      * already be known.  It not, the Latin1 definition
12698                      * (guaranteed to already known) is used plus code is
12699                      * generated to load the rest at run-time (only if needed).
12700                      * If the complete definition is known, it drops down to
12701                      * the second clause, where the complete definition is
12702                      * known */
12703
12704                     if (classnum < _FIRST_NON_SWASH_CC) {
12705
12706                         /* Here, the class has a swash, which may or not
12707                          * already be loaded */
12708
12709                         /* The name of the property to use to match the full
12710                          * eXtended Unicode range swash for this character
12711                          * class */
12712                         const char *Xname = swash_property_names[classnum];
12713
12714                         /* If returning the inversion list, we can't defer
12715                          * getting this until runtime */
12716                         if (ret_invlist && !  PL_utf8_swash_ptrs[classnum]) {
12717                             PL_utf8_swash_ptrs[classnum] =
12718                                 _core_swash_init("utf8", Xname, &PL_sv_undef,
12719                                              1, /* binary */
12720                                              0, /* not tr/// */
12721                                              NULL, /* No inversion list */
12722                                              NULL  /* No flags */
12723                                             );
12724                             assert(PL_utf8_swash_ptrs[classnum]);
12725                         }
12726                         if ( !  PL_utf8_swash_ptrs[classnum]) {
12727                             if (namedclass % 2 == 0) { /* A non-complemented
12728                                                           class */
12729                                 /* If not /a matching, there are code points we
12730                                  * don't know at compile time.  Arrange for the
12731                                  * unknown matches to be loaded at run-time, if
12732                                  * needed */
12733                                 if (! AT_LEAST_ASCII_RESTRICTED) {
12734                                     Perl_sv_catpvf(aTHX_ listsv, "+utf8::%s\n",
12735                                                                  Xname);
12736                                 }
12737                                 if (LOC) {  /* Under locale, set run-time
12738                                                lookup */
12739                                     ANYOF_CLASS_SET(ret, namedclass);
12740                                 }
12741                                 else {
12742                                     /* Add the current class's code points to
12743                                      * the running total */
12744                                     _invlist_union(posixes,
12745                                                    (AT_LEAST_ASCII_RESTRICTED)
12746                                                         ? ascii_source
12747                                                         : l1_source,
12748                                                    &posixes);
12749                                 }
12750                             }
12751                             else {  /* A complemented class */
12752                                 if (AT_LEAST_ASCII_RESTRICTED) {
12753                                     /* Under /a should match everything above
12754                                      * ASCII, plus the complement of the set's
12755                                      * ASCII matches */
12756                                     _invlist_union_complement_2nd(posixes,
12757                                                                   ascii_source,
12758                                                                   &posixes);
12759                                 }
12760                                 else {
12761                                     /* Arrange for the unknown matches to be
12762                                      * loaded at run-time, if needed */
12763                                     Perl_sv_catpvf(aTHX_ listsv, "!utf8::%s\n",
12764                                                                  Xname);
12765                                     runtime_posix_matches_above_Unicode = TRUE;
12766                                     if (LOC) {
12767                                         ANYOF_CLASS_SET(ret, namedclass);
12768                                     }
12769                                     else {
12770
12771                                         /* We want to match everything in
12772                                          * Latin1, except those things that
12773                                          * l1_source matches */
12774                                         SV* scratch_list = NULL;
12775                                         _invlist_subtract(PL_Latin1, l1_source,
12776                                                           &scratch_list);
12777
12778                                         /* Add the list from this class to the
12779                                          * running total */
12780                                         if (! posixes) {
12781                                             posixes = scratch_list;
12782                                         }
12783                                         else {
12784                                             _invlist_union(posixes,
12785                                                            scratch_list,
12786                                                            &posixes);
12787                                             SvREFCNT_dec_NN(scratch_list);
12788                                         }
12789                                         if (DEPENDS_SEMANTICS) {
12790                                             ANYOF_FLAGS(ret)
12791                                                   |= ANYOF_NON_UTF8_LATIN1_ALL;
12792                                         }
12793                                     }
12794                                 }
12795                             }
12796                             goto namedclass_done;
12797                         }
12798
12799                         /* Here, there is a swash loaded for the class.  If no
12800                          * inversion list for it yet, get it */
12801                         if (! PL_XPosix_ptrs[classnum]) {
12802                             PL_XPosix_ptrs[classnum]
12803                              = _swash_to_invlist(PL_utf8_swash_ptrs[classnum]);
12804                         }
12805                     }
12806
12807                     /* Here there is an inversion list already loaded for the
12808                      * entire class */
12809
12810                     if (namedclass % 2 == 0) {  /* A non-complemented class,
12811                                                    like ANYOF_PUNCT */
12812                         if (! LOC) {
12813                             /* For non-locale, just add it to any existing list
12814                              * */
12815                             _invlist_union(posixes,
12816                                            (AT_LEAST_ASCII_RESTRICTED)
12817                                                ? ascii_source
12818                                                : PL_XPosix_ptrs[classnum],
12819                                            &posixes);
12820                         }
12821                         else {  /* Locale */
12822                             SV* scratch_list = NULL;
12823
12824                             /* For above Latin1 code points, we use the full
12825                              * Unicode range */
12826                             _invlist_intersection(PL_AboveLatin1,
12827                                                   PL_XPosix_ptrs[classnum],
12828                                                   &scratch_list);
12829                             /* And set the output to it, adding instead if
12830                              * there already is an output.  Checking if
12831                              * 'posixes' is NULL first saves an extra clone.
12832                              * Its reference count will be decremented at the
12833                              * next union, etc, or if this is the only
12834                              * instance, at the end of the routine */
12835                             if (! posixes) {
12836                                 posixes = scratch_list;
12837                             }
12838                             else {
12839                                 _invlist_union(posixes, scratch_list, &posixes);
12840                                 SvREFCNT_dec_NN(scratch_list);
12841                             }
12842
12843 #ifndef HAS_ISBLANK
12844                             if (namedclass != ANYOF_BLANK) {
12845 #endif
12846                                 /* Set this class in the node for runtime
12847                                  * matching */
12848                                 ANYOF_CLASS_SET(ret, namedclass);
12849 #ifndef HAS_ISBLANK
12850                             }
12851                             else {
12852                                 /* No isblank(), use the hard-coded ASCII-range
12853                                  * blanks, adding them to the running total. */
12854
12855                                 _invlist_union(posixes, ascii_source, &posixes);
12856                             }
12857 #endif
12858                         }
12859                     }
12860                     else {  /* A complemented class, like ANYOF_NPUNCT */
12861                         if (! LOC) {
12862                             _invlist_union_complement_2nd(
12863                                                 posixes,
12864                                                 (AT_LEAST_ASCII_RESTRICTED)
12865                                                     ? ascii_source
12866                                                     : PL_XPosix_ptrs[classnum],
12867                                                 &posixes);
12868                             /* Under /d, everything in the upper half of the
12869                              * Latin1 range matches this complement */
12870                             if (DEPENDS_SEMANTICS) {
12871                                 ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL;
12872                             }
12873                         }
12874                         else {  /* Locale */
12875                             SV* scratch_list = NULL;
12876                             _invlist_subtract(PL_AboveLatin1,
12877                                               PL_XPosix_ptrs[classnum],
12878                                               &scratch_list);
12879                             if (! posixes) {
12880                                 posixes = scratch_list;
12881                             }
12882                             else {
12883                                 _invlist_union(posixes, scratch_list, &posixes);
12884                                 SvREFCNT_dec_NN(scratch_list);
12885                             }
12886 #ifndef HAS_ISBLANK
12887                             if (namedclass != ANYOF_NBLANK) {
12888 #endif
12889                                 ANYOF_CLASS_SET(ret, namedclass);
12890 #ifndef HAS_ISBLANK
12891                             }
12892                             else {
12893                                 /* Get the list of all code points in Latin1
12894                                  * that are not ASCII blanks, and add them to
12895                                  * the running total */
12896                                 _invlist_subtract(PL_Latin1, ascii_source,
12897                                                   &scratch_list);
12898                                 _invlist_union(posixes, scratch_list, &posixes);
12899                                 SvREFCNT_dec_NN(scratch_list);
12900                             }
12901 #endif
12902                         }
12903                     }
12904                 }
12905               namedclass_done:
12906                 continue;   /* Go get next character */
12907             }
12908         } /* end of namedclass \blah */
12909
12910         /* Here, we have a single value.  If 'range' is set, it is the ending
12911          * of a range--check its validity.  Later, we will handle each
12912          * individual code point in the range.  If 'range' isn't set, this
12913          * could be the beginning of a range, so check for that by looking
12914          * ahead to see if the next real character to be processed is the range
12915          * indicator--the minus sign */
12916
12917         if (skip_white) {
12918             RExC_parse = regpatws(pRExC_state, RExC_parse,
12919                                 FALSE /* means don't recognize comments */);
12920         }
12921
12922         if (range) {
12923             if (prevvalue > value) /* b-a */ {
12924                 const int w = RExC_parse - rangebegin;
12925                 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
12926                 range = 0; /* not a valid range */
12927             }
12928         }
12929         else {
12930             prevvalue = value; /* save the beginning of the potential range */
12931             if (! stop_at_1     /* Can't be a range if parsing just one thing */
12932                 && *RExC_parse == '-')
12933             {
12934                 char* next_char_ptr = RExC_parse + 1;
12935                 if (skip_white) {   /* Get the next real char after the '-' */
12936                     next_char_ptr = regpatws(pRExC_state,
12937                                              RExC_parse + 1,
12938                                              FALSE); /* means don't recognize
12939                                                         comments */
12940                 }
12941
12942                 /* If the '-' is at the end of the class (just before the ']',
12943                  * it is a literal minus; otherwise it is a range */
12944                 if (next_char_ptr < RExC_end && *next_char_ptr != ']') {
12945                     RExC_parse = next_char_ptr;
12946
12947                     /* a bad range like \w-, [:word:]- ? */
12948                     if (namedclass > OOB_NAMEDCLASS) {
12949                         if (strict || ckWARN(WARN_REGEXP)) {
12950                             const int w =
12951                                 RExC_parse >= rangebegin ?
12952                                 RExC_parse - rangebegin : 0;
12953                             if (strict) {
12954                                 vFAIL4("False [] range \"%*.*s\"",
12955                                     w, w, rangebegin);
12956                             }
12957                             else {
12958                                 vWARN4(RExC_parse,
12959                                     "False [] range \"%*.*s\"",
12960                                     w, w, rangebegin);
12961                             }
12962                         }
12963                         if (!SIZE_ONLY) {
12964                             cp_list = add_cp_to_invlist(cp_list, '-');
12965                         }
12966                         element_count++;
12967                     } else
12968                         range = 1;      /* yeah, it's a range! */
12969                     continue;   /* but do it the next time */
12970                 }
12971             }
12972         }
12973
12974         /* Here, <prevvalue> is the beginning of the range, if any; or <value>
12975          * if not */
12976
12977         /* non-Latin1 code point implies unicode semantics.  Must be set in
12978          * pass1 so is there for the whole of pass 2 */
12979         if (value > 255) {
12980             RExC_uni_semantics = 1;
12981         }
12982
12983         /* Ready to process either the single value, or the completed range.
12984          * For single-valued non-inverted ranges, we consider the possibility
12985          * of multi-char folds.  (We made a conscious decision to not do this
12986          * for the other cases because it can often lead to non-intuitive
12987          * results.  For example, you have the peculiar case that:
12988          *  "s s" =~ /^[^\xDF]+$/i => Y
12989          *  "ss"  =~ /^[^\xDF]+$/i => N
12990          *
12991          * See [perl #89750] */
12992         if (FOLD && allow_multi_folds && value == prevvalue) {
12993             if (value == LATIN_SMALL_LETTER_SHARP_S
12994                 || (value > 255 && _invlist_contains_cp(PL_HasMultiCharFold,
12995                                                         value)))
12996             {
12997                 /* Here <value> is indeed a multi-char fold.  Get what it is */
12998
12999                 U8 foldbuf[UTF8_MAXBYTES_CASE];
13000                 STRLEN foldlen;
13001
13002                 UV folded = _to_uni_fold_flags(
13003                                 value,
13004                                 foldbuf,
13005                                 &foldlen,
13006                                 FOLD_FLAGS_FULL
13007                                 | ((LOC) ?  FOLD_FLAGS_LOCALE
13008                                             : (ASCII_FOLD_RESTRICTED)
13009                                               ? FOLD_FLAGS_NOMIX_ASCII
13010                                               : 0)
13011                                 );
13012
13013                 /* Here, <folded> should be the first character of the
13014                  * multi-char fold of <value>, with <foldbuf> containing the
13015                  * whole thing.  But, if this fold is not allowed (because of
13016                  * the flags), <fold> will be the same as <value>, and should
13017                  * be processed like any other character, so skip the special
13018                  * handling */
13019                 if (folded != value) {
13020
13021                     /* Skip if we are recursed, currently parsing the class
13022                      * again.  Otherwise add this character to the list of
13023                      * multi-char folds. */
13024                     if (! RExC_in_multi_char_class) {
13025                         AV** this_array_ptr;
13026                         AV* this_array;
13027                         STRLEN cp_count = utf8_length(foldbuf,
13028                                                       foldbuf + foldlen);
13029                         SV* multi_fold = sv_2mortal(newSVpvn("", 0));
13030
13031                         Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%"UVXf"}", value);
13032
13033
13034                         if (! multi_char_matches) {
13035                             multi_char_matches = newAV();
13036                         }
13037
13038                         /* <multi_char_matches> is actually an array of arrays.
13039                          * There will be one or two top-level elements: [2],
13040                          * and/or [3].  The [2] element is an array, each
13041                          * element thereof is a character which folds to TWO
13042                          * characters; [3] is for folds to THREE characters.
13043                          * (Unicode guarantees a maximum of 3 characters in any
13044                          * fold.)  When we rewrite the character class below,
13045                          * we will do so such that the longest folds are
13046                          * written first, so that it prefers the longest
13047                          * matching strings first.  This is done even if it
13048                          * turns out that any quantifier is non-greedy, out of
13049                          * programmer laziness.  Tom Christiansen has agreed
13050                          * that this is ok.  This makes the test for the
13051                          * ligature 'ffi' come before the test for 'ff' */
13052                         if (av_exists(multi_char_matches, cp_count)) {
13053                             this_array_ptr = (AV**) av_fetch(multi_char_matches,
13054                                                              cp_count, FALSE);
13055                             this_array = *this_array_ptr;
13056                         }
13057                         else {
13058                             this_array = newAV();
13059                             av_store(multi_char_matches, cp_count,
13060                                      (SV*) this_array);
13061                         }
13062                         av_push(this_array, multi_fold);
13063                     }
13064
13065                     /* This element should not be processed further in this
13066                      * class */
13067                     element_count--;
13068                     value = save_value;
13069                     prevvalue = save_prevvalue;
13070                     continue;
13071                 }
13072             }
13073         }
13074
13075         /* Deal with this element of the class */
13076         if (! SIZE_ONLY) {
13077 #ifndef EBCDIC
13078             cp_list = _add_range_to_invlist(cp_list, prevvalue, value);
13079 #else
13080             SV* this_range = _new_invlist(1);
13081             _append_range_to_invlist(this_range, prevvalue, value);
13082
13083             /* In EBCDIC, the ranges 'A-Z' and 'a-z' are each not contiguous.
13084              * If this range was specified using something like 'i-j', we want
13085              * to include only the 'i' and the 'j', and not anything in
13086              * between, so exclude non-ASCII, non-alphabetics from it.
13087              * However, if the range was specified with something like
13088              * [\x89-\x91] or [\x89-j], all code points within it should be
13089              * included.  literal_endpoint==2 means both ends of the range used
13090              * a literal character, not \x{foo} */
13091             if (literal_endpoint == 2
13092                 && (prevvalue >= 'a' && value <= 'z')
13093                     || (prevvalue >= 'A' && value <= 'Z'))
13094             {
13095                 _invlist_intersection(this_range, PL_Posix_ptrs[_CC_ALPHA],
13096                                       &this_range);
13097             }
13098             _invlist_union(cp_list, this_range, &cp_list);
13099             literal_endpoint = 0;
13100 #endif
13101         }
13102
13103         range = 0; /* this range (if it was one) is done now */
13104     } /* End of loop through all the text within the brackets */
13105
13106     /* If anything in the class expands to more than one character, we have to
13107      * deal with them by building up a substitute parse string, and recursively
13108      * calling reg() on it, instead of proceeding */
13109     if (multi_char_matches) {
13110         SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
13111         I32 cp_count;
13112         STRLEN len;
13113         char *save_end = RExC_end;
13114         char *save_parse = RExC_parse;
13115         bool first_time = TRUE;     /* First multi-char occurrence doesn't get
13116                                        a "|" */
13117         I32 reg_flags;
13118
13119         assert(! invert);
13120 #if 0   /* Have decided not to deal with multi-char folds in inverted classes,
13121            because too confusing */
13122         if (invert) {
13123             sv_catpv(substitute_parse, "(?:");
13124         }
13125 #endif
13126
13127         /* Look at the longest folds first */
13128         for (cp_count = av_len(multi_char_matches); cp_count > 0; cp_count--) {
13129
13130             if (av_exists(multi_char_matches, cp_count)) {
13131                 AV** this_array_ptr;
13132                 SV* this_sequence;
13133
13134                 this_array_ptr = (AV**) av_fetch(multi_char_matches,
13135                                                  cp_count, FALSE);
13136                 while ((this_sequence = av_pop(*this_array_ptr)) !=
13137                                                                 &PL_sv_undef)
13138                 {
13139                     if (! first_time) {
13140                         sv_catpv(substitute_parse, "|");
13141                     }
13142                     first_time = FALSE;
13143
13144                     sv_catpv(substitute_parse, SvPVX(this_sequence));
13145                 }
13146             }
13147         }
13148
13149         /* If the character class contains anything else besides these
13150          * multi-character folds, have to include it in recursive parsing */
13151         if (element_count) {
13152             sv_catpv(substitute_parse, "|[");
13153             sv_catpvn(substitute_parse, orig_parse, RExC_parse - orig_parse);
13154             sv_catpv(substitute_parse, "]");
13155         }
13156
13157         sv_catpv(substitute_parse, ")");
13158 #if 0
13159         if (invert) {
13160             /* This is a way to get the parse to skip forward a whole named
13161              * sequence instead of matching the 2nd character when it fails the
13162              * first */
13163             sv_catpv(substitute_parse, "(*THEN)(*SKIP)(*FAIL)|.)");
13164         }
13165 #endif
13166
13167         RExC_parse = SvPV(substitute_parse, len);
13168         RExC_end = RExC_parse + len;
13169         RExC_in_multi_char_class = 1;
13170         RExC_emit = (regnode *)orig_emit;
13171
13172         ret = reg(pRExC_state, 1, &reg_flags, depth+1);
13173
13174         *flagp |= reg_flags&(HASWIDTH|SIMPLE|SPSTART|POSTPONED|RESTART_UTF8);
13175
13176         RExC_parse = save_parse;
13177         RExC_end = save_end;
13178         RExC_in_multi_char_class = 0;
13179         SvREFCNT_dec_NN(multi_char_matches);
13180         return ret;
13181     }
13182
13183     /* If the character class contains only a single element, it may be
13184      * optimizable into another node type which is smaller and runs faster.
13185      * Check if this is the case for this class */
13186     if (element_count == 1 && ! ret_invlist) {
13187         U8 op = END;
13188         U8 arg = 0;
13189
13190         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class, like \w or
13191                                               [:digit:] or \p{foo} */
13192
13193             /* All named classes are mapped into POSIXish nodes, with its FLAG
13194              * argument giving which class it is */
13195             switch ((I32)namedclass) {
13196                 case ANYOF_UNIPROP:
13197                     break;
13198
13199                 /* These don't depend on the charset modifiers.  They always
13200                  * match under /u rules */
13201                 case ANYOF_NHORIZWS:
13202                 case ANYOF_HORIZWS:
13203                     namedclass = ANYOF_BLANK + namedclass - ANYOF_HORIZWS;
13204                     /* FALLTHROUGH */
13205
13206                 case ANYOF_NVERTWS:
13207                 case ANYOF_VERTWS:
13208                     op = POSIXU;
13209                     goto join_posix;
13210
13211                 /* The actual POSIXish node for all the rest depends on the
13212                  * charset modifier.  The ones in the first set depend only on
13213                  * ASCII or, if available on this platform, locale */
13214                 case ANYOF_ASCII:
13215                 case ANYOF_NASCII:
13216 #ifdef HAS_ISASCII
13217                     op = (LOC) ? POSIXL : POSIXA;
13218 #else
13219                     op = POSIXA;
13220 #endif
13221                     goto join_posix;
13222
13223                 case ANYOF_NCASED:
13224                 case ANYOF_LOWER:
13225                 case ANYOF_NLOWER:
13226                 case ANYOF_UPPER:
13227                 case ANYOF_NUPPER:
13228                     /* under /a could be alpha */
13229                     if (FOLD) {
13230                         if (ASCII_RESTRICTED) {
13231                             namedclass = ANYOF_ALPHA + (namedclass % 2);
13232                         }
13233                         else if (! LOC) {
13234                             break;
13235                         }
13236                     }
13237                     /* FALLTHROUGH */
13238
13239                 /* The rest have more possibilities depending on the charset.
13240                  * We take advantage of the enum ordering of the charset
13241                  * modifiers to get the exact node type, */
13242                 default:
13243                     op = POSIXD + get_regex_charset(RExC_flags);
13244                     if (op > POSIXA) { /* /aa is same as /a */
13245                         op = POSIXA;
13246                     }
13247 #ifndef HAS_ISBLANK
13248                     if (op == POSIXL
13249                         && (namedclass == ANYOF_BLANK
13250                             || namedclass == ANYOF_NBLANK))
13251                     {
13252                         op = POSIXA;
13253                     }
13254 #endif
13255
13256                 join_posix:
13257                     /* The odd numbered ones are the complements of the
13258                      * next-lower even number one */
13259                     if (namedclass % 2 == 1) {
13260                         invert = ! invert;
13261                         namedclass--;
13262                     }
13263                     arg = namedclass_to_classnum(namedclass);
13264                     break;
13265             }
13266         }
13267         else if (value == prevvalue) {
13268
13269             /* Here, the class consists of just a single code point */
13270
13271             if (invert) {
13272                 if (! LOC && value == '\n') {
13273                     op = REG_ANY; /* Optimize [^\n] */
13274                     *flagp |= HASWIDTH|SIMPLE;
13275                     RExC_naughty++;
13276                 }
13277             }
13278             else if (value < 256 || UTF) {
13279
13280                 /* Optimize a single value into an EXACTish node, but not if it
13281                  * would require converting the pattern to UTF-8. */
13282                 op = compute_EXACTish(pRExC_state);
13283             }
13284         } /* Otherwise is a range */
13285         else if (! LOC) {   /* locale could vary these */
13286             if (prevvalue == '0') {
13287                 if (value == '9') {
13288                     arg = _CC_DIGIT;
13289                     op = POSIXA;
13290                 }
13291             }
13292         }
13293
13294         /* Here, we have changed <op> away from its initial value iff we found
13295          * an optimization */
13296         if (op != END) {
13297
13298             /* Throw away this ANYOF regnode, and emit the calculated one,
13299              * which should correspond to the beginning, not current, state of
13300              * the parse */
13301             const char * cur_parse = RExC_parse;
13302             RExC_parse = (char *)orig_parse;
13303             if ( SIZE_ONLY) {
13304                 if (! LOC) {
13305
13306                     /* To get locale nodes to not use the full ANYOF size would
13307                      * require moving the code above that writes the portions
13308                      * of it that aren't in other nodes to after this point.
13309                      * e.g.  ANYOF_CLASS_SET */
13310                     RExC_size = orig_size;
13311                 }
13312             }
13313             else {
13314                 RExC_emit = (regnode *)orig_emit;
13315                 if (PL_regkind[op] == POSIXD) {
13316                     if (invert) {
13317                         op += NPOSIXD - POSIXD;
13318                     }
13319                 }
13320             }
13321
13322             ret = reg_node(pRExC_state, op);
13323
13324             if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
13325                 if (! SIZE_ONLY) {
13326                     FLAGS(ret) = arg;
13327                 }
13328                 *flagp |= HASWIDTH|SIMPLE;
13329             }
13330             else if (PL_regkind[op] == EXACT) {
13331                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value);
13332             }
13333
13334             RExC_parse = (char *) cur_parse;
13335
13336             SvREFCNT_dec(posixes);
13337             SvREFCNT_dec(cp_list);
13338             return ret;
13339         }
13340     }
13341
13342     if (SIZE_ONLY)
13343         return ret;
13344     /****** !SIZE_ONLY (Pass 2) AFTER HERE *********/
13345
13346     /* If folding, we calculate all characters that could fold to or from the
13347      * ones already on the list */
13348     if (FOLD && cp_list) {
13349         UV start, end;  /* End points of code point ranges */
13350
13351         SV* fold_intersection = NULL;
13352
13353         /* If the highest code point is within Latin1, we can use the
13354          * compiled-in Alphas list, and not have to go out to disk.  This
13355          * yields two false positives, the masculine and feminine ordinal
13356          * indicators, which are weeded out below using the
13357          * IS_IN_SOME_FOLD_L1() macro */
13358         if (invlist_highest(cp_list) < 256) {
13359             _invlist_intersection(PL_L1Posix_ptrs[_CC_ALPHA], cp_list,
13360                                                            &fold_intersection);
13361         }
13362         else {
13363
13364             /* Here, there are non-Latin1 code points, so we will have to go
13365              * fetch the list of all the characters that participate in folds
13366              */
13367             if (! PL_utf8_foldable) {
13368                 SV* swash = swash_init("utf8", "_Perl_Any_Folds",
13369                                        &PL_sv_undef, 1, 0);
13370                 PL_utf8_foldable = _get_swash_invlist(swash);
13371                 SvREFCNT_dec_NN(swash);
13372             }
13373
13374             /* This is a hash that for a particular fold gives all characters
13375              * that are involved in it */
13376             if (! PL_utf8_foldclosures) {
13377
13378                 /* If we were unable to find any folds, then we likely won't be
13379                  * able to find the closures.  So just create an empty list.
13380                  * Folding will effectively be restricted to the non-Unicode
13381                  * rules hard-coded into Perl.  (This case happens legitimately
13382                  * during compilation of Perl itself before the Unicode tables
13383                  * are generated) */
13384                 if (_invlist_len(PL_utf8_foldable) == 0) {
13385                     PL_utf8_foldclosures = newHV();
13386                 }
13387                 else {
13388                     /* If the folds haven't been read in, call a fold function
13389                      * to force that */
13390                     if (! PL_utf8_tofold) {
13391                         U8 dummy[UTF8_MAXBYTES+1];
13392
13393                         /* This string is just a short named one above \xff */
13394                         to_utf8_fold((U8*) HYPHEN_UTF8, dummy, NULL);
13395                         assert(PL_utf8_tofold); /* Verify that worked */
13396                     }
13397                     PL_utf8_foldclosures =
13398                                     _swash_inversion_hash(PL_utf8_tofold);
13399                 }
13400             }
13401
13402             /* Only the characters in this class that participate in folds need
13403              * be checked.  Get the intersection of this class and all the
13404              * possible characters that are foldable.  This can quickly narrow
13405              * down a large class */
13406             _invlist_intersection(PL_utf8_foldable, cp_list,
13407                                   &fold_intersection);
13408         }
13409
13410         /* Now look at the foldable characters in this class individually */
13411         invlist_iterinit(fold_intersection);
13412         while (invlist_iternext(fold_intersection, &start, &end)) {
13413             UV j;
13414
13415             /* Locale folding for Latin1 characters is deferred until runtime */
13416             if (LOC && start < 256) {
13417                 start = 256;
13418             }
13419
13420             /* Look at every character in the range */
13421             for (j = start; j <= end; j++) {
13422
13423                 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
13424                 STRLEN foldlen;
13425                 SV** listp;
13426
13427                 if (j < 256) {
13428
13429                     /* We have the latin1 folding rules hard-coded here so that
13430                      * an innocent-looking character class, like /[ks]/i won't
13431                      * have to go out to disk to find the possible matches.
13432                      * XXX It would be better to generate these via regen, in
13433                      * case a new version of the Unicode standard adds new
13434                      * mappings, though that is not really likely, and may be
13435                      * caught by the default: case of the switch below. */
13436
13437                     if (IS_IN_SOME_FOLD_L1(j)) {
13438
13439                         /* ASCII is always matched; non-ASCII is matched only
13440                          * under Unicode rules */
13441                         if (isASCII(j) || AT_LEAST_UNI_SEMANTICS) {
13442                             cp_list =
13443                                 add_cp_to_invlist(cp_list, PL_fold_latin1[j]);
13444                         }
13445                         else {
13446                             depends_list =
13447                              add_cp_to_invlist(depends_list, PL_fold_latin1[j]);
13448                         }
13449                     }
13450
13451                     if (HAS_NONLATIN1_FOLD_CLOSURE(j)
13452                         && (! isASCII(j) || ! ASCII_FOLD_RESTRICTED))
13453                     {
13454                         /* Certain Latin1 characters have matches outside
13455                          * Latin1.  To get here, <j> is one of those
13456                          * characters.   None of these matches is valid for
13457                          * ASCII characters under /aa, which is why the 'if'
13458                          * just above excludes those.  These matches only
13459                          * happen when the target string is utf8.  The code
13460                          * below adds the single fold closures for <j> to the
13461                          * inversion list. */
13462                         switch (j) {
13463                             case 'k':
13464                             case 'K':
13465                                 cp_list =
13466                                     add_cp_to_invlist(cp_list, KELVIN_SIGN);
13467                                 break;
13468                             case 's':
13469                             case 'S':
13470                                 cp_list = add_cp_to_invlist(cp_list,
13471                                                     LATIN_SMALL_LETTER_LONG_S);
13472                                 break;
13473                             case MICRO_SIGN:
13474                                 cp_list = add_cp_to_invlist(cp_list,
13475                                                     GREEK_CAPITAL_LETTER_MU);
13476                                 cp_list = add_cp_to_invlist(cp_list,
13477                                                     GREEK_SMALL_LETTER_MU);
13478                                 break;
13479                             case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
13480                             case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
13481                                 cp_list =
13482                                     add_cp_to_invlist(cp_list, ANGSTROM_SIGN);
13483                                 break;
13484                             case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
13485                                 cp_list = add_cp_to_invlist(cp_list,
13486                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
13487                                 break;
13488                             case LATIN_SMALL_LETTER_SHARP_S:
13489                                 cp_list = add_cp_to_invlist(cp_list,
13490                                                 LATIN_CAPITAL_LETTER_SHARP_S);
13491                                 break;
13492                             case 'F': case 'f':
13493                             case 'I': case 'i':
13494                             case 'L': case 'l':
13495                             case 'T': case 't':
13496                             case 'A': case 'a':
13497                             case 'H': case 'h':
13498                             case 'J': case 'j':
13499                             case 'N': case 'n':
13500                             case 'W': case 'w':
13501                             case 'Y': case 'y':
13502                                 /* These all are targets of multi-character
13503                                  * folds from code points that require UTF8 to
13504                                  * express, so they can't match unless the
13505                                  * target string is in UTF-8, so no action here
13506                                  * is necessary, as regexec.c properly handles
13507                                  * the general case for UTF-8 matching and
13508                                  * multi-char folds */
13509                                 break;
13510                             default:
13511                                 /* Use deprecated warning to increase the
13512                                  * chances of this being output */
13513                                 ckWARN2reg_d(RExC_parse, "Perl folding rules are not up-to-date for 0x%"UVXf"; please use the perlbug utility to report;", j);
13514                                 break;
13515                         }
13516                     }
13517                     continue;
13518                 }
13519
13520                 /* Here is an above Latin1 character.  We don't have the rules
13521                  * hard-coded for it.  First, get its fold.  This is the simple
13522                  * fold, as the multi-character folds have been handled earlier
13523                  * and separated out */
13524                 _to_uni_fold_flags(j, foldbuf, &foldlen,
13525                                                ((LOC)
13526                                                ? FOLD_FLAGS_LOCALE
13527                                                : (ASCII_FOLD_RESTRICTED)
13528                                                   ? FOLD_FLAGS_NOMIX_ASCII
13529                                                   : 0));
13530
13531                 /* Single character fold of above Latin1.  Add everything in
13532                  * its fold closure to the list that this node should match.
13533                  * The fold closures data structure is a hash with the keys
13534                  * being the UTF-8 of every character that is folded to, like
13535                  * 'k', and the values each an array of all code points that
13536                  * fold to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ].
13537                  * Multi-character folds are not included */
13538                 if ((listp = hv_fetch(PL_utf8_foldclosures,
13539                                       (char *) foldbuf, foldlen, FALSE)))
13540                 {
13541                     AV* list = (AV*) *listp;
13542                     IV k;
13543                     for (k = 0; k <= av_len(list); k++) {
13544                         SV** c_p = av_fetch(list, k, FALSE);
13545                         UV c;
13546                         if (c_p == NULL) {
13547                             Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
13548                         }
13549                         c = SvUV(*c_p);
13550
13551                         /* /aa doesn't allow folds between ASCII and non-; /l
13552                          * doesn't allow them between above and below 256 */
13553                         if ((ASCII_FOLD_RESTRICTED
13554                                   && (isASCII(c) != isASCII(j)))
13555                             || (LOC && c < 256)) {
13556                             continue;
13557                         }
13558
13559                         /* Folds involving non-ascii Latin1 characters
13560                          * under /d are added to a separate list */
13561                         if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS)
13562                         {
13563                             cp_list = add_cp_to_invlist(cp_list, c);
13564                         }
13565                         else {
13566                           depends_list = add_cp_to_invlist(depends_list, c);
13567                         }
13568                     }
13569                 }
13570             }
13571         }
13572         SvREFCNT_dec_NN(fold_intersection);
13573     }
13574
13575     /* And combine the result (if any) with any inversion list from posix
13576      * classes.  The lists are kept separate up to now because we don't want to
13577      * fold the classes (folding of those is automatically handled by the swash
13578      * fetching code) */
13579     if (posixes) {
13580         if (! DEPENDS_SEMANTICS) {
13581             if (cp_list) {
13582                 _invlist_union(cp_list, posixes, &cp_list);
13583                 SvREFCNT_dec_NN(posixes);
13584             }
13585             else {
13586                 cp_list = posixes;
13587             }
13588         }
13589         else {
13590             /* Under /d, we put into a separate list the Latin1 things that
13591              * match only when the target string is utf8 */
13592             SV* nonascii_but_latin1_properties = NULL;
13593             _invlist_intersection(posixes, PL_Latin1,
13594                                   &nonascii_but_latin1_properties);
13595             _invlist_subtract(nonascii_but_latin1_properties, PL_ASCII,
13596                               &nonascii_but_latin1_properties);
13597             _invlist_subtract(posixes, nonascii_but_latin1_properties,
13598                               &posixes);
13599             if (cp_list) {
13600                 _invlist_union(cp_list, posixes, &cp_list);
13601                 SvREFCNT_dec_NN(posixes);
13602             }
13603             else {
13604                 cp_list = posixes;
13605             }
13606
13607             if (depends_list) {
13608                 _invlist_union(depends_list, nonascii_but_latin1_properties,
13609                                &depends_list);
13610                 SvREFCNT_dec_NN(nonascii_but_latin1_properties);
13611             }
13612             else {
13613                 depends_list = nonascii_but_latin1_properties;
13614             }
13615         }
13616     }
13617
13618     /* And combine the result (if any) with any inversion list from properties.
13619      * The lists are kept separate up to now so that we can distinguish the two
13620      * in regards to matching above-Unicode.  A run-time warning is generated
13621      * if a Unicode property is matched against a non-Unicode code point. But,
13622      * we allow user-defined properties to match anything, without any warning,
13623      * and we also suppress the warning if there is a portion of the character
13624      * class that isn't a Unicode property, and which matches above Unicode, \W
13625      * or [\x{110000}] for example.
13626      * (Note that in this case, unlike the Posix one above, there is no
13627      * <depends_list>, because having a Unicode property forces Unicode
13628      * semantics */
13629     if (properties) {
13630         bool warn_super = ! has_user_defined_property;
13631         if (cp_list) {
13632
13633             /* If it matters to the final outcome, see if a non-property
13634              * component of the class matches above Unicode.  If so, the
13635              * warning gets suppressed.  This is true even if just a single
13636              * such code point is specified, as though not strictly correct if
13637              * another such code point is matched against, the fact that they
13638              * are using above-Unicode code points indicates they should know
13639              * the issues involved */
13640             if (warn_super) {
13641                 bool non_prop_matches_above_Unicode =
13642                             runtime_posix_matches_above_Unicode
13643                             | (invlist_highest(cp_list) > PERL_UNICODE_MAX);
13644                 if (invert) {
13645                     non_prop_matches_above_Unicode =
13646                                             !  non_prop_matches_above_Unicode;
13647                 }
13648                 warn_super = ! non_prop_matches_above_Unicode;
13649             }
13650
13651             _invlist_union(properties, cp_list, &cp_list);
13652             SvREFCNT_dec_NN(properties);
13653         }
13654         else {
13655             cp_list = properties;
13656         }
13657
13658         if (warn_super) {
13659             OP(ret) = ANYOF_WARN_SUPER;
13660         }
13661     }
13662
13663     /* Here, we have calculated what code points should be in the character
13664      * class.
13665      *
13666      * Now we can see about various optimizations.  Fold calculation (which we
13667      * did above) needs to take place before inversion.  Otherwise /[^k]/i
13668      * would invert to include K, which under /i would match k, which it
13669      * shouldn't.  Therefore we can't invert folded locale now, as it won't be
13670      * folded until runtime */
13671
13672     /* Optimize inverted simple patterns (e.g. [^a-z]) when everything is known
13673      * at compile time.  Besides not inverting folded locale now, we can't
13674      * invert if there are things such as \w, which aren't known until runtime
13675      * */
13676     if (invert
13677         && ! (LOC && (FOLD || (ANYOF_FLAGS(ret) & ANYOF_CLASS)))
13678         && ! depends_list
13679         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
13680     {
13681         _invlist_invert(cp_list);
13682
13683         /* Any swash can't be used as-is, because we've inverted things */
13684         if (swash) {
13685             SvREFCNT_dec_NN(swash);
13686             swash = NULL;
13687         }
13688
13689         /* Clear the invert flag since have just done it here */
13690         invert = FALSE;
13691     }
13692
13693     if (ret_invlist) {
13694         *ret_invlist = cp_list;
13695         SvREFCNT_dec(swash);
13696
13697         /* Discard the generated node */
13698         if (SIZE_ONLY) {
13699             RExC_size = orig_size;
13700         }
13701         else {
13702             RExC_emit = orig_emit;
13703         }
13704         return orig_emit;
13705     }
13706
13707     /* If we didn't do folding, it's because some information isn't available
13708      * until runtime; set the run-time fold flag for these.  (We don't have to
13709      * worry about properties folding, as that is taken care of by the swash
13710      * fetching) */
13711     if (FOLD && LOC)
13712     {
13713        ANYOF_FLAGS(ret) |= ANYOF_LOC_FOLD;
13714     }
13715
13716     /* Some character classes are equivalent to other nodes.  Such nodes take
13717      * up less room and generally fewer operations to execute than ANYOF nodes.
13718      * Above, we checked for and optimized into some such equivalents for
13719      * certain common classes that are easy to test.  Getting to this point in
13720      * the code means that the class didn't get optimized there.  Since this
13721      * code is only executed in Pass 2, it is too late to save space--it has
13722      * been allocated in Pass 1, and currently isn't given back.  But turning
13723      * things into an EXACTish node can allow the optimizer to join it to any
13724      * adjacent such nodes.  And if the class is equivalent to things like /./,
13725      * expensive run-time swashes can be avoided.  Now that we have more
13726      * complete information, we can find things necessarily missed by the
13727      * earlier code.  I (khw) am not sure how much to look for here.  It would
13728      * be easy, but perhaps too slow, to check any candidates against all the
13729      * node types they could possibly match using _invlistEQ(). */
13730
13731     if (cp_list
13732         && ! invert
13733         && ! depends_list
13734         && ! (ANYOF_FLAGS(ret) & ANYOF_CLASS)
13735         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
13736     {
13737         UV start, end;
13738         U8 op = END;  /* The optimzation node-type */
13739         const char * cur_parse= RExC_parse;
13740
13741         invlist_iterinit(cp_list);
13742         if (! invlist_iternext(cp_list, &start, &end)) {
13743
13744             /* Here, the list is empty.  This happens, for example, when a
13745              * Unicode property is the only thing in the character class, and
13746              * it doesn't match anything.  (perluniprops.pod notes such
13747              * properties) */
13748             op = OPFAIL;
13749             *flagp |= HASWIDTH|SIMPLE;
13750         }
13751         else if (start == end) {    /* The range is a single code point */
13752             if (! invlist_iternext(cp_list, &start, &end)
13753
13754                     /* Don't do this optimization if it would require changing
13755                      * the pattern to UTF-8 */
13756                 && (start < 256 || UTF))
13757             {
13758                 /* Here, the list contains a single code point.  Can optimize
13759                  * into an EXACT node */
13760
13761                 value = start;
13762
13763                 if (! FOLD) {
13764                     op = EXACT;
13765                 }
13766                 else if (LOC) {
13767
13768                     /* A locale node under folding with one code point can be
13769                      * an EXACTFL, as its fold won't be calculated until
13770                      * runtime */
13771                     op = EXACTFL;
13772                 }
13773                 else {
13774
13775                     /* Here, we are generally folding, but there is only one
13776                      * code point to match.  If we have to, we use an EXACT
13777                      * node, but it would be better for joining with adjacent
13778                      * nodes in the optimization pass if we used the same
13779                      * EXACTFish node that any such are likely to be.  We can
13780                      * do this iff the code point doesn't participate in any
13781                      * folds.  For example, an EXACTF of a colon is the same as
13782                      * an EXACT one, since nothing folds to or from a colon. */
13783                     if (value < 256) {
13784                         if (IS_IN_SOME_FOLD_L1(value)) {
13785                             op = EXACT;
13786                         }
13787                     }
13788                     else {
13789                         if (! PL_utf8_foldable) {
13790                             SV* swash = swash_init("utf8", "_Perl_Any_Folds",
13791                                                 &PL_sv_undef, 1, 0);
13792                             PL_utf8_foldable = _get_swash_invlist(swash);
13793                             SvREFCNT_dec_NN(swash);
13794                         }
13795                         if (_invlist_contains_cp(PL_utf8_foldable, value)) {
13796                             op = EXACT;
13797                         }
13798                     }
13799
13800                     /* If we haven't found the node type, above, it means we
13801                      * can use the prevailing one */
13802                     if (op == END) {
13803                         op = compute_EXACTish(pRExC_state);
13804                     }
13805                 }
13806             }
13807         }
13808         else if (start == 0) {
13809             if (end == UV_MAX) {
13810                 op = SANY;
13811                 *flagp |= HASWIDTH|SIMPLE;
13812                 RExC_naughty++;
13813             }
13814             else if (end == '\n' - 1
13815                     && invlist_iternext(cp_list, &start, &end)
13816                     && start == '\n' + 1 && end == UV_MAX)
13817             {
13818                 op = REG_ANY;
13819                 *flagp |= HASWIDTH|SIMPLE;
13820                 RExC_naughty++;
13821             }
13822         }
13823         invlist_iterfinish(cp_list);
13824
13825         if (op != END) {
13826             RExC_parse = (char *)orig_parse;
13827             RExC_emit = (regnode *)orig_emit;
13828
13829             ret = reg_node(pRExC_state, op);
13830
13831             RExC_parse = (char *)cur_parse;
13832
13833             if (PL_regkind[op] == EXACT) {
13834                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value);
13835             }
13836
13837             SvREFCNT_dec_NN(cp_list);
13838             return ret;
13839         }
13840     }
13841
13842     /* Here, <cp_list> contains all the code points we can determine at
13843      * compile time that match under all conditions.  Go through it, and
13844      * for things that belong in the bitmap, put them there, and delete from
13845      * <cp_list>.  While we are at it, see if everything above 255 is in the
13846      * list, and if so, set a flag to speed up execution */
13847     ANYOF_BITMAP_ZERO(ret);
13848     if (cp_list) {
13849
13850         /* This gets set if we actually need to modify things */
13851         bool change_invlist = FALSE;
13852
13853         UV start, end;
13854
13855         /* Start looking through <cp_list> */
13856         invlist_iterinit(cp_list);
13857         while (invlist_iternext(cp_list, &start, &end)) {
13858             UV high;
13859             int i;
13860
13861             if (end == UV_MAX && start <= 256) {
13862                 ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
13863             }
13864
13865             /* Quit if are above what we should change */
13866             if (start > 255) {
13867                 break;
13868             }
13869
13870             change_invlist = TRUE;
13871
13872             /* Set all the bits in the range, up to the max that we are doing */
13873             high = (end < 255) ? end : 255;
13874             for (i = start; i <= (int) high; i++) {
13875                 if (! ANYOF_BITMAP_TEST(ret, i)) {
13876                     ANYOF_BITMAP_SET(ret, i);
13877                     prevvalue = value;
13878                     value = i;
13879                 }
13880             }
13881         }
13882         invlist_iterfinish(cp_list);
13883
13884         /* Done with loop; remove any code points that are in the bitmap from
13885          * <cp_list> */
13886         if (change_invlist) {
13887             _invlist_subtract(cp_list, PL_Latin1, &cp_list);
13888         }
13889
13890         /* If have completely emptied it, remove it completely */
13891         if (_invlist_len(cp_list) == 0) {
13892             SvREFCNT_dec_NN(cp_list);
13893             cp_list = NULL;
13894         }
13895     }
13896
13897     if (invert) {
13898         ANYOF_FLAGS(ret) |= ANYOF_INVERT;
13899     }
13900
13901     /* Here, the bitmap has been populated with all the Latin1 code points that
13902      * always match.  Can now add to the overall list those that match only
13903      * when the target string is UTF-8 (<depends_list>). */
13904     if (depends_list) {
13905         if (cp_list) {
13906             _invlist_union(cp_list, depends_list, &cp_list);
13907             SvREFCNT_dec_NN(depends_list);
13908         }
13909         else {
13910             cp_list = depends_list;
13911         }
13912     }
13913
13914     /* If there is a swash and more than one element, we can't use the swash in
13915      * the optimization below. */
13916     if (swash && element_count > 1) {
13917         SvREFCNT_dec_NN(swash);
13918         swash = NULL;
13919     }
13920
13921     if (! cp_list
13922         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
13923     {
13924         ARG_SET(ret, ANYOF_NONBITMAP_EMPTY);
13925     }
13926     else {
13927         /* av[0] stores the character class description in its textual form:
13928          *       used later (regexec.c:Perl_regclass_swash()) to initialize the
13929          *       appropriate swash, and is also useful for dumping the regnode.
13930          * av[1] if NULL, is a placeholder to later contain the swash computed
13931          *       from av[0].  But if no further computation need be done, the
13932          *       swash is stored there now.
13933          * av[2] stores the cp_list inversion list for use in addition or
13934          *       instead of av[0]; used only if av[1] is NULL
13935          * av[3] is set if any component of the class is from a user-defined
13936          *       property; used only if av[1] is NULL */
13937         AV * const av = newAV();
13938         SV *rv;
13939
13940         av_store(av, 0, (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
13941                         ? SvREFCNT_inc(listsv) : &PL_sv_undef);
13942         if (swash) {
13943             av_store(av, 1, swash);
13944             SvREFCNT_dec_NN(cp_list);
13945         }
13946         else {
13947             av_store(av, 1, NULL);
13948             if (cp_list) {
13949                 av_store(av, 2, cp_list);
13950                 av_store(av, 3, newSVuv(has_user_defined_property));
13951             }
13952         }
13953
13954         rv = newRV_noinc(MUTABLE_SV(av));
13955         n = add_data(pRExC_state, 1, "s");
13956         RExC_rxi->data->data[n] = (void*)rv;
13957         ARG_SET(ret, n);
13958     }
13959
13960     *flagp |= HASWIDTH|SIMPLE;
13961     return ret;
13962 }
13963 #undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
13964
13965
13966 /* reg_skipcomment()
13967
13968    Absorbs an /x style # comments from the input stream.
13969    Returns true if there is more text remaining in the stream.
13970    Will set the REG_SEEN_RUN_ON_COMMENT flag if the comment
13971    terminates the pattern without including a newline.
13972
13973    Note its the callers responsibility to ensure that we are
13974    actually in /x mode
13975
13976 */
13977
13978 STATIC bool
13979 S_reg_skipcomment(pTHX_ RExC_state_t *pRExC_state)
13980 {
13981     bool ended = 0;
13982
13983     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
13984
13985     while (RExC_parse < RExC_end)
13986         if (*RExC_parse++ == '\n') {
13987             ended = 1;
13988             break;
13989         }
13990     if (!ended) {
13991         /* we ran off the end of the pattern without ending
13992            the comment, so we have to add an \n when wrapping */
13993         RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
13994         return 0;
13995     } else
13996         return 1;
13997 }
13998
13999 /* nextchar()
14000
14001    Advances the parse position, and optionally absorbs
14002    "whitespace" from the inputstream.
14003
14004    Without /x "whitespace" means (?#...) style comments only,
14005    with /x this means (?#...) and # comments and whitespace proper.
14006
14007    Returns the RExC_parse point from BEFORE the scan occurs.
14008
14009    This is the /x friendly way of saying RExC_parse++.
14010 */
14011
14012 STATIC char*
14013 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
14014 {
14015     char* const retval = RExC_parse++;
14016
14017     PERL_ARGS_ASSERT_NEXTCHAR;
14018
14019     for (;;) {
14020         if (RExC_end - RExC_parse >= 3
14021             && *RExC_parse == '('
14022             && RExC_parse[1] == '?'
14023             && RExC_parse[2] == '#')
14024         {
14025             while (*RExC_parse != ')') {
14026                 if (RExC_parse == RExC_end)
14027                     FAIL("Sequence (?#... not terminated");
14028                 RExC_parse++;
14029             }
14030             RExC_parse++;
14031             continue;
14032         }
14033         if (RExC_flags & RXf_PMf_EXTENDED) {
14034             if (isSPACE(*RExC_parse)) {
14035                 RExC_parse++;
14036                 continue;
14037             }
14038             else if (*RExC_parse == '#') {
14039                 if ( reg_skipcomment( pRExC_state ) )
14040                     continue;
14041             }
14042         }
14043         return retval;
14044     }
14045 }
14046
14047 /*
14048 - reg_node - emit a node
14049 */
14050 STATIC regnode *                        /* Location. */
14051 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
14052 {
14053     dVAR;
14054     regnode *ptr;
14055     regnode * const ret = RExC_emit;
14056     GET_RE_DEBUG_FLAGS_DECL;
14057
14058     PERL_ARGS_ASSERT_REG_NODE;
14059
14060     if (SIZE_ONLY) {
14061         SIZE_ALIGN(RExC_size);
14062         RExC_size += 1;
14063         return(ret);
14064     }
14065     if (RExC_emit >= RExC_emit_bound)
14066         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
14067                    op, RExC_emit, RExC_emit_bound);
14068
14069     NODE_ALIGN_FILL(ret);
14070     ptr = ret;
14071     FILL_ADVANCE_NODE(ptr, op);
14072 #ifdef RE_TRACK_PATTERN_OFFSETS
14073     if (RExC_offsets) {         /* MJD */
14074         MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n", 
14075               "reg_node", __LINE__, 
14076               PL_reg_name[op],
14077               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] 
14078                 ? "Overwriting end of array!\n" : "OK",
14079               (UV)(RExC_emit - RExC_emit_start),
14080               (UV)(RExC_parse - RExC_start),
14081               (UV)RExC_offsets[0])); 
14082         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
14083     }
14084 #endif
14085     RExC_emit = ptr;
14086     return(ret);
14087 }
14088
14089 /*
14090 - reganode - emit a node with an argument
14091 */
14092 STATIC regnode *                        /* Location. */
14093 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
14094 {
14095     dVAR;
14096     regnode *ptr;
14097     regnode * const ret = RExC_emit;
14098     GET_RE_DEBUG_FLAGS_DECL;
14099
14100     PERL_ARGS_ASSERT_REGANODE;
14101
14102     if (SIZE_ONLY) {
14103         SIZE_ALIGN(RExC_size);
14104         RExC_size += 2;
14105         /* 
14106            We can't do this:
14107            
14108            assert(2==regarglen[op]+1); 
14109
14110            Anything larger than this has to allocate the extra amount.
14111            If we changed this to be:
14112            
14113            RExC_size += (1 + regarglen[op]);
14114            
14115            then it wouldn't matter. Its not clear what side effect
14116            might come from that so its not done so far.
14117            -- dmq
14118         */
14119         return(ret);
14120     }
14121     if (RExC_emit >= RExC_emit_bound)
14122         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
14123                    op, RExC_emit, RExC_emit_bound);
14124
14125     NODE_ALIGN_FILL(ret);
14126     ptr = ret;
14127     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
14128 #ifdef RE_TRACK_PATTERN_OFFSETS
14129     if (RExC_offsets) {         /* MJD */
14130         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
14131               "reganode",
14132               __LINE__,
14133               PL_reg_name[op],
14134               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? 
14135               "Overwriting end of array!\n" : "OK",
14136               (UV)(RExC_emit - RExC_emit_start),
14137               (UV)(RExC_parse - RExC_start),
14138               (UV)RExC_offsets[0])); 
14139         Set_Cur_Node_Offset;
14140     }
14141 #endif            
14142     RExC_emit = ptr;
14143     return(ret);
14144 }
14145
14146 /*
14147 - reguni - emit (if appropriate) a Unicode character
14148 */
14149 STATIC STRLEN
14150 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
14151 {
14152     dVAR;
14153
14154     PERL_ARGS_ASSERT_REGUNI;
14155
14156     return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
14157 }
14158
14159 /*
14160 - reginsert - insert an operator in front of already-emitted operand
14161 *
14162 * Means relocating the operand.
14163 */
14164 STATIC void
14165 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
14166 {
14167     dVAR;
14168     regnode *src;
14169     regnode *dst;
14170     regnode *place;
14171     const int offset = regarglen[(U8)op];
14172     const int size = NODE_STEP_REGNODE + offset;
14173     GET_RE_DEBUG_FLAGS_DECL;
14174
14175     PERL_ARGS_ASSERT_REGINSERT;
14176     PERL_UNUSED_ARG(depth);
14177 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
14178     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
14179     if (SIZE_ONLY) {
14180         RExC_size += size;
14181         return;
14182     }
14183
14184     src = RExC_emit;
14185     RExC_emit += size;
14186     dst = RExC_emit;
14187     if (RExC_open_parens) {
14188         int paren;
14189         /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
14190         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
14191             if ( RExC_open_parens[paren] >= opnd ) {
14192                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
14193                 RExC_open_parens[paren] += size;
14194             } else {
14195                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
14196             }
14197             if ( RExC_close_parens[paren] >= opnd ) {
14198                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
14199                 RExC_close_parens[paren] += size;
14200             } else {
14201                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
14202             }
14203         }
14204     }
14205
14206     while (src > opnd) {
14207         StructCopy(--src, --dst, regnode);
14208 #ifdef RE_TRACK_PATTERN_OFFSETS
14209         if (RExC_offsets) {     /* MJD 20010112 */
14210             MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
14211                   "reg_insert",
14212                   __LINE__,
14213                   PL_reg_name[op],
14214                   (UV)(dst - RExC_emit_start) > RExC_offsets[0] 
14215                     ? "Overwriting end of array!\n" : "OK",
14216                   (UV)(src - RExC_emit_start),
14217                   (UV)(dst - RExC_emit_start),
14218                   (UV)RExC_offsets[0])); 
14219             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
14220             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
14221         }
14222 #endif
14223     }
14224     
14225
14226     place = opnd;               /* Op node, where operand used to be. */
14227 #ifdef RE_TRACK_PATTERN_OFFSETS
14228     if (RExC_offsets) {         /* MJD */
14229         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
14230               "reginsert",
14231               __LINE__,
14232               PL_reg_name[op],
14233               (UV)(place - RExC_emit_start) > RExC_offsets[0] 
14234               ? "Overwriting end of array!\n" : "OK",
14235               (UV)(place - RExC_emit_start),
14236               (UV)(RExC_parse - RExC_start),
14237               (UV)RExC_offsets[0]));
14238         Set_Node_Offset(place, RExC_parse);
14239         Set_Node_Length(place, 1);
14240     }
14241 #endif    
14242     src = NEXTOPER(place);
14243     FILL_ADVANCE_NODE(place, op);
14244     Zero(src, offset, regnode);
14245 }
14246
14247 /*
14248 - regtail - set the next-pointer at the end of a node chain of p to val.
14249 - SEE ALSO: regtail_study
14250 */
14251 /* TODO: All three parms should be const */
14252 STATIC void
14253 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
14254 {
14255     dVAR;
14256     regnode *scan;
14257     GET_RE_DEBUG_FLAGS_DECL;
14258
14259     PERL_ARGS_ASSERT_REGTAIL;
14260 #ifndef DEBUGGING
14261     PERL_UNUSED_ARG(depth);
14262 #endif
14263
14264     if (SIZE_ONLY)
14265         return;
14266
14267     /* Find last node. */
14268     scan = p;
14269     for (;;) {
14270         regnode * const temp = regnext(scan);
14271         DEBUG_PARSE_r({
14272             SV * const mysv=sv_newmortal();
14273             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
14274             regprop(RExC_rx, mysv, scan);
14275             PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
14276                 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
14277                     (temp == NULL ? "->" : ""),
14278                     (temp == NULL ? PL_reg_name[OP(val)] : "")
14279             );
14280         });
14281         if (temp == NULL)
14282             break;
14283         scan = temp;
14284     }
14285
14286     if (reg_off_by_arg[OP(scan)]) {
14287         ARG_SET(scan, val - scan);
14288     }
14289     else {
14290         NEXT_OFF(scan) = val - scan;
14291     }
14292 }
14293
14294 #ifdef DEBUGGING
14295 /*
14296 - regtail_study - set the next-pointer at the end of a node chain of p to val.
14297 - Look for optimizable sequences at the same time.
14298 - currently only looks for EXACT chains.
14299
14300 This is experimental code. The idea is to use this routine to perform 
14301 in place optimizations on branches and groups as they are constructed,
14302 with the long term intention of removing optimization from study_chunk so
14303 that it is purely analytical.
14304
14305 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
14306 to control which is which.
14307
14308 */
14309 /* TODO: All four parms should be const */
14310
14311 STATIC U8
14312 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
14313 {
14314     dVAR;
14315     regnode *scan;
14316     U8 exact = PSEUDO;
14317 #ifdef EXPERIMENTAL_INPLACESCAN
14318     I32 min = 0;
14319 #endif
14320     GET_RE_DEBUG_FLAGS_DECL;
14321
14322     PERL_ARGS_ASSERT_REGTAIL_STUDY;
14323
14324
14325     if (SIZE_ONLY)
14326         return exact;
14327
14328     /* Find last node. */
14329
14330     scan = p;
14331     for (;;) {
14332         regnode * const temp = regnext(scan);
14333 #ifdef EXPERIMENTAL_INPLACESCAN
14334         if (PL_regkind[OP(scan)] == EXACT) {
14335             bool has_exactf_sharp_s;    /* Unexamined in this routine */
14336             if (join_exact(pRExC_state,scan,&min, &has_exactf_sharp_s, 1,val,depth+1))
14337                 return EXACT;
14338         }
14339 #endif
14340         if ( exact ) {
14341             switch (OP(scan)) {
14342                 case EXACT:
14343                 case EXACTF:
14344                 case EXACTFA:
14345                 case EXACTFU:
14346                 case EXACTFU_SS:
14347                 case EXACTFU_TRICKYFOLD:
14348                 case EXACTFL:
14349                         if( exact == PSEUDO )
14350                             exact= OP(scan);
14351                         else if ( exact != OP(scan) )
14352                             exact= 0;
14353                 case NOTHING:
14354                     break;
14355                 default:
14356                     exact= 0;
14357             }
14358         }
14359         DEBUG_PARSE_r({
14360             SV * const mysv=sv_newmortal();
14361             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
14362             regprop(RExC_rx, mysv, scan);
14363             PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
14364                 SvPV_nolen_const(mysv),
14365                 REG_NODE_NUM(scan),
14366                 PL_reg_name[exact]);
14367         });
14368         if (temp == NULL)
14369             break;
14370         scan = temp;
14371     }
14372     DEBUG_PARSE_r({
14373         SV * const mysv_val=sv_newmortal();
14374         DEBUG_PARSE_MSG("");
14375         regprop(RExC_rx, mysv_val, val);
14376         PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
14377                       SvPV_nolen_const(mysv_val),
14378                       (IV)REG_NODE_NUM(val),
14379                       (IV)(val - scan)
14380         );
14381     });
14382     if (reg_off_by_arg[OP(scan)]) {
14383         ARG_SET(scan, val - scan);
14384     }
14385     else {
14386         NEXT_OFF(scan) = val - scan;
14387     }
14388
14389     return exact;
14390 }
14391 #endif
14392
14393 /*
14394  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
14395  */
14396 #ifdef DEBUGGING
14397
14398 static void
14399 S_regdump_intflags(pTHX_ const char *lead, const U32 flags)
14400 {
14401     int bit;
14402     int set=0;
14403
14404     for (bit=0; bit<32; bit++) {
14405         if (flags & (1<<bit)) {
14406             if (!set++ && lead)
14407                 PerlIO_printf(Perl_debug_log, "%s",lead);
14408             PerlIO_printf(Perl_debug_log, "%s ",PL_reg_intflags_name[bit]);
14409         }
14410     }
14411     if (lead)  {
14412         if (set)
14413             PerlIO_printf(Perl_debug_log, "\n");
14414         else
14415             PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
14416     }
14417 }
14418
14419 static void 
14420 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
14421 {
14422     int bit;
14423     int set=0;
14424     regex_charset cs;
14425
14426     for (bit=0; bit<32; bit++) {
14427         if (flags & (1<<bit)) {
14428             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
14429                 continue;
14430             }
14431             if (!set++ && lead) 
14432                 PerlIO_printf(Perl_debug_log, "%s",lead);
14433             PerlIO_printf(Perl_debug_log, "%s ",PL_reg_extflags_name[bit]);
14434         }               
14435     }      
14436     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
14437             if (!set++ && lead) {
14438                 PerlIO_printf(Perl_debug_log, "%s",lead);
14439             }
14440             switch (cs) {
14441                 case REGEX_UNICODE_CHARSET:
14442                     PerlIO_printf(Perl_debug_log, "UNICODE");
14443                     break;
14444                 case REGEX_LOCALE_CHARSET:
14445                     PerlIO_printf(Perl_debug_log, "LOCALE");
14446                     break;
14447                 case REGEX_ASCII_RESTRICTED_CHARSET:
14448                     PerlIO_printf(Perl_debug_log, "ASCII-RESTRICTED");
14449                     break;
14450                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
14451                     PerlIO_printf(Perl_debug_log, "ASCII-MORE_RESTRICTED");
14452                     break;
14453                 default:
14454                     PerlIO_printf(Perl_debug_log, "UNKNOWN CHARACTER SET");
14455                     break;
14456             }
14457     }
14458     if (lead)  {
14459         if (set) 
14460             PerlIO_printf(Perl_debug_log, "\n");
14461         else 
14462             PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
14463     }            
14464 }   
14465 #endif
14466
14467 void
14468 Perl_regdump(pTHX_ const regexp *r)
14469 {
14470 #ifdef DEBUGGING
14471     dVAR;
14472     SV * const sv = sv_newmortal();
14473     SV *dsv= sv_newmortal();
14474     RXi_GET_DECL(r,ri);
14475     GET_RE_DEBUG_FLAGS_DECL;
14476
14477     PERL_ARGS_ASSERT_REGDUMP;
14478
14479     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
14480
14481     /* Header fields of interest. */
14482     if (r->anchored_substr) {
14483         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr), 
14484             RE_SV_DUMPLEN(r->anchored_substr), 30);
14485         PerlIO_printf(Perl_debug_log,
14486                       "anchored %s%s at %"IVdf" ",
14487                       s, RE_SV_TAIL(r->anchored_substr),
14488                       (IV)r->anchored_offset);
14489     } else if (r->anchored_utf8) {
14490         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8), 
14491             RE_SV_DUMPLEN(r->anchored_utf8), 30);
14492         PerlIO_printf(Perl_debug_log,
14493                       "anchored utf8 %s%s at %"IVdf" ",
14494                       s, RE_SV_TAIL(r->anchored_utf8),
14495                       (IV)r->anchored_offset);
14496     }                 
14497     if (r->float_substr) {
14498         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr), 
14499             RE_SV_DUMPLEN(r->float_substr), 30);
14500         PerlIO_printf(Perl_debug_log,
14501                       "floating %s%s at %"IVdf"..%"UVuf" ",
14502                       s, RE_SV_TAIL(r->float_substr),
14503                       (IV)r->float_min_offset, (UV)r->float_max_offset);
14504     } else if (r->float_utf8) {
14505         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8), 
14506             RE_SV_DUMPLEN(r->float_utf8), 30);
14507         PerlIO_printf(Perl_debug_log,
14508                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
14509                       s, RE_SV_TAIL(r->float_utf8),
14510                       (IV)r->float_min_offset, (UV)r->float_max_offset);
14511     }
14512     if (r->check_substr || r->check_utf8)
14513         PerlIO_printf(Perl_debug_log,
14514                       (const char *)
14515                       (r->check_substr == r->float_substr
14516                        && r->check_utf8 == r->float_utf8
14517                        ? "(checking floating" : "(checking anchored"));
14518     if (r->extflags & RXf_NOSCAN)
14519         PerlIO_printf(Perl_debug_log, " noscan");
14520     if (r->extflags & RXf_CHECK_ALL)
14521         PerlIO_printf(Perl_debug_log, " isall");
14522     if (r->check_substr || r->check_utf8)
14523         PerlIO_printf(Perl_debug_log, ") ");
14524
14525     if (ri->regstclass) {
14526         regprop(r, sv, ri->regstclass);
14527         PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
14528     }
14529     if (r->extflags & RXf_ANCH) {
14530         PerlIO_printf(Perl_debug_log, "anchored");
14531         if (r->extflags & RXf_ANCH_BOL)
14532             PerlIO_printf(Perl_debug_log, "(BOL)");
14533         if (r->extflags & RXf_ANCH_MBOL)
14534             PerlIO_printf(Perl_debug_log, "(MBOL)");
14535         if (r->extflags & RXf_ANCH_SBOL)
14536             PerlIO_printf(Perl_debug_log, "(SBOL)");
14537         if (r->extflags & RXf_ANCH_GPOS)
14538             PerlIO_printf(Perl_debug_log, "(GPOS)");
14539         PerlIO_putc(Perl_debug_log, ' ');
14540     }
14541     if (r->extflags & RXf_GPOS_SEEN)
14542         PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
14543     if (r->intflags & PREGf_SKIP)
14544         PerlIO_printf(Perl_debug_log, "plus ");
14545     if (r->intflags & PREGf_IMPLICIT)
14546         PerlIO_printf(Perl_debug_log, "implicit ");
14547     PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
14548     if (r->extflags & RXf_EVAL_SEEN)
14549         PerlIO_printf(Perl_debug_log, "with eval ");
14550     PerlIO_printf(Perl_debug_log, "\n");
14551     DEBUG_FLAGS_r({
14552         regdump_extflags("r->extflags: ",r->extflags);
14553         regdump_intflags("r->intflags: ",r->intflags);
14554     });
14555 #else
14556     PERL_ARGS_ASSERT_REGDUMP;
14557     PERL_UNUSED_CONTEXT;
14558     PERL_UNUSED_ARG(r);
14559 #endif  /* DEBUGGING */
14560 }
14561
14562 /*
14563 - regprop - printable representation of opcode
14564 */
14565 #define EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags) \
14566 STMT_START { \
14567         if (do_sep) {                           \
14568             Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]); \
14569             if (flags & ANYOF_INVERT)           \
14570                 /*make sure the invert info is in each */ \
14571                 sv_catpvs(sv, "^");             \
14572             do_sep = 0;                         \
14573         }                                       \
14574 } STMT_END
14575
14576 void
14577 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
14578 {
14579 #ifdef DEBUGGING
14580     dVAR;
14581     int k;
14582
14583     /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
14584     static const char * const anyofs[] = {
14585 #if _CC_WORDCHAR != 0 || _CC_DIGIT != 1 || _CC_ALPHA != 2 || _CC_LOWER != 3 \
14586     || _CC_UPPER != 4 || _CC_PUNCT != 5 || _CC_PRINT != 6                   \
14587     || _CC_ALPHANUMERIC != 7 || _CC_GRAPH != 8 || _CC_CASED != 9            \
14588     || _CC_SPACE != 10 || _CC_BLANK != 11 || _CC_XDIGIT != 12               \
14589     || _CC_PSXSPC != 13 || _CC_CNTRL != 14 || _CC_ASCII != 15               \
14590     || _CC_VERTSPACE != 16
14591   #error Need to adjust order of anyofs[]
14592 #endif
14593         "[\\w]",
14594         "[\\W]",
14595         "[\\d]",
14596         "[\\D]",
14597         "[:alpha:]",
14598         "[:^alpha:]",
14599         "[:lower:]",
14600         "[:^lower:]",
14601         "[:upper:]",
14602         "[:^upper:]",
14603         "[:punct:]",
14604         "[:^punct:]",
14605         "[:print:]",
14606         "[:^print:]",
14607         "[:alnum:]",
14608         "[:^alnum:]",
14609         "[:graph:]",
14610         "[:^graph:]",
14611         "[:cased:]",
14612         "[:^cased:]",
14613         "[\\s]",
14614         "[\\S]",
14615         "[:blank:]",
14616         "[:^blank:]",
14617         "[:xdigit:]",
14618         "[:^xdigit:]",
14619         "[:space:]",
14620         "[:^space:]",
14621         "[:cntrl:]",
14622         "[:^cntrl:]",
14623         "[:ascii:]",
14624         "[:^ascii:]",
14625         "[\\v]",
14626         "[\\V]"
14627     };
14628     RXi_GET_DECL(prog,progi);
14629     GET_RE_DEBUG_FLAGS_DECL;
14630     
14631     PERL_ARGS_ASSERT_REGPROP;
14632
14633     sv_setpvs(sv, "");
14634
14635     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
14636         /* It would be nice to FAIL() here, but this may be called from
14637            regexec.c, and it would be hard to supply pRExC_state. */
14638         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
14639     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
14640
14641     k = PL_regkind[OP(o)];
14642
14643     if (k == EXACT) {
14644         sv_catpvs(sv, " ");
14645         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT) 
14646          * is a crude hack but it may be the best for now since 
14647          * we have no flag "this EXACTish node was UTF-8" 
14648          * --jhi */
14649         pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
14650                   PERL_PV_ESCAPE_UNI_DETECT |
14651                   PERL_PV_ESCAPE_NONASCII   |
14652                   PERL_PV_PRETTY_ELLIPSES   |
14653                   PERL_PV_PRETTY_LTGT       |
14654                   PERL_PV_PRETTY_NOCLEAR
14655                   );
14656     } else if (k == TRIE) {
14657         /* print the details of the trie in dumpuntil instead, as
14658          * progi->data isn't available here */
14659         const char op = OP(o);
14660         const U32 n = ARG(o);
14661         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
14662                (reg_ac_data *)progi->data->data[n] :
14663                NULL;
14664         const reg_trie_data * const trie
14665             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
14666         
14667         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
14668         DEBUG_TRIE_COMPILE_r(
14669             Perl_sv_catpvf(aTHX_ sv,
14670                 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
14671                 (UV)trie->startstate,
14672                 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
14673                 (UV)trie->wordcount,
14674                 (UV)trie->minlen,
14675                 (UV)trie->maxlen,
14676                 (UV)TRIE_CHARCOUNT(trie),
14677                 (UV)trie->uniquecharcount
14678             )
14679         );
14680         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
14681             int i;
14682             int rangestart = -1;
14683             U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
14684             sv_catpvs(sv, "[");
14685             for (i = 0; i <= 256; i++) {
14686                 if (i < 256 && BITMAP_TEST(bitmap,i)) {
14687                     if (rangestart == -1)
14688                         rangestart = i;
14689                 } else if (rangestart != -1) {
14690                     if (i <= rangestart + 3)
14691                         for (; rangestart < i; rangestart++)
14692                             put_byte(sv, rangestart);
14693                     else {
14694                         put_byte(sv, rangestart);
14695                         sv_catpvs(sv, "-");
14696                         put_byte(sv, i - 1);
14697                     }
14698                     rangestart = -1;
14699                 }
14700             }
14701             sv_catpvs(sv, "]");
14702         } 
14703          
14704     } else if (k == CURLY) {
14705         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
14706             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
14707         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
14708     }
14709     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
14710         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
14711     else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
14712         Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
14713         if ( RXp_PAREN_NAMES(prog) ) {
14714             if ( k != REF || (OP(o) < NREF)) {
14715                 AV *list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
14716                 SV **name= av_fetch(list, ARG(o), 0 );
14717                 if (name)
14718                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
14719             }       
14720             else {
14721                 AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]);
14722                 SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]);
14723                 I32 *nums=(I32*)SvPVX(sv_dat);
14724                 SV **name= av_fetch(list, nums[0], 0 );
14725                 I32 n;
14726                 if (name) {
14727                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
14728                         Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
14729                                     (n ? "," : ""), (IV)nums[n]);
14730                     }
14731                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
14732                 }
14733             }
14734         }            
14735     } else if (k == GOSUB) 
14736         Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
14737     else if (k == VERB) {
14738         if (!o->flags) 
14739             Perl_sv_catpvf(aTHX_ sv, ":%"SVf, 
14740                            SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
14741     } else if (k == LOGICAL)
14742         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);     /* 2: embedded, otherwise 1 */
14743     else if (k == ANYOF) {
14744         int i, rangestart = -1;
14745         const U8 flags = ANYOF_FLAGS(o);
14746         int do_sep = 0;
14747
14748
14749         if (flags & ANYOF_LOCALE)
14750             sv_catpvs(sv, "{loc}");
14751         if (flags & ANYOF_LOC_FOLD)
14752             sv_catpvs(sv, "{i}");
14753         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
14754         if (flags & ANYOF_INVERT)
14755             sv_catpvs(sv, "^");
14756
14757         /* output what the standard cp 0-255 bitmap matches */
14758         for (i = 0; i <= 256; i++) {
14759             if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
14760                 if (rangestart == -1)
14761                     rangestart = i;
14762             } else if (rangestart != -1) {
14763                 if (i <= rangestart + 3)
14764                     for (; rangestart < i; rangestart++)
14765                         put_byte(sv, rangestart);
14766                 else {
14767                     put_byte(sv, rangestart);
14768                     sv_catpvs(sv, "-");
14769                     put_byte(sv, i - 1);
14770                 }
14771                 do_sep = 1;
14772                 rangestart = -1;
14773             }
14774         }
14775         
14776         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
14777         /* output any special charclass tests (used entirely under use locale) */
14778         if (ANYOF_CLASS_TEST_ANY_SET(o))
14779             for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
14780                 if (ANYOF_CLASS_TEST(o,i)) {
14781                     sv_catpv(sv, anyofs[i]);
14782                     do_sep = 1;
14783                 }
14784         
14785         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
14786         
14787         if (flags & ANYOF_NON_UTF8_LATIN1_ALL) {
14788             sv_catpvs(sv, "{non-utf8-latin1-all}");
14789         }
14790
14791         /* output information about the unicode matching */
14792         if (flags & ANYOF_UNICODE_ALL)
14793             sv_catpvs(sv, "{unicode_all}");
14794         else if (ANYOF_NONBITMAP(o))
14795             sv_catpvs(sv, "{unicode}");
14796         if (flags & ANYOF_NONBITMAP_NON_UTF8)
14797             sv_catpvs(sv, "{outside bitmap}");
14798
14799         if (ANYOF_NONBITMAP(o)) {
14800             SV *lv; /* Set if there is something outside the bit map */
14801             SV * const sw = regclass_swash(prog, o, FALSE, &lv, NULL);
14802             bool byte_output = FALSE;   /* If something in the bitmap has been
14803                                            output */
14804
14805             if (lv && lv != &PL_sv_undef) {
14806                 if (sw) {
14807                     U8 s[UTF8_MAXBYTES_CASE+1];
14808
14809                     for (i = 0; i <= 256; i++) { /* Look at chars in bitmap */
14810                         uvchr_to_utf8(s, i);
14811
14812                         if (i < 256
14813                             && ! ANYOF_BITMAP_TEST(o, i)    /* Don't duplicate
14814                                                                things already
14815                                                                output as part
14816                                                                of the bitmap */
14817                             && swash_fetch(sw, s, TRUE))
14818                         {
14819                             if (rangestart == -1)
14820                                 rangestart = i;
14821                         } else if (rangestart != -1) {
14822                             byte_output = TRUE;
14823                             if (i <= rangestart + 3)
14824                                 for (; rangestart < i; rangestart++) {
14825                                     put_byte(sv, rangestart);
14826                                 }
14827                             else {
14828                                 put_byte(sv, rangestart);
14829                                 sv_catpvs(sv, "-");
14830                                 put_byte(sv, i-1);
14831                             }
14832                             rangestart = -1;
14833                         }
14834                     }
14835                 }
14836
14837                 {
14838                     char *s = savesvpv(lv);
14839                     char * const origs = s;
14840
14841                     while (*s && *s != '\n')
14842                         s++;
14843
14844                     if (*s == '\n') {
14845                         const char * const t = ++s;
14846
14847                         if (byte_output) {
14848                             sv_catpvs(sv, " ");
14849                         }
14850
14851                         while (*s) {
14852                             if (*s == '\n') {
14853
14854                                 /* Truncate very long output */
14855                                 if (s - origs > 256) {
14856                                     Perl_sv_catpvf(aTHX_ sv,
14857                                                    "%.*s...",
14858                                                    (int) (s - origs - 1),
14859                                                    t);
14860                                     goto out_dump;
14861                                 }
14862                                 *s = ' ';
14863                             }
14864                             else if (*s == '\t') {
14865                                 *s = '-';
14866                             }
14867                             s++;
14868                         }
14869                         if (s[-1] == ' ')
14870                             s[-1] = 0;
14871
14872                         sv_catpv(sv, t);
14873                     }
14874
14875                 out_dump:
14876
14877                     Safefree(origs);
14878                 }
14879                 SvREFCNT_dec_NN(lv);
14880             }
14881         }
14882
14883         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
14884     }
14885     else if (k == POSIXD || k == NPOSIXD) {
14886         U8 index = FLAGS(o) * 2;
14887         if (index > (sizeof(anyofs) / sizeof(anyofs[0]))) {
14888             Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
14889         }
14890         else {
14891             sv_catpv(sv, anyofs[index]);
14892         }
14893     }
14894     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
14895         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
14896 #else
14897     PERL_UNUSED_CONTEXT;
14898     PERL_UNUSED_ARG(sv);
14899     PERL_UNUSED_ARG(o);
14900     PERL_UNUSED_ARG(prog);
14901 #endif  /* DEBUGGING */
14902 }
14903
14904 SV *
14905 Perl_re_intuit_string(pTHX_ REGEXP * const r)
14906 {                               /* Assume that RE_INTUIT is set */
14907     dVAR;
14908     struct regexp *const prog = ReANY(r);
14909     GET_RE_DEBUG_FLAGS_DECL;
14910
14911     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
14912     PERL_UNUSED_CONTEXT;
14913
14914     DEBUG_COMPILE_r(
14915         {
14916             const char * const s = SvPV_nolen_const(prog->check_substr
14917                       ? prog->check_substr : prog->check_utf8);
14918
14919             if (!PL_colorset) reginitcolors();
14920             PerlIO_printf(Perl_debug_log,
14921                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
14922                       PL_colors[4],
14923                       prog->check_substr ? "" : "utf8 ",
14924                       PL_colors[5],PL_colors[0],
14925                       s,
14926                       PL_colors[1],
14927                       (strlen(s) > 60 ? "..." : ""));
14928         } );
14929
14930     return prog->check_substr ? prog->check_substr : prog->check_utf8;
14931 }
14932
14933 /* 
14934    pregfree() 
14935    
14936    handles refcounting and freeing the perl core regexp structure. When 
14937    it is necessary to actually free the structure the first thing it 
14938    does is call the 'free' method of the regexp_engine associated to
14939    the regexp, allowing the handling of the void *pprivate; member 
14940    first. (This routine is not overridable by extensions, which is why 
14941    the extensions free is called first.)
14942    
14943    See regdupe and regdupe_internal if you change anything here. 
14944 */
14945 #ifndef PERL_IN_XSUB_RE
14946 void
14947 Perl_pregfree(pTHX_ REGEXP *r)
14948 {
14949     SvREFCNT_dec(r);
14950 }
14951
14952 void
14953 Perl_pregfree2(pTHX_ REGEXP *rx)
14954 {
14955     dVAR;
14956     struct regexp *const r = ReANY(rx);
14957     GET_RE_DEBUG_FLAGS_DECL;
14958
14959     PERL_ARGS_ASSERT_PREGFREE2;
14960
14961     if (r->mother_re) {
14962         ReREFCNT_dec(r->mother_re);
14963     } else {
14964         CALLREGFREE_PVT(rx); /* free the private data */
14965         SvREFCNT_dec(RXp_PAREN_NAMES(r));
14966         Safefree(r->xpv_len_u.xpvlenu_pv);
14967     }        
14968     if (r->substrs) {
14969         SvREFCNT_dec(r->anchored_substr);
14970         SvREFCNT_dec(r->anchored_utf8);
14971         SvREFCNT_dec(r->float_substr);
14972         SvREFCNT_dec(r->float_utf8);
14973         Safefree(r->substrs);
14974     }
14975     RX_MATCH_COPY_FREE(rx);
14976 #ifdef PERL_ANY_COW
14977     SvREFCNT_dec(r->saved_copy);
14978 #endif
14979     Safefree(r->offs);
14980     SvREFCNT_dec(r->qr_anoncv);
14981     rx->sv_u.svu_rx = 0;
14982 }
14983
14984 /*  reg_temp_copy()
14985     
14986     This is a hacky workaround to the structural issue of match results
14987     being stored in the regexp structure which is in turn stored in
14988     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
14989     could be PL_curpm in multiple contexts, and could require multiple
14990     result sets being associated with the pattern simultaneously, such
14991     as when doing a recursive match with (??{$qr})
14992     
14993     The solution is to make a lightweight copy of the regexp structure 
14994     when a qr// is returned from the code executed by (??{$qr}) this
14995     lightweight copy doesn't actually own any of its data except for
14996     the starp/end and the actual regexp structure itself. 
14997     
14998 */    
14999     
15000     
15001 REGEXP *
15002 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
15003 {
15004     struct regexp *ret;
15005     struct regexp *const r = ReANY(rx);
15006     const bool islv = ret_x && SvTYPE(ret_x) == SVt_PVLV;
15007
15008     PERL_ARGS_ASSERT_REG_TEMP_COPY;
15009
15010     if (!ret_x)
15011         ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
15012     else {
15013         SvOK_off((SV *)ret_x);
15014         if (islv) {
15015             /* For PVLVs, SvANY points to the xpvlv body while sv_u points
15016                to the regexp.  (For SVt_REGEXPs, sv_upgrade has already
15017                made both spots point to the same regexp body.) */
15018             REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
15019             assert(!SvPVX(ret_x));
15020             ret_x->sv_u.svu_rx = temp->sv_any;
15021             temp->sv_any = NULL;
15022             SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
15023             SvREFCNT_dec_NN(temp);
15024             /* SvCUR still resides in the xpvlv struct, so the regexp copy-
15025                ing below will not set it. */
15026             SvCUR_set(ret_x, SvCUR(rx));
15027         }
15028     }
15029     /* This ensures that SvTHINKFIRST(sv) is true, and hence that
15030        sv_force_normal(sv) is called.  */
15031     SvFAKE_on(ret_x);
15032     ret = ReANY(ret_x);
15033     
15034     SvFLAGS(ret_x) |= SvUTF8(rx);
15035     /* We share the same string buffer as the original regexp, on which we
15036        hold a reference count, incremented when mother_re is set below.
15037        The string pointer is copied here, being part of the regexp struct.
15038      */
15039     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
15040            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
15041     if (r->offs) {
15042         const I32 npar = r->nparens+1;
15043         Newx(ret->offs, npar, regexp_paren_pair);
15044         Copy(r->offs, ret->offs, npar, regexp_paren_pair);
15045     }
15046     if (r->substrs) {
15047         Newx(ret->substrs, 1, struct reg_substr_data);
15048         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
15049
15050         SvREFCNT_inc_void(ret->anchored_substr);
15051         SvREFCNT_inc_void(ret->anchored_utf8);
15052         SvREFCNT_inc_void(ret->float_substr);
15053         SvREFCNT_inc_void(ret->float_utf8);
15054
15055         /* check_substr and check_utf8, if non-NULL, point to either their
15056            anchored or float namesakes, and don't hold a second reference.  */
15057     }
15058     RX_MATCH_COPIED_off(ret_x);
15059 #ifdef PERL_ANY_COW
15060     ret->saved_copy = NULL;
15061 #endif
15062     ret->mother_re = ReREFCNT_inc(r->mother_re ? r->mother_re : rx);
15063     SvREFCNT_inc_void(ret->qr_anoncv);
15064     
15065     return ret_x;
15066 }
15067 #endif
15068
15069 /* regfree_internal() 
15070
15071    Free the private data in a regexp. This is overloadable by 
15072    extensions. Perl takes care of the regexp structure in pregfree(), 
15073    this covers the *pprivate pointer which technically perl doesn't 
15074    know about, however of course we have to handle the 
15075    regexp_internal structure when no extension is in use. 
15076    
15077    Note this is called before freeing anything in the regexp 
15078    structure. 
15079  */
15080  
15081 void
15082 Perl_regfree_internal(pTHX_ REGEXP * const rx)
15083 {
15084     dVAR;
15085     struct regexp *const r = ReANY(rx);
15086     RXi_GET_DECL(r,ri);
15087     GET_RE_DEBUG_FLAGS_DECL;
15088
15089     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
15090
15091     DEBUG_COMPILE_r({
15092         if (!PL_colorset)
15093             reginitcolors();
15094         {
15095             SV *dsv= sv_newmortal();
15096             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
15097                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
15098             PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n", 
15099                 PL_colors[4],PL_colors[5],s);
15100         }
15101     });
15102 #ifdef RE_TRACK_PATTERN_OFFSETS
15103     if (ri->u.offsets)
15104         Safefree(ri->u.offsets);             /* 20010421 MJD */
15105 #endif
15106     if (ri->code_blocks) {
15107         int n;
15108         for (n = 0; n < ri->num_code_blocks; n++)
15109             SvREFCNT_dec(ri->code_blocks[n].src_regex);
15110         Safefree(ri->code_blocks);
15111     }
15112
15113     if (ri->data) {
15114         int n = ri->data->count;
15115
15116         while (--n >= 0) {
15117           /* If you add a ->what type here, update the comment in regcomp.h */
15118             switch (ri->data->what[n]) {
15119             case 'a':
15120             case 'r':
15121             case 's':
15122             case 'S':
15123             case 'u':
15124                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
15125                 break;
15126             case 'f':
15127                 Safefree(ri->data->data[n]);
15128                 break;
15129             case 'l':
15130             case 'L':
15131                 break;
15132             case 'T':           
15133                 { /* Aho Corasick add-on structure for a trie node.
15134                      Used in stclass optimization only */
15135                     U32 refcount;
15136                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
15137                     OP_REFCNT_LOCK;
15138                     refcount = --aho->refcount;
15139                     OP_REFCNT_UNLOCK;
15140                     if ( !refcount ) {
15141                         PerlMemShared_free(aho->states);
15142                         PerlMemShared_free(aho->fail);
15143                          /* do this last!!!! */
15144                         PerlMemShared_free(ri->data->data[n]);
15145                         PerlMemShared_free(ri->regstclass);
15146                     }
15147                 }
15148                 break;
15149             case 't':
15150                 {
15151                     /* trie structure. */
15152                     U32 refcount;
15153                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
15154                     OP_REFCNT_LOCK;
15155                     refcount = --trie->refcount;
15156                     OP_REFCNT_UNLOCK;
15157                     if ( !refcount ) {
15158                         PerlMemShared_free(trie->charmap);
15159                         PerlMemShared_free(trie->states);
15160                         PerlMemShared_free(trie->trans);
15161                         if (trie->bitmap)
15162                             PerlMemShared_free(trie->bitmap);
15163                         if (trie->jump)
15164                             PerlMemShared_free(trie->jump);
15165                         PerlMemShared_free(trie->wordinfo);
15166                         /* do this last!!!! */
15167                         PerlMemShared_free(ri->data->data[n]);
15168                     }
15169                 }
15170                 break;
15171             default:
15172                 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
15173             }
15174         }
15175         Safefree(ri->data->what);
15176         Safefree(ri->data);
15177     }
15178
15179     Safefree(ri);
15180 }
15181
15182 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
15183 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
15184 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
15185
15186 /* 
15187    re_dup - duplicate a regexp. 
15188    
15189    This routine is expected to clone a given regexp structure. It is only
15190    compiled under USE_ITHREADS.
15191
15192    After all of the core data stored in struct regexp is duplicated
15193    the regexp_engine.dupe method is used to copy any private data
15194    stored in the *pprivate pointer. This allows extensions to handle
15195    any duplication it needs to do.
15196
15197    See pregfree() and regfree_internal() if you change anything here. 
15198 */
15199 #if defined(USE_ITHREADS)
15200 #ifndef PERL_IN_XSUB_RE
15201 void
15202 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
15203 {
15204     dVAR;
15205     I32 npar;
15206     const struct regexp *r = ReANY(sstr);
15207     struct regexp *ret = ReANY(dstr);
15208     
15209     PERL_ARGS_ASSERT_RE_DUP_GUTS;
15210
15211     npar = r->nparens+1;
15212     Newx(ret->offs, npar, regexp_paren_pair);
15213     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
15214
15215     if (ret->substrs) {
15216         /* Do it this way to avoid reading from *r after the StructCopy().
15217            That way, if any of the sv_dup_inc()s dislodge *r from the L1
15218            cache, it doesn't matter.  */
15219         const bool anchored = r->check_substr
15220             ? r->check_substr == r->anchored_substr
15221             : r->check_utf8 == r->anchored_utf8;
15222         Newx(ret->substrs, 1, struct reg_substr_data);
15223         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
15224
15225         ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
15226         ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
15227         ret->float_substr = sv_dup_inc(ret->float_substr, param);
15228         ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
15229
15230         /* check_substr and check_utf8, if non-NULL, point to either their
15231            anchored or float namesakes, and don't hold a second reference.  */
15232
15233         if (ret->check_substr) {
15234             if (anchored) {
15235                 assert(r->check_utf8 == r->anchored_utf8);
15236                 ret->check_substr = ret->anchored_substr;
15237                 ret->check_utf8 = ret->anchored_utf8;
15238             } else {
15239                 assert(r->check_substr == r->float_substr);
15240                 assert(r->check_utf8 == r->float_utf8);
15241                 ret->check_substr = ret->float_substr;
15242                 ret->check_utf8 = ret->float_utf8;
15243             }
15244         } else if (ret->check_utf8) {
15245             if (anchored) {
15246                 ret->check_utf8 = ret->anchored_utf8;
15247             } else {
15248                 ret->check_utf8 = ret->float_utf8;
15249             }
15250         }
15251     }
15252
15253     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
15254     ret->qr_anoncv = MUTABLE_CV(sv_dup_inc((const SV *)ret->qr_anoncv, param));
15255
15256     if (ret->pprivate)
15257         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
15258
15259     if (RX_MATCH_COPIED(dstr))
15260         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
15261     else
15262         ret->subbeg = NULL;
15263 #ifdef PERL_ANY_COW
15264     ret->saved_copy = NULL;
15265 #endif
15266
15267     /* Whether mother_re be set or no, we need to copy the string.  We
15268        cannot refrain from copying it when the storage points directly to
15269        our mother regexp, because that's
15270                1: a buffer in a different thread
15271                2: something we no longer hold a reference on
15272                so we need to copy it locally.  */
15273     RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED(sstr), SvCUR(sstr)+1);
15274     ret->mother_re   = NULL;
15275     ret->gofs = 0;
15276 }
15277 #endif /* PERL_IN_XSUB_RE */
15278
15279 /*
15280    regdupe_internal()
15281    
15282    This is the internal complement to regdupe() which is used to copy
15283    the structure pointed to by the *pprivate pointer in the regexp.
15284    This is the core version of the extension overridable cloning hook.
15285    The regexp structure being duplicated will be copied by perl prior
15286    to this and will be provided as the regexp *r argument, however 
15287    with the /old/ structures pprivate pointer value. Thus this routine
15288    may override any copying normally done by perl.
15289    
15290    It returns a pointer to the new regexp_internal structure.
15291 */
15292
15293 void *
15294 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
15295 {
15296     dVAR;
15297     struct regexp *const r = ReANY(rx);
15298     regexp_internal *reti;
15299     int len;
15300     RXi_GET_DECL(r,ri);
15301
15302     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
15303     
15304     len = ProgLen(ri);
15305     
15306     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), char, regexp_internal);
15307     Copy(ri->program, reti->program, len+1, regnode);
15308
15309     reti->num_code_blocks = ri->num_code_blocks;
15310     if (ri->code_blocks) {
15311         int n;
15312         Newxc(reti->code_blocks, ri->num_code_blocks, struct reg_code_block,
15313                 struct reg_code_block);
15314         Copy(ri->code_blocks, reti->code_blocks, ri->num_code_blocks,
15315                 struct reg_code_block);
15316         for (n = 0; n < ri->num_code_blocks; n++)
15317              reti->code_blocks[n].src_regex = (REGEXP*)
15318                     sv_dup_inc((SV*)(ri->code_blocks[n].src_regex), param);
15319     }
15320     else
15321         reti->code_blocks = NULL;
15322
15323     reti->regstclass = NULL;
15324
15325     if (ri->data) {
15326         struct reg_data *d;
15327         const int count = ri->data->count;
15328         int i;
15329
15330         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
15331                 char, struct reg_data);
15332         Newx(d->what, count, U8);
15333
15334         d->count = count;
15335         for (i = 0; i < count; i++) {
15336             d->what[i] = ri->data->what[i];
15337             switch (d->what[i]) {
15338                 /* see also regcomp.h and regfree_internal() */
15339             case 'a': /* actually an AV, but the dup function is identical.  */
15340             case 'r':
15341             case 's':
15342             case 'S':
15343             case 'u': /* actually an HV, but the dup function is identical.  */
15344                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
15345                 break;
15346             case 'f':
15347                 /* This is cheating. */
15348                 Newx(d->data[i], 1, struct regnode_charclass_class);
15349                 StructCopy(ri->data->data[i], d->data[i],
15350                             struct regnode_charclass_class);
15351                 reti->regstclass = (regnode*)d->data[i];
15352                 break;
15353             case 'T':
15354                 /* Trie stclasses are readonly and can thus be shared
15355                  * without duplication. We free the stclass in pregfree
15356                  * when the corresponding reg_ac_data struct is freed.
15357                  */
15358                 reti->regstclass= ri->regstclass;
15359                 /* Fall through */
15360             case 't':
15361                 OP_REFCNT_LOCK;
15362                 ((reg_trie_data*)ri->data->data[i])->refcount++;
15363                 OP_REFCNT_UNLOCK;
15364                 /* Fall through */
15365             case 'l':
15366             case 'L':
15367                 d->data[i] = ri->data->data[i];
15368                 break;
15369             default:
15370                 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
15371             }
15372         }
15373
15374         reti->data = d;
15375     }
15376     else
15377         reti->data = NULL;
15378
15379     reti->name_list_idx = ri->name_list_idx;
15380
15381 #ifdef RE_TRACK_PATTERN_OFFSETS
15382     if (ri->u.offsets) {
15383         Newx(reti->u.offsets, 2*len+1, U32);
15384         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
15385     }
15386 #else
15387     SetProgLen(reti,len);
15388 #endif
15389
15390     return (void*)reti;
15391 }
15392
15393 #endif    /* USE_ITHREADS */
15394
15395 #ifndef PERL_IN_XSUB_RE
15396
15397 /*
15398  - regnext - dig the "next" pointer out of a node
15399  */
15400 regnode *
15401 Perl_regnext(pTHX_ regnode *p)
15402 {
15403     dVAR;
15404     I32 offset;
15405
15406     if (!p)
15407         return(NULL);
15408
15409     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
15410         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(p), (int)REGNODE_MAX);
15411     }
15412
15413     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
15414     if (offset == 0)
15415         return(NULL);
15416
15417     return(p+offset);
15418 }
15419 #endif
15420
15421 STATIC void
15422 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
15423 {
15424     va_list args;
15425     STRLEN l1 = strlen(pat1);
15426     STRLEN l2 = strlen(pat2);
15427     char buf[512];
15428     SV *msv;
15429     const char *message;
15430
15431     PERL_ARGS_ASSERT_RE_CROAK2;
15432
15433     if (l1 > 510)
15434         l1 = 510;
15435     if (l1 + l2 > 510)
15436         l2 = 510 - l1;
15437     Copy(pat1, buf, l1 , char);
15438     Copy(pat2, buf + l1, l2 , char);
15439     buf[l1 + l2] = '\n';
15440     buf[l1 + l2 + 1] = '\0';
15441 #ifdef I_STDARG
15442     /* ANSI variant takes additional second argument */
15443     va_start(args, pat2);
15444 #else
15445     va_start(args);
15446 #endif
15447     msv = vmess(buf, &args);
15448     va_end(args);
15449     message = SvPV_const(msv,l1);
15450     if (l1 > 512)
15451         l1 = 512;
15452     Copy(message, buf, l1 , char);
15453     buf[l1-1] = '\0';                   /* Overwrite \n */
15454     Perl_croak(aTHX_ "%s", buf);
15455 }
15456
15457 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
15458
15459 #ifndef PERL_IN_XSUB_RE
15460 void
15461 Perl_save_re_context(pTHX)
15462 {
15463     dVAR;
15464
15465     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
15466     if (PL_curpm) {
15467         const REGEXP * const rx = PM_GETRE(PL_curpm);
15468         if (rx) {
15469             U32 i;
15470             for (i = 1; i <= RX_NPARENS(rx); i++) {
15471                 char digits[TYPE_CHARS(long)];
15472                 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
15473                 GV *const *const gvp
15474                     = (GV**)hv_fetch(PL_defstash, digits, len, 0);
15475
15476                 if (gvp) {
15477                     GV * const gv = *gvp;
15478                     if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
15479                         save_scalar(gv);
15480                 }
15481             }
15482         }
15483     }
15484 }
15485 #endif
15486
15487 #ifdef DEBUGGING
15488
15489 STATIC void
15490 S_put_byte(pTHX_ SV *sv, int c)
15491 {
15492     PERL_ARGS_ASSERT_PUT_BYTE;
15493
15494     /* Our definition of isPRINT() ignores locales, so only bytes that are
15495        not part of UTF-8 are considered printable. I assume that the same
15496        holds for UTF-EBCDIC.
15497        Also, code point 255 is not printable in either (it's E0 in EBCDIC,
15498        which Wikipedia says:
15499
15500        EO, or Eight Ones, is an 8-bit EBCDIC character code represented as all
15501        ones (binary 1111 1111, hexadecimal FF). It is similar, but not
15502        identical, to the ASCII delete (DEL) or rubout control character. ...
15503        it is typically mapped to hexadecimal code 9F, in order to provide a
15504        unique character mapping in both directions)
15505
15506        So the old condition can be simplified to !isPRINT(c)  */
15507     if (!isPRINT(c)) {
15508         if (c < 256) {
15509             Perl_sv_catpvf(aTHX_ sv, "\\x%02x", c);
15510         }
15511         else {
15512             Perl_sv_catpvf(aTHX_ sv, "\\x{%x}", c);
15513         }
15514     }
15515     else {
15516         const char string = c;
15517         if (c == '-' || c == ']' || c == '\\' || c == '^')
15518             sv_catpvs(sv, "\\");
15519         sv_catpvn(sv, &string, 1);
15520     }
15521 }
15522
15523
15524 #define CLEAR_OPTSTART \
15525     if (optstart) STMT_START { \
15526             DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
15527             optstart=NULL; \
15528     } STMT_END
15529
15530 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
15531
15532 STATIC const regnode *
15533 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
15534             const regnode *last, const regnode *plast, 
15535             SV* sv, I32 indent, U32 depth)
15536 {
15537     dVAR;
15538     U8 op = PSEUDO;     /* Arbitrary non-END op. */
15539     const regnode *next;
15540     const regnode *optstart= NULL;
15541     
15542     RXi_GET_DECL(r,ri);
15543     GET_RE_DEBUG_FLAGS_DECL;
15544
15545     PERL_ARGS_ASSERT_DUMPUNTIL;
15546
15547 #ifdef DEBUG_DUMPUNTIL
15548     PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
15549         last ? last-start : 0,plast ? plast-start : 0);
15550 #endif
15551             
15552     if (plast && plast < last) 
15553         last= plast;
15554
15555     while (PL_regkind[op] != END && (!last || node < last)) {
15556         /* While that wasn't END last time... */
15557         NODE_ALIGN(node);
15558         op = OP(node);
15559         if (op == CLOSE || op == WHILEM)
15560             indent--;
15561         next = regnext((regnode *)node);
15562
15563         /* Where, what. */
15564         if (OP(node) == OPTIMIZED) {
15565             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
15566                 optstart = node;
15567             else
15568                 goto after_print;
15569         } else
15570             CLEAR_OPTSTART;
15571
15572         regprop(r, sv, node);
15573         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
15574                       (int)(2*indent + 1), "", SvPVX_const(sv));
15575         
15576         if (OP(node) != OPTIMIZED) {                  
15577             if (next == NULL)           /* Next ptr. */
15578                 PerlIO_printf(Perl_debug_log, " (0)");
15579             else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
15580                 PerlIO_printf(Perl_debug_log, " (FAIL)");
15581             else 
15582                 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
15583             (void)PerlIO_putc(Perl_debug_log, '\n'); 
15584         }
15585         
15586       after_print:
15587         if (PL_regkind[(U8)op] == BRANCHJ) {
15588             assert(next);
15589             {
15590                 const regnode *nnode = (OP(next) == LONGJMP
15591                                        ? regnext((regnode *)next)
15592                                        : next);
15593                 if (last && nnode > last)
15594                     nnode = last;
15595                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
15596             }
15597         }
15598         else if (PL_regkind[(U8)op] == BRANCH) {
15599             assert(next);
15600             DUMPUNTIL(NEXTOPER(node), next);
15601         }
15602         else if ( PL_regkind[(U8)op]  == TRIE ) {
15603             const regnode *this_trie = node;
15604             const char op = OP(node);
15605             const U32 n = ARG(node);
15606             const reg_ac_data * const ac = op>=AHOCORASICK ?
15607                (reg_ac_data *)ri->data->data[n] :
15608                NULL;
15609             const reg_trie_data * const trie =
15610                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
15611 #ifdef DEBUGGING
15612             AV *const trie_words = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
15613 #endif
15614             const regnode *nextbranch= NULL;
15615             I32 word_idx;
15616             sv_setpvs(sv, "");
15617             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
15618                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
15619
15620                 PerlIO_printf(Perl_debug_log, "%*s%s ",
15621                    (int)(2*(indent+3)), "",
15622                     elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
15623                             PL_colors[0], PL_colors[1],
15624                             (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
15625                             PERL_PV_PRETTY_ELLIPSES    |
15626                             PERL_PV_PRETTY_LTGT
15627                             )
15628                             : "???"
15629                 );
15630                 if (trie->jump) {
15631                     U16 dist= trie->jump[word_idx+1];
15632                     PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
15633                                   (UV)((dist ? this_trie + dist : next) - start));
15634                     if (dist) {
15635                         if (!nextbranch)
15636                             nextbranch= this_trie + trie->jump[0];    
15637                         DUMPUNTIL(this_trie + dist, nextbranch);
15638                     }
15639                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
15640                         nextbranch= regnext((regnode *)nextbranch);
15641                 } else {
15642                     PerlIO_printf(Perl_debug_log, "\n");
15643                 }
15644             }
15645             if (last && next > last)
15646                 node= last;
15647             else
15648                 node= next;
15649         }
15650         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
15651             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
15652                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
15653         }
15654         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
15655             assert(next);
15656             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
15657         }
15658         else if ( op == PLUS || op == STAR) {
15659             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
15660         }
15661         else if (PL_regkind[(U8)op] == ANYOF) {
15662             /* arglen 1 + class block */
15663             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_CLASS)
15664                     ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
15665             node = NEXTOPER(node);
15666         }
15667         else if (PL_regkind[(U8)op] == EXACT) {
15668             /* Literal string, where present. */
15669             node += NODE_SZ_STR(node) - 1;
15670             node = NEXTOPER(node);
15671         }
15672         else {
15673             node = NEXTOPER(node);
15674             node += regarglen[(U8)op];
15675         }
15676         if (op == CURLYX || op == OPEN)
15677             indent++;
15678     }
15679     CLEAR_OPTSTART;
15680 #ifdef DEBUG_DUMPUNTIL    
15681     PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
15682 #endif
15683     return node;
15684 }
15685
15686 #endif  /* DEBUGGING */
15687
15688 /*
15689  * Local variables:
15690  * c-indentation-style: bsd
15691  * c-basic-offset: 4
15692  * indent-tabs-mode: nil
15693  * End:
15694  *
15695  * ex: set ts=8 sts=4 sw=4 et:
15696  */