This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Perl_re_op_compile(): eliminate xend var
[perl5.git] / regcomp.c
1 /*    regcomp.c
2  */
3
4 /*
5  * 'A fair jaw-cracker dwarf-language must be.'            --Samwise Gamgee
6  *
7  *     [p.285 of _The Lord of the Rings_, II/iii: "The Ring Goes South"]
8  */
9
10 /* This file contains functions for compiling a regular expression.  See
11  * also regexec.c which funnily enough, contains functions for executing
12  * a regular expression.
13  *
14  * This file is also copied at build time to ext/re/re_comp.c, where
15  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
16  * This causes the main functions to be compiled under new names and with
17  * debugging support added, which makes "use re 'debug'" work.
18  */
19
20 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
21  * confused with the original package (see point 3 below).  Thanks, Henry!
22  */
23
24 /* Additional note: this code is very heavily munged from Henry's version
25  * in places.  In some spots I've traded clarity for efficiency, so don't
26  * blame Henry for some of the lack of readability.
27  */
28
29 /* The names of the functions have been changed from regcomp and
30  * regexec to pregcomp and pregexec in order to avoid conflicts
31  * with the POSIX routines of the same names.
32 */
33
34 #ifdef PERL_EXT_RE_BUILD
35 #include "re_top.h"
36 #endif
37
38 /*
39  * pregcomp and pregexec -- regsub and regerror are not used in perl
40  *
41  *      Copyright (c) 1986 by University of Toronto.
42  *      Written by Henry Spencer.  Not derived from licensed software.
43  *
44  *      Permission is granted to anyone to use this software for any
45  *      purpose on any computer system, and to redistribute it freely,
46  *      subject to the following restrictions:
47  *
48  *      1. The author is not responsible for the consequences of use of
49  *              this software, no matter how awful, even if they arise
50  *              from defects in it.
51  *
52  *      2. The origin of this software must not be misrepresented, either
53  *              by explicit claim or by omission.
54  *
55  *      3. Altered versions must be plainly marked as such, and must not
56  *              be misrepresented as being the original software.
57  *
58  *
59  ****    Alterations to Henry's code are...
60  ****
61  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
62  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
63  ****    by Larry Wall and others
64  ****
65  ****    You may distribute under the terms of either the GNU General Public
66  ****    License or the Artistic License, as specified in the README file.
67
68  *
69  * Beware that some of this code is subtly aware of the way operator
70  * precedence is structured in regular expressions.  Serious changes in
71  * regular-expression syntax might require a total rethink.
72  */
73 #include "EXTERN.h"
74 #define PERL_IN_REGCOMP_C
75 #include "perl.h"
76
77 #ifndef PERL_IN_XSUB_RE
78 #  include "INTERN.h"
79 #endif
80
81 #define REG_COMP_C
82 #ifdef PERL_IN_XSUB_RE
83 #  include "re_comp.h"
84 extern const struct regexp_engine my_reg_engine;
85 #else
86 #  include "regcomp.h"
87 #endif
88
89 #include "dquote_static.c"
90 #include "charclass_invlists.h"
91 #include "inline_invlist.c"
92 #include "unicode_constants.h"
93
94 #define HAS_NONLATIN1_FOLD_CLOSURE(i) _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
95 #define IS_NON_FINAL_FOLD(c) _IS_NON_FINAL_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
96 #define IS_IN_SOME_FOLD_L1(c) _IS_IN_SOME_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
97
98 #ifdef op
99 #undef op
100 #endif /* op */
101
102 #ifdef MSDOS
103 #  if defined(BUGGY_MSC6)
104  /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
105 #    pragma optimize("a",off)
106  /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
107 #    pragma optimize("w",on )
108 #  endif /* BUGGY_MSC6 */
109 #endif /* MSDOS */
110
111 #ifndef STATIC
112 #define STATIC  static
113 #endif
114
115
116 typedef struct RExC_state_t {
117     U32         flags;                  /* RXf_* are we folding, multilining? */
118     U32         pm_flags;               /* PMf_* stuff from the calling PMOP */
119     char        *precomp;               /* uncompiled string. */
120     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
121     regexp      *rx;                    /* perl core regexp structure */
122     regexp_internal     *rxi;           /* internal data for regexp object pprivate field */        
123     char        *start;                 /* Start of input for compile */
124     char        *end;                   /* End of input for compile */
125     char        *parse;                 /* Input-scan pointer. */
126     I32         whilem_seen;            /* number of WHILEM in this expr */
127     regnode     *emit_start;            /* Start of emitted-code area */
128     regnode     *emit_bound;            /* First regnode outside of the allocated space */
129     regnode     *emit;                  /* Code-emit pointer; &regdummy = don't = compiling */
130     I32         naughty;                /* How bad is this pattern? */
131     I32         sawback;                /* Did we see \1, ...? */
132     U32         seen;
133     I32         size;                   /* Code size. */
134     I32         npar;                   /* Capture buffer count, (OPEN). */
135     I32         cpar;                   /* Capture buffer count, (CLOSE). */
136     I32         nestroot;               /* root parens we are in - used by accept */
137     I32         extralen;
138     I32         seen_zerolen;
139     regnode     **open_parens;          /* pointers to open parens */
140     regnode     **close_parens;         /* pointers to close parens */
141     regnode     *opend;                 /* END node in program */
142     I32         utf8;           /* whether the pattern is utf8 or not */
143     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
144                                 /* XXX use this for future optimisation of case
145                                  * where pattern must be upgraded to utf8. */
146     I32         uni_semantics;  /* If a d charset modifier should use unicode
147                                    rules, even if the pattern is not in
148                                    utf8 */
149     HV          *paren_names;           /* Paren names */
150     
151     regnode     **recurse;              /* Recurse regops */
152     I32         recurse_count;          /* Number of recurse regops */
153     I32         in_lookbehind;
154     I32         contains_locale;
155     I32         override_recoding;
156     I32         in_multi_char_class;
157     struct reg_code_block *code_blocks; /* positions of literal (?{})
158                                             within pattern */
159     int         num_code_blocks;        /* size of code_blocks[] */
160     int         code_index;             /* next code_blocks[] slot */
161 #if ADD_TO_REGEXEC
162     char        *starttry;              /* -Dr: where regtry was called. */
163 #define RExC_starttry   (pRExC_state->starttry)
164 #endif
165     SV          *runtime_code_qr;       /* qr with the runtime code blocks */
166 #ifdef DEBUGGING
167     const char  *lastparse;
168     I32         lastnum;
169     AV          *paren_name_list;       /* idx -> name */
170 #define RExC_lastparse  (pRExC_state->lastparse)
171 #define RExC_lastnum    (pRExC_state->lastnum)
172 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
173 #endif
174 } RExC_state_t;
175
176 #define RExC_flags      (pRExC_state->flags)
177 #define RExC_pm_flags   (pRExC_state->pm_flags)
178 #define RExC_precomp    (pRExC_state->precomp)
179 #define RExC_rx_sv      (pRExC_state->rx_sv)
180 #define RExC_rx         (pRExC_state->rx)
181 #define RExC_rxi        (pRExC_state->rxi)
182 #define RExC_start      (pRExC_state->start)
183 #define RExC_end        (pRExC_state->end)
184 #define RExC_parse      (pRExC_state->parse)
185 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
186 #ifdef RE_TRACK_PATTERN_OFFSETS
187 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the others */
188 #endif
189 #define RExC_emit       (pRExC_state->emit)
190 #define RExC_emit_start (pRExC_state->emit_start)
191 #define RExC_emit_bound (pRExC_state->emit_bound)
192 #define RExC_naughty    (pRExC_state->naughty)
193 #define RExC_sawback    (pRExC_state->sawback)
194 #define RExC_seen       (pRExC_state->seen)
195 #define RExC_size       (pRExC_state->size)
196 #define RExC_npar       (pRExC_state->npar)
197 #define RExC_nestroot   (pRExC_state->nestroot)
198 #define RExC_extralen   (pRExC_state->extralen)
199 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
200 #define RExC_utf8       (pRExC_state->utf8)
201 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
202 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
203 #define RExC_open_parens        (pRExC_state->open_parens)
204 #define RExC_close_parens       (pRExC_state->close_parens)
205 #define RExC_opend      (pRExC_state->opend)
206 #define RExC_paren_names        (pRExC_state->paren_names)
207 #define RExC_recurse    (pRExC_state->recurse)
208 #define RExC_recurse_count      (pRExC_state->recurse_count)
209 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
210 #define RExC_contains_locale    (pRExC_state->contains_locale)
211 #define RExC_override_recoding (pRExC_state->override_recoding)
212 #define RExC_in_multi_char_class (pRExC_state->in_multi_char_class)
213
214
215 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
216 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
217         ((*s) == '{' && regcurly(s, FALSE)))
218
219 #ifdef SPSTART
220 #undef SPSTART          /* dratted cpp namespace... */
221 #endif
222 /*
223  * Flags to be passed up and down.
224  */
225 #define WORST           0       /* Worst case. */
226 #define HASWIDTH        0x01    /* Known to match non-null strings. */
227
228 /* Simple enough to be STAR/PLUS operand; in an EXACTish node must be a single
229  * character.  (There needs to be a case: in the switch statement in regexec.c
230  * for any node marked SIMPLE.)  Note that this is not the same thing as
231  * REGNODE_SIMPLE */
232 #define SIMPLE          0x02
233 #define SPSTART         0x04    /* Starts with * or + */
234 #define POSTPONED       0x08    /* (?1),(?&name), (??{...}) or similar */
235 #define TRYAGAIN        0x10    /* Weeded out a declaration. */
236 #define RESTART_UTF8    0x20    /* Restart, need to calcuate sizes as UTF-8 */
237
238 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
239
240 /* whether trie related optimizations are enabled */
241 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
242 #define TRIE_STUDY_OPT
243 #define FULL_TRIE_STUDY
244 #define TRIE_STCLASS
245 #endif
246
247
248
249 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
250 #define PBITVAL(paren) (1 << ((paren) & 7))
251 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
252 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
253 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
254
255 #define REQUIRE_UTF8    STMT_START {                                       \
256                                      if (!UTF) {                           \
257                                          *flagp = RESTART_UTF8;            \
258                                          return NULL;                      \
259                                      }                                     \
260                         } STMT_END
261
262 /* This converts the named class defined in regcomp.h to its equivalent class
263  * number defined in handy.h. */
264 #define namedclass_to_classnum(class)  ((int) ((class) / 2))
265 #define classnum_to_namedclass(classnum)  ((classnum) * 2)
266
267 /* About scan_data_t.
268
269   During optimisation we recurse through the regexp program performing
270   various inplace (keyhole style) optimisations. In addition study_chunk
271   and scan_commit populate this data structure with information about
272   what strings MUST appear in the pattern. We look for the longest 
273   string that must appear at a fixed location, and we look for the
274   longest string that may appear at a floating location. So for instance
275   in the pattern:
276   
277     /FOO[xX]A.*B[xX]BAR/
278     
279   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
280   strings (because they follow a .* construct). study_chunk will identify
281   both FOO and BAR as being the longest fixed and floating strings respectively.
282   
283   The strings can be composites, for instance
284   
285      /(f)(o)(o)/
286      
287   will result in a composite fixed substring 'foo'.
288   
289   For each string some basic information is maintained:
290   
291   - offset or min_offset
292     This is the position the string must appear at, or not before.
293     It also implicitly (when combined with minlenp) tells us how many
294     characters must match before the string we are searching for.
295     Likewise when combined with minlenp and the length of the string it
296     tells us how many characters must appear after the string we have 
297     found.
298   
299   - max_offset
300     Only used for floating strings. This is the rightmost point that
301     the string can appear at. If set to I32 max it indicates that the
302     string can occur infinitely far to the right.
303   
304   - minlenp
305     A pointer to the minimum number of characters of the pattern that the
306     string was found inside. This is important as in the case of positive
307     lookahead or positive lookbehind we can have multiple patterns 
308     involved. Consider
309     
310     /(?=FOO).*F/
311     
312     The minimum length of the pattern overall is 3, the minimum length
313     of the lookahead part is 3, but the minimum length of the part that
314     will actually match is 1. So 'FOO's minimum length is 3, but the 
315     minimum length for the F is 1. This is important as the minimum length
316     is used to determine offsets in front of and behind the string being 
317     looked for.  Since strings can be composites this is the length of the
318     pattern at the time it was committed with a scan_commit. Note that
319     the length is calculated by study_chunk, so that the minimum lengths
320     are not known until the full pattern has been compiled, thus the 
321     pointer to the value.
322   
323   - lookbehind
324   
325     In the case of lookbehind the string being searched for can be
326     offset past the start point of the final matching string. 
327     If this value was just blithely removed from the min_offset it would
328     invalidate some of the calculations for how many chars must match
329     before or after (as they are derived from min_offset and minlen and
330     the length of the string being searched for). 
331     When the final pattern is compiled and the data is moved from the
332     scan_data_t structure into the regexp structure the information
333     about lookbehind is factored in, with the information that would 
334     have been lost precalculated in the end_shift field for the 
335     associated string.
336
337   The fields pos_min and pos_delta are used to store the minimum offset
338   and the delta to the maximum offset at the current point in the pattern.    
339
340 */
341
342 typedef struct scan_data_t {
343     /*I32 len_min;      unused */
344     /*I32 len_delta;    unused */
345     I32 pos_min;
346     I32 pos_delta;
347     SV *last_found;
348     I32 last_end;           /* min value, <0 unless valid. */
349     I32 last_start_min;
350     I32 last_start_max;
351     SV **longest;           /* Either &l_fixed, or &l_float. */
352     SV *longest_fixed;      /* longest fixed string found in pattern */
353     I32 offset_fixed;       /* offset where it starts */
354     I32 *minlen_fixed;      /* pointer to the minlen relevant to the string */
355     I32 lookbehind_fixed;   /* is the position of the string modfied by LB */
356     SV *longest_float;      /* longest floating string found in pattern */
357     I32 offset_float_min;   /* earliest point in string it can appear */
358     I32 offset_float_max;   /* latest point in string it can appear */
359     I32 *minlen_float;      /* pointer to the minlen relevant to the string */
360     I32 lookbehind_float;   /* is the position of the string modified by LB */
361     I32 flags;
362     I32 whilem_c;
363     I32 *last_closep;
364     struct regnode_charclass_class *start_class;
365 } scan_data_t;
366
367 /*
368  * Forward declarations for pregcomp()'s friends.
369  */
370
371 static const scan_data_t zero_scan_data =
372   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
373
374 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
375 #define SF_BEFORE_SEOL          0x0001
376 #define SF_BEFORE_MEOL          0x0002
377 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
378 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
379
380 #ifdef NO_UNARY_PLUS
381 #  define SF_FIX_SHIFT_EOL      (0+2)
382 #  define SF_FL_SHIFT_EOL               (0+4)
383 #else
384 #  define SF_FIX_SHIFT_EOL      (+2)
385 #  define SF_FL_SHIFT_EOL               (+4)
386 #endif
387
388 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
389 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
390
391 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
392 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
393 #define SF_IS_INF               0x0040
394 #define SF_HAS_PAR              0x0080
395 #define SF_IN_PAR               0x0100
396 #define SF_HAS_EVAL             0x0200
397 #define SCF_DO_SUBSTR           0x0400
398 #define SCF_DO_STCLASS_AND      0x0800
399 #define SCF_DO_STCLASS_OR       0x1000
400 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
401 #define SCF_WHILEM_VISITED_POS  0x2000
402
403 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
404 #define SCF_SEEN_ACCEPT         0x8000 
405
406 #define UTF cBOOL(RExC_utf8)
407
408 /* The enums for all these are ordered so things work out correctly */
409 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
410 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_DEPENDS_CHARSET)
411 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
412 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags) >= REGEX_UNICODE_CHARSET)
413 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_RESTRICTED_CHARSET)
414 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags) >= REGEX_ASCII_RESTRICTED_CHARSET)
415 #define ASCII_FOLD_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
416
417 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
418
419 #define OOB_NAMEDCLASS          -1
420
421 /* There is no code point that is out-of-bounds, so this is problematic.  But
422  * its only current use is to initialize a variable that is always set before
423  * looked at. */
424 #define OOB_UNICODE             0xDEADBEEF
425
426 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
427 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
428
429
430 /* length of regex to show in messages that don't mark a position within */
431 #define RegexLengthToShowInErrorMessages 127
432
433 /*
434  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
435  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
436  * op/pragma/warn/regcomp.
437  */
438 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
439 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
440
441 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
442
443 /*
444  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
445  * arg. Show regex, up to a maximum length. If it's too long, chop and add
446  * "...".
447  */
448 #define _FAIL(code) STMT_START {                                        \
449     const char *ellipses = "";                                          \
450     IV len = RExC_end - RExC_precomp;                                   \
451                                                                         \
452     if (!SIZE_ONLY)                                                     \
453         SAVEFREESV(RExC_rx_sv);                                         \
454     if (len > RegexLengthToShowInErrorMessages) {                       \
455         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
456         len = RegexLengthToShowInErrorMessages - 10;                    \
457         ellipses = "...";                                               \
458     }                                                                   \
459     code;                                                               \
460 } STMT_END
461
462 #define FAIL(msg) _FAIL(                            \
463     Perl_croak(aTHX_ "%s in regex m/%.*s%s/",       \
464             msg, (int)len, RExC_precomp, ellipses))
465
466 #define FAIL2(msg,arg) _FAIL(                       \
467     Perl_croak(aTHX_ msg " in regex m/%.*s%s/",     \
468             arg, (int)len, RExC_precomp, ellipses))
469
470 /*
471  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
472  */
473 #define Simple_vFAIL(m) STMT_START {                                    \
474     const IV offset = RExC_parse - RExC_precomp;                        \
475     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
476             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
477 } STMT_END
478
479 /*
480  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
481  */
482 #define vFAIL(m) STMT_START {                           \
483     if (!SIZE_ONLY)                                     \
484         SAVEFREESV(RExC_rx_sv);                         \
485     Simple_vFAIL(m);                                    \
486 } STMT_END
487
488 /*
489  * Like Simple_vFAIL(), but accepts two arguments.
490  */
491 #define Simple_vFAIL2(m,a1) STMT_START {                        \
492     const IV offset = RExC_parse - RExC_precomp;                        \
493     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1,                   \
494             (int)offset, RExC_precomp, RExC_precomp + offset);  \
495 } STMT_END
496
497 /*
498  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
499  */
500 #define vFAIL2(m,a1) STMT_START {                       \
501     if (!SIZE_ONLY)                                     \
502         SAVEFREESV(RExC_rx_sv);                         \
503     Simple_vFAIL2(m, a1);                               \
504 } STMT_END
505
506
507 /*
508  * Like Simple_vFAIL(), but accepts three arguments.
509  */
510 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
511     const IV offset = RExC_parse - RExC_precomp;                \
512     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2,               \
513             (int)offset, RExC_precomp, RExC_precomp + offset);  \
514 } STMT_END
515
516 /*
517  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
518  */
519 #define vFAIL3(m,a1,a2) STMT_START {                    \
520     if (!SIZE_ONLY)                                     \
521         SAVEFREESV(RExC_rx_sv);                         \
522     Simple_vFAIL3(m, a1, a2);                           \
523 } STMT_END
524
525 /*
526  * Like Simple_vFAIL(), but accepts four arguments.
527  */
528 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
529     const IV offset = RExC_parse - RExC_precomp;                \
530     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3,           \
531             (int)offset, RExC_precomp, RExC_precomp + offset);  \
532 } STMT_END
533
534 #define vFAIL4(m,a1,a2,a3) STMT_START {                 \
535     if (!SIZE_ONLY)                                     \
536         SAVEFREESV(RExC_rx_sv);                         \
537     Simple_vFAIL4(m, a1, a2, a3);                       \
538 } STMT_END
539
540 /* m is not necessarily a "literal string", in this macro */
541 #define reg_warn_non_literal_string(loc, m) STMT_START {                \
542     const IV offset = loc - RExC_precomp;                               \
543     Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s" REPORT_LOCATION,      \
544             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
545 } STMT_END
546
547 #define ckWARNreg(loc,m) STMT_START {                                   \
548     const IV offset = loc - RExC_precomp;                               \
549     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
550             (int)offset, RExC_precomp, RExC_precomp + offset);          \
551 } STMT_END
552
553 #define vWARN_dep(loc, m) STMT_START {                                  \
554     const IV offset = loc - RExC_precomp;                               \
555     Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), m REPORT_LOCATION,     \
556             (int)offset, RExC_precomp, RExC_precomp + offset);          \
557 } STMT_END
558
559 #define ckWARNdep(loc,m) STMT_START {                                   \
560     const IV offset = loc - RExC_precomp;                               \
561     Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),                   \
562             m REPORT_LOCATION,                                          \
563             (int)offset, RExC_precomp, RExC_precomp + offset);          \
564 } STMT_END
565
566 #define ckWARNregdep(loc,m) STMT_START {                                \
567     const IV offset = loc - RExC_precomp;                               \
568     Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),     \
569             m REPORT_LOCATION,                                          \
570             (int)offset, RExC_precomp, RExC_precomp + offset);          \
571 } STMT_END
572
573 #define ckWARN2regdep(loc,m, a1) STMT_START {                           \
574     const IV offset = loc - RExC_precomp;                               \
575     Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),     \
576             m REPORT_LOCATION,                                          \
577             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
578 } STMT_END
579
580 #define ckWARN2reg(loc, m, a1) STMT_START {                             \
581     const IV offset = loc - RExC_precomp;                               \
582     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
583             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
584 } STMT_END
585
586 #define vWARN3(loc, m, a1, a2) STMT_START {                             \
587     const IV offset = loc - RExC_precomp;                               \
588     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
589             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
590 } STMT_END
591
592 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                         \
593     const IV offset = loc - RExC_precomp;                               \
594     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
595             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
596 } STMT_END
597
598 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
599     const IV offset = loc - RExC_precomp;                               \
600     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
601             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
602 } STMT_END
603
604 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
605     const IV offset = loc - RExC_precomp;                               \
606     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
607             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
608 } STMT_END
609
610 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
611     const IV offset = loc - RExC_precomp;                               \
612     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
613             a1, a2, a3, a4, (int)offset, RExC_precomp, RExC_precomp + offset); \
614 } STMT_END
615
616
617 /* Allow for side effects in s */
618 #define REGC(c,s) STMT_START {                  \
619     if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
620 } STMT_END
621
622 /* Macros for recording node offsets.   20001227 mjd@plover.com 
623  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
624  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
625  * Element 0 holds the number n.
626  * Position is 1 indexed.
627  */
628 #ifndef RE_TRACK_PATTERN_OFFSETS
629 #define Set_Node_Offset_To_R(node,byte)
630 #define Set_Node_Offset(node,byte)
631 #define Set_Cur_Node_Offset
632 #define Set_Node_Length_To_R(node,len)
633 #define Set_Node_Length(node,len)
634 #define Set_Node_Cur_Length(node)
635 #define Node_Offset(n) 
636 #define Node_Length(n) 
637 #define Set_Node_Offset_Length(node,offset,len)
638 #define ProgLen(ri) ri->u.proglen
639 #define SetProgLen(ri,x) ri->u.proglen = x
640 #else
641 #define ProgLen(ri) ri->u.offsets[0]
642 #define SetProgLen(ri,x) ri->u.offsets[0] = x
643 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
644     if (! SIZE_ONLY) {                                                  \
645         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
646                     __LINE__, (int)(node), (int)(byte)));               \
647         if((node) < 0) {                                                \
648             Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \
649         } else {                                                        \
650             RExC_offsets[2*(node)-1] = (byte);                          \
651         }                                                               \
652     }                                                                   \
653 } STMT_END
654
655 #define Set_Node_Offset(node,byte) \
656     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
657 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
658
659 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
660     if (! SIZE_ONLY) {                                                  \
661         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
662                 __LINE__, (int)(node), (int)(len)));                    \
663         if((node) < 0) {                                                \
664             Perl_croak(aTHX_ "value of node is %d in Length macro", (int)(node)); \
665         } else {                                                        \
666             RExC_offsets[2*(node)] = (len);                             \
667         }                                                               \
668     }                                                                   \
669 } STMT_END
670
671 #define Set_Node_Length(node,len) \
672     Set_Node_Length_To_R((node)-RExC_emit_start, len)
673 #define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
674 #define Set_Node_Cur_Length(node) \
675     Set_Node_Length(node, RExC_parse - parse_start)
676
677 /* Get offsets and lengths */
678 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
679 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
680
681 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
682     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
683     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
684 } STMT_END
685 #endif
686
687 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
688 #define EXPERIMENTAL_INPLACESCAN
689 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
690
691 #define DEBUG_STUDYDATA(str,data,depth)                              \
692 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
693     PerlIO_printf(Perl_debug_log,                                    \
694         "%*s" str "Pos:%"IVdf"/%"IVdf                                \
695         " Flags: 0x%"UVXf" Whilem_c: %"IVdf" Lcp: %"IVdf" %s",       \
696         (int)(depth)*2, "",                                          \
697         (IV)((data)->pos_min),                                       \
698         (IV)((data)->pos_delta),                                     \
699         (UV)((data)->flags),                                         \
700         (IV)((data)->whilem_c),                                      \
701         (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
702         is_inf ? "INF " : ""                                         \
703     );                                                               \
704     if ((data)->last_found)                                          \
705         PerlIO_printf(Perl_debug_log,                                \
706             "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
707             " %sFloat: '%s' @ %"IVdf"/%"IVdf"",                      \
708             SvPVX_const((data)->last_found),                         \
709             (IV)((data)->last_end),                                  \
710             (IV)((data)->last_start_min),                            \
711             (IV)((data)->last_start_max),                            \
712             ((data)->longest &&                                      \
713              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
714             SvPVX_const((data)->longest_fixed),                      \
715             (IV)((data)->offset_fixed),                              \
716             ((data)->longest &&                                      \
717              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
718             SvPVX_const((data)->longest_float),                      \
719             (IV)((data)->offset_float_min),                          \
720             (IV)((data)->offset_float_max)                           \
721         );                                                           \
722     PerlIO_printf(Perl_debug_log,"\n");                              \
723 });
724
725 /* Mark that we cannot extend a found fixed substring at this point.
726    Update the longest found anchored substring and the longest found
727    floating substrings if needed. */
728
729 STATIC void
730 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp, int is_inf)
731 {
732     const STRLEN l = CHR_SVLEN(data->last_found);
733     const STRLEN old_l = CHR_SVLEN(*data->longest);
734     GET_RE_DEBUG_FLAGS_DECL;
735
736     PERL_ARGS_ASSERT_SCAN_COMMIT;
737
738     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
739         SvSetMagicSV(*data->longest, data->last_found);
740         if (*data->longest == data->longest_fixed) {
741             data->offset_fixed = l ? data->last_start_min : data->pos_min;
742             if (data->flags & SF_BEFORE_EOL)
743                 data->flags
744                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
745             else
746                 data->flags &= ~SF_FIX_BEFORE_EOL;
747             data->minlen_fixed=minlenp;
748             data->lookbehind_fixed=0;
749         }
750         else { /* *data->longest == data->longest_float */
751             data->offset_float_min = l ? data->last_start_min : data->pos_min;
752             data->offset_float_max = (l
753                                       ? data->last_start_max
754                                       : (data->pos_delta == I32_MAX ? I32_MAX : data->pos_min + data->pos_delta));
755             if (is_inf || (U32)data->offset_float_max > (U32)I32_MAX)
756                 data->offset_float_max = I32_MAX;
757             if (data->flags & SF_BEFORE_EOL)
758                 data->flags
759                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
760             else
761                 data->flags &= ~SF_FL_BEFORE_EOL;
762             data->minlen_float=minlenp;
763             data->lookbehind_float=0;
764         }
765     }
766     SvCUR_set(data->last_found, 0);
767     {
768         SV * const sv = data->last_found;
769         if (SvUTF8(sv) && SvMAGICAL(sv)) {
770             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
771             if (mg)
772                 mg->mg_len = 0;
773         }
774     }
775     data->last_end = -1;
776     data->flags &= ~SF_BEFORE_EOL;
777     DEBUG_STUDYDATA("commit: ",data,0);
778 }
779
780 /* These macros set, clear and test whether the synthetic start class ('ssc',
781  * given by the parameter) matches an empty string (EOS).  This uses the
782  * 'next_off' field in the node, to save a bit in the flags field.  The ssc
783  * stands alone, so there is never a next_off, so this field is otherwise
784  * unused.  The EOS information is used only for compilation, but theoretically
785  * it could be passed on to the execution code.  This could be used to store
786  * more than one bit of information, but only this one is currently used. */
787 #define SET_SSC_EOS(node)   STMT_START { (node)->next_off = TRUE; } STMT_END
788 #define CLEAR_SSC_EOS(node) STMT_START { (node)->next_off = FALSE; } STMT_END
789 #define TEST_SSC_EOS(node)  cBOOL((node)->next_off)
790
791 /* Can match anything (initialization) */
792 STATIC void
793 S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
794 {
795     PERL_ARGS_ASSERT_CL_ANYTHING;
796
797     ANYOF_BITMAP_SETALL(cl);
798     cl->flags = ANYOF_UNICODE_ALL;
799     SET_SSC_EOS(cl);
800
801     /* If any portion of the regex is to operate under locale rules,
802      * initialization includes it.  The reason this isn't done for all regexes
803      * is that the optimizer was written under the assumption that locale was
804      * all-or-nothing.  Given the complexity and lack of documentation in the
805      * optimizer, and that there are inadequate test cases for locale, so many
806      * parts of it may not work properly, it is safest to avoid locale unless
807      * necessary. */
808     if (RExC_contains_locale) {
809         ANYOF_CLASS_SETALL(cl);     /* /l uses class */
810         cl->flags |= ANYOF_LOCALE|ANYOF_CLASS|ANYOF_LOC_FOLD;
811     }
812     else {
813         ANYOF_CLASS_ZERO(cl);       /* Only /l uses class now */
814     }
815 }
816
817 /* Can match anything (initialization) */
818 STATIC int
819 S_cl_is_anything(const struct regnode_charclass_class *cl)
820 {
821     int value;
822
823     PERL_ARGS_ASSERT_CL_IS_ANYTHING;
824
825     for (value = 0; value < ANYOF_MAX; value += 2)
826         if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
827             return 1;
828     if (!(cl->flags & ANYOF_UNICODE_ALL))
829         return 0;
830     if (!ANYOF_BITMAP_TESTALLSET((const void*)cl))
831         return 0;
832     return 1;
833 }
834
835 /* Can match anything (initialization) */
836 STATIC void
837 S_cl_init(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
838 {
839     PERL_ARGS_ASSERT_CL_INIT;
840
841     Zero(cl, 1, struct regnode_charclass_class);
842     cl->type = ANYOF;
843     cl_anything(pRExC_state, cl);
844     ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
845 }
846
847 /* These two functions currently do the exact same thing */
848 #define cl_init_zero            S_cl_init
849
850 /* 'AND' a given class with another one.  Can create false positives.  'cl'
851  * should not be inverted.  'and_with->flags & ANYOF_CLASS' should be 0 if
852  * 'and_with' is a regnode_charclass instead of a regnode_charclass_class. */
853 STATIC void
854 S_cl_and(struct regnode_charclass_class *cl,
855         const struct regnode_charclass_class *and_with)
856 {
857     PERL_ARGS_ASSERT_CL_AND;
858
859     assert(PL_regkind[and_with->type] == ANYOF);
860
861     /* I (khw) am not sure all these restrictions are necessary XXX */
862     if (!(ANYOF_CLASS_TEST_ANY_SET(and_with))
863         && !(ANYOF_CLASS_TEST_ANY_SET(cl))
864         && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
865         && !(and_with->flags & ANYOF_LOC_FOLD)
866         && !(cl->flags & ANYOF_LOC_FOLD)) {
867         int i;
868
869         if (and_with->flags & ANYOF_INVERT)
870             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
871                 cl->bitmap[i] &= ~and_with->bitmap[i];
872         else
873             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
874                 cl->bitmap[i] &= and_with->bitmap[i];
875     } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
876
877     if (and_with->flags & ANYOF_INVERT) {
878
879         /* Here, the and'ed node is inverted.  Get the AND of the flags that
880          * aren't affected by the inversion.  Those that are affected are
881          * handled individually below */
882         U8 affected_flags = cl->flags & ~INVERSION_UNAFFECTED_FLAGS;
883         cl->flags &= (and_with->flags & INVERSION_UNAFFECTED_FLAGS);
884         cl->flags |= affected_flags;
885
886         /* We currently don't know how to deal with things that aren't in the
887          * bitmap, but we know that the intersection is no greater than what
888          * is already in cl, so let there be false positives that get sorted
889          * out after the synthetic start class succeeds, and the node is
890          * matched for real. */
891
892         /* The inversion of these two flags indicate that the resulting
893          * intersection doesn't have them */
894         if (and_with->flags & ANYOF_UNICODE_ALL) {
895             cl->flags &= ~ANYOF_UNICODE_ALL;
896         }
897         if (and_with->flags & ANYOF_NON_UTF8_LATIN1_ALL) {
898             cl->flags &= ~ANYOF_NON_UTF8_LATIN1_ALL;
899         }
900     }
901     else {   /* and'd node is not inverted */
902         U8 outside_bitmap_but_not_utf8; /* Temp variable */
903
904         if (! ANYOF_NONBITMAP(and_with)) {
905
906             /* Here 'and_with' doesn't match anything outside the bitmap
907              * (except possibly ANYOF_UNICODE_ALL), which means the
908              * intersection can't either, except for ANYOF_UNICODE_ALL, in
909              * which case we don't know what the intersection is, but it's no
910              * greater than what cl already has, so can just leave it alone,
911              * with possible false positives */
912             if (! (and_with->flags & ANYOF_UNICODE_ALL)) {
913                 ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
914                 cl->flags &= ~ANYOF_NONBITMAP_NON_UTF8;
915             }
916         }
917         else if (! ANYOF_NONBITMAP(cl)) {
918
919             /* Here, 'and_with' does match something outside the bitmap, and cl
920              * doesn't have a list of things to match outside the bitmap.  If
921              * cl can match all code points above 255, the intersection will
922              * be those above-255 code points that 'and_with' matches.  If cl
923              * can't match all Unicode code points, it means that it can't
924              * match anything outside the bitmap (since the 'if' that got us
925              * into this block tested for that), so we leave the bitmap empty.
926              */
927             if (cl->flags & ANYOF_UNICODE_ALL) {
928                 ARG_SET(cl, ARG(and_with));
929
930                 /* and_with's ARG may match things that don't require UTF8.
931                  * And now cl's will too, in spite of this being an 'and'.  See
932                  * the comments below about the kludge */
933                 cl->flags |= and_with->flags & ANYOF_NONBITMAP_NON_UTF8;
934             }
935         }
936         else {
937             /* Here, both 'and_with' and cl match something outside the
938              * bitmap.  Currently we do not do the intersection, so just match
939              * whatever cl had at the beginning.  */
940         }
941
942
943         /* Take the intersection of the two sets of flags.  However, the
944          * ANYOF_NONBITMAP_NON_UTF8 flag is treated as an 'or'.  This is a
945          * kludge around the fact that this flag is not treated like the others
946          * which are initialized in cl_anything().  The way the optimizer works
947          * is that the synthetic start class (SSC) is initialized to match
948          * anything, and then the first time a real node is encountered, its
949          * values are AND'd with the SSC's with the result being the values of
950          * the real node.  However, there are paths through the optimizer where
951          * the AND never gets called, so those initialized bits are set
952          * inappropriately, which is not usually a big deal, as they just cause
953          * false positives in the SSC, which will just mean a probably
954          * imperceptible slow down in execution.  However this bit has a
955          * higher false positive consequence in that it can cause utf8.pm,
956          * utf8_heavy.pl ... to be loaded when not necessary, which is a much
957          * bigger slowdown and also causes significant extra memory to be used.
958          * In order to prevent this, the code now takes a different tack.  The
959          * bit isn't set unless some part of the regular expression needs it,
960          * but once set it won't get cleared.  This means that these extra
961          * modules won't get loaded unless there was some path through the
962          * pattern that would have required them anyway, and  so any false
963          * positives that occur by not ANDing them out when they could be
964          * aren't as severe as they would be if we treated this bit like all
965          * the others */
966         outside_bitmap_but_not_utf8 = (cl->flags | and_with->flags)
967                                       & ANYOF_NONBITMAP_NON_UTF8;
968         cl->flags &= and_with->flags;
969         cl->flags |= outside_bitmap_but_not_utf8;
970     }
971 }
972
973 /* 'OR' a given class with another one.  Can create false positives.  'cl'
974  * should not be inverted.  'or_with->flags & ANYOF_CLASS' should be 0 if
975  * 'or_with' is a regnode_charclass instead of a regnode_charclass_class. */
976 STATIC void
977 S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
978 {
979     PERL_ARGS_ASSERT_CL_OR;
980
981     if (or_with->flags & ANYOF_INVERT) {
982
983         /* Here, the or'd node is to be inverted.  This means we take the
984          * complement of everything not in the bitmap, but currently we don't
985          * know what that is, so give up and match anything */
986         if (ANYOF_NONBITMAP(or_with)) {
987             cl_anything(pRExC_state, cl);
988         }
989         /* We do not use
990          * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
991          *   <= (B1 | !B2) | (CL1 | !CL2)
992          * which is wasteful if CL2 is small, but we ignore CL2:
993          *   (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
994          * XXXX Can we handle case-fold?  Unclear:
995          *   (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
996          *   (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
997          */
998         else if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
999              && !(or_with->flags & ANYOF_LOC_FOLD)
1000              && !(cl->flags & ANYOF_LOC_FOLD) ) {
1001             int i;
1002
1003             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
1004                 cl->bitmap[i] |= ~or_with->bitmap[i];
1005         } /* XXXX: logic is complicated otherwise */
1006         else {
1007             cl_anything(pRExC_state, cl);
1008         }
1009
1010         /* And, we can just take the union of the flags that aren't affected
1011          * by the inversion */
1012         cl->flags |= or_with->flags & INVERSION_UNAFFECTED_FLAGS;
1013
1014         /* For the remaining flags:
1015             ANYOF_UNICODE_ALL and inverted means to not match anything above
1016                     255, which means that the union with cl should just be
1017                     what cl has in it, so can ignore this flag
1018             ANYOF_NON_UTF8_LATIN1_ALL and inverted means if not utf8 and ord
1019                     is 127-255 to match them, but then invert that, so the
1020                     union with cl should just be what cl has in it, so can
1021                     ignore this flag
1022          */
1023     } else {    /* 'or_with' is not inverted */
1024         /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
1025         if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
1026              && (!(or_with->flags & ANYOF_LOC_FOLD)
1027                  || (cl->flags & ANYOF_LOC_FOLD)) ) {
1028             int i;
1029
1030             /* OR char bitmap and class bitmap separately */
1031             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
1032                 cl->bitmap[i] |= or_with->bitmap[i];
1033             if (or_with->flags & ANYOF_CLASS) {
1034                 ANYOF_CLASS_OR(or_with, cl);
1035             }
1036         }
1037         else { /* XXXX: logic is complicated, leave it along for a moment. */
1038             cl_anything(pRExC_state, cl);
1039         }
1040
1041         if (ANYOF_NONBITMAP(or_with)) {
1042
1043             /* Use the added node's outside-the-bit-map match if there isn't a
1044              * conflict.  If there is a conflict (both nodes match something
1045              * outside the bitmap, but what they match outside is not the same
1046              * pointer, and hence not easily compared until XXX we extend
1047              * inversion lists this far), give up and allow the start class to
1048              * match everything outside the bitmap.  If that stuff is all above
1049              * 255, can just set UNICODE_ALL, otherwise caould be anything. */
1050             if (! ANYOF_NONBITMAP(cl)) {
1051                 ARG_SET(cl, ARG(or_with));
1052             }
1053             else if (ARG(cl) != ARG(or_with)) {
1054
1055                 if ((or_with->flags & ANYOF_NONBITMAP_NON_UTF8)) {
1056                     cl_anything(pRExC_state, cl);
1057                 }
1058                 else {
1059                     cl->flags |= ANYOF_UNICODE_ALL;
1060                 }
1061             }
1062         }
1063
1064         /* Take the union */
1065         cl->flags |= or_with->flags;
1066     }
1067 }
1068
1069 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1070 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
1071 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1072 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list ? (TRIE_LIST_CUR( idx ) - 1) : 0 )
1073
1074
1075 #ifdef DEBUGGING
1076 /*
1077    dump_trie(trie,widecharmap,revcharmap)
1078    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1079    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1080
1081    These routines dump out a trie in a somewhat readable format.
1082    The _interim_ variants are used for debugging the interim
1083    tables that are used to generate the final compressed
1084    representation which is what dump_trie expects.
1085
1086    Part of the reason for their existence is to provide a form
1087    of documentation as to how the different representations function.
1088
1089 */
1090
1091 /*
1092   Dumps the final compressed table form of the trie to Perl_debug_log.
1093   Used for debugging make_trie().
1094 */
1095
1096 STATIC void
1097 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1098             AV *revcharmap, U32 depth)
1099 {
1100     U32 state;
1101     SV *sv=sv_newmortal();
1102     int colwidth= widecharmap ? 6 : 4;
1103     U16 word;
1104     GET_RE_DEBUG_FLAGS_DECL;
1105
1106     PERL_ARGS_ASSERT_DUMP_TRIE;
1107
1108     PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
1109         (int)depth * 2 + 2,"",
1110         "Match","Base","Ofs" );
1111
1112     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1113         SV ** const tmp = av_fetch( revcharmap, state, 0);
1114         if ( tmp ) {
1115             PerlIO_printf( Perl_debug_log, "%*s", 
1116                 colwidth,
1117                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1118                             PL_colors[0], PL_colors[1],
1119                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1120                             PERL_PV_ESCAPE_FIRSTCHAR 
1121                 ) 
1122             );
1123         }
1124     }
1125     PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
1126         (int)depth * 2 + 2,"");
1127
1128     for( state = 0 ; state < trie->uniquecharcount ; state++ )
1129         PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
1130     PerlIO_printf( Perl_debug_log, "\n");
1131
1132     for( state = 1 ; state < trie->statecount ; state++ ) {
1133         const U32 base = trie->states[ state ].trans.base;
1134
1135         PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state);
1136
1137         if ( trie->states[ state ].wordnum ) {
1138             PerlIO_printf( Perl_debug_log, " W%4X", trie->states[ state ].wordnum );
1139         } else {
1140             PerlIO_printf( Perl_debug_log, "%6s", "" );
1141         }
1142
1143         PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
1144
1145         if ( base ) {
1146             U32 ofs = 0;
1147
1148             while( ( base + ofs  < trie->uniquecharcount ) ||
1149                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
1150                      && trie->trans[ base + ofs - trie->uniquecharcount ].check != state))
1151                     ofs++;
1152
1153             PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
1154
1155             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
1156                 if ( ( base + ofs >= trie->uniquecharcount ) &&
1157                      ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
1158                      trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
1159                 {
1160                    PerlIO_printf( Perl_debug_log, "%*"UVXf,
1161                     colwidth,
1162                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
1163                 } else {
1164                     PerlIO_printf( Perl_debug_log, "%*s",colwidth,"   ." );
1165                 }
1166             }
1167
1168             PerlIO_printf( Perl_debug_log, "]");
1169
1170         }
1171         PerlIO_printf( Perl_debug_log, "\n" );
1172     }
1173     PerlIO_printf(Perl_debug_log, "%*sword_info N:(prev,len)=", (int)depth*2, "");
1174     for (word=1; word <= trie->wordcount; word++) {
1175         PerlIO_printf(Perl_debug_log, " %d:(%d,%d)",
1176             (int)word, (int)(trie->wordinfo[word].prev),
1177             (int)(trie->wordinfo[word].len));
1178     }
1179     PerlIO_printf(Perl_debug_log, "\n" );
1180 }    
1181 /*
1182   Dumps a fully constructed but uncompressed trie in list form.
1183   List tries normally only are used for construction when the number of 
1184   possible chars (trie->uniquecharcount) is very high.
1185   Used for debugging make_trie().
1186 */
1187 STATIC void
1188 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
1189                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
1190                          U32 depth)
1191 {
1192     U32 state;
1193     SV *sv=sv_newmortal();
1194     int colwidth= widecharmap ? 6 : 4;
1195     GET_RE_DEBUG_FLAGS_DECL;
1196
1197     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
1198
1199     /* print out the table precompression.  */
1200     PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
1201         (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
1202         "------:-----+-----------------\n" );
1203     
1204     for( state=1 ; state < next_alloc ; state ++ ) {
1205         U16 charid;
1206     
1207         PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
1208             (int)depth * 2 + 2,"", (UV)state  );
1209         if ( ! trie->states[ state ].wordnum ) {
1210             PerlIO_printf( Perl_debug_log, "%5s| ","");
1211         } else {
1212             PerlIO_printf( Perl_debug_log, "W%4x| ",
1213                 trie->states[ state ].wordnum
1214             );
1215         }
1216         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
1217             SV ** const tmp = av_fetch( revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
1218             if ( tmp ) {
1219                 PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
1220                     colwidth,
1221                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1222                             PL_colors[0], PL_colors[1],
1223                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1224                             PERL_PV_ESCAPE_FIRSTCHAR 
1225                     ) ,
1226                     TRIE_LIST_ITEM(state,charid).forid,
1227                     (UV)TRIE_LIST_ITEM(state,charid).newstate
1228                 );
1229                 if (!(charid % 10)) 
1230                     PerlIO_printf(Perl_debug_log, "\n%*s| ",
1231                         (int)((depth * 2) + 14), "");
1232             }
1233         }
1234         PerlIO_printf( Perl_debug_log, "\n");
1235     }
1236 }    
1237
1238 /*
1239   Dumps a fully constructed but uncompressed trie in table form.
1240   This is the normal DFA style state transition table, with a few 
1241   twists to facilitate compression later. 
1242   Used for debugging make_trie().
1243 */
1244 STATIC void
1245 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
1246                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
1247                           U32 depth)
1248 {
1249     U32 state;
1250     U16 charid;
1251     SV *sv=sv_newmortal();
1252     int colwidth= widecharmap ? 6 : 4;
1253     GET_RE_DEBUG_FLAGS_DECL;
1254
1255     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
1256     
1257     /*
1258        print out the table precompression so that we can do a visual check
1259        that they are identical.
1260      */
1261     
1262     PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
1263
1264     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1265         SV ** const tmp = av_fetch( revcharmap, charid, 0);
1266         if ( tmp ) {
1267             PerlIO_printf( Perl_debug_log, "%*s", 
1268                 colwidth,
1269                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1270                             PL_colors[0], PL_colors[1],
1271                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1272                             PERL_PV_ESCAPE_FIRSTCHAR 
1273                 ) 
1274             );
1275         }
1276     }
1277
1278     PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
1279
1280     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
1281         PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
1282     }
1283
1284     PerlIO_printf( Perl_debug_log, "\n" );
1285
1286     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
1287
1288         PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ", 
1289             (int)depth * 2 + 2,"",
1290             (UV)TRIE_NODENUM( state ) );
1291
1292         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1293             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
1294             if (v)
1295                 PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
1296             else
1297                 PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
1298         }
1299         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1300             PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check );
1301         } else {
1302             PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n", (UV)trie->trans[ state ].check,
1303             trie->states[ TRIE_NODENUM( state ) ].wordnum );
1304         }
1305     }
1306 }
1307
1308 #endif
1309
1310
1311 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
1312   startbranch: the first branch in the whole branch sequence
1313   first      : start branch of sequence of branch-exact nodes.
1314                May be the same as startbranch
1315   last       : Thing following the last branch.
1316                May be the same as tail.
1317   tail       : item following the branch sequence
1318   count      : words in the sequence
1319   flags      : currently the OP() type we will be building one of /EXACT(|F|Fl)/
1320   depth      : indent depth
1321
1322 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
1323
1324 A trie is an N'ary tree where the branches are determined by digital
1325 decomposition of the key. IE, at the root node you look up the 1st character and
1326 follow that branch repeat until you find the end of the branches. Nodes can be
1327 marked as "accepting" meaning they represent a complete word. Eg:
1328
1329   /he|she|his|hers/
1330
1331 would convert into the following structure. Numbers represent states, letters
1332 following numbers represent valid transitions on the letter from that state, if
1333 the number is in square brackets it represents an accepting state, otherwise it
1334 will be in parenthesis.
1335
1336       +-h->+-e->[3]-+-r->(8)-+-s->[9]
1337       |    |
1338       |   (2)
1339       |    |
1340      (1)   +-i->(6)-+-s->[7]
1341       |
1342       +-s->(3)-+-h->(4)-+-e->[5]
1343
1344       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
1345
1346 This shows that when matching against the string 'hers' we will begin at state 1
1347 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
1348 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
1349 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
1350 single traverse. We store a mapping from accepting to state to which word was
1351 matched, and then when we have multiple possibilities we try to complete the
1352 rest of the regex in the order in which they occured in the alternation.
1353
1354 The only prior NFA like behaviour that would be changed by the TRIE support is
1355 the silent ignoring of duplicate alternations which are of the form:
1356
1357  / (DUPE|DUPE) X? (?{ ... }) Y /x
1358
1359 Thus EVAL blocks following a trie may be called a different number of times with
1360 and without the optimisation. With the optimisations dupes will be silently
1361 ignored. This inconsistent behaviour of EVAL type nodes is well established as
1362 the following demonstrates:
1363
1364  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
1365
1366 which prints out 'word' three times, but
1367
1368  'words'=~/(word|word|word)(?{ print $1 })S/
1369
1370 which doesnt print it out at all. This is due to other optimisations kicking in.
1371
1372 Example of what happens on a structural level:
1373
1374 The regexp /(ac|ad|ab)+/ will produce the following debug output:
1375
1376    1: CURLYM[1] {1,32767}(18)
1377    5:   BRANCH(8)
1378    6:     EXACT <ac>(16)
1379    8:   BRANCH(11)
1380    9:     EXACT <ad>(16)
1381   11:   BRANCH(14)
1382   12:     EXACT <ab>(16)
1383   16:   SUCCEED(0)
1384   17:   NOTHING(18)
1385   18: END(0)
1386
1387 This would be optimizable with startbranch=5, first=5, last=16, tail=16
1388 and should turn into:
1389
1390    1: CURLYM[1] {1,32767}(18)
1391    5:   TRIE(16)
1392         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
1393           <ac>
1394           <ad>
1395           <ab>
1396   16:   SUCCEED(0)
1397   17:   NOTHING(18)
1398   18: END(0)
1399
1400 Cases where tail != last would be like /(?foo|bar)baz/:
1401
1402    1: BRANCH(4)
1403    2:   EXACT <foo>(8)
1404    4: BRANCH(7)
1405    5:   EXACT <bar>(8)
1406    7: TAIL(8)
1407    8: EXACT <baz>(10)
1408   10: END(0)
1409
1410 which would be optimizable with startbranch=1, first=1, last=7, tail=8
1411 and would end up looking like:
1412
1413     1: TRIE(8)
1414       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
1415         <foo>
1416         <bar>
1417    7: TAIL(8)
1418    8: EXACT <baz>(10)
1419   10: END(0)
1420
1421     d = uvuni_to_utf8_flags(d, uv, 0);
1422
1423 is the recommended Unicode-aware way of saying
1424
1425     *(d++) = uv;
1426 */
1427
1428 #define TRIE_STORE_REVCHAR(val)                                            \
1429     STMT_START {                                                           \
1430         if (UTF) {                                                         \
1431             SV *zlopp = newSV(7); /* XXX: optimize me */                   \
1432             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
1433             unsigned const char *const kapow = uvuni_to_utf8(flrbbbbb, val); \
1434             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
1435             SvPOK_on(zlopp);                                               \
1436             SvUTF8_on(zlopp);                                              \
1437             av_push(revcharmap, zlopp);                                    \
1438         } else {                                                           \
1439             char ooooff = (char)val;                                           \
1440             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
1441         }                                                                  \
1442         } STMT_END
1443
1444 #define TRIE_READ_CHAR STMT_START {                                                     \
1445     wordlen++;                                                                          \
1446     if ( UTF ) {                                                                        \
1447         /* if it is UTF then it is either already folded, or does not need folding */   \
1448         uvc = utf8n_to_uvuni( (const U8*) uc, UTF8_MAXLEN, &len, uniflags);             \
1449     }                                                                                   \
1450     else if (folder == PL_fold_latin1) {                                                \
1451         /* if we use this folder we have to obey unicode rules on latin-1 data */       \
1452         if ( foldlen > 0 ) {                                                            \
1453            uvc = utf8n_to_uvuni( (const U8*) scan, UTF8_MAXLEN, &len, uniflags );       \
1454            foldlen -= len;                                                              \
1455            scan += len;                                                                 \
1456            len = 0;                                                                     \
1457         } else {                                                                        \
1458             len = 1;                                                                    \
1459             uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, 1);                     \
1460             skiplen = UNISKIP(uvc);                                                     \
1461             foldlen -= skiplen;                                                         \
1462             scan = foldbuf + skiplen;                                                   \
1463         }                                                                               \
1464     } else {                                                                            \
1465         /* raw data, will be folded later if needed */                                  \
1466         uvc = (U32)*uc;                                                                 \
1467         len = 1;                                                                        \
1468     }                                                                                   \
1469 } STMT_END
1470
1471
1472
1473 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
1474     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
1475         U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
1476         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
1477     }                                                           \
1478     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
1479     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
1480     TRIE_LIST_CUR( state )++;                                   \
1481 } STMT_END
1482
1483 #define TRIE_LIST_NEW(state) STMT_START {                       \
1484     Newxz( trie->states[ state ].trans.list,               \
1485         4, reg_trie_trans_le );                                 \
1486      TRIE_LIST_CUR( state ) = 1;                                \
1487      TRIE_LIST_LEN( state ) = 4;                                \
1488 } STMT_END
1489
1490 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
1491     U16 dupe= trie->states[ state ].wordnum;                    \
1492     regnode * const noper_next = regnext( noper );              \
1493                                                                 \
1494     DEBUG_r({                                                   \
1495         /* store the word for dumping */                        \
1496         SV* tmp;                                                \
1497         if (OP(noper) != NOTHING)                               \
1498             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
1499         else                                                    \
1500             tmp = newSVpvn_utf8( "", 0, UTF );                  \
1501         av_push( trie_words, tmp );                             \
1502     });                                                         \
1503                                                                 \
1504     curword++;                                                  \
1505     trie->wordinfo[curword].prev   = 0;                         \
1506     trie->wordinfo[curword].len    = wordlen;                   \
1507     trie->wordinfo[curword].accept = state;                     \
1508                                                                 \
1509     if ( noper_next < tail ) {                                  \
1510         if (!trie->jump)                                        \
1511             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, sizeof(U16) ); \
1512         trie->jump[curword] = (U16)(noper_next - convert);      \
1513         if (!jumper)                                            \
1514             jumper = noper_next;                                \
1515         if (!nextbranch)                                        \
1516             nextbranch= regnext(cur);                           \
1517     }                                                           \
1518                                                                 \
1519     if ( dupe ) {                                               \
1520         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
1521         /* chain, so that when the bits of chain are later    */\
1522         /* linked together, the dups appear in the chain      */\
1523         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
1524         trie->wordinfo[dupe].prev = curword;                    \
1525     } else {                                                    \
1526         /* we haven't inserted this word yet.                */ \
1527         trie->states[ state ].wordnum = curword;                \
1528     }                                                           \
1529 } STMT_END
1530
1531
1532 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
1533      ( ( base + charid >=  ucharcount                                   \
1534          && base + charid < ubound                                      \
1535          && state == trie->trans[ base - ucharcount + charid ].check    \
1536          && trie->trans[ base - ucharcount + charid ].next )            \
1537            ? trie->trans[ base - ucharcount + charid ].next             \
1538            : ( state==1 ? special : 0 )                                 \
1539       )
1540
1541 #define MADE_TRIE       1
1542 #define MADE_JUMP_TRIE  2
1543 #define MADE_EXACT_TRIE 4
1544
1545 STATIC I32
1546 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth)
1547 {
1548     dVAR;
1549     /* first pass, loop through and scan words */
1550     reg_trie_data *trie;
1551     HV *widecharmap = NULL;
1552     AV *revcharmap = newAV();
1553     regnode *cur;
1554     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1555     STRLEN len = 0;
1556     UV uvc = 0;
1557     U16 curword = 0;
1558     U32 next_alloc = 0;
1559     regnode *jumper = NULL;
1560     regnode *nextbranch = NULL;
1561     regnode *convert = NULL;
1562     U32 *prev_states; /* temp array mapping each state to previous one */
1563     /* we just use folder as a flag in utf8 */
1564     const U8 * folder = NULL;
1565
1566 #ifdef DEBUGGING
1567     const U32 data_slot = add_data( pRExC_state, 4, "tuuu" );
1568     AV *trie_words = NULL;
1569     /* along with revcharmap, this only used during construction but both are
1570      * useful during debugging so we store them in the struct when debugging.
1571      */
1572 #else
1573     const U32 data_slot = add_data( pRExC_state, 2, "tu" );
1574     STRLEN trie_charcount=0;
1575 #endif
1576     SV *re_trie_maxbuff;
1577     GET_RE_DEBUG_FLAGS_DECL;
1578
1579     PERL_ARGS_ASSERT_MAKE_TRIE;
1580 #ifndef DEBUGGING
1581     PERL_UNUSED_ARG(depth);
1582 #endif
1583
1584     switch (flags) {
1585         case EXACT: break;
1586         case EXACTFA:
1587         case EXACTFU_SS:
1588         case EXACTFU_TRICKYFOLD:
1589         case EXACTFU: folder = PL_fold_latin1; break;
1590         case EXACTF:  folder = PL_fold; break;
1591         case EXACTFL: folder = PL_fold_locale; break;
1592         default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
1593     }
1594
1595     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
1596     trie->refcount = 1;
1597     trie->startstate = 1;
1598     trie->wordcount = word_count;
1599     RExC_rxi->data->data[ data_slot ] = (void*)trie;
1600     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
1601     if (flags == EXACT)
1602         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
1603     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
1604                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
1605
1606     DEBUG_r({
1607         trie_words = newAV();
1608     });
1609
1610     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
1611     if (!SvIOK(re_trie_maxbuff)) {
1612         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
1613     }
1614     DEBUG_TRIE_COMPILE_r({
1615                 PerlIO_printf( Perl_debug_log,
1616                   "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
1617                   (int)depth * 2 + 2, "", 
1618                   REG_NODE_NUM(startbranch),REG_NODE_NUM(first), 
1619                   REG_NODE_NUM(last), REG_NODE_NUM(tail),
1620                   (int)depth);
1621     });
1622    
1623    /* Find the node we are going to overwrite */
1624     if ( first == startbranch && OP( last ) != BRANCH ) {
1625         /* whole branch chain */
1626         convert = first;
1627     } else {
1628         /* branch sub-chain */
1629         convert = NEXTOPER( first );
1630     }
1631         
1632     /*  -- First loop and Setup --
1633
1634        We first traverse the branches and scan each word to determine if it
1635        contains widechars, and how many unique chars there are, this is
1636        important as we have to build a table with at least as many columns as we
1637        have unique chars.
1638
1639        We use an array of integers to represent the character codes 0..255
1640        (trie->charmap) and we use a an HV* to store Unicode characters. We use the
1641        native representation of the character value as the key and IV's for the
1642        coded index.
1643
1644        *TODO* If we keep track of how many times each character is used we can
1645        remap the columns so that the table compression later on is more
1646        efficient in terms of memory by ensuring the most common value is in the
1647        middle and the least common are on the outside.  IMO this would be better
1648        than a most to least common mapping as theres a decent chance the most
1649        common letter will share a node with the least common, meaning the node
1650        will not be compressible. With a middle is most common approach the worst
1651        case is when we have the least common nodes twice.
1652
1653      */
1654
1655     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1656         regnode *noper = NEXTOPER( cur );
1657         const U8 *uc = (U8*)STRING( noper );
1658         const U8 *e  = uc + STR_LEN( noper );
1659         STRLEN foldlen = 0;
1660         U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1661         STRLEN skiplen = 0;
1662         const U8 *scan = (U8*)NULL;
1663         U32 wordlen      = 0;         /* required init */
1664         STRLEN chars = 0;
1665         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the bitmap?*/
1666
1667         if (OP(noper) == NOTHING) {
1668             regnode *noper_next= regnext(noper);
1669             if (noper_next != tail && OP(noper_next) == flags) {
1670                 noper = noper_next;
1671                 uc= (U8*)STRING(noper);
1672                 e= uc + STR_LEN(noper);
1673                 trie->minlen= STR_LEN(noper);
1674             } else {
1675                 trie->minlen= 0;
1676                 continue;
1677             }
1678         }
1679
1680         if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
1681             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
1682                                           regardless of encoding */
1683             if (OP( noper ) == EXACTFU_SS) {
1684                 /* false positives are ok, so just set this */
1685                 TRIE_BITMAP_SET(trie,0xDF);
1686             }
1687         }
1688         for ( ; uc < e ; uc += len ) {
1689             TRIE_CHARCOUNT(trie)++;
1690             TRIE_READ_CHAR;
1691             chars++;
1692             if ( uvc < 256 ) {
1693                 if ( folder ) {
1694                     U8 folded= folder[ (U8) uvc ];
1695                     if ( !trie->charmap[ folded ] ) {
1696                         trie->charmap[ folded ]=( ++trie->uniquecharcount );
1697                         TRIE_STORE_REVCHAR( folded );
1698                     }
1699                 }
1700                 if ( !trie->charmap[ uvc ] ) {
1701                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
1702                     TRIE_STORE_REVCHAR( uvc );
1703                 }
1704                 if ( set_bit ) {
1705                     /* store the codepoint in the bitmap, and its folded
1706                      * equivalent. */
1707                     TRIE_BITMAP_SET(trie, uvc);
1708
1709                     /* store the folded codepoint */
1710                     if ( folder ) TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);
1711
1712                     if ( !UTF ) {
1713                         /* store first byte of utf8 representation of
1714                            variant codepoints */
1715                         if (! UNI_IS_INVARIANT(uvc)) {
1716                             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));
1717                         }
1718                     }
1719                     set_bit = 0; /* We've done our bit :-) */
1720                 }
1721             } else {
1722                 SV** svpp;
1723                 if ( !widecharmap )
1724                     widecharmap = newHV();
1725
1726                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
1727
1728                 if ( !svpp )
1729                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
1730
1731                 if ( !SvTRUE( *svpp ) ) {
1732                     sv_setiv( *svpp, ++trie->uniquecharcount );
1733                     TRIE_STORE_REVCHAR(uvc);
1734                 }
1735             }
1736         }
1737         if( cur == first ) {
1738             trie->minlen = chars;
1739             trie->maxlen = chars;
1740         } else if (chars < trie->minlen) {
1741             trie->minlen = chars;
1742         } else if (chars > trie->maxlen) {
1743             trie->maxlen = chars;
1744         }
1745         if (OP( noper ) == EXACTFU_SS) {
1746             /* XXX: workaround - 'ss' could match "\x{DF}" so minlen could be 1 and not 2*/
1747             if (trie->minlen > 1)
1748                 trie->minlen= 1;
1749         }
1750         if (OP( noper ) == EXACTFU_TRICKYFOLD) {
1751             /* XXX: workround - things like "\x{1FBE}\x{0308}\x{0301}" can match "\x{0390}" 
1752              *                - We assume that any such sequence might match a 2 byte string */
1753             if (trie->minlen > 2 )
1754                 trie->minlen= 2;
1755         }
1756
1757     } /* end first pass */
1758     DEBUG_TRIE_COMPILE_r(
1759         PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
1760                 (int)depth * 2 + 2,"",
1761                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
1762                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
1763                 (int)trie->minlen, (int)trie->maxlen )
1764     );
1765
1766     /*
1767         We now know what we are dealing with in terms of unique chars and
1768         string sizes so we can calculate how much memory a naive
1769         representation using a flat table  will take. If it's over a reasonable
1770         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
1771         conservative but potentially much slower representation using an array
1772         of lists.
1773
1774         At the end we convert both representations into the same compressed
1775         form that will be used in regexec.c for matching with. The latter
1776         is a form that cannot be used to construct with but has memory
1777         properties similar to the list form and access properties similar
1778         to the table form making it both suitable for fast searches and
1779         small enough that its feasable to store for the duration of a program.
1780
1781         See the comment in the code where the compressed table is produced
1782         inplace from the flat tabe representation for an explanation of how
1783         the compression works.
1784
1785     */
1786
1787
1788     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
1789     prev_states[1] = 0;
1790
1791     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1) > SvIV(re_trie_maxbuff) ) {
1792         /*
1793             Second Pass -- Array Of Lists Representation
1794
1795             Each state will be represented by a list of charid:state records
1796             (reg_trie_trans_le) the first such element holds the CUR and LEN
1797             points of the allocated array. (See defines above).
1798
1799             We build the initial structure using the lists, and then convert
1800             it into the compressed table form which allows faster lookups
1801             (but cant be modified once converted).
1802         */
1803
1804         STRLEN transcount = 1;
1805
1806         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
1807             "%*sCompiling trie using list compiler\n",
1808             (int)depth * 2 + 2, ""));
1809
1810         trie->states = (reg_trie_state *)
1811             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1812                                   sizeof(reg_trie_state) );
1813         TRIE_LIST_NEW(1);
1814         next_alloc = 2;
1815
1816         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1817
1818             regnode *noper   = NEXTOPER( cur );
1819             U8 *uc           = (U8*)STRING( noper );
1820             const U8 *e      = uc + STR_LEN( noper );
1821             U32 state        = 1;         /* required init */
1822             U16 charid       = 0;         /* sanity init */
1823             U8 *scan         = (U8*)NULL; /* sanity init */
1824             STRLEN foldlen   = 0;         /* required init */
1825             U32 wordlen      = 0;         /* required init */
1826             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1827             STRLEN skiplen   = 0;
1828
1829             if (OP(noper) == NOTHING) {
1830                 regnode *noper_next= regnext(noper);
1831                 if (noper_next != tail && OP(noper_next) == flags) {
1832                     noper = noper_next;
1833                     uc= (U8*)STRING(noper);
1834                     e= uc + STR_LEN(noper);
1835                 }
1836             }
1837
1838             if (OP(noper) != NOTHING) {
1839                 for ( ; uc < e ; uc += len ) {
1840
1841                     TRIE_READ_CHAR;
1842
1843                     if ( uvc < 256 ) {
1844                         charid = trie->charmap[ uvc ];
1845                     } else {
1846                         SV** const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1847                         if ( !svpp ) {
1848                             charid = 0;
1849                         } else {
1850                             charid=(U16)SvIV( *svpp );
1851                         }
1852                     }
1853                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
1854                     if ( charid ) {
1855
1856                         U16 check;
1857                         U32 newstate = 0;
1858
1859                         charid--;
1860                         if ( !trie->states[ state ].trans.list ) {
1861                             TRIE_LIST_NEW( state );
1862                         }
1863                         for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) {
1864                             if ( TRIE_LIST_ITEM( state, check ).forid == charid ) {
1865                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
1866                                 break;
1867                             }
1868                         }
1869                         if ( ! newstate ) {
1870                             newstate = next_alloc++;
1871                             prev_states[newstate] = state;
1872                             TRIE_LIST_PUSH( state, charid, newstate );
1873                             transcount++;
1874                         }
1875                         state = newstate;
1876                     } else {
1877                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1878                     }
1879                 }
1880             }
1881             TRIE_HANDLE_WORD(state);
1882
1883         } /* end second pass */
1884
1885         /* next alloc is the NEXT state to be allocated */
1886         trie->statecount = next_alloc; 
1887         trie->states = (reg_trie_state *)
1888             PerlMemShared_realloc( trie->states,
1889                                    next_alloc
1890                                    * sizeof(reg_trie_state) );
1891
1892         /* and now dump it out before we compress it */
1893         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
1894                                                          revcharmap, next_alloc,
1895                                                          depth+1)
1896         );
1897
1898         trie->trans = (reg_trie_trans *)
1899             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
1900         {
1901             U32 state;
1902             U32 tp = 0;
1903             U32 zp = 0;
1904
1905
1906             for( state=1 ; state < next_alloc ; state ++ ) {
1907                 U32 base=0;
1908
1909                 /*
1910                 DEBUG_TRIE_COMPILE_MORE_r(
1911                     PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
1912                 );
1913                 */
1914
1915                 if (trie->states[state].trans.list) {
1916                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
1917                     U16 maxid=minid;
1918                     U16 idx;
1919
1920                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1921                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
1922                         if ( forid < minid ) {
1923                             minid=forid;
1924                         } else if ( forid > maxid ) {
1925                             maxid=forid;
1926                         }
1927                     }
1928                     if ( transcount < tp + maxid - minid + 1) {
1929                         transcount *= 2;
1930                         trie->trans = (reg_trie_trans *)
1931                             PerlMemShared_realloc( trie->trans,
1932                                                      transcount
1933                                                      * sizeof(reg_trie_trans) );
1934                         Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans );
1935                     }
1936                     base = trie->uniquecharcount + tp - minid;
1937                     if ( maxid == minid ) {
1938                         U32 set = 0;
1939                         for ( ; zp < tp ; zp++ ) {
1940                             if ( ! trie->trans[ zp ].next ) {
1941                                 base = trie->uniquecharcount + zp - minid;
1942                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1943                                 trie->trans[ zp ].check = state;
1944                                 set = 1;
1945                                 break;
1946                             }
1947                         }
1948                         if ( !set ) {
1949                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1950                             trie->trans[ tp ].check = state;
1951                             tp++;
1952                             zp = tp;
1953                         }
1954                     } else {
1955                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1956                             const U32 tid = base -  trie->uniquecharcount + TRIE_LIST_ITEM( state, idx ).forid;
1957                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state, idx ).newstate;
1958                             trie->trans[ tid ].check = state;
1959                         }
1960                         tp += ( maxid - minid + 1 );
1961                     }
1962                     Safefree(trie->states[ state ].trans.list);
1963                 }
1964                 /*
1965                 DEBUG_TRIE_COMPILE_MORE_r(
1966                     PerlIO_printf( Perl_debug_log, " base: %d\n",base);
1967                 );
1968                 */
1969                 trie->states[ state ].trans.base=base;
1970             }
1971             trie->lasttrans = tp + 1;
1972         }
1973     } else {
1974         /*
1975            Second Pass -- Flat Table Representation.
1976
1977            we dont use the 0 slot of either trans[] or states[] so we add 1 to each.
1978            We know that we will need Charcount+1 trans at most to store the data
1979            (one row per char at worst case) So we preallocate both structures
1980            assuming worst case.
1981
1982            We then construct the trie using only the .next slots of the entry
1983            structs.
1984
1985            We use the .check field of the first entry of the node temporarily to
1986            make compression both faster and easier by keeping track of how many non
1987            zero fields are in the node.
1988
1989            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
1990            transition.
1991
1992            There are two terms at use here: state as a TRIE_NODEIDX() which is a
1993            number representing the first entry of the node, and state as a
1994            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1) and
1995            TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3) if there
1996            are 2 entrys per node. eg:
1997
1998              A B       A B
1999           1. 2 4    1. 3 7
2000           2. 0 3    3. 0 5
2001           3. 0 0    5. 0 0
2002           4. 0 0    7. 0 0
2003
2004            The table is internally in the right hand, idx form. However as we also
2005            have to deal with the states array which is indexed by nodenum we have to
2006            use TRIE_NODENUM() to convert.
2007
2008         */
2009         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
2010             "%*sCompiling trie using table compiler\n",
2011             (int)depth * 2 + 2, ""));
2012
2013         trie->trans = (reg_trie_trans *)
2014             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
2015                                   * trie->uniquecharcount + 1,
2016                                   sizeof(reg_trie_trans) );
2017         trie->states = (reg_trie_state *)
2018             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2019                                   sizeof(reg_trie_state) );
2020         next_alloc = trie->uniquecharcount + 1;
2021
2022
2023         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2024
2025             regnode *noper   = NEXTOPER( cur );
2026             const U8 *uc     = (U8*)STRING( noper );
2027             const U8 *e      = uc + STR_LEN( noper );
2028
2029             U32 state        = 1;         /* required init */
2030
2031             U16 charid       = 0;         /* sanity init */
2032             U32 accept_state = 0;         /* sanity init */
2033             U8 *scan         = (U8*)NULL; /* sanity init */
2034
2035             STRLEN foldlen   = 0;         /* required init */
2036             U32 wordlen      = 0;         /* required init */
2037             STRLEN skiplen   = 0;
2038             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2039
2040             if (OP(noper) == NOTHING) {
2041                 regnode *noper_next= regnext(noper);
2042                 if (noper_next != tail && OP(noper_next) == flags) {
2043                     noper = noper_next;
2044                     uc= (U8*)STRING(noper);
2045                     e= uc + STR_LEN(noper);
2046                 }
2047             }
2048
2049             if ( OP(noper) != NOTHING ) {
2050                 for ( ; uc < e ; uc += len ) {
2051
2052                     TRIE_READ_CHAR;
2053
2054                     if ( uvc < 256 ) {
2055                         charid = trie->charmap[ uvc ];
2056                     } else {
2057                         SV* const * const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
2058                         charid = svpp ? (U16)SvIV(*svpp) : 0;
2059                     }
2060                     if ( charid ) {
2061                         charid--;
2062                         if ( !trie->trans[ state + charid ].next ) {
2063                             trie->trans[ state + charid ].next = next_alloc;
2064                             trie->trans[ state ].check++;
2065                             prev_states[TRIE_NODENUM(next_alloc)]
2066                                     = TRIE_NODENUM(state);
2067                             next_alloc += trie->uniquecharcount;
2068                         }
2069                         state = trie->trans[ state + charid ].next;
2070                     } else {
2071                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
2072                     }
2073                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
2074                 }
2075             }
2076             accept_state = TRIE_NODENUM( state );
2077             TRIE_HANDLE_WORD(accept_state);
2078
2079         } /* end second pass */
2080
2081         /* and now dump it out before we compress it */
2082         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
2083                                                           revcharmap,
2084                                                           next_alloc, depth+1));
2085
2086         {
2087         /*
2088            * Inplace compress the table.*
2089
2090            For sparse data sets the table constructed by the trie algorithm will
2091            be mostly 0/FAIL transitions or to put it another way mostly empty.
2092            (Note that leaf nodes will not contain any transitions.)
2093
2094            This algorithm compresses the tables by eliminating most such
2095            transitions, at the cost of a modest bit of extra work during lookup:
2096
2097            - Each states[] entry contains a .base field which indicates the
2098            index in the state[] array wheres its transition data is stored.
2099
2100            - If .base is 0 there are no valid transitions from that node.
2101
2102            - If .base is nonzero then charid is added to it to find an entry in
2103            the trans array.
2104
2105            -If trans[states[state].base+charid].check!=state then the
2106            transition is taken to be a 0/Fail transition. Thus if there are fail
2107            transitions at the front of the node then the .base offset will point
2108            somewhere inside the previous nodes data (or maybe even into a node
2109            even earlier), but the .check field determines if the transition is
2110            valid.
2111
2112            XXX - wrong maybe?
2113            The following process inplace converts the table to the compressed
2114            table: We first do not compress the root node 1,and mark all its
2115            .check pointers as 1 and set its .base pointer as 1 as well. This
2116            allows us to do a DFA construction from the compressed table later,
2117            and ensures that any .base pointers we calculate later are greater
2118            than 0.
2119
2120            - We set 'pos' to indicate the first entry of the second node.
2121
2122            - We then iterate over the columns of the node, finding the first and
2123            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
2124            and set the .check pointers accordingly, and advance pos
2125            appropriately and repreat for the next node. Note that when we copy
2126            the next pointers we have to convert them from the original
2127            NODEIDX form to NODENUM form as the former is not valid post
2128            compression.
2129
2130            - If a node has no transitions used we mark its base as 0 and do not
2131            advance the pos pointer.
2132
2133            - If a node only has one transition we use a second pointer into the
2134            structure to fill in allocated fail transitions from other states.
2135            This pointer is independent of the main pointer and scans forward
2136            looking for null transitions that are allocated to a state. When it
2137            finds one it writes the single transition into the "hole".  If the
2138            pointer doesnt find one the single transition is appended as normal.
2139
2140            - Once compressed we can Renew/realloc the structures to release the
2141            excess space.
2142
2143            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
2144            specifically Fig 3.47 and the associated pseudocode.
2145
2146            demq
2147         */
2148         const U32 laststate = TRIE_NODENUM( next_alloc );
2149         U32 state, charid;
2150         U32 pos = 0, zp=0;
2151         trie->statecount = laststate;
2152
2153         for ( state = 1 ; state < laststate ; state++ ) {
2154             U8 flag = 0;
2155             const U32 stateidx = TRIE_NODEIDX( state );
2156             const U32 o_used = trie->trans[ stateidx ].check;
2157             U32 used = trie->trans[ stateidx ].check;
2158             trie->trans[ stateidx ].check = 0;
2159
2160             for ( charid = 0 ; used && charid < trie->uniquecharcount ; charid++ ) {
2161                 if ( flag || trie->trans[ stateidx + charid ].next ) {
2162                     if ( trie->trans[ stateidx + charid ].next ) {
2163                         if (o_used == 1) {
2164                             for ( ; zp < pos ; zp++ ) {
2165                                 if ( ! trie->trans[ zp ].next ) {
2166                                     break;
2167                                 }
2168                             }
2169                             trie->states[ state ].trans.base = zp + trie->uniquecharcount - charid ;
2170                             trie->trans[ zp ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2171                             trie->trans[ zp ].check = state;
2172                             if ( ++zp > pos ) pos = zp;
2173                             break;
2174                         }
2175                         used--;
2176                     }
2177                     if ( !flag ) {
2178                         flag = 1;
2179                         trie->states[ state ].trans.base = pos + trie->uniquecharcount - charid ;
2180                     }
2181                     trie->trans[ pos ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2182                     trie->trans[ pos ].check = state;
2183                     pos++;
2184                 }
2185             }
2186         }
2187         trie->lasttrans = pos + 1;
2188         trie->states = (reg_trie_state *)
2189             PerlMemShared_realloc( trie->states, laststate
2190                                    * sizeof(reg_trie_state) );
2191         DEBUG_TRIE_COMPILE_MORE_r(
2192                 PerlIO_printf( Perl_debug_log,
2193                     "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
2194                     (int)depth * 2 + 2,"",
2195                     (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1 ),
2196                     (IV)next_alloc,
2197                     (IV)pos,
2198                     ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
2199             );
2200
2201         } /* end table compress */
2202     }
2203     DEBUG_TRIE_COMPILE_MORE_r(
2204             PerlIO_printf(Perl_debug_log, "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
2205                 (int)depth * 2 + 2, "",
2206                 (UV)trie->statecount,
2207                 (UV)trie->lasttrans)
2208     );
2209     /* resize the trans array to remove unused space */
2210     trie->trans = (reg_trie_trans *)
2211         PerlMemShared_realloc( trie->trans, trie->lasttrans
2212                                * sizeof(reg_trie_trans) );
2213
2214     {   /* Modify the program and insert the new TRIE node */ 
2215         U8 nodetype =(U8)(flags & 0xFF);
2216         char *str=NULL;
2217         
2218 #ifdef DEBUGGING
2219         regnode *optimize = NULL;
2220 #ifdef RE_TRACK_PATTERN_OFFSETS
2221
2222         U32 mjd_offset = 0;
2223         U32 mjd_nodelen = 0;
2224 #endif /* RE_TRACK_PATTERN_OFFSETS */
2225 #endif /* DEBUGGING */
2226         /*
2227            This means we convert either the first branch or the first Exact,
2228            depending on whether the thing following (in 'last') is a branch
2229            or not and whther first is the startbranch (ie is it a sub part of
2230            the alternation or is it the whole thing.)
2231            Assuming its a sub part we convert the EXACT otherwise we convert
2232            the whole branch sequence, including the first.
2233          */
2234         /* Find the node we are going to overwrite */
2235         if ( first != startbranch || OP( last ) == BRANCH ) {
2236             /* branch sub-chain */
2237             NEXT_OFF( first ) = (U16)(last - first);
2238 #ifdef RE_TRACK_PATTERN_OFFSETS
2239             DEBUG_r({
2240                 mjd_offset= Node_Offset((convert));
2241                 mjd_nodelen= Node_Length((convert));
2242             });
2243 #endif
2244             /* whole branch chain */
2245         }
2246 #ifdef RE_TRACK_PATTERN_OFFSETS
2247         else {
2248             DEBUG_r({
2249                 const  regnode *nop = NEXTOPER( convert );
2250                 mjd_offset= Node_Offset((nop));
2251                 mjd_nodelen= Node_Length((nop));
2252             });
2253         }
2254         DEBUG_OPTIMISE_r(
2255             PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
2256                 (int)depth * 2 + 2, "",
2257                 (UV)mjd_offset, (UV)mjd_nodelen)
2258         );
2259 #endif
2260         /* But first we check to see if there is a common prefix we can 
2261            split out as an EXACT and put in front of the TRIE node.  */
2262         trie->startstate= 1;
2263         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
2264             U32 state;
2265             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
2266                 U32 ofs = 0;
2267                 I32 idx = -1;
2268                 U32 count = 0;
2269                 const U32 base = trie->states[ state ].trans.base;
2270
2271                 if ( trie->states[state].wordnum )
2272                         count = 1;
2273
2274                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2275                     if ( ( base + ofs >= trie->uniquecharcount ) &&
2276                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
2277                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
2278                     {
2279                         if ( ++count > 1 ) {
2280                             SV **tmp = av_fetch( revcharmap, ofs, 0);
2281                             const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
2282                             if ( state == 1 ) break;
2283                             if ( count == 2 ) {
2284                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
2285                                 DEBUG_OPTIMISE_r(
2286                                     PerlIO_printf(Perl_debug_log,
2287                                         "%*sNew Start State=%"UVuf" Class: [",
2288                                         (int)depth * 2 + 2, "",
2289                                         (UV)state));
2290                                 if (idx >= 0) {
2291                                     SV ** const tmp = av_fetch( revcharmap, idx, 0);
2292                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
2293
2294                                     TRIE_BITMAP_SET(trie,*ch);
2295                                     if ( folder )
2296                                         TRIE_BITMAP_SET(trie, folder[ *ch ]);
2297                                     DEBUG_OPTIMISE_r(
2298                                         PerlIO_printf(Perl_debug_log, "%s", (char*)ch)
2299                                     );
2300                                 }
2301                             }
2302                             TRIE_BITMAP_SET(trie,*ch);
2303                             if ( folder )
2304                                 TRIE_BITMAP_SET(trie,folder[ *ch ]);
2305                             DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
2306                         }
2307                         idx = ofs;
2308                     }
2309                 }
2310                 if ( count == 1 ) {
2311                     SV **tmp = av_fetch( revcharmap, idx, 0);
2312                     STRLEN len;
2313                     char *ch = SvPV( *tmp, len );
2314                     DEBUG_OPTIMISE_r({
2315                         SV *sv=sv_newmortal();
2316                         PerlIO_printf( Perl_debug_log,
2317                             "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
2318                             (int)depth * 2 + 2, "",
2319                             (UV)state, (UV)idx, 
2320                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6, 
2321                                 PL_colors[0], PL_colors[1],
2322                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2323                                 PERL_PV_ESCAPE_FIRSTCHAR 
2324                             )
2325                         );
2326                     });
2327                     if ( state==1 ) {
2328                         OP( convert ) = nodetype;
2329                         str=STRING(convert);
2330                         STR_LEN(convert)=0;
2331                     }
2332                     STR_LEN(convert) += len;
2333                     while (len--)
2334                         *str++ = *ch++;
2335                 } else {
2336 #ifdef DEBUGGING            
2337                     if (state>1)
2338                         DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
2339 #endif
2340                     break;
2341                 }
2342             }
2343             trie->prefixlen = (state-1);
2344             if (str) {
2345                 regnode *n = convert+NODE_SZ_STR(convert);
2346                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
2347                 trie->startstate = state;
2348                 trie->minlen -= (state - 1);
2349                 trie->maxlen -= (state - 1);
2350 #ifdef DEBUGGING
2351                /* At least the UNICOS C compiler choked on this
2352                 * being argument to DEBUG_r(), so let's just have
2353                 * it right here. */
2354                if (
2355 #ifdef PERL_EXT_RE_BUILD
2356                    1
2357 #else
2358                    DEBUG_r_TEST
2359 #endif
2360                    ) {
2361                    regnode *fix = convert;
2362                    U32 word = trie->wordcount;
2363                    mjd_nodelen++;
2364                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
2365                    while( ++fix < n ) {
2366                        Set_Node_Offset_Length(fix, 0, 0);
2367                    }
2368                    while (word--) {
2369                        SV ** const tmp = av_fetch( trie_words, word, 0 );
2370                        if (tmp) {
2371                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
2372                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
2373                            else
2374                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
2375                        }
2376                    }
2377                }
2378 #endif
2379                 if (trie->maxlen) {
2380                     convert = n;
2381                 } else {
2382                     NEXT_OFF(convert) = (U16)(tail - convert);
2383                     DEBUG_r(optimize= n);
2384                 }
2385             }
2386         }
2387         if (!jumper) 
2388             jumper = last; 
2389         if ( trie->maxlen ) {
2390             NEXT_OFF( convert ) = (U16)(tail - convert);
2391             ARG_SET( convert, data_slot );
2392             /* Store the offset to the first unabsorbed branch in 
2393                jump[0], which is otherwise unused by the jump logic. 
2394                We use this when dumping a trie and during optimisation. */
2395             if (trie->jump) 
2396                 trie->jump[0] = (U16)(nextbranch - convert);
2397             
2398             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
2399              *   and there is a bitmap
2400              *   and the first "jump target" node we found leaves enough room
2401              * then convert the TRIE node into a TRIEC node, with the bitmap
2402              * embedded inline in the opcode - this is hypothetically faster.
2403              */
2404             if ( !trie->states[trie->startstate].wordnum
2405                  && trie->bitmap
2406                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
2407             {
2408                 OP( convert ) = TRIEC;
2409                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
2410                 PerlMemShared_free(trie->bitmap);
2411                 trie->bitmap= NULL;
2412             } else 
2413                 OP( convert ) = TRIE;
2414
2415             /* store the type in the flags */
2416             convert->flags = nodetype;
2417             DEBUG_r({
2418             optimize = convert 
2419                       + NODE_STEP_REGNODE 
2420                       + regarglen[ OP( convert ) ];
2421             });
2422             /* XXX We really should free up the resource in trie now, 
2423                    as we won't use them - (which resources?) dmq */
2424         }
2425         /* needed for dumping*/
2426         DEBUG_r(if (optimize) {
2427             regnode *opt = convert;
2428
2429             while ( ++opt < optimize) {
2430                 Set_Node_Offset_Length(opt,0,0);
2431             }
2432             /* 
2433                 Try to clean up some of the debris left after the 
2434                 optimisation.
2435              */
2436             while( optimize < jumper ) {
2437                 mjd_nodelen += Node_Length((optimize));
2438                 OP( optimize ) = OPTIMIZED;
2439                 Set_Node_Offset_Length(optimize,0,0);
2440                 optimize++;
2441             }
2442             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
2443         });
2444     } /* end node insert */
2445
2446     /*  Finish populating the prev field of the wordinfo array.  Walk back
2447      *  from each accept state until we find another accept state, and if
2448      *  so, point the first word's .prev field at the second word. If the
2449      *  second already has a .prev field set, stop now. This will be the
2450      *  case either if we've already processed that word's accept state,
2451      *  or that state had multiple words, and the overspill words were
2452      *  already linked up earlier.
2453      */
2454     {
2455         U16 word;
2456         U32 state;
2457         U16 prev;
2458
2459         for (word=1; word <= trie->wordcount; word++) {
2460             prev = 0;
2461             if (trie->wordinfo[word].prev)
2462                 continue;
2463             state = trie->wordinfo[word].accept;
2464             while (state) {
2465                 state = prev_states[state];
2466                 if (!state)
2467                     break;
2468                 prev = trie->states[state].wordnum;
2469                 if (prev)
2470                     break;
2471             }
2472             trie->wordinfo[word].prev = prev;
2473         }
2474         Safefree(prev_states);
2475     }
2476
2477
2478     /* and now dump out the compressed format */
2479     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
2480
2481     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
2482 #ifdef DEBUGGING
2483     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
2484     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
2485 #else
2486     SvREFCNT_dec_NN(revcharmap);
2487 #endif
2488     return trie->jump 
2489            ? MADE_JUMP_TRIE 
2490            : trie->startstate>1 
2491              ? MADE_EXACT_TRIE 
2492              : MADE_TRIE;
2493 }
2494
2495 STATIC void
2496 S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source,  regnode *stclass, U32 depth)
2497 {
2498 /* The Trie is constructed and compressed now so we can build a fail array if it's needed
2499
2500    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
2501    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
2502    ISBN 0-201-10088-6
2503
2504    We find the fail state for each state in the trie, this state is the longest proper
2505    suffix of the current state's 'word' that is also a proper prefix of another word in our
2506    trie. State 1 represents the word '' and is thus the default fail state. This allows
2507    the DFA not to have to restart after its tried and failed a word at a given point, it
2508    simply continues as though it had been matching the other word in the first place.
2509    Consider
2510       'abcdgu'=~/abcdefg|cdgu/
2511    When we get to 'd' we are still matching the first word, we would encounter 'g' which would
2512    fail, which would bring us to the state representing 'd' in the second word where we would
2513    try 'g' and succeed, proceeding to match 'cdgu'.
2514  */
2515  /* add a fail transition */
2516     const U32 trie_offset = ARG(source);
2517     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
2518     U32 *q;
2519     const U32 ucharcount = trie->uniquecharcount;
2520     const U32 numstates = trie->statecount;
2521     const U32 ubound = trie->lasttrans + ucharcount;
2522     U32 q_read = 0;
2523     U32 q_write = 0;
2524     U32 charid;
2525     U32 base = trie->states[ 1 ].trans.base;
2526     U32 *fail;
2527     reg_ac_data *aho;
2528     const U32 data_slot = add_data( pRExC_state, 1, "T" );
2529     GET_RE_DEBUG_FLAGS_DECL;
2530
2531     PERL_ARGS_ASSERT_MAKE_TRIE_FAILTABLE;
2532 #ifndef DEBUGGING
2533     PERL_UNUSED_ARG(depth);
2534 #endif
2535
2536
2537     ARG_SET( stclass, data_slot );
2538     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
2539     RExC_rxi->data->data[ data_slot ] = (void*)aho;
2540     aho->trie=trie_offset;
2541     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
2542     Copy( trie->states, aho->states, numstates, reg_trie_state );
2543     Newxz( q, numstates, U32);
2544     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
2545     aho->refcount = 1;
2546     fail = aho->fail;
2547     /* initialize fail[0..1] to be 1 so that we always have
2548        a valid final fail state */
2549     fail[ 0 ] = fail[ 1 ] = 1;
2550
2551     for ( charid = 0; charid < ucharcount ; charid++ ) {
2552         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
2553         if ( newstate ) {
2554             q[ q_write ] = newstate;
2555             /* set to point at the root */
2556             fail[ q[ q_write++ ] ]=1;
2557         }
2558     }
2559     while ( q_read < q_write) {
2560         const U32 cur = q[ q_read++ % numstates ];
2561         base = trie->states[ cur ].trans.base;
2562
2563         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
2564             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
2565             if (ch_state) {
2566                 U32 fail_state = cur;
2567                 U32 fail_base;
2568                 do {
2569                     fail_state = fail[ fail_state ];
2570                     fail_base = aho->states[ fail_state ].trans.base;
2571                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
2572
2573                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
2574                 fail[ ch_state ] = fail_state;
2575                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
2576                 {
2577                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
2578                 }
2579                 q[ q_write++ % numstates] = ch_state;
2580             }
2581         }
2582     }
2583     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
2584        when we fail in state 1, this allows us to use the
2585        charclass scan to find a valid start char. This is based on the principle
2586        that theres a good chance the string being searched contains lots of stuff
2587        that cant be a start char.
2588      */
2589     fail[ 0 ] = fail[ 1 ] = 0;
2590     DEBUG_TRIE_COMPILE_r({
2591         PerlIO_printf(Perl_debug_log,
2592                       "%*sStclass Failtable (%"UVuf" states): 0", 
2593                       (int)(depth * 2), "", (UV)numstates
2594         );
2595         for( q_read=1; q_read<numstates; q_read++ ) {
2596             PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
2597         }
2598         PerlIO_printf(Perl_debug_log, "\n");
2599     });
2600     Safefree(q);
2601     /*RExC_seen |= REG_SEEN_TRIEDFA;*/
2602 }
2603
2604
2605 /*
2606  * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2607  * These need to be revisited when a newer toolchain becomes available.
2608  */
2609 #if defined(__sparc64__) && defined(__GNUC__)
2610 #   if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2611 #       undef  SPARC64_GCC_WORKAROUND
2612 #       define SPARC64_GCC_WORKAROUND 1
2613 #   endif
2614 #endif
2615
2616 #define DEBUG_PEEP(str,scan,depth) \
2617     DEBUG_OPTIMISE_r({if (scan){ \
2618        SV * const mysv=sv_newmortal(); \
2619        regnode *Next = regnext(scan); \
2620        regprop(RExC_rx, mysv, scan); \
2621        PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
2622        (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
2623        Next ? (REG_NODE_NUM(Next)) : 0 ); \
2624    }});
2625
2626
2627 /* The below joins as many adjacent EXACTish nodes as possible into a single
2628  * one.  The regop may be changed if the node(s) contain certain sequences that
2629  * require special handling.  The joining is only done if:
2630  * 1) there is room in the current conglomerated node to entirely contain the
2631  *    next one.
2632  * 2) they are the exact same node type
2633  *
2634  * The adjacent nodes actually may be separated by NOTHING-kind nodes, and
2635  * these get optimized out
2636  *
2637  * If a node is to match under /i (folded), the number of characters it matches
2638  * can be different than its character length if it contains a multi-character
2639  * fold.  *min_subtract is set to the total delta of the input nodes.
2640  *
2641  * And *has_exactf_sharp_s is set to indicate whether or not the node is EXACTF
2642  * and contains LATIN SMALL LETTER SHARP S
2643  *
2644  * This is as good a place as any to discuss the design of handling these
2645  * multi-character fold sequences.  It's been wrong in Perl for a very long
2646  * time.  There are three code points in Unicode whose multi-character folds
2647  * were long ago discovered to mess things up.  The previous designs for
2648  * dealing with these involved assigning a special node for them.  This
2649  * approach doesn't work, as evidenced by this example:
2650  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
2651  * Both these fold to "sss", but if the pattern is parsed to create a node that
2652  * would match just the \xDF, it won't be able to handle the case where a
2653  * successful match would have to cross the node's boundary.  The new approach
2654  * that hopefully generally solves the problem generates an EXACTFU_SS node
2655  * that is "sss".
2656  *
2657  * It turns out that there are problems with all multi-character folds, and not
2658  * just these three.  Now the code is general, for all such cases, but the
2659  * three still have some special handling.  The approach taken is:
2660  * 1)   This routine examines each EXACTFish node that could contain multi-
2661  *      character fold sequences.  It returns in *min_subtract how much to
2662  *      subtract from the the actual length of the string to get a real minimum
2663  *      match length; it is 0 if there are no multi-char folds.  This delta is
2664  *      used by the caller to adjust the min length of the match, and the delta
2665  *      between min and max, so that the optimizer doesn't reject these
2666  *      possibilities based on size constraints.
2667  * 2)   Certain of these sequences require special handling by the trie code,
2668  *      so, if found, this code changes the joined node type to special ops:
2669  *      EXACTFU_TRICKYFOLD and EXACTFU_SS.
2670  * 3)   For the sequence involving the Sharp s (\xDF), the node type EXACTFU_SS
2671  *      is used for an EXACTFU node that contains at least one "ss" sequence in
2672  *      it.  For non-UTF-8 patterns and strings, this is the only case where
2673  *      there is a possible fold length change.  That means that a regular
2674  *      EXACTFU node without UTF-8 involvement doesn't have to concern itself
2675  *      with length changes, and so can be processed faster.  regexec.c takes
2676  *      advantage of this.  Generally, an EXACTFish node that is in UTF-8 is
2677  *      pre-folded by regcomp.c.  This saves effort in regex matching.
2678  *      However, the pre-folding isn't done for non-UTF8 patterns because the
2679  *      fold of the MICRO SIGN requires UTF-8, and we don't want to slow things
2680  *      down by forcing the pattern into UTF8 unless necessary.  Also what
2681  *      EXACTF and EXACTFL nodes fold to isn't known until runtime.  The fold
2682  *      possibilities for the non-UTF8 patterns are quite simple, except for
2683  *      the sharp s.  All the ones that don't involve a UTF-8 target string are
2684  *      members of a fold-pair, and arrays are set up for all of them so that
2685  *      the other member of the pair can be found quickly.  Code elsewhere in
2686  *      this file makes sure that in EXACTFU nodes, the sharp s gets folded to
2687  *      'ss', even if the pattern isn't UTF-8.  This avoids the issues
2688  *      described in the next item.
2689  * 4)   A problem remains for the sharp s in EXACTF nodes.  Whether it matches
2690  *      'ss' or not is not knowable at compile time.  It will match iff the
2691  *      target string is in UTF-8, unlike the EXACTFU nodes, where it always
2692  *      matches; and the EXACTFL and EXACTFA nodes where it never does.  Thus
2693  *      it can't be folded to "ss" at compile time, unlike EXACTFU does (as
2694  *      described in item 3).  An assumption that the optimizer part of
2695  *      regexec.c (probably unwittingly) makes is that a character in the
2696  *      pattern corresponds to at most a single character in the target string.
2697  *      (And I do mean character, and not byte here, unlike other parts of the
2698  *      documentation that have never been updated to account for multibyte
2699  *      Unicode.)  This assumption is wrong only in this case, as all other
2700  *      cases are either 1-1 folds when no UTF-8 is involved; or is true by
2701  *      virtue of having this file pre-fold UTF-8 patterns.   I'm
2702  *      reluctant to try to change this assumption, so instead the code punts.
2703  *      This routine examines EXACTF nodes for the sharp s, and returns a
2704  *      boolean indicating whether or not the node is an EXACTF node that
2705  *      contains a sharp s.  When it is true, the caller sets a flag that later
2706  *      causes the optimizer in this file to not set values for the floating
2707  *      and fixed string lengths, and thus avoids the optimizer code in
2708  *      regexec.c that makes the invalid assumption.  Thus, there is no
2709  *      optimization based on string lengths for EXACTF nodes that contain the
2710  *      sharp s.  This only happens for /id rules (which means the pattern
2711  *      isn't in UTF-8).
2712  */
2713
2714 #define JOIN_EXACT(scan,min_subtract,has_exactf_sharp_s, flags) \
2715     if (PL_regkind[OP(scan)] == EXACT) \
2716         join_exact(pRExC_state,(scan),(min_subtract),has_exactf_sharp_s, (flags),NULL,depth+1)
2717
2718 STATIC U32
2719 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, UV *min_subtract, bool *has_exactf_sharp_s, U32 flags,regnode *val, U32 depth) {
2720     /* Merge several consecutive EXACTish nodes into one. */
2721     regnode *n = regnext(scan);
2722     U32 stringok = 1;
2723     regnode *next = scan + NODE_SZ_STR(scan);
2724     U32 merged = 0;
2725     U32 stopnow = 0;
2726 #ifdef DEBUGGING
2727     regnode *stop = scan;
2728     GET_RE_DEBUG_FLAGS_DECL;
2729 #else
2730     PERL_UNUSED_ARG(depth);
2731 #endif
2732
2733     PERL_ARGS_ASSERT_JOIN_EXACT;
2734 #ifndef EXPERIMENTAL_INPLACESCAN
2735     PERL_UNUSED_ARG(flags);
2736     PERL_UNUSED_ARG(val);
2737 #endif
2738     DEBUG_PEEP("join",scan,depth);
2739
2740     /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
2741      * EXACT ones that are mergeable to the current one. */
2742     while (n
2743            && (PL_regkind[OP(n)] == NOTHING
2744                || (stringok && OP(n) == OP(scan)))
2745            && NEXT_OFF(n)
2746            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
2747     {
2748         
2749         if (OP(n) == TAIL || n > next)
2750             stringok = 0;
2751         if (PL_regkind[OP(n)] == NOTHING) {
2752             DEBUG_PEEP("skip:",n,depth);
2753             NEXT_OFF(scan) += NEXT_OFF(n);
2754             next = n + NODE_STEP_REGNODE;
2755 #ifdef DEBUGGING
2756             if (stringok)
2757                 stop = n;
2758 #endif
2759             n = regnext(n);
2760         }
2761         else if (stringok) {
2762             const unsigned int oldl = STR_LEN(scan);
2763             regnode * const nnext = regnext(n);
2764
2765             /* XXX I (khw) kind of doubt that this works on platforms where
2766              * U8_MAX is above 255 because of lots of other assumptions */
2767             /* Don't join if the sum can't fit into a single node */
2768             if (oldl + STR_LEN(n) > U8_MAX)
2769                 break;
2770             
2771             DEBUG_PEEP("merg",n,depth);
2772             merged++;
2773
2774             NEXT_OFF(scan) += NEXT_OFF(n);
2775             STR_LEN(scan) += STR_LEN(n);
2776             next = n + NODE_SZ_STR(n);
2777             /* Now we can overwrite *n : */
2778             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
2779 #ifdef DEBUGGING
2780             stop = next - 1;
2781 #endif
2782             n = nnext;
2783             if (stopnow) break;
2784         }
2785
2786 #ifdef EXPERIMENTAL_INPLACESCAN
2787         if (flags && !NEXT_OFF(n)) {
2788             DEBUG_PEEP("atch", val, depth);
2789             if (reg_off_by_arg[OP(n)]) {
2790                 ARG_SET(n, val - n);
2791             }
2792             else {
2793                 NEXT_OFF(n) = val - n;
2794             }
2795             stopnow = 1;
2796         }
2797 #endif
2798     }
2799
2800     *min_subtract = 0;
2801     *has_exactf_sharp_s = FALSE;
2802
2803     /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
2804      * can now analyze for sequences of problematic code points.  (Prior to
2805      * this final joining, sequences could have been split over boundaries, and
2806      * hence missed).  The sequences only happen in folding, hence for any
2807      * non-EXACT EXACTish node */
2808     if (OP(scan) != EXACT) {
2809         const U8 * const s0 = (U8*) STRING(scan);
2810         const U8 * s = s0;
2811         const U8 * const s_end = s0 + STR_LEN(scan);
2812
2813         /* One pass is made over the node's string looking for all the
2814          * possibilities.  to avoid some tests in the loop, there are two main
2815          * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
2816          * non-UTF-8 */
2817         if (UTF) {
2818
2819             /* Examine the string for a multi-character fold sequence.  UTF-8
2820              * patterns have all characters pre-folded by the time this code is
2821              * executed */
2822             while (s < s_end - 1) /* Can stop 1 before the end, as minimum
2823                                      length sequence we are looking for is 2 */
2824             {
2825                 int count = 0;
2826                 int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
2827                 if (! len) {    /* Not a multi-char fold: get next char */
2828                     s += UTF8SKIP(s);
2829                     continue;
2830                 }
2831
2832                 /* Nodes with 'ss' require special handling, except for EXACTFL
2833                  * and EXACTFA for which there is no multi-char fold to this */
2834                 if (len == 2 && *s == 's' && *(s+1) == 's'
2835                     && OP(scan) != EXACTFL && OP(scan) != EXACTFA)
2836                 {
2837                     count = 2;
2838                     OP(scan) = EXACTFU_SS;
2839                     s += 2;
2840                 }
2841                 else if (len == 6   /* len is the same in both ASCII and EBCDIC for these */
2842                          && (memEQ(s, GREEK_SMALL_LETTER_IOTA_UTF8
2843                                       COMBINING_DIAERESIS_UTF8
2844                                       COMBINING_ACUTE_ACCENT_UTF8,
2845                                    6)
2846                              || memEQ(s, GREEK_SMALL_LETTER_UPSILON_UTF8
2847                                          COMBINING_DIAERESIS_UTF8
2848                                          COMBINING_ACUTE_ACCENT_UTF8,
2849                                      6)))
2850                 {
2851                     count = 3;
2852
2853                     /* These two folds require special handling by trie's, so
2854                      * change the node type to indicate this.  If EXACTFA and
2855                      * EXACTFL were ever to be handled by trie's, this would
2856                      * have to be changed.  If this node has already been
2857                      * changed to EXACTFU_SS in this loop, leave it as is.  (I
2858                      * (khw) think it doesn't matter in regexec.c for UTF
2859                      * patterns, but no need to change it */
2860                     if (OP(scan) == EXACTFU) {
2861                         OP(scan) = EXACTFU_TRICKYFOLD;
2862                     }
2863                     s += 6;
2864                 }
2865                 else { /* Here is a generic multi-char fold. */
2866                     const U8* multi_end  = s + len;
2867
2868                     /* Count how many characters in it.  In the case of /l and
2869                      * /aa, no folds which contain ASCII code points are
2870                      * allowed, so check for those, and skip if found.  (In
2871                      * EXACTFL, no folds are allowed to any Latin1 code point,
2872                      * not just ASCII.  But there aren't any of these
2873                      * currently, nor ever likely, so don't take the time to
2874                      * test for them.  The code that generates the
2875                      * is_MULTI_foo() macros croaks should one actually get put
2876                      * into Unicode .) */
2877                     if (OP(scan) != EXACTFL && OP(scan) != EXACTFA) {
2878                         count = utf8_length(s, multi_end);
2879                         s = multi_end;
2880                     }
2881                     else {
2882                         while (s < multi_end) {
2883                             if (isASCII(*s)) {
2884                                 s++;
2885                                 goto next_iteration;
2886                             }
2887                             else {
2888                                 s += UTF8SKIP(s);
2889                             }
2890                             count++;
2891                         }
2892                     }
2893                 }
2894
2895                 /* The delta is how long the sequence is minus 1 (1 is how long
2896                  * the character that folds to the sequence is) */
2897                 *min_subtract += count - 1;
2898             next_iteration: ;
2899             }
2900         }
2901         else if (OP(scan) != EXACTFL && OP(scan) != EXACTFA) {
2902
2903             /* Here, the pattern is not UTF-8.  Look for the multi-char folds
2904              * that are all ASCII.  As in the above case, EXACTFL and EXACTFA
2905              * nodes can't have multi-char folds to this range (and there are
2906              * no existing ones in the upper latin1 range).  In the EXACTF
2907              * case we look also for the sharp s, which can be in the final
2908              * position.  Otherwise we can stop looking 1 byte earlier because
2909              * have to find at least two characters for a multi-fold */
2910             const U8* upper = (OP(scan) == EXACTF) ? s_end : s_end -1;
2911
2912             /* The below is perhaps overboard, but this allows us to save a
2913              * test each time through the loop at the expense of a mask.  This
2914              * is because on both EBCDIC and ASCII machines, 'S' and 's' differ
2915              * by a single bit.  On ASCII they are 32 apart; on EBCDIC, they
2916              * are 64.  This uses an exclusive 'or' to find that bit and then
2917              * inverts it to form a mask, with just a single 0, in the bit
2918              * position where 'S' and 's' differ. */
2919             const U8 S_or_s_mask = (U8) ~ ('S' ^ 's');
2920             const U8 s_masked = 's' & S_or_s_mask;
2921
2922             while (s < upper) {
2923                 int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end);
2924                 if (! len) {    /* Not a multi-char fold. */
2925                     if (*s == LATIN_SMALL_LETTER_SHARP_S && OP(scan) == EXACTF)
2926                     {
2927                         *has_exactf_sharp_s = TRUE;
2928                     }
2929                     s++;
2930                     continue;
2931                 }
2932
2933                 if (len == 2
2934                     && ((*s & S_or_s_mask) == s_masked)
2935                     && ((*(s+1) & S_or_s_mask) == s_masked))
2936                 {
2937
2938                     /* EXACTF nodes need to know that the minimum length
2939                      * changed so that a sharp s in the string can match this
2940                      * ss in the pattern, but they remain EXACTF nodes, as they
2941                      * won't match this unless the target string is is UTF-8,
2942                      * which we don't know until runtime */
2943                     if (OP(scan) != EXACTF) {
2944                         OP(scan) = EXACTFU_SS;
2945                     }
2946                 }
2947
2948                 *min_subtract += len - 1;
2949                 s += len;
2950             }
2951         }
2952     }
2953
2954 #ifdef DEBUGGING
2955     /* Allow dumping but overwriting the collection of skipped
2956      * ops and/or strings with fake optimized ops */
2957     n = scan + NODE_SZ_STR(scan);
2958     while (n <= stop) {
2959         OP(n) = OPTIMIZED;
2960         FLAGS(n) = 0;
2961         NEXT_OFF(n) = 0;
2962         n++;
2963     }
2964 #endif
2965     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
2966     return stopnow;
2967 }
2968
2969 /* REx optimizer.  Converts nodes into quicker variants "in place".
2970    Finds fixed substrings.  */
2971
2972 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
2973    to the position after last scanned or to NULL. */
2974
2975 #define INIT_AND_WITHP \
2976     assert(!and_withp); \
2977     Newx(and_withp,1,struct regnode_charclass_class); \
2978     SAVEFREEPV(and_withp)
2979
2980 /* this is a chain of data about sub patterns we are processing that
2981    need to be handled separately/specially in study_chunk. Its so
2982    we can simulate recursion without losing state.  */
2983 struct scan_frame;
2984 typedef struct scan_frame {
2985     regnode *last;  /* last node to process in this frame */
2986     regnode *next;  /* next node to process when last is reached */
2987     struct scan_frame *prev; /*previous frame*/
2988     I32 stop; /* what stopparen do we use */
2989 } scan_frame;
2990
2991
2992 #define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf)
2993
2994 STATIC I32
2995 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
2996                         I32 *minlenp, I32 *deltap,
2997                         regnode *last,
2998                         scan_data_t *data,
2999                         I32 stopparen,
3000                         U8* recursed,
3001                         struct regnode_charclass_class *and_withp,
3002                         U32 flags, U32 depth)
3003                         /* scanp: Start here (read-write). */
3004                         /* deltap: Write maxlen-minlen here. */
3005                         /* last: Stop before this one. */
3006                         /* data: string data about the pattern */
3007                         /* stopparen: treat close N as END */
3008                         /* recursed: which subroutines have we recursed into */
3009                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
3010 {
3011     dVAR;
3012     I32 min = 0;    /* There must be at least this number of characters to match */
3013     I32 pars = 0, code;
3014     regnode *scan = *scanp, *next;
3015     I32 delta = 0;
3016     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
3017     int is_inf_internal = 0;            /* The studied chunk is infinite */
3018     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
3019     scan_data_t data_fake;
3020     SV *re_trie_maxbuff = NULL;
3021     regnode *first_non_open = scan;
3022     I32 stopmin = I32_MAX;
3023     scan_frame *frame = NULL;
3024     GET_RE_DEBUG_FLAGS_DECL;
3025
3026     PERL_ARGS_ASSERT_STUDY_CHUNK;
3027
3028 #ifdef DEBUGGING
3029     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
3030 #endif
3031
3032     if ( depth == 0 ) {
3033         while (first_non_open && OP(first_non_open) == OPEN)
3034             first_non_open=regnext(first_non_open);
3035     }
3036
3037
3038   fake_study_recurse:
3039     while ( scan && OP(scan) != END && scan < last ){
3040         UV min_subtract = 0;    /* How mmany chars to subtract from the minimum
3041                                    node length to get a real minimum (because
3042                                    the folded version may be shorter) */
3043         bool has_exactf_sharp_s = FALSE;
3044         /* Peephole optimizer: */
3045         DEBUG_STUDYDATA("Peep:", data,depth);
3046         DEBUG_PEEP("Peep",scan,depth);
3047
3048         /* Its not clear to khw or hv why this is done here, and not in the
3049          * clauses that deal with EXACT nodes.  khw's guess is that it's
3050          * because of a previous design */
3051         JOIN_EXACT(scan,&min_subtract, &has_exactf_sharp_s, 0);
3052
3053         /* Follow the next-chain of the current node and optimize
3054            away all the NOTHINGs from it.  */
3055         if (OP(scan) != CURLYX) {
3056             const int max = (reg_off_by_arg[OP(scan)]
3057                        ? I32_MAX
3058                        /* I32 may be smaller than U16 on CRAYs! */
3059                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
3060             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
3061             int noff;
3062             regnode *n = scan;
3063
3064             /* Skip NOTHING and LONGJMP. */
3065             while ((n = regnext(n))
3066                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
3067                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
3068                    && off + noff < max)
3069                 off += noff;
3070             if (reg_off_by_arg[OP(scan)])
3071                 ARG(scan) = off;
3072             else
3073                 NEXT_OFF(scan) = off;
3074         }
3075
3076
3077
3078         /* The principal pseudo-switch.  Cannot be a switch, since we
3079            look into several different things.  */
3080         if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
3081                    || OP(scan) == IFTHEN) {
3082             next = regnext(scan);
3083             code = OP(scan);
3084             /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
3085
3086             if (OP(next) == code || code == IFTHEN) {
3087                 /* NOTE - There is similar code to this block below for handling
3088                    TRIE nodes on a re-study.  If you change stuff here check there
3089                    too. */
3090                 I32 max1 = 0, min1 = I32_MAX, num = 0;
3091                 struct regnode_charclass_class accum;
3092                 regnode * const startbranch=scan;
3093
3094                 if (flags & SCF_DO_SUBSTR)
3095                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
3096                 if (flags & SCF_DO_STCLASS)
3097                     cl_init_zero(pRExC_state, &accum);
3098
3099                 while (OP(scan) == code) {
3100                     I32 deltanext, minnext, f = 0, fake;
3101                     struct regnode_charclass_class this_class;
3102
3103                     num++;
3104                     data_fake.flags = 0;
3105                     if (data) {
3106                         data_fake.whilem_c = data->whilem_c;
3107                         data_fake.last_closep = data->last_closep;
3108                     }
3109                     else
3110                         data_fake.last_closep = &fake;
3111
3112                     data_fake.pos_delta = delta;
3113                     next = regnext(scan);
3114                     scan = NEXTOPER(scan);
3115                     if (code != BRANCH)
3116                         scan = NEXTOPER(scan);
3117                     if (flags & SCF_DO_STCLASS) {
3118                         cl_init(pRExC_state, &this_class);
3119                         data_fake.start_class = &this_class;
3120                         f = SCF_DO_STCLASS_AND;
3121                     }
3122                     if (flags & SCF_WHILEM_VISITED_POS)
3123                         f |= SCF_WHILEM_VISITED_POS;
3124
3125                     /* we suppose the run is continuous, last=next...*/
3126                     minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
3127                                           next, &data_fake,
3128                                           stopparen, recursed, NULL, f,depth+1);
3129                     if (min1 > minnext)
3130                         min1 = minnext;
3131                     if (deltanext == I32_MAX) {
3132                         is_inf = is_inf_internal = 1;
3133                         max1 = I32_MAX;
3134                     } else if (max1 < minnext + deltanext)
3135                         max1 = minnext + deltanext;
3136                     scan = next;
3137                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3138                         pars++;
3139                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
3140                         if ( stopmin > minnext) 
3141                             stopmin = min + min1;
3142                         flags &= ~SCF_DO_SUBSTR;
3143                         if (data)
3144                             data->flags |= SCF_SEEN_ACCEPT;
3145                     }
3146                     if (data) {
3147                         if (data_fake.flags & SF_HAS_EVAL)
3148                             data->flags |= SF_HAS_EVAL;
3149                         data->whilem_c = data_fake.whilem_c;
3150                     }
3151                     if (flags & SCF_DO_STCLASS)
3152                         cl_or(pRExC_state, &accum, &this_class);
3153                 }
3154                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
3155                     min1 = 0;
3156                 if (flags & SCF_DO_SUBSTR) {
3157                     data->pos_min += min1;
3158                     if (data->pos_delta >= I32_MAX - (max1 - min1))
3159                         data->pos_delta = I32_MAX;
3160                     else
3161                         data->pos_delta += max1 - min1;
3162                     if (max1 != min1 || is_inf)
3163                         data->longest = &(data->longest_float);
3164                 }
3165                 min += min1;
3166                 if (delta == I32_MAX || I32_MAX - delta - (max1 - min1) < 0)
3167                     delta = I32_MAX;
3168                 else
3169                     delta += max1 - min1;
3170                 if (flags & SCF_DO_STCLASS_OR) {
3171                     cl_or(pRExC_state, data->start_class, &accum);
3172                     if (min1) {
3173                         cl_and(data->start_class, and_withp);
3174                         flags &= ~SCF_DO_STCLASS;
3175                     }
3176                 }
3177                 else if (flags & SCF_DO_STCLASS_AND) {
3178                     if (min1) {
3179                         cl_and(data->start_class, &accum);
3180                         flags &= ~SCF_DO_STCLASS;
3181                     }
3182                     else {
3183                         /* Switch to OR mode: cache the old value of
3184                          * data->start_class */
3185                         INIT_AND_WITHP;
3186                         StructCopy(data->start_class, and_withp,
3187                                    struct regnode_charclass_class);
3188                         flags &= ~SCF_DO_STCLASS_AND;
3189                         StructCopy(&accum, data->start_class,
3190                                    struct regnode_charclass_class);
3191                         flags |= SCF_DO_STCLASS_OR;
3192                         SET_SSC_EOS(data->start_class);
3193                     }
3194                 }
3195
3196                 if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) == BRANCH ) {
3197                 /* demq.
3198
3199                    Assuming this was/is a branch we are dealing with: 'scan' now
3200                    points at the item that follows the branch sequence, whatever
3201                    it is. We now start at the beginning of the sequence and look
3202                    for subsequences of
3203
3204                    BRANCH->EXACT=>x1
3205                    BRANCH->EXACT=>x2
3206                    tail
3207
3208                    which would be constructed from a pattern like /A|LIST|OF|WORDS/
3209
3210                    If we can find such a subsequence we need to turn the first
3211                    element into a trie and then add the subsequent branch exact
3212                    strings to the trie.
3213
3214                    We have two cases
3215
3216                      1. patterns where the whole set of branches can be converted. 
3217
3218                      2. patterns where only a subset can be converted.
3219
3220                    In case 1 we can replace the whole set with a single regop
3221                    for the trie. In case 2 we need to keep the start and end
3222                    branches so
3223
3224                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
3225                      becomes BRANCH TRIE; BRANCH X;
3226
3227                   There is an additional case, that being where there is a 
3228                   common prefix, which gets split out into an EXACT like node
3229                   preceding the TRIE node.
3230
3231                   If x(1..n)==tail then we can do a simple trie, if not we make
3232                   a "jump" trie, such that when we match the appropriate word
3233                   we "jump" to the appropriate tail node. Essentially we turn
3234                   a nested if into a case structure of sorts.
3235
3236                 */
3237
3238                     int made=0;
3239                     if (!re_trie_maxbuff) {
3240                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
3241                         if (!SvIOK(re_trie_maxbuff))
3242                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
3243                     }
3244                     if ( SvIV(re_trie_maxbuff)>=0  ) {
3245                         regnode *cur;
3246                         regnode *first = (regnode *)NULL;
3247                         regnode *last = (regnode *)NULL;
3248                         regnode *tail = scan;
3249                         U8 trietype = 0;
3250                         U32 count=0;
3251
3252 #ifdef DEBUGGING
3253                         SV * const mysv = sv_newmortal();       /* for dumping */
3254 #endif
3255                         /* var tail is used because there may be a TAIL
3256                            regop in the way. Ie, the exacts will point to the
3257                            thing following the TAIL, but the last branch will
3258                            point at the TAIL. So we advance tail. If we
3259                            have nested (?:) we may have to move through several
3260                            tails.
3261                          */
3262
3263                         while ( OP( tail ) == TAIL ) {
3264                             /* this is the TAIL generated by (?:) */
3265                             tail = regnext( tail );
3266                         }
3267
3268                         
3269                         DEBUG_TRIE_COMPILE_r({
3270                             regprop(RExC_rx, mysv, tail );
3271                             PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
3272                                 (int)depth * 2 + 2, "", 
3273                                 "Looking for TRIE'able sequences. Tail node is: ", 
3274                                 SvPV_nolen_const( mysv )
3275                             );
3276                         });
3277                         
3278                         /*
3279
3280                             Step through the branches
3281                                 cur represents each branch,
3282                                 noper is the first thing to be matched as part of that branch
3283                                 noper_next is the regnext() of that node.
3284
3285                             We normally handle a case like this /FOO[xyz]|BAR[pqr]/
3286                             via a "jump trie" but we also support building with NOJUMPTRIE,
3287                             which restricts the trie logic to structures like /FOO|BAR/.
3288
3289                             If noper is a trieable nodetype then the branch is a possible optimization
3290                             target. If we are building under NOJUMPTRIE then we require that noper_next
3291                             is the same as scan (our current position in the regex program).
3292
3293                             Once we have two or more consecutive such branches we can create a
3294                             trie of the EXACT's contents and stitch it in place into the program.
3295
3296                             If the sequence represents all of the branches in the alternation we
3297                             replace the entire thing with a single TRIE node.
3298
3299                             Otherwise when it is a subsequence we need to stitch it in place and
3300                             replace only the relevant branches. This means the first branch has
3301                             to remain as it is used by the alternation logic, and its next pointer,
3302                             and needs to be repointed at the item on the branch chain following
3303                             the last branch we have optimized away.
3304
3305                             This could be either a BRANCH, in which case the subsequence is internal,
3306                             or it could be the item following the branch sequence in which case the
3307                             subsequence is at the end (which does not necessarily mean the first node
3308                             is the start of the alternation).
3309
3310                             TRIE_TYPE(X) is a define which maps the optype to a trietype.
3311
3312                                 optype          |  trietype
3313                                 ----------------+-----------
3314                                 NOTHING         | NOTHING
3315                                 EXACT           | EXACT
3316                                 EXACTFU         | EXACTFU
3317                                 EXACTFU_SS      | EXACTFU
3318                                 EXACTFU_TRICKYFOLD | EXACTFU
3319                                 EXACTFA         | 0
3320
3321
3322                         */
3323 #define TRIE_TYPE(X) ( ( NOTHING == (X) ) ? NOTHING :   \
3324                        ( EXACT == (X) )   ? EXACT :        \
3325                        ( EXACTFU == (X) || EXACTFU_SS == (X) || EXACTFU_TRICKYFOLD == (X) ) ? EXACTFU :        \
3326                        0 )
3327
3328                         /* dont use tail as the end marker for this traverse */
3329                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
3330                             regnode * const noper = NEXTOPER( cur );
3331                             U8 noper_type = OP( noper );
3332                             U8 noper_trietype = TRIE_TYPE( noper_type );
3333 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
3334                             regnode * const noper_next = regnext( noper );
3335                             U8 noper_next_type = (noper_next && noper_next != tail) ? OP(noper_next) : 0;
3336                             U8 noper_next_trietype = (noper_next && noper_next != tail) ? TRIE_TYPE( noper_next_type ) :0;
3337 #endif
3338
3339                             DEBUG_TRIE_COMPILE_r({
3340                                 regprop(RExC_rx, mysv, cur);
3341                                 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
3342                                    (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
3343
3344                                 regprop(RExC_rx, mysv, noper);
3345                                 PerlIO_printf( Perl_debug_log, " -> %s",
3346                                     SvPV_nolen_const(mysv));
3347
3348                                 if ( noper_next ) {
3349                                   regprop(RExC_rx, mysv, noper_next );
3350                                   PerlIO_printf( Perl_debug_log,"\t=> %s\t",
3351                                     SvPV_nolen_const(mysv));
3352                                 }
3353                                 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d,tt==%s,nt==%s,nnt==%s)\n",
3354                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
3355                                    PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype] 
3356                                 );
3357                             });
3358
3359                             /* Is noper a trieable nodetype that can be merged with the
3360                              * current trie (if there is one)? */
3361                             if ( noper_trietype
3362                                   &&
3363                                   (
3364                                         ( noper_trietype == NOTHING)
3365                                         || ( trietype == NOTHING )
3366                                         || ( trietype == noper_trietype )
3367                                   )
3368 #ifdef NOJUMPTRIE
3369                                   && noper_next == tail
3370 #endif
3371                                   && count < U16_MAX)
3372                             {
3373                                 /* Handle mergable triable node
3374                                  * Either we are the first node in a new trieable sequence,
3375                                  * in which case we do some bookkeeping, otherwise we update
3376                                  * the end pointer. */
3377                                 if ( !first ) {
3378                                     first = cur;
3379                                     if ( noper_trietype == NOTHING ) {
3380 #if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
3381                                         regnode * const noper_next = regnext( noper );
3382                                         U8 noper_next_type = (noper_next && noper_next!=tail) ? OP(noper_next) : 0;
3383                                         U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
3384 #endif
3385
3386                                         if ( noper_next_trietype ) {
3387                                             trietype = noper_next_trietype;
3388                                         } else if (noper_next_type)  {
3389                                             /* a NOTHING regop is 1 regop wide. We need at least two
3390                                              * for a trie so we can't merge this in */
3391                                             first = NULL;
3392                                         }
3393                                     } else {
3394                                         trietype = noper_trietype;
3395                                     }
3396                                 } else {
3397                                     if ( trietype == NOTHING )
3398                                         trietype = noper_trietype;
3399                                     last = cur;
3400                                 }
3401                                 if (first)
3402                                     count++;
3403                             } /* end handle mergable triable node */
3404                             else {
3405                                 /* handle unmergable node -
3406                                  * noper may either be a triable node which can not be tried
3407                                  * together with the current trie, or a non triable node */
3408                                 if ( last ) {
3409                                     /* If last is set and trietype is not NOTHING then we have found
3410                                      * at least two triable branch sequences in a row of a similar
3411                                      * trietype so we can turn them into a trie. If/when we
3412                                      * allow NOTHING to start a trie sequence this condition will be
3413                                      * required, and it isn't expensive so we leave it in for now. */
3414                                     if ( trietype && trietype != NOTHING )
3415                                         make_trie( pRExC_state,
3416                                                 startbranch, first, cur, tail, count,
3417                                                 trietype, depth+1 );
3418                                     last = NULL; /* note: we clear/update first, trietype etc below, so we dont do it here */
3419                                 }
3420                                 if ( noper_trietype
3421 #ifdef NOJUMPTRIE
3422                                      && noper_next == tail
3423 #endif
3424                                 ){
3425                                     /* noper is triable, so we can start a new trie sequence */
3426                                     count = 1;
3427                                     first = cur;
3428                                     trietype = noper_trietype;
3429                                 } else if (first) {
3430                                     /* if we already saw a first but the current node is not triable then we have
3431                                      * to reset the first information. */
3432                                     count = 0;
3433                                     first = NULL;
3434                                     trietype = 0;
3435                                 }
3436                             } /* end handle unmergable node */
3437                         } /* loop over branches */
3438                         DEBUG_TRIE_COMPILE_r({
3439                             regprop(RExC_rx, mysv, cur);
3440                             PerlIO_printf( Perl_debug_log,
3441                               "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
3442                               "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3443
3444                         });
3445                         if ( last && trietype ) {
3446                             if ( trietype != NOTHING ) {
3447                                 /* the last branch of the sequence was part of a trie,
3448                                  * so we have to construct it here outside of the loop
3449                                  */
3450                                 made= make_trie( pRExC_state, startbranch, first, scan, tail, count, trietype, depth+1 );
3451 #ifdef TRIE_STUDY_OPT
3452                                 if ( ((made == MADE_EXACT_TRIE &&
3453                                      startbranch == first)
3454                                      || ( first_non_open == first )) &&
3455                                      depth==0 ) {
3456                                     flags |= SCF_TRIE_RESTUDY;
3457                                     if ( startbranch == first
3458                                          && scan == tail )
3459                                     {
3460                                         RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
3461                                     }
3462                                 }
3463 #endif
3464                             } else {
3465                                 /* at this point we know whatever we have is a NOTHING sequence/branch
3466                                  * AND if 'startbranch' is 'first' then we can turn the whole thing into a NOTHING
3467                                  */
3468                                 if ( startbranch == first ) {
3469                                     regnode *opt;
3470                                     /* the entire thing is a NOTHING sequence, something like this:
3471                                      * (?:|) So we can turn it into a plain NOTHING op. */
3472                                     DEBUG_TRIE_COMPILE_r({
3473                                         regprop(RExC_rx, mysv, cur);
3474                                         PerlIO_printf( Perl_debug_log,
3475                                           "%*s- %s (%d) <NOTHING BRANCH SEQUENCE>\n", (int)depth * 2 + 2,
3476                                           "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3477
3478                                     });
3479                                     OP(startbranch)= NOTHING;
3480                                     NEXT_OFF(startbranch)= tail - startbranch;
3481                                     for ( opt= startbranch + 1; opt < tail ; opt++ )
3482                                         OP(opt)= OPTIMIZED;
3483                                 }
3484                             }
3485                         } /* end if ( last) */
3486                     } /* TRIE_MAXBUF is non zero */
3487                     
3488                 } /* do trie */
3489                 
3490             }
3491             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
3492                 scan = NEXTOPER(NEXTOPER(scan));
3493             } else                      /* single branch is optimized. */
3494                 scan = NEXTOPER(scan);
3495             continue;
3496         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
3497             scan_frame *newframe = NULL;
3498             I32 paren;
3499             regnode *start;
3500             regnode *end;
3501
3502             if (OP(scan) != SUSPEND) {
3503             /* set the pointer */
3504                 if (OP(scan) == GOSUB) {
3505                     paren = ARG(scan);
3506                     RExC_recurse[ARG2L(scan)] = scan;
3507                     start = RExC_open_parens[paren-1];
3508                     end   = RExC_close_parens[paren-1];
3509                 } else {
3510                     paren = 0;
3511                     start = RExC_rxi->program + 1;
3512                     end   = RExC_opend;
3513                 }
3514                 if (!recursed) {
3515                     Newxz(recursed, (((RExC_npar)>>3) +1), U8);
3516                     SAVEFREEPV(recursed);
3517                 }
3518                 if (!PAREN_TEST(recursed,paren+1)) {
3519                     PAREN_SET(recursed,paren+1);
3520                     Newx(newframe,1,scan_frame);
3521                 } else {
3522                     if (flags & SCF_DO_SUBSTR) {
3523                         SCAN_COMMIT(pRExC_state,data,minlenp);
3524                         data->longest = &(data->longest_float);
3525                     }
3526                     is_inf = is_inf_internal = 1;
3527                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3528                         cl_anything(pRExC_state, data->start_class);
3529                     flags &= ~SCF_DO_STCLASS;
3530                 }
3531             } else {
3532                 Newx(newframe,1,scan_frame);
3533                 paren = stopparen;
3534                 start = scan+2;
3535                 end = regnext(scan);
3536             }
3537             if (newframe) {
3538                 assert(start);
3539                 assert(end);
3540                 SAVEFREEPV(newframe);
3541                 newframe->next = regnext(scan);
3542                 newframe->last = last;
3543                 newframe->stop = stopparen;
3544                 newframe->prev = frame;
3545
3546                 frame = newframe;
3547                 scan =  start;
3548                 stopparen = paren;
3549                 last = end;
3550
3551                 continue;
3552             }
3553         }
3554         else if (OP(scan) == EXACT) {
3555             I32 l = STR_LEN(scan);
3556             UV uc;
3557             if (UTF) {
3558                 const U8 * const s = (U8*)STRING(scan);
3559                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
3560                 l = utf8_length(s, s + l);
3561             } else {
3562                 uc = *((U8*)STRING(scan));
3563             }
3564             min += l;
3565             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
3566                 /* The code below prefers earlier match for fixed
3567                    offset, later match for variable offset.  */
3568                 if (data->last_end == -1) { /* Update the start info. */
3569                     data->last_start_min = data->pos_min;
3570                     data->last_start_max = is_inf
3571                         ? I32_MAX : data->pos_min + data->pos_delta;
3572                 }
3573                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
3574                 if (UTF)
3575                     SvUTF8_on(data->last_found);
3576                 {
3577                     SV * const sv = data->last_found;
3578                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3579                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
3580                     if (mg && mg->mg_len >= 0)
3581                         mg->mg_len += utf8_length((U8*)STRING(scan),
3582                                                   (U8*)STRING(scan)+STR_LEN(scan));
3583                 }
3584                 data->last_end = data->pos_min + l;
3585                 data->pos_min += l; /* As in the first entry. */
3586                 data->flags &= ~SF_BEFORE_EOL;
3587             }
3588             if (flags & SCF_DO_STCLASS_AND) {
3589                 /* Check whether it is compatible with what we know already! */
3590                 int compat = 1;
3591
3592
3593                 /* If compatible, we or it in below.  It is compatible if is
3594                  * in the bitmp and either 1) its bit or its fold is set, or 2)
3595                  * it's for a locale.  Even if there isn't unicode semantics
3596                  * here, at runtime there may be because of matching against a
3597                  * utf8 string, so accept a possible false positive for
3598                  * latin1-range folds */
3599                 if (uc >= 0x100 ||
3600                     (!(data->start_class->flags & ANYOF_LOCALE)
3601                     && !ANYOF_BITMAP_TEST(data->start_class, uc)
3602                     && (!(data->start_class->flags & ANYOF_LOC_FOLD)
3603                         || !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3604                     )
3605                 {
3606                     compat = 0;
3607                 }
3608                 ANYOF_CLASS_ZERO(data->start_class);
3609                 ANYOF_BITMAP_ZERO(data->start_class);
3610                 if (compat)
3611                     ANYOF_BITMAP_SET(data->start_class, uc);
3612                 else if (uc >= 0x100) {
3613                     int i;
3614
3615                     /* Some Unicode code points fold to the Latin1 range; as
3616                      * XXX temporary code, instead of figuring out if this is
3617                      * one, just assume it is and set all the start class bits
3618                      * that could be some such above 255 code point's fold
3619                      * which will generate fals positives.  As the code
3620                      * elsewhere that does compute the fold settles down, it
3621                      * can be extracted out and re-used here */
3622                     for (i = 0; i < 256; i++){
3623                         if (HAS_NONLATIN1_FOLD_CLOSURE(i)) {
3624                             ANYOF_BITMAP_SET(data->start_class, i);
3625                         }
3626                     }
3627                 }
3628                 CLEAR_SSC_EOS(data->start_class);
3629                 if (uc < 0x100)
3630                   data->start_class->flags &= ~ANYOF_UNICODE_ALL;
3631             }
3632             else if (flags & SCF_DO_STCLASS_OR) {
3633                 /* false positive possible if the class is case-folded */
3634                 if (uc < 0x100)
3635                     ANYOF_BITMAP_SET(data->start_class, uc);
3636                 else
3637                     data->start_class->flags |= ANYOF_UNICODE_ALL;
3638                 CLEAR_SSC_EOS(data->start_class);
3639                 cl_and(data->start_class, and_withp);
3640             }
3641             flags &= ~SCF_DO_STCLASS;
3642         }
3643         else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
3644             I32 l = STR_LEN(scan);
3645             UV uc = *((U8*)STRING(scan));
3646
3647             /* Search for fixed substrings supports EXACT only. */
3648             if (flags & SCF_DO_SUBSTR) {
3649                 assert(data);
3650                 SCAN_COMMIT(pRExC_state, data, minlenp);
3651             }
3652             if (UTF) {
3653                 const U8 * const s = (U8 *)STRING(scan);
3654                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
3655                 l = utf8_length(s, s + l);
3656             }
3657             if (has_exactf_sharp_s) {
3658                 RExC_seen |= REG_SEEN_EXACTF_SHARP_S;
3659             }
3660             min += l - min_subtract;
3661             assert (min >= 0);
3662             delta += min_subtract;
3663             if (flags & SCF_DO_SUBSTR) {
3664                 data->pos_min += l - min_subtract;
3665                 if (data->pos_min < 0) {
3666                     data->pos_min = 0;
3667                 }
3668                 data->pos_delta += min_subtract;
3669                 if (min_subtract) {
3670                     data->longest = &(data->longest_float);
3671                 }
3672             }
3673             if (flags & SCF_DO_STCLASS_AND) {
3674                 /* Check whether it is compatible with what we know already! */
3675                 int compat = 1;
3676                 if (uc >= 0x100 ||
3677                  (!(data->start_class->flags & ANYOF_LOCALE)
3678                   && !ANYOF_BITMAP_TEST(data->start_class, uc)
3679                   && !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3680                 {
3681                     compat = 0;
3682                 }
3683                 ANYOF_CLASS_ZERO(data->start_class);
3684                 ANYOF_BITMAP_ZERO(data->start_class);
3685                 if (compat) {
3686                     ANYOF_BITMAP_SET(data->start_class, uc);
3687                     CLEAR_SSC_EOS(data->start_class);
3688                     if (OP(scan) == EXACTFL) {
3689                         /* XXX This set is probably no longer necessary, and
3690                          * probably wrong as LOCALE now is on in the initial
3691                          * state */
3692                         data->start_class->flags |= ANYOF_LOCALE|ANYOF_LOC_FOLD;
3693                     }
3694                     else {
3695
3696                         /* Also set the other member of the fold pair.  In case
3697                          * that unicode semantics is called for at runtime, use
3698                          * the full latin1 fold.  (Can't do this for locale,
3699                          * because not known until runtime) */
3700                         ANYOF_BITMAP_SET(data->start_class, PL_fold_latin1[uc]);
3701
3702                         /* All other (EXACTFL handled above) folds except under
3703                          * /iaa that include s, S, and sharp_s also may include
3704                          * the others */
3705                         if (OP(scan) != EXACTFA) {
3706                             if (uc == 's' || uc == 'S') {
3707                                 ANYOF_BITMAP_SET(data->start_class,
3708                                                  LATIN_SMALL_LETTER_SHARP_S);
3709                             }
3710                             else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3711                                 ANYOF_BITMAP_SET(data->start_class, 's');
3712                                 ANYOF_BITMAP_SET(data->start_class, 'S');
3713                             }
3714                         }
3715                     }
3716                 }
3717                 else if (uc >= 0x100) {
3718                     int i;
3719                     for (i = 0; i < 256; i++){
3720                         if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3721                             ANYOF_BITMAP_SET(data->start_class, i);
3722                         }
3723                     }
3724                 }
3725             }
3726             else if (flags & SCF_DO_STCLASS_OR) {
3727                 if (data->start_class->flags & ANYOF_LOC_FOLD) {
3728                     /* false positive possible if the class is case-folded.
3729                        Assume that the locale settings are the same... */
3730                     if (uc < 0x100) {
3731                         ANYOF_BITMAP_SET(data->start_class, uc);
3732                         if (OP(scan) != EXACTFL) {
3733
3734                             /* And set the other member of the fold pair, but
3735                              * can't do that in locale because not known until
3736                              * run-time */
3737                             ANYOF_BITMAP_SET(data->start_class,
3738                                              PL_fold_latin1[uc]);
3739
3740                             /* All folds except under /iaa that include s, S,
3741                              * and sharp_s also may include the others */
3742                             if (OP(scan) != EXACTFA) {
3743                                 if (uc == 's' || uc == 'S') {
3744                                     ANYOF_BITMAP_SET(data->start_class,
3745                                                    LATIN_SMALL_LETTER_SHARP_S);
3746                                 }
3747                                 else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3748                                     ANYOF_BITMAP_SET(data->start_class, 's');
3749                                     ANYOF_BITMAP_SET(data->start_class, 'S');
3750                                 }
3751                             }
3752                         }
3753                     }
3754                     CLEAR_SSC_EOS(data->start_class);
3755                 }
3756                 cl_and(data->start_class, and_withp);
3757             }
3758             flags &= ~SCF_DO_STCLASS;
3759         }
3760         else if (REGNODE_VARIES(OP(scan))) {
3761             I32 mincount, maxcount, minnext, deltanext, fl = 0;
3762             I32 f = flags, pos_before = 0;
3763             regnode * const oscan = scan;
3764             struct regnode_charclass_class this_class;
3765             struct regnode_charclass_class *oclass = NULL;
3766             I32 next_is_eval = 0;
3767
3768             switch (PL_regkind[OP(scan)]) {
3769             case WHILEM:                /* End of (?:...)* . */
3770                 scan = NEXTOPER(scan);
3771                 goto finish;
3772             case PLUS:
3773                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
3774                     next = NEXTOPER(scan);
3775                     if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
3776                         mincount = 1;
3777                         maxcount = REG_INFTY;
3778                         next = regnext(scan);
3779                         scan = NEXTOPER(scan);
3780                         goto do_curly;
3781                     }
3782                 }
3783                 if (flags & SCF_DO_SUBSTR)
3784                     data->pos_min++;
3785                 min++;
3786                 /* Fall through. */
3787             case STAR:
3788                 if (flags & SCF_DO_STCLASS) {
3789                     mincount = 0;
3790                     maxcount = REG_INFTY;
3791                     next = regnext(scan);
3792                     scan = NEXTOPER(scan);
3793                     goto do_curly;
3794                 }
3795                 is_inf = is_inf_internal = 1;
3796                 scan = regnext(scan);
3797                 if (flags & SCF_DO_SUBSTR) {
3798                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
3799                     data->longest = &(data->longest_float);
3800                 }
3801                 goto optimize_curly_tail;
3802             case CURLY:
3803                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
3804                     && (scan->flags == stopparen))
3805                 {
3806                     mincount = 1;
3807                     maxcount = 1;
3808                 } else {
3809                     mincount = ARG1(scan);
3810                     maxcount = ARG2(scan);
3811                 }
3812                 next = regnext(scan);
3813                 if (OP(scan) == CURLYX) {
3814                     I32 lp = (data ? *(data->last_closep) : 0);
3815                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
3816                 }
3817                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3818                 next_is_eval = (OP(scan) == EVAL);
3819               do_curly:
3820                 if (flags & SCF_DO_SUBSTR) {
3821                     if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
3822                     pos_before = data->pos_min;
3823                 }
3824                 if (data) {
3825                     fl = data->flags;
3826                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
3827                     if (is_inf)
3828                         data->flags |= SF_IS_INF;
3829                 }
3830                 if (flags & SCF_DO_STCLASS) {
3831                     cl_init(pRExC_state, &this_class);
3832                     oclass = data->start_class;
3833                     data->start_class = &this_class;
3834                     f |= SCF_DO_STCLASS_AND;
3835                     f &= ~SCF_DO_STCLASS_OR;
3836                 }
3837                 /* Exclude from super-linear cache processing any {n,m}
3838                    regops for which the combination of input pos and regex
3839                    pos is not enough information to determine if a match
3840                    will be possible.
3841
3842                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
3843                    regex pos at the \s*, the prospects for a match depend not
3844                    only on the input position but also on how many (bar\s*)
3845                    repeats into the {4,8} we are. */
3846                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
3847                     f &= ~SCF_WHILEM_VISITED_POS;
3848
3849                 /* This will finish on WHILEM, setting scan, or on NULL: */
3850                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, 
3851                                       last, data, stopparen, recursed, NULL,
3852                                       (mincount == 0
3853                                         ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
3854
3855                 if (flags & SCF_DO_STCLASS)
3856                     data->start_class = oclass;
3857                 if (mincount == 0 || minnext == 0) {
3858                     if (flags & SCF_DO_STCLASS_OR) {
3859                         cl_or(pRExC_state, data->start_class, &this_class);
3860                     }
3861                     else if (flags & SCF_DO_STCLASS_AND) {
3862                         /* Switch to OR mode: cache the old value of
3863                          * data->start_class */
3864                         INIT_AND_WITHP;
3865                         StructCopy(data->start_class, and_withp,
3866                                    struct regnode_charclass_class);
3867                         flags &= ~SCF_DO_STCLASS_AND;
3868                         StructCopy(&this_class, data->start_class,
3869                                    struct regnode_charclass_class);
3870                         flags |= SCF_DO_STCLASS_OR;
3871                         SET_SSC_EOS(data->start_class);
3872                     }
3873                 } else {                /* Non-zero len */
3874                     if (flags & SCF_DO_STCLASS_OR) {
3875                         cl_or(pRExC_state, data->start_class, &this_class);
3876                         cl_and(data->start_class, and_withp);
3877                     }
3878                     else if (flags & SCF_DO_STCLASS_AND)
3879                         cl_and(data->start_class, &this_class);
3880                     flags &= ~SCF_DO_STCLASS;
3881                 }
3882                 if (!scan)              /* It was not CURLYX, but CURLY. */
3883                     scan = next;
3884                 if ( /* ? quantifier ok, except for (?{ ... }) */
3885                     (next_is_eval || !(mincount == 0 && maxcount == 1))
3886                     && (minnext == 0) && (deltanext == 0)
3887                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
3888                     && maxcount <= REG_INFTY/3) /* Complement check for big count */
3889                 {
3890                     /* Fatal warnings may leak the regexp without this: */
3891                     SAVEFREESV(RExC_rx_sv);
3892                     ckWARNreg(RExC_parse,
3893                               "Quantifier unexpected on zero-length expression");
3894                     (void)ReREFCNT_inc(RExC_rx_sv);
3895                 }
3896
3897                 min += minnext * mincount;
3898                 is_inf_internal |= deltanext == I32_MAX
3899                                      || (maxcount == REG_INFTY && minnext + deltanext > 0);
3900                 is_inf |= is_inf_internal;
3901                 if (is_inf)
3902                     delta = I32_MAX;
3903                 else
3904                     delta += (minnext + deltanext) * maxcount - minnext * mincount;
3905
3906                 /* Try powerful optimization CURLYX => CURLYN. */
3907                 if (  OP(oscan) == CURLYX && data
3908                       && data->flags & SF_IN_PAR
3909                       && !(data->flags & SF_HAS_EVAL)
3910                       && !deltanext && minnext == 1 ) {
3911                     /* Try to optimize to CURLYN.  */
3912                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
3913                     regnode * const nxt1 = nxt;
3914 #ifdef DEBUGGING
3915                     regnode *nxt2;
3916 #endif
3917
3918                     /* Skip open. */
3919                     nxt = regnext(nxt);
3920                     if (!REGNODE_SIMPLE(OP(nxt))
3921                         && !(PL_regkind[OP(nxt)] == EXACT
3922                              && STR_LEN(nxt) == 1))
3923                         goto nogo;
3924 #ifdef DEBUGGING
3925                     nxt2 = nxt;
3926 #endif
3927                     nxt = regnext(nxt);
3928                     if (OP(nxt) != CLOSE)
3929                         goto nogo;
3930                     if (RExC_open_parens) {
3931                         RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3932                         RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
3933                     }
3934                     /* Now we know that nxt2 is the only contents: */
3935                     oscan->flags = (U8)ARG(nxt);
3936                     OP(oscan) = CURLYN;
3937                     OP(nxt1) = NOTHING; /* was OPEN. */
3938
3939 #ifdef DEBUGGING
3940                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3941                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
3942                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
3943                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
3944                     OP(nxt + 1) = OPTIMIZED; /* was count. */
3945                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
3946 #endif
3947                 }
3948               nogo:
3949
3950                 /* Try optimization CURLYX => CURLYM. */
3951                 if (  OP(oscan) == CURLYX && data
3952                       && !(data->flags & SF_HAS_PAR)
3953                       && !(data->flags & SF_HAS_EVAL)
3954                       && !deltanext     /* atom is fixed width */
3955                       && minnext != 0   /* CURLYM can't handle zero width */
3956                       && ! (RExC_seen & REG_SEEN_EXACTF_SHARP_S) /* Nor \xDF */
3957                 ) {
3958                     /* XXXX How to optimize if data == 0? */
3959                     /* Optimize to a simpler form.  */
3960                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
3961                     regnode *nxt2;
3962
3963                     OP(oscan) = CURLYM;
3964                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
3965                             && (OP(nxt2) != WHILEM))
3966                         nxt = nxt2;
3967                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
3968                     /* Need to optimize away parenths. */
3969                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
3970                         /* Set the parenth number.  */
3971                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
3972
3973                         oscan->flags = (U8)ARG(nxt);
3974                         if (RExC_open_parens) {
3975                             RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3976                             RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
3977                         }
3978                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
3979                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
3980
3981 #ifdef DEBUGGING
3982                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3983                         OP(nxt + 1) = OPTIMIZED; /* was count. */
3984                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
3985                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
3986 #endif
3987 #if 0
3988                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
3989                             regnode *nnxt = regnext(nxt1);
3990                             if (nnxt == nxt) {
3991                                 if (reg_off_by_arg[OP(nxt1)])
3992                                     ARG_SET(nxt1, nxt2 - nxt1);
3993                                 else if (nxt2 - nxt1 < U16_MAX)
3994                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
3995                                 else
3996                                     OP(nxt) = NOTHING;  /* Cannot beautify */
3997                             }
3998                             nxt1 = nnxt;
3999                         }
4000 #endif
4001                         /* Optimize again: */
4002                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
4003                                     NULL, stopparen, recursed, NULL, 0,depth+1);
4004                     }
4005                     else
4006                         oscan->flags = 0;
4007                 }
4008                 else if ((OP(oscan) == CURLYX)
4009                          && (flags & SCF_WHILEM_VISITED_POS)
4010                          /* See the comment on a similar expression above.
4011                             However, this time it's not a subexpression
4012                             we care about, but the expression itself. */
4013                          && (maxcount == REG_INFTY)
4014                          && data && ++data->whilem_c < 16) {
4015                     /* This stays as CURLYX, we can put the count/of pair. */
4016                     /* Find WHILEM (as in regexec.c) */
4017                     regnode *nxt = oscan + NEXT_OFF(oscan);
4018
4019                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
4020                         nxt += ARG(nxt);
4021                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
4022                         | (RExC_whilem_seen << 4)); /* On WHILEM */
4023                 }
4024                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
4025                     pars++;
4026                 if (flags & SCF_DO_SUBSTR) {
4027                     SV *last_str = NULL;
4028                     int counted = mincount != 0;
4029
4030                     if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
4031 #if defined(SPARC64_GCC_WORKAROUND)
4032                         I32 b = 0;
4033                         STRLEN l = 0;
4034                         const char *s = NULL;
4035                         I32 old = 0;
4036
4037                         if (pos_before >= data->last_start_min)
4038                             b = pos_before;
4039                         else
4040                             b = data->last_start_min;
4041
4042                         l = 0;
4043                         s = SvPV_const(data->last_found, l);
4044                         old = b - data->last_start_min;
4045
4046 #else
4047                         I32 b = pos_before >= data->last_start_min
4048                             ? pos_before : data->last_start_min;
4049                         STRLEN l;
4050                         const char * const s = SvPV_const(data->last_found, l);
4051                         I32 old = b - data->last_start_min;
4052 #endif
4053
4054                         if (UTF)
4055                             old = utf8_hop((U8*)s, old) - (U8*)s;
4056                         l -= old;
4057                         /* Get the added string: */
4058                         last_str = newSVpvn_utf8(s  + old, l, UTF);
4059                         if (deltanext == 0 && pos_before == b) {
4060                             /* What was added is a constant string */
4061                             if (mincount > 1) {
4062                                 SvGROW(last_str, (mincount * l) + 1);
4063                                 repeatcpy(SvPVX(last_str) + l,
4064                                           SvPVX_const(last_str), l, mincount - 1);
4065                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
4066                                 /* Add additional parts. */
4067                                 SvCUR_set(data->last_found,
4068                                           SvCUR(data->last_found) - l);
4069                                 sv_catsv(data->last_found, last_str);
4070                                 {
4071                                     SV * sv = data->last_found;
4072                                     MAGIC *mg =
4073                                         SvUTF8(sv) && SvMAGICAL(sv) ?
4074                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
4075                                     if (mg && mg->mg_len >= 0)
4076                                         mg->mg_len += CHR_SVLEN(last_str) - l;
4077                                 }
4078                                 data->last_end += l * (mincount - 1);
4079                             }
4080                         } else {
4081                             /* start offset must point into the last copy */
4082                             data->last_start_min += minnext * (mincount - 1);
4083                             data->last_start_max += is_inf ? I32_MAX
4084                                 : (maxcount - 1) * (minnext + data->pos_delta);
4085                         }
4086                     }
4087                     /* It is counted once already... */
4088                     data->pos_min += minnext * (mincount - counted);
4089 #if 0
4090 PerlIO_printf(Perl_debug_log, "counted=%d deltanext=%d I32_MAX=%d minnext=%d maxcount=%d mincount=%d\n",
4091     counted, deltanext, I32_MAX, minnext, maxcount, mincount);
4092 if (deltanext != I32_MAX)
4093 PerlIO_printf(Perl_debug_log, "LHS=%d RHS=%d\n", -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount, I32_MAX - data->pos_delta);
4094 #endif
4095                     if (deltanext == I32_MAX || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= I32_MAX - data->pos_delta)
4096                         data->pos_delta = I32_MAX;
4097                     else
4098                         data->pos_delta += - counted * deltanext +
4099                         (minnext + deltanext) * maxcount - minnext * mincount;
4100                     if (mincount != maxcount) {
4101                          /* Cannot extend fixed substrings found inside
4102                             the group.  */
4103                         SCAN_COMMIT(pRExC_state,data,minlenp);
4104                         if (mincount && last_str) {
4105                             SV * const sv = data->last_found;
4106                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4107                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
4108
4109                             if (mg)
4110                                 mg->mg_len = -1;
4111                             sv_setsv(sv, last_str);
4112                             data->last_end = data->pos_min;
4113                             data->last_start_min =
4114                                 data->pos_min - CHR_SVLEN(last_str);
4115                             data->last_start_max = is_inf
4116                                 ? I32_MAX
4117                                 : data->pos_min + data->pos_delta
4118                                 - CHR_SVLEN(last_str);
4119                         }
4120                         data->longest = &(data->longest_float);
4121                     }
4122                     SvREFCNT_dec(last_str);
4123                 }
4124                 if (data && (fl & SF_HAS_EVAL))
4125                     data->flags |= SF_HAS_EVAL;
4126               optimize_curly_tail:
4127                 if (OP(oscan) != CURLYX) {
4128                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
4129                            && NEXT_OFF(next))
4130                         NEXT_OFF(oscan) += NEXT_OFF(next);
4131                 }
4132                 continue;
4133             default:                    /* REF, and CLUMP only? */
4134                 if (flags & SCF_DO_SUBSTR) {
4135                     SCAN_COMMIT(pRExC_state,data,minlenp);      /* Cannot expect anything... */
4136                     data->longest = &(data->longest_float);
4137                 }
4138                 is_inf = is_inf_internal = 1;
4139                 if (flags & SCF_DO_STCLASS_OR)
4140                     cl_anything(pRExC_state, data->start_class);
4141                 flags &= ~SCF_DO_STCLASS;
4142                 break;
4143             }
4144         }
4145         else if (OP(scan) == LNBREAK) {
4146             if (flags & SCF_DO_STCLASS) {
4147                 int value = 0;
4148                 CLEAR_SSC_EOS(data->start_class); /* No match on empty */
4149                 if (flags & SCF_DO_STCLASS_AND) {
4150                     for (value = 0; value < 256; value++)
4151                         if (!is_VERTWS_cp(value))
4152                             ANYOF_BITMAP_CLEAR(data->start_class, value);
4153                 }
4154                 else {
4155                     for (value = 0; value < 256; value++)
4156                         if (is_VERTWS_cp(value))
4157                             ANYOF_BITMAP_SET(data->start_class, value);
4158                 }
4159                 if (flags & SCF_DO_STCLASS_OR)
4160                     cl_and(data->start_class, and_withp);
4161                 flags &= ~SCF_DO_STCLASS;
4162             }
4163             min++;
4164             delta++;    /* Because of the 2 char string cr-lf */
4165             if (flags & SCF_DO_SUBSTR) {
4166                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
4167                 data->pos_min += 1;
4168                 data->pos_delta += 1;
4169                 data->longest = &(data->longest_float);
4170             }
4171         }
4172         else if (REGNODE_SIMPLE(OP(scan))) {
4173             int value = 0;
4174
4175             if (flags & SCF_DO_SUBSTR) {
4176                 SCAN_COMMIT(pRExC_state,data,minlenp);
4177                 data->pos_min++;
4178             }
4179             min++;
4180             if (flags & SCF_DO_STCLASS) {
4181                 int loop_max = 256;
4182                 CLEAR_SSC_EOS(data->start_class); /* No match on empty */
4183
4184                 /* Some of the logic below assumes that switching
4185                    locale on will only add false positives. */
4186                 switch (PL_regkind[OP(scan)]) {
4187                     U8 classnum;
4188
4189                 case SANY:
4190                 default:
4191 #ifdef DEBUGGING
4192                    Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan));
4193 #endif
4194                  do_default:
4195                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4196                         cl_anything(pRExC_state, data->start_class);
4197                     break;
4198                 case REG_ANY:
4199                     if (OP(scan) == SANY)
4200                         goto do_default;
4201                     if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
4202                         value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
4203                                 || ANYOF_CLASS_TEST_ANY_SET(data->start_class));
4204                         cl_anything(pRExC_state, data->start_class);
4205                     }
4206                     if (flags & SCF_DO_STCLASS_AND || !value)
4207                         ANYOF_BITMAP_CLEAR(data->start_class,'\n');
4208                     break;
4209                 case ANYOF:
4210                     if (flags & SCF_DO_STCLASS_AND)
4211                         cl_and(data->start_class,
4212                                (struct regnode_charclass_class*)scan);
4213                     else
4214                         cl_or(pRExC_state, data->start_class,
4215                               (struct regnode_charclass_class*)scan);
4216                     break;
4217                 case POSIXA:
4218                     loop_max = 128;
4219                     /* FALL THROUGH */
4220                 case POSIXL:
4221                 case POSIXD:
4222                 case POSIXU:
4223                     classnum = FLAGS(scan);
4224                     if (flags & SCF_DO_STCLASS_AND) {
4225                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
4226                             ANYOF_CLASS_CLEAR(data->start_class, classnum_to_namedclass(classnum) + 1);
4227                             for (value = 0; value < loop_max; value++) {
4228                                 if (! _generic_isCC(UNI_TO_NATIVE(value), classnum)) {
4229                                     ANYOF_BITMAP_CLEAR(data->start_class, UNI_TO_NATIVE(value));
4230                                 }
4231                             }
4232                         }
4233                     }
4234                     else {
4235                         if (data->start_class->flags & ANYOF_LOCALE) {
4236                             ANYOF_CLASS_SET(data->start_class, classnum_to_namedclass(classnum));
4237                         }
4238                         else {
4239
4240                         /* Even if under locale, set the bits for non-locale
4241                          * in case it isn't a true locale-node.  This will
4242                          * create false positives if it truly is locale */
4243                         for (value = 0; value < loop_max; value++) {
4244                             if (_generic_isCC(UNI_TO_NATIVE(value), classnum)) {
4245                                 ANYOF_BITMAP_SET(data->start_class, UNI_TO_NATIVE(value));
4246                             }
4247                         }
4248                         }
4249                     }
4250                     break;
4251                 case NPOSIXA:
4252                     loop_max = 128;
4253                     /* FALL THROUGH */
4254                 case NPOSIXL:
4255                 case NPOSIXU:
4256                 case NPOSIXD:
4257                     classnum = FLAGS(scan);
4258                     if (flags & SCF_DO_STCLASS_AND) {
4259                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
4260                             ANYOF_CLASS_CLEAR(data->start_class, classnum_to_namedclass(classnum));
4261                             for (value = 0; value < loop_max; value++) {
4262                                 if (_generic_isCC(UNI_TO_NATIVE(value), classnum)) {
4263                                     ANYOF_BITMAP_CLEAR(data->start_class, UNI_TO_NATIVE(value));
4264                                 }
4265                             }
4266                         }
4267                     }
4268                     else {
4269                         if (data->start_class->flags & ANYOF_LOCALE) {
4270                             ANYOF_CLASS_SET(data->start_class, classnum_to_namedclass(classnum) + 1);
4271                         }
4272                         else {
4273
4274                         /* Even if under locale, set the bits for non-locale in
4275                          * case it isn't a true locale-node.  This will create
4276                          * false positives if it truly is locale */
4277                         for (value = 0; value < loop_max; value++) {
4278                             if (! _generic_isCC(UNI_TO_NATIVE(value), classnum)) {
4279                                 ANYOF_BITMAP_SET(data->start_class, UNI_TO_NATIVE(value));
4280                             }
4281                         }
4282                         if (PL_regkind[OP(scan)] == NPOSIXD) {
4283                             data->start_class->flags |= ANYOF_NON_UTF8_LATIN1_ALL;
4284                         }
4285                         }
4286                     }
4287                     break;
4288                 }
4289                 if (flags & SCF_DO_STCLASS_OR)
4290                     cl_and(data->start_class, and_withp);
4291                 flags &= ~SCF_DO_STCLASS;
4292             }
4293         }
4294         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
4295             data->flags |= (OP(scan) == MEOL
4296                             ? SF_BEFORE_MEOL
4297                             : SF_BEFORE_SEOL);
4298             SCAN_COMMIT(pRExC_state, data, minlenp);
4299
4300         }
4301         else if (  PL_regkind[OP(scan)] == BRANCHJ
4302                  /* Lookbehind, or need to calculate parens/evals/stclass: */
4303                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
4304                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
4305             if ( OP(scan) == UNLESSM &&
4306                  scan->flags == 0 &&
4307                  OP(NEXTOPER(NEXTOPER(scan))) == NOTHING &&
4308                  OP(regnext(NEXTOPER(NEXTOPER(scan)))) == SUCCEED
4309             ) {
4310                 regnode *opt;
4311                 regnode *upto= regnext(scan);
4312                 DEBUG_PARSE_r({
4313                     SV * const mysv_val=sv_newmortal();
4314                     DEBUG_STUDYDATA("OPFAIL",data,depth);
4315
4316                     /*DEBUG_PARSE_MSG("opfail");*/
4317                     regprop(RExC_rx, mysv_val, upto);
4318                     PerlIO_printf(Perl_debug_log, "~ replace with OPFAIL pointed at %s (%"IVdf") offset %"IVdf"\n",
4319                                   SvPV_nolen_const(mysv_val),
4320                                   (IV)REG_NODE_NUM(upto),
4321                                   (IV)(upto - scan)
4322                     );
4323                 });
4324                 OP(scan) = OPFAIL;
4325                 NEXT_OFF(scan) = upto - scan;
4326                 for (opt= scan + 1; opt < upto ; opt++)
4327                     OP(opt) = OPTIMIZED;
4328                 scan= upto;
4329                 continue;
4330             }
4331             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY 
4332                 || OP(scan) == UNLESSM )
4333             {
4334                 /* Negative Lookahead/lookbehind
4335                    In this case we can't do fixed string optimisation.
4336                 */
4337
4338                 I32 deltanext, minnext, fake = 0;
4339                 regnode *nscan;
4340                 struct regnode_charclass_class intrnl;
4341                 int f = 0;
4342
4343                 data_fake.flags = 0;
4344                 if (data) {
4345                     data_fake.whilem_c = data->whilem_c;
4346                     data_fake.last_closep = data->last_closep;
4347                 }
4348                 else
4349                     data_fake.last_closep = &fake;
4350                 data_fake.pos_delta = delta;
4351                 if ( flags & SCF_DO_STCLASS && !scan->flags
4352                      && OP(scan) == IFMATCH ) { /* Lookahead */
4353                     cl_init(pRExC_state, &intrnl);
4354                     data_fake.start_class = &intrnl;
4355                     f |= SCF_DO_STCLASS_AND;
4356                 }
4357                 if (flags & SCF_WHILEM_VISITED_POS)
4358                     f |= SCF_WHILEM_VISITED_POS;
4359                 next = regnext(scan);
4360                 nscan = NEXTOPER(NEXTOPER(scan));
4361                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext, 
4362                     last, &data_fake, stopparen, recursed, NULL, f, depth+1);
4363                 if (scan->flags) {
4364                     if (deltanext) {
4365                         FAIL("Variable length lookbehind not implemented");
4366                     }
4367                     else if (minnext > (I32)U8_MAX) {
4368                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4369                     }
4370                     scan->flags = (U8)minnext;
4371                 }
4372                 if (data) {
4373                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4374                         pars++;
4375                     if (data_fake.flags & SF_HAS_EVAL)
4376                         data->flags |= SF_HAS_EVAL;
4377                     data->whilem_c = data_fake.whilem_c;
4378                 }
4379                 if (f & SCF_DO_STCLASS_AND) {
4380                     if (flags & SCF_DO_STCLASS_OR) {
4381                         /* OR before, AND after: ideally we would recurse with
4382                          * data_fake to get the AND applied by study of the
4383                          * remainder of the pattern, and then derecurse;
4384                          * *** HACK *** for now just treat as "no information".
4385                          * See [perl #56690].
4386                          */
4387                         cl_init(pRExC_state, data->start_class);
4388                     }  else {
4389                         /* AND before and after: combine and continue */
4390                         const int was = TEST_SSC_EOS(data->start_class);
4391
4392                         cl_and(data->start_class, &intrnl);
4393                         if (was)
4394                             SET_SSC_EOS(data->start_class);
4395                     }
4396                 }
4397             }
4398 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
4399             else {
4400                 /* Positive Lookahead/lookbehind
4401                    In this case we can do fixed string optimisation,
4402                    but we must be careful about it. Note in the case of
4403                    lookbehind the positions will be offset by the minimum
4404                    length of the pattern, something we won't know about
4405                    until after the recurse.
4406                 */
4407                 I32 deltanext, fake = 0;
4408                 regnode *nscan;
4409                 struct regnode_charclass_class intrnl;
4410                 int f = 0;
4411                 /* We use SAVEFREEPV so that when the full compile 
4412                     is finished perl will clean up the allocated 
4413                     minlens when it's all done. This way we don't
4414                     have to worry about freeing them when we know
4415                     they wont be used, which would be a pain.
4416                  */
4417                 I32 *minnextp;
4418                 Newx( minnextp, 1, I32 );
4419                 SAVEFREEPV(minnextp);
4420
4421                 if (data) {
4422                     StructCopy(data, &data_fake, scan_data_t);
4423                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
4424                         f |= SCF_DO_SUBSTR;
4425                         if (scan->flags) 
4426                             SCAN_COMMIT(pRExC_state, &data_fake,minlenp);
4427                         data_fake.last_found=newSVsv(data->last_found);
4428                     }
4429                 }
4430                 else
4431                     data_fake.last_closep = &fake;
4432                 data_fake.flags = 0;
4433                 data_fake.pos_delta = delta;
4434                 if (is_inf)
4435                     data_fake.flags |= SF_IS_INF;
4436                 if ( flags & SCF_DO_STCLASS && !scan->flags
4437                      && OP(scan) == IFMATCH ) { /* Lookahead */
4438                     cl_init(pRExC_state, &intrnl);
4439                     data_fake.start_class = &intrnl;
4440                     f |= SCF_DO_STCLASS_AND;
4441                 }
4442                 if (flags & SCF_WHILEM_VISITED_POS)
4443                     f |= SCF_WHILEM_VISITED_POS;
4444                 next = regnext(scan);
4445                 nscan = NEXTOPER(NEXTOPER(scan));
4446
4447                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext, 
4448                     last, &data_fake, stopparen, recursed, NULL, f,depth+1);
4449                 if (scan->flags) {
4450                     if (deltanext) {
4451                         FAIL("Variable length lookbehind not implemented");
4452                     }
4453                     else if (*minnextp > (I32)U8_MAX) {
4454                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4455                     }
4456                     scan->flags = (U8)*minnextp;
4457                 }
4458
4459                 *minnextp += min;
4460
4461                 if (f & SCF_DO_STCLASS_AND) {
4462                     const int was = TEST_SSC_EOS(data.start_class);
4463
4464                     cl_and(data->start_class, &intrnl);
4465                     if (was)
4466                         SET_SSC_EOS(data->start_class);
4467                 }
4468                 if (data) {
4469                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4470                         pars++;
4471                     if (data_fake.flags & SF_HAS_EVAL)
4472                         data->flags |= SF_HAS_EVAL;
4473                     data->whilem_c = data_fake.whilem_c;
4474                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
4475                         if (RExC_rx->minlen<*minnextp)
4476                             RExC_rx->minlen=*minnextp;
4477                         SCAN_COMMIT(pRExC_state, &data_fake, minnextp);
4478                         SvREFCNT_dec_NN(data_fake.last_found);
4479                         
4480                         if ( data_fake.minlen_fixed != minlenp ) 
4481                         {
4482                             data->offset_fixed= data_fake.offset_fixed;
4483                             data->minlen_fixed= data_fake.minlen_fixed;
4484                             data->lookbehind_fixed+= scan->flags;
4485                         }
4486                         if ( data_fake.minlen_float != minlenp )
4487                         {
4488                             data->minlen_float= data_fake.minlen_float;
4489                             data->offset_float_min=data_fake.offset_float_min;
4490                             data->offset_float_max=data_fake.offset_float_max;
4491                             data->lookbehind_float+= scan->flags;
4492                         }
4493                     }
4494                 }
4495             }
4496 #endif
4497         }
4498         else if (OP(scan) == OPEN) {
4499             if (stopparen != (I32)ARG(scan))
4500                 pars++;
4501         }
4502         else if (OP(scan) == CLOSE) {
4503             if (stopparen == (I32)ARG(scan)) {
4504                 break;
4505             }
4506             if ((I32)ARG(scan) == is_par) {
4507                 next = regnext(scan);
4508
4509                 if ( next && (OP(next) != WHILEM) && next < last)
4510                     is_par = 0;         /* Disable optimization */
4511             }
4512             if (data)
4513                 *(data->last_closep) = ARG(scan);
4514         }
4515         else if (OP(scan) == EVAL) {
4516                 if (data)
4517                     data->flags |= SF_HAS_EVAL;
4518         }
4519         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
4520             if (flags & SCF_DO_SUBSTR) {
4521                 SCAN_COMMIT(pRExC_state,data,minlenp);
4522                 flags &= ~SCF_DO_SUBSTR;
4523             }
4524             if (data && OP(scan)==ACCEPT) {
4525                 data->flags |= SCF_SEEN_ACCEPT;
4526                 if (stopmin > min)
4527                     stopmin = min;
4528             }
4529         }
4530         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
4531         {
4532                 if (flags & SCF_DO_SUBSTR) {
4533                     SCAN_COMMIT(pRExC_state,data,minlenp);
4534                     data->longest = &(data->longest_float);
4535                 }
4536                 is_inf = is_inf_internal = 1;
4537                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4538                     cl_anything(pRExC_state, data->start_class);
4539                 flags &= ~SCF_DO_STCLASS;
4540         }
4541         else if (OP(scan) == GPOS) {
4542             if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) &&
4543                 !(delta || is_inf || (data && data->pos_delta))) 
4544             {
4545                 if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR))
4546                     RExC_rx->extflags |= RXf_ANCH_GPOS;
4547                 if (RExC_rx->gofs < (U32)min)
4548                     RExC_rx->gofs = min;
4549             } else {
4550                 RExC_rx->extflags |= RXf_GPOS_FLOAT;
4551                 RExC_rx->gofs = 0;
4552             }       
4553         }
4554 #ifdef TRIE_STUDY_OPT
4555 #ifdef FULL_TRIE_STUDY
4556         else if (PL_regkind[OP(scan)] == TRIE) {
4557             /* NOTE - There is similar code to this block above for handling
4558                BRANCH nodes on the initial study.  If you change stuff here
4559                check there too. */
4560             regnode *trie_node= scan;
4561             regnode *tail= regnext(scan);
4562             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4563             I32 max1 = 0, min1 = I32_MAX;
4564             struct regnode_charclass_class accum;
4565
4566             if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
4567                 SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
4568             if (flags & SCF_DO_STCLASS)
4569                 cl_init_zero(pRExC_state, &accum);
4570                 
4571             if (!trie->jump) {
4572                 min1= trie->minlen;
4573                 max1= trie->maxlen;
4574             } else {
4575                 const regnode *nextbranch= NULL;
4576                 U32 word;
4577                 
4578                 for ( word=1 ; word <= trie->wordcount ; word++) 
4579                 {
4580                     I32 deltanext=0, minnext=0, f = 0, fake;
4581                     struct regnode_charclass_class this_class;
4582                     
4583                     data_fake.flags = 0;
4584                     if (data) {
4585                         data_fake.whilem_c = data->whilem_c;
4586                         data_fake.last_closep = data->last_closep;
4587                     }
4588                     else
4589                         data_fake.last_closep = &fake;
4590                     data_fake.pos_delta = delta;
4591                     if (flags & SCF_DO_STCLASS) {
4592                         cl_init(pRExC_state, &this_class);
4593                         data_fake.start_class = &this_class;
4594                         f = SCF_DO_STCLASS_AND;
4595                     }
4596                     if (flags & SCF_WHILEM_VISITED_POS)
4597                         f |= SCF_WHILEM_VISITED_POS;
4598     
4599                     if (trie->jump[word]) {
4600                         if (!nextbranch)
4601                             nextbranch = trie_node + trie->jump[0];
4602                         scan= trie_node + trie->jump[word];
4603                         /* We go from the jump point to the branch that follows
4604                            it. Note this means we need the vestigal unused branches
4605                            even though they arent otherwise used.
4606                          */
4607                         minnext = study_chunk(pRExC_state, &scan, minlenp, 
4608                             &deltanext, (regnode *)nextbranch, &data_fake, 
4609                             stopparen, recursed, NULL, f,depth+1);
4610                     }
4611                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
4612                         nextbranch= regnext((regnode*)nextbranch);
4613                     
4614                     if (min1 > (I32)(minnext + trie->minlen))
4615                         min1 = minnext + trie->minlen;
4616                     if (deltanext == I32_MAX) {
4617                         is_inf = is_inf_internal = 1;
4618                         max1 = I32_MAX;
4619                     } else if (max1 < (I32)(minnext + deltanext + trie->maxlen))
4620                         max1 = minnext + deltanext + trie->maxlen;
4621                     
4622                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4623                         pars++;
4624                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4625                         if ( stopmin > min + min1) 
4626                             stopmin = min + min1;
4627                         flags &= ~SCF_DO_SUBSTR;
4628                         if (data)
4629                             data->flags |= SCF_SEEN_ACCEPT;
4630                     }
4631                     if (data) {
4632                         if (data_fake.flags & SF_HAS_EVAL)
4633                             data->flags |= SF_HAS_EVAL;
4634                         data->whilem_c = data_fake.whilem_c;
4635                     }
4636                     if (flags & SCF_DO_STCLASS)
4637                         cl_or(pRExC_state, &accum, &this_class);
4638                 }
4639             }
4640             if (flags & SCF_DO_SUBSTR) {
4641                 data->pos_min += min1;
4642                 data->pos_delta += max1 - min1;
4643                 if (max1 != min1 || is_inf)
4644                     data->longest = &(data->longest_float);
4645             }
4646             min += min1;
4647             delta += max1 - min1;
4648             if (flags & SCF_DO_STCLASS_OR) {
4649                 cl_or(pRExC_state, data->start_class, &accum);
4650                 if (min1) {
4651                     cl_and(data->start_class, and_withp);
4652                     flags &= ~SCF_DO_STCLASS;
4653                 }
4654             }
4655             else if (flags & SCF_DO_STCLASS_AND) {
4656                 if (min1) {
4657                     cl_and(data->start_class, &accum);
4658                     flags &= ~SCF_DO_STCLASS;
4659                 }
4660                 else {
4661                     /* Switch to OR mode: cache the old value of
4662                      * data->start_class */
4663                     INIT_AND_WITHP;
4664                     StructCopy(data->start_class, and_withp,
4665                                struct regnode_charclass_class);
4666                     flags &= ~SCF_DO_STCLASS_AND;
4667                     StructCopy(&accum, data->start_class,
4668                                struct regnode_charclass_class);
4669                     flags |= SCF_DO_STCLASS_OR;
4670                     SET_SSC_EOS(data->start_class);
4671                 }
4672             }
4673             scan= tail;
4674             continue;
4675         }
4676 #else
4677         else if (PL_regkind[OP(scan)] == TRIE) {
4678             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4679             U8*bang=NULL;
4680             
4681             min += trie->minlen;
4682             delta += (trie->maxlen - trie->minlen);
4683             flags &= ~SCF_DO_STCLASS; /* xxx */
4684             if (flags & SCF_DO_SUBSTR) {
4685                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
4686                 data->pos_min += trie->minlen;
4687                 data->pos_delta += (trie->maxlen - trie->minlen);
4688                 if (trie->maxlen != trie->minlen)
4689                     data->longest = &(data->longest_float);
4690             }
4691             if (trie->jump) /* no more substrings -- for now /grr*/
4692                 flags &= ~SCF_DO_SUBSTR; 
4693         }
4694 #endif /* old or new */
4695 #endif /* TRIE_STUDY_OPT */
4696
4697         /* Else: zero-length, ignore. */
4698         scan = regnext(scan);
4699     }
4700     if (frame) {
4701         last = frame->last;
4702         scan = frame->next;
4703         stopparen = frame->stop;
4704         frame = frame->prev;
4705         goto fake_study_recurse;
4706     }
4707
4708   finish:
4709     assert(!frame);
4710     DEBUG_STUDYDATA("pre-fin:",data,depth);
4711
4712     *scanp = scan;
4713     *deltap = is_inf_internal ? I32_MAX : delta;
4714     if (flags & SCF_DO_SUBSTR && is_inf)
4715         data->pos_delta = I32_MAX - data->pos_min;
4716     if (is_par > (I32)U8_MAX)
4717         is_par = 0;
4718     if (is_par && pars==1 && data) {
4719         data->flags |= SF_IN_PAR;
4720         data->flags &= ~SF_HAS_PAR;
4721     }
4722     else if (pars && data) {
4723         data->flags |= SF_HAS_PAR;
4724         data->flags &= ~SF_IN_PAR;
4725     }
4726     if (flags & SCF_DO_STCLASS_OR)
4727         cl_and(data->start_class, and_withp);
4728     if (flags & SCF_TRIE_RESTUDY)
4729         data->flags |=  SCF_TRIE_RESTUDY;
4730     
4731     DEBUG_STUDYDATA("post-fin:",data,depth);
4732     
4733     return min < stopmin ? min : stopmin;
4734 }
4735
4736 STATIC U32
4737 S_add_data(RExC_state_t *pRExC_state, U32 n, const char *s)
4738 {
4739     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
4740
4741     PERL_ARGS_ASSERT_ADD_DATA;
4742
4743     Renewc(RExC_rxi->data,
4744            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
4745            char, struct reg_data);
4746     if(count)
4747         Renew(RExC_rxi->data->what, count + n, U8);
4748     else
4749         Newx(RExC_rxi->data->what, n, U8);
4750     RExC_rxi->data->count = count + n;
4751     Copy(s, RExC_rxi->data->what + count, n, U8);
4752     return count;
4753 }
4754
4755 /*XXX: todo make this not included in a non debugging perl */
4756 #ifndef PERL_IN_XSUB_RE
4757 void
4758 Perl_reginitcolors(pTHX)
4759 {
4760     dVAR;
4761     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
4762     if (s) {
4763         char *t = savepv(s);
4764         int i = 0;
4765         PL_colors[0] = t;
4766         while (++i < 6) {
4767             t = strchr(t, '\t');
4768             if (t) {
4769                 *t = '\0';
4770                 PL_colors[i] = ++t;
4771             }
4772             else
4773                 PL_colors[i] = t = (char *)"";
4774         }
4775     } else {
4776         int i = 0;
4777         while (i < 6)
4778             PL_colors[i++] = (char *)"";
4779     }
4780     PL_colorset = 1;
4781 }
4782 #endif
4783
4784
4785 #ifdef TRIE_STUDY_OPT
4786 #define CHECK_RESTUDY_GOTO_butfirst(dOsomething)            \
4787     STMT_START {                                            \
4788         if (                                                \
4789               (data.flags & SCF_TRIE_RESTUDY)               \
4790               && ! restudied++                              \
4791         ) {                                                 \
4792             dOsomething;                                    \
4793             goto reStudy;                                   \
4794         }                                                   \
4795     } STMT_END
4796 #else
4797 #define CHECK_RESTUDY_GOTO_butfirst
4798 #endif        
4799
4800 /*
4801  * pregcomp - compile a regular expression into internal code
4802  *
4803  * Decides which engine's compiler to call based on the hint currently in
4804  * scope
4805  */
4806
4807 #ifndef PERL_IN_XSUB_RE 
4808
4809 /* return the currently in-scope regex engine (or the default if none)  */
4810
4811 regexp_engine const *
4812 Perl_current_re_engine(pTHX)
4813 {
4814     dVAR;
4815
4816     if (IN_PERL_COMPILETIME) {
4817         HV * const table = GvHV(PL_hintgv);
4818         SV **ptr;
4819
4820         if (!table)
4821             return &PL_core_reg_engine;
4822         ptr = hv_fetchs(table, "regcomp", FALSE);
4823         if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
4824             return &PL_core_reg_engine;
4825         return INT2PTR(regexp_engine*,SvIV(*ptr));
4826     }
4827     else {
4828         SV *ptr;
4829         if (!PL_curcop->cop_hints_hash)
4830             return &PL_core_reg_engine;
4831         ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
4832         if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
4833             return &PL_core_reg_engine;
4834         return INT2PTR(regexp_engine*,SvIV(ptr));
4835     }
4836 }
4837
4838
4839 REGEXP *
4840 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
4841 {
4842     dVAR;
4843     regexp_engine const *eng = current_re_engine();
4844     GET_RE_DEBUG_FLAGS_DECL;
4845
4846     PERL_ARGS_ASSERT_PREGCOMP;
4847
4848     /* Dispatch a request to compile a regexp to correct regexp engine. */
4849     DEBUG_COMPILE_r({
4850         PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
4851                         PTR2UV(eng));
4852     });
4853     return CALLREGCOMP_ENG(eng, pattern, flags);
4854 }
4855 #endif
4856
4857 /* public(ish) entry point for the perl core's own regex compiling code.
4858  * It's actually a wrapper for Perl_re_op_compile that only takes an SV
4859  * pattern rather than a list of OPs, and uses the internal engine rather
4860  * than the current one */
4861
4862 REGEXP *
4863 Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
4864 {
4865     SV *pat = pattern; /* defeat constness! */
4866     PERL_ARGS_ASSERT_RE_COMPILE;
4867     return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
4868 #ifdef PERL_IN_XSUB_RE
4869                                 &my_reg_engine,
4870 #else
4871                                 &PL_core_reg_engine,
4872 #endif
4873                                 NULL, NULL, rx_flags, 0);
4874 }
4875
4876
4877 /* upgrade pattern pat_p of length plen_p to UTF8, and if there are code
4878  * blocks, recalculate the indices. Update pat_p and plen_p in-place to
4879  * point to the realloced string and length.
4880  *
4881  * This is essentially a copy of Perl_bytes_to_utf8() with the code index
4882  * stuff added */
4883
4884 static void
4885 S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state,
4886                     char **pat_p, STRLEN *plen_p)
4887 {
4888     U8 *const src = (U8*)*pat_p;
4889     U8 *dst;
4890     int n=0;
4891     STRLEN s = 0, d = 0;
4892     bool do_end = 0;
4893     GET_RE_DEBUG_FLAGS_DECL;
4894
4895     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
4896         "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
4897
4898     Newx(dst, *plen_p * 2 + 1, U8);
4899
4900     while (s < *plen_p) {
4901         const UV uv = NATIVE_TO_ASCII(src[s]);
4902         if (UNI_IS_INVARIANT(uv))
4903             dst[d]   = (U8)UTF_TO_NATIVE(uv);
4904         else {
4905             dst[d++] = (U8)UTF8_EIGHT_BIT_HI(uv);
4906             dst[d]   = (U8)UTF8_EIGHT_BIT_LO(uv);
4907         }
4908         if (n < pRExC_state->num_code_blocks) {
4909             if (!do_end && pRExC_state->code_blocks[n].start == s) {
4910                 pRExC_state->code_blocks[n].start = d;
4911                 assert(dst[d] == '(');
4912                 do_end = 1;
4913             }
4914             else if (do_end && pRExC_state->code_blocks[n].end == s) {
4915                 pRExC_state->code_blocks[n].end = d;
4916                 assert(dst[d] == ')');
4917                 do_end = 0;
4918                 n++;
4919             }
4920         }
4921         s++;
4922         d++;
4923     }
4924     dst[d] = '\0';
4925     *plen_p = d;
4926     *pat_p = (char*) dst;
4927     SAVEFREEPV(*pat_p);
4928     RExC_orig_utf8 = RExC_utf8 = 1;
4929 }
4930
4931
4932 /* see if there are any run-time code blocks in the pattern.
4933  * False positives are allowed */
4934
4935 static bool
4936 S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
4937                     char *pat, STRLEN plen)
4938 {
4939     int n = 0;
4940     STRLEN s;
4941
4942     for (s = 0; s < plen; s++) {
4943         if (n < pRExC_state->num_code_blocks
4944             && s == pRExC_state->code_blocks[n].start)
4945         {
4946             s = pRExC_state->code_blocks[n].end;
4947             n++;
4948             continue;
4949         }
4950         /* TODO ideally should handle [..], (#..), /#.../x to reduce false
4951          * positives here */
4952         if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' &&
4953             (pat[s+2] == '{'
4954                 || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{'))
4955         )
4956             return 1;
4957     }
4958     return 0;
4959 }
4960
4961 /* Handle run-time code blocks. We will already have compiled any direct
4962  * or indirect literal code blocks. Now, take the pattern 'pat' and make a
4963  * copy of it, but with any literal code blocks blanked out and
4964  * appropriate chars escaped; then feed it into
4965  *
4966  *    eval "qr'modified_pattern'"
4967  *
4968  * For example,
4969  *
4970  *       a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
4971  *
4972  * becomes
4973  *
4974  *    qr'a\\bc_______________________def\'ghi\\\\jkl(?{"this is runtime"})mno'
4975  *
4976  * After eval_sv()-ing that, grab any new code blocks from the returned qr
4977  * and merge them with any code blocks of the original regexp.
4978  *
4979  * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
4980  * instead, just save the qr and return FALSE; this tells our caller that
4981  * the original pattern needs upgrading to utf8.
4982  */
4983
4984 static bool
4985 S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
4986     char *pat, STRLEN plen)
4987 {
4988     SV *qr;
4989
4990     GET_RE_DEBUG_FLAGS_DECL;
4991
4992     if (pRExC_state->runtime_code_qr) {
4993         /* this is the second time we've been called; this should
4994          * only happen if the main pattern got upgraded to utf8
4995          * during compilation; re-use the qr we compiled first time
4996          * round (which should be utf8 too)
4997          */
4998         qr = pRExC_state->runtime_code_qr;
4999         pRExC_state->runtime_code_qr = NULL;
5000         assert(RExC_utf8 && SvUTF8(qr));
5001     }
5002     else {
5003         int n = 0;
5004         STRLEN s;
5005         char *p, *newpat;
5006         int newlen = plen + 6; /* allow for "qr''x\0" extra chars */
5007         SV *sv, *qr_ref;
5008         dSP;
5009
5010         /* determine how many extra chars we need for ' and \ escaping */
5011         for (s = 0; s < plen; s++) {
5012             if (pat[s] == '\'' || pat[s] == '\\')
5013                 newlen++;
5014         }
5015
5016         Newx(newpat, newlen, char);
5017         p = newpat;
5018         *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
5019
5020         for (s = 0; s < plen; s++) {
5021             if (n < pRExC_state->num_code_blocks
5022                 && s == pRExC_state->code_blocks[n].start)
5023             {
5024                 /* blank out literal code block */
5025                 assert(pat[s] == '(');
5026                 while (s <= pRExC_state->code_blocks[n].end) {
5027                     *p++ = '_';
5028                     s++;
5029                 }
5030                 s--;
5031                 n++;
5032                 continue;
5033             }
5034             if (pat[s] == '\'' || pat[s] == '\\')
5035                 *p++ = '\\';
5036             *p++ = pat[s];
5037         }
5038         *p++ = '\'';
5039         if (pRExC_state->pm_flags & RXf_PMf_EXTENDED)
5040             *p++ = 'x';
5041         *p++ = '\0';
5042         DEBUG_COMPILE_r({
5043             PerlIO_printf(Perl_debug_log,
5044                 "%sre-parsing pattern for runtime code:%s %s\n",
5045                 PL_colors[4],PL_colors[5],newpat);
5046         });
5047
5048         sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
5049         Safefree(newpat);
5050
5051         ENTER;
5052         SAVETMPS;
5053         save_re_context();
5054         PUSHSTACKi(PERLSI_REQUIRE);
5055         /* G_RE_REPARSING causes the toker to collapse \\ into \ when
5056          * parsing qr''; normally only q'' does this. It also alters
5057          * hints handling */
5058         eval_sv(sv, G_SCALAR|G_RE_REPARSING);
5059         SvREFCNT_dec_NN(sv);
5060         SPAGAIN;
5061         qr_ref = POPs;
5062         PUTBACK;
5063         {
5064             SV * const errsv = ERRSV;
5065             if (SvTRUE_NN(errsv))
5066             {
5067                 Safefree(pRExC_state->code_blocks);
5068                 /* use croak_sv ? */
5069                 Perl_croak_nocontext("%s", SvPV_nolen_const(errsv));
5070             }
5071         }
5072         assert(SvROK(qr_ref));
5073         qr = SvRV(qr_ref);
5074         assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
5075         /* the leaving below frees the tmp qr_ref.
5076          * Give qr a life of its own */
5077         SvREFCNT_inc(qr);
5078         POPSTACK;
5079         FREETMPS;
5080         LEAVE;
5081
5082     }
5083
5084     if (!RExC_utf8 && SvUTF8(qr)) {
5085         /* first time through; the pattern got upgraded; save the
5086          * qr for the next time through */
5087         assert(!pRExC_state->runtime_code_qr);
5088         pRExC_state->runtime_code_qr = qr;
5089         return 0;
5090     }
5091
5092
5093     /* extract any code blocks within the returned qr//  */
5094
5095
5096     /* merge the main (r1) and run-time (r2) code blocks into one */
5097     {
5098         RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
5099         struct reg_code_block *new_block, *dst;
5100         RExC_state_t * const r1 = pRExC_state; /* convenient alias */
5101         int i1 = 0, i2 = 0;
5102
5103         if (!r2->num_code_blocks) /* we guessed wrong */
5104         {
5105             SvREFCNT_dec_NN(qr);
5106             return 1;
5107         }
5108
5109         Newx(new_block,
5110             r1->num_code_blocks + r2->num_code_blocks,
5111             struct reg_code_block);
5112         dst = new_block;
5113
5114         while (    i1 < r1->num_code_blocks
5115                 || i2 < r2->num_code_blocks)
5116         {
5117             struct reg_code_block *src;
5118             bool is_qr = 0;
5119
5120             if (i1 == r1->num_code_blocks) {
5121                 src = &r2->code_blocks[i2++];
5122                 is_qr = 1;
5123             }
5124             else if (i2 == r2->num_code_blocks)
5125                 src = &r1->code_blocks[i1++];
5126             else if (  r1->code_blocks[i1].start
5127                      < r2->code_blocks[i2].start)
5128             {
5129                 src = &r1->code_blocks[i1++];
5130                 assert(src->end < r2->code_blocks[i2].start);
5131             }
5132             else {
5133                 assert(  r1->code_blocks[i1].start
5134                        > r2->code_blocks[i2].start);
5135                 src = &r2->code_blocks[i2++];
5136                 is_qr = 1;
5137                 assert(src->end < r1->code_blocks[i1].start);
5138             }
5139
5140             assert(pat[src->start] == '(');
5141             assert(pat[src->end]   == ')');
5142             dst->start      = src->start;
5143             dst->end        = src->end;
5144             dst->block      = src->block;
5145             dst->src_regex  = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
5146                                     : src->src_regex;
5147             dst++;
5148         }
5149         r1->num_code_blocks += r2->num_code_blocks;
5150         Safefree(r1->code_blocks);
5151         r1->code_blocks = new_block;
5152     }
5153
5154     SvREFCNT_dec_NN(qr);
5155     return 1;
5156 }
5157
5158
5159 STATIC bool
5160 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)
5161 {
5162     /* This is the common code for setting up the floating and fixed length
5163      * string data extracted from Perl_re_op_compile() below.  Returns a boolean
5164      * as to whether succeeded or not */
5165
5166     I32 t,ml;
5167
5168     if (! (longest_length
5169            || (eol /* Can't have SEOL and MULTI */
5170                && (! meol || (RExC_flags & RXf_PMf_MULTILINE)))
5171           )
5172             /* See comments for join_exact for why REG_SEEN_EXACTF_SHARP_S */
5173         || (RExC_seen & REG_SEEN_EXACTF_SHARP_S))
5174     {
5175         return FALSE;
5176     }
5177
5178     /* copy the information about the longest from the reg_scan_data
5179         over to the program. */
5180     if (SvUTF8(sv_longest)) {
5181         *rx_utf8 = sv_longest;
5182         *rx_substr = NULL;
5183     } else {
5184         *rx_substr = sv_longest;
5185         *rx_utf8 = NULL;
5186     }
5187     /* end_shift is how many chars that must be matched that
5188         follow this item. We calculate it ahead of time as once the
5189         lookbehind offset is added in we lose the ability to correctly
5190         calculate it.*/
5191     ml = minlen ? *(minlen) : (I32)longest_length;
5192     *rx_end_shift = ml - offset
5193         - longest_length + (SvTAIL(sv_longest) != 0)
5194         + lookbehind;
5195
5196     t = (eol/* Can't have SEOL and MULTI */
5197          && (! meol || (RExC_flags & RXf_PMf_MULTILINE)));
5198     fbm_compile(sv_longest, t ? FBMcf_TAIL : 0);
5199
5200     return TRUE;
5201 }
5202
5203 /*
5204  * Perl_re_op_compile - the perl internal RE engine's function to compile a
5205  * regular expression into internal code.
5206  * The pattern may be passed either as:
5207  *    a list of SVs (patternp plus pat_count)
5208  *    a list of OPs (expr)
5209  * If both are passed, the SV list is used, but the OP list indicates
5210  * which SVs are actually pre-compiled code blocks
5211  *
5212  * The SVs in the list have magic and qr overloading applied to them (and
5213  * the list may be modified in-place with replacement SVs in the latter
5214  * case).
5215  *
5216  * If the pattern hasn't changed from old_re, then old_re will be
5217  * returned.
5218  *
5219  * eng is the current engine. If that engine has an op_comp method, then
5220  * handle directly (i.e. we assume that op_comp was us); otherwise, just
5221  * do the initial concatenation of arguments and pass on to the external
5222  * engine.
5223  *
5224  * If is_bare_re is not null, set it to a boolean indicating whether the
5225  * arg list reduced (after overloading) to a single bare regex which has
5226  * been returned (i.e. /$qr/).
5227  *
5228  * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
5229  *
5230  * pm_flags contains the PMf_* flags, typically based on those from the
5231  * pm_flags field of the related PMOP. Currently we're only interested in
5232  * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL.
5233  *
5234  * We can't allocate space until we know how big the compiled form will be,
5235  * but we can't compile it (and thus know how big it is) until we've got a
5236  * place to put the code.  So we cheat:  we compile it twice, once with code
5237  * generation turned off and size counting turned on, and once "for real".
5238  * This also means that we don't allocate space until we are sure that the
5239  * thing really will compile successfully, and we never have to move the
5240  * code and thus invalidate pointers into it.  (Note that it has to be in
5241  * one piece because free() must be able to free it all.) [NB: not true in perl]
5242  *
5243  * Beware that the optimization-preparation code in here knows about some
5244  * of the structure of the compiled regexp.  [I'll say.]
5245  */
5246
5247 REGEXP *
5248 Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
5249                     OP *expr, const regexp_engine* eng, REGEXP *old_re,
5250                      bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags)
5251 {
5252     dVAR;
5253     REGEXP *rx;
5254     struct regexp *r;
5255     regexp_internal *ri;
5256     STRLEN plen;
5257     char *exp;
5258     regnode *scan;
5259     I32 flags;
5260     I32 minlen = 0;
5261     U32 rx_flags;
5262     SV *pat = NULL;
5263     SV *code_blocksv = NULL;
5264     SV** new_patternp = patternp;
5265
5266     /* these are all flags - maybe they should be turned
5267      * into a single int with different bit masks */
5268     I32 sawlookahead = 0;
5269     I32 sawplus = 0;
5270     I32 sawopen = 0;
5271     regex_charset initial_charset = get_regex_charset(orig_rx_flags);
5272     bool recompile = 0;
5273     bool runtime_code = 0;
5274     scan_data_t data;
5275     RExC_state_t RExC_state;
5276     RExC_state_t * const pRExC_state = &RExC_state;
5277 #ifdef TRIE_STUDY_OPT    
5278     int restudied = 0;
5279     RExC_state_t copyRExC_state;
5280 #endif    
5281     GET_RE_DEBUG_FLAGS_DECL;
5282
5283     PERL_ARGS_ASSERT_RE_OP_COMPILE;
5284
5285     DEBUG_r(if (!PL_colorset) reginitcolors());
5286
5287 #ifndef PERL_IN_XSUB_RE
5288     /* Initialize these here instead of as-needed, as is quick and avoids
5289      * having to test them each time otherwise */
5290     if (! PL_AboveLatin1) {
5291         PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
5292         PL_ASCII = _new_invlist_C_array(ASCII_invlist);
5293         PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
5294
5295         PL_L1Posix_ptrs[_CC_ALPHANUMERIC]
5296                                 = _new_invlist_C_array(L1PosixAlnum_invlist);
5297         PL_Posix_ptrs[_CC_ALPHANUMERIC]
5298                                 = _new_invlist_C_array(PosixAlnum_invlist);
5299
5300         PL_L1Posix_ptrs[_CC_ALPHA]
5301                                 = _new_invlist_C_array(L1PosixAlpha_invlist);
5302         PL_Posix_ptrs[_CC_ALPHA] = _new_invlist_C_array(PosixAlpha_invlist);
5303
5304         PL_Posix_ptrs[_CC_BLANK] = _new_invlist_C_array(PosixBlank_invlist);
5305         PL_XPosix_ptrs[_CC_BLANK] = _new_invlist_C_array(XPosixBlank_invlist);
5306
5307         /* Cased is the same as Alpha in the ASCII range */
5308         PL_L1Posix_ptrs[_CC_CASED] =  _new_invlist_C_array(L1Cased_invlist);
5309         PL_Posix_ptrs[_CC_CASED] =  _new_invlist_C_array(PosixAlpha_invlist);
5310
5311         PL_Posix_ptrs[_CC_CNTRL] = _new_invlist_C_array(PosixCntrl_invlist);
5312         PL_XPosix_ptrs[_CC_CNTRL] = _new_invlist_C_array(XPosixCntrl_invlist);
5313
5314         PL_Posix_ptrs[_CC_DIGIT] = _new_invlist_C_array(PosixDigit_invlist);
5315         PL_L1Posix_ptrs[_CC_DIGIT] = _new_invlist_C_array(PosixDigit_invlist);
5316
5317         PL_L1Posix_ptrs[_CC_GRAPH] = _new_invlist_C_array(L1PosixGraph_invlist);
5318         PL_Posix_ptrs[_CC_GRAPH] = _new_invlist_C_array(PosixGraph_invlist);
5319
5320         PL_L1Posix_ptrs[_CC_LOWER] = _new_invlist_C_array(L1PosixLower_invlist);
5321         PL_Posix_ptrs[_CC_LOWER] = _new_invlist_C_array(PosixLower_invlist);
5322
5323         PL_L1Posix_ptrs[_CC_PRINT] = _new_invlist_C_array(L1PosixPrint_invlist);
5324         PL_Posix_ptrs[_CC_PRINT] = _new_invlist_C_array(PosixPrint_invlist);
5325
5326         PL_L1Posix_ptrs[_CC_PUNCT] = _new_invlist_C_array(L1PosixPunct_invlist);
5327         PL_Posix_ptrs[_CC_PUNCT] = _new_invlist_C_array(PosixPunct_invlist);
5328
5329         PL_Posix_ptrs[_CC_SPACE] = _new_invlist_C_array(PerlSpace_invlist);
5330         PL_XPosix_ptrs[_CC_SPACE] = _new_invlist_C_array(XPerlSpace_invlist);
5331         PL_Posix_ptrs[_CC_PSXSPC] = _new_invlist_C_array(PosixSpace_invlist);
5332         PL_XPosix_ptrs[_CC_PSXSPC] = _new_invlist_C_array(XPosixSpace_invlist);
5333
5334         PL_L1Posix_ptrs[_CC_UPPER] = _new_invlist_C_array(L1PosixUpper_invlist);
5335         PL_Posix_ptrs[_CC_UPPER] = _new_invlist_C_array(PosixUpper_invlist);
5336
5337         PL_XPosix_ptrs[_CC_VERTSPACE] = _new_invlist_C_array(VertSpace_invlist);
5338
5339         PL_Posix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(PosixWord_invlist);
5340         PL_L1Posix_ptrs[_CC_WORDCHAR]
5341                                 = _new_invlist_C_array(L1PosixWord_invlist);
5342
5343         PL_Posix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(PosixXDigit_invlist);
5344         PL_XPosix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(XPosixXDigit_invlist);
5345
5346         PL_HasMultiCharFold = _new_invlist_C_array(_Perl_Multi_Char_Folds_invlist);
5347     }
5348 #endif
5349
5350     pRExC_state->code_blocks = NULL;
5351     pRExC_state->num_code_blocks = 0;
5352
5353     if (is_bare_re)
5354         *is_bare_re = FALSE;
5355
5356     if (expr && (expr->op_type == OP_LIST ||
5357                 (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
5358         /* allocate code_blocks if needed */
5359         OP *o;
5360         int ncode = 0;
5361
5362         for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling)
5363             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
5364                 ncode++; /* count of DO blocks */
5365         if (ncode) {
5366             pRExC_state->num_code_blocks = ncode;
5367             Newx(pRExC_state->code_blocks, ncode, struct reg_code_block);
5368         }
5369     }
5370
5371     if (!pat_count) {
5372         /* compile-time pattern with just OP_CONSTs and DO blocks */
5373
5374         int n;
5375         OP *o;
5376
5377         /* find how many CONSTs there are */
5378         assert(expr);
5379         n = 0;
5380         if (expr->op_type == OP_CONST)
5381             n = 1;
5382         else
5383             for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
5384                 if (o->op_type == OP_CONST)
5385                     n++;
5386             }
5387
5388         /* fake up an SV array */
5389
5390         assert(!new_patternp);
5391         Newx(new_patternp, n, SV*);
5392         SAVEFREEPV(new_patternp);
5393         pat_count = n;
5394
5395         n = 0;
5396         if (expr->op_type == OP_CONST)
5397             new_patternp[n] = cSVOPx_sv(expr);
5398         else
5399             for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
5400                 if (o->op_type == OP_CONST)
5401                     new_patternp[n++] = cSVOPo_sv;
5402             }
5403
5404     }
5405
5406     {
5407         /* concat args, handling magic, overloading etc */
5408
5409         SV **svp;
5410         OP *o = NULL;
5411         int n = 0;
5412         STRLEN orig_patlen = 0;
5413
5414         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
5415             "Assembling pattern from %d elements%s\n", pat_count,
5416                 orig_rx_flags & RXf_SPLIT ? " for split" : ""));
5417
5418         /* apply magic and RE overloading to each arg */
5419         for (svp = new_patternp; svp < new_patternp + pat_count; svp++) {
5420             SV *rx = *svp;
5421             SvGETMAGIC(rx);
5422             if (SvROK(rx) && SvAMAGIC(rx)) {
5423                 SV *sv = AMG_CALLunary(rx, regexp_amg);
5424                 if (sv) {
5425                     if (SvROK(sv))
5426                         sv = SvRV(sv);
5427                     if (SvTYPE(sv) != SVt_REGEXP)
5428                         Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
5429                     *svp = sv;
5430                 }
5431             }
5432         }
5433
5434         if (pRExC_state->num_code_blocks) {
5435             if (expr->op_type == OP_CONST)
5436                 o = expr;
5437             else {
5438                 o = cLISTOPx(expr)->op_first;
5439                 assert(   o->op_type == OP_PUSHMARK
5440                        || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)
5441                        || o->op_type == OP_PADRANGE);
5442                 o = o->op_sibling;
5443             }
5444         }
5445
5446         if (pat_count > 1) {
5447
5448             pat = newSVpvn("", 0);
5449             SAVEFREESV(pat);
5450
5451             /* determine if the pattern is going to be utf8 (needed
5452              * in advance to align code block indices correctly).
5453              * XXX This could fail to be detected for an arg with
5454              * overloading but not concat overloading; but the main effect
5455              * in this obscure case is to need a 'use re eval' for a
5456              * literal code block */
5457             for (svp = new_patternp; svp < new_patternp + pat_count; svp++) {
5458                 if (SvUTF8(*svp))
5459                     SvUTF8_on(pat);
5460             }
5461         }
5462
5463         /* process args, concat them if there are multiple ones,
5464          * and find any code block indexes */
5465
5466
5467         for (svp = new_patternp; svp < new_patternp + pat_count; svp++) {
5468             SV *sv, *msv = *svp;
5469             SV *rx  = NULL;
5470             bool code = 0;
5471             /* we make the assumption here that each op in the list of
5472              * op_siblings maps to one SV pushed onto the stack,
5473              * except for code blocks, with have both an OP_NULL and
5474              * and OP_CONST.
5475              * This allows us to match up the list of SVs against the
5476              * list of OPs to find the next code block.
5477              *
5478              * Note that       PUSHMARK PADSV PADSV ..
5479              * is optimised to
5480              *                 PADRANGE NULL  NULL  ..
5481              * so the alignment still works. */
5482             if (o) {
5483                 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5484                     assert(n < pRExC_state->num_code_blocks);
5485                     pRExC_state->code_blocks[n].start = pat ? SvCUR(pat) : 0;
5486                     pRExC_state->code_blocks[n].block = o;
5487                     pRExC_state->code_blocks[n].src_regex = NULL;
5488                     n++;
5489                     code = 1;
5490                     o = o->op_sibling; /* skip CONST */
5491                     assert(o);
5492                 }
5493                 o = o->op_sibling;;
5494             }
5495
5496             /* try concatenation overload ... */
5497             if (pat && (SvAMAGIC(pat) || SvAMAGIC(msv)) &&
5498                     (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
5499             {
5500                 sv_setsv(pat, sv);
5501                 /* overloading involved: all bets are off over literal
5502                  * code. Pretend we haven't seen it */
5503                 pRExC_state->num_code_blocks -= n;
5504                 n = 0;
5505             }
5506             else  {
5507                 /* ... or failing that, try "" overload */
5508                 while (SvAMAGIC(msv)
5509                         && (sv = AMG_CALLunary(msv, string_amg))
5510                         && sv != msv
5511                         &&  !(   SvROK(msv)
5512                               && SvROK(sv)
5513                               && SvRV(msv) == SvRV(sv))
5514                 ) {
5515                     msv = sv;
5516                     SvGETMAGIC(msv);
5517                 }
5518                 if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
5519                     msv = SvRV(msv);
5520                 if (pat) {
5521                     orig_patlen = SvCUR(pat);
5522                     sv_catsv_nomg(pat, msv);
5523                     rx = msv;
5524                 }
5525                 else
5526                     pat = msv;
5527                 if (code)
5528                     pRExC_state->code_blocks[n-1].end = SvCUR(pat)-1;
5529             }
5530
5531             /* extract any code blocks within any embedded qr//'s */
5532             if (rx && SvTYPE(rx) == SVt_REGEXP
5533                 && RX_ENGINE((REGEXP*)rx)->op_comp)
5534             {
5535
5536                 RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
5537                 if (ri->num_code_blocks) {
5538                     int i;
5539                     /* the presence of an embedded qr// with code means
5540                      * we should always recompile: the text of the
5541                      * qr// may not have changed, but it may be a
5542                      * different closure than last time */
5543                     recompile = 1;
5544                     Renew(pRExC_state->code_blocks,
5545                         pRExC_state->num_code_blocks + ri->num_code_blocks,
5546                         struct reg_code_block);
5547                     pRExC_state->num_code_blocks += ri->num_code_blocks;
5548                     for (i=0; i < ri->num_code_blocks; i++) {
5549                         struct reg_code_block *src, *dst;
5550                         STRLEN offset =  orig_patlen
5551                             + ReANY((REGEXP *)rx)->pre_prefix;
5552                         assert(n < pRExC_state->num_code_blocks);
5553                         src = &ri->code_blocks[i];
5554                         dst = &pRExC_state->code_blocks[n];
5555                         dst->start          = src->start + offset;
5556                         dst->end            = src->end   + offset;
5557                         dst->block          = src->block;
5558                         dst->src_regex  = (REGEXP*) SvREFCNT_inc( (SV*)
5559                                                 src->src_regex
5560                                                     ? src->src_regex
5561                                                     : (REGEXP*)rx);
5562                         n++;
5563                     }
5564                 }
5565             }
5566         }
5567         if (pat_count > 1)
5568             SvSETMAGIC(pat);
5569
5570         /* handle bare (possibly after overloading) regex: foo =~ $re */
5571         {
5572             SV *re = pat;
5573             if (SvROK(re))
5574                 re = SvRV(re);
5575             if (SvTYPE(re) == SVt_REGEXP) {
5576                 if (is_bare_re)
5577                     *is_bare_re = TRUE;
5578                 SvREFCNT_inc(re);
5579                 Safefree(pRExC_state->code_blocks);
5580                 DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
5581                     "Precompiled pattern%s\n",
5582                         orig_rx_flags & RXf_SPLIT ? " for split" : ""));
5583
5584                 return (REGEXP*)re;
5585             }
5586         }
5587     }
5588
5589     exp = SvPV_nomg(pat, plen);
5590
5591     if (!eng->op_comp) {
5592         if ((SvUTF8(pat) && IN_BYTES)
5593                 || SvGMAGICAL(pat) || SvAMAGIC(pat))
5594         {
5595             /* make a temporary copy; either to convert to bytes,
5596              * or to avoid repeating get-magic / overloaded stringify */
5597             pat = newSVpvn_flags(exp, plen, SVs_TEMP |
5598                                         (IN_BYTES ? 0 : SvUTF8(pat)));
5599         }
5600         Safefree(pRExC_state->code_blocks);
5601         return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
5602     }
5603
5604     /* ignore the utf8ness if the pattern is 0 length */
5605     RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
5606     RExC_uni_semantics = 0;
5607     RExC_contains_locale = 0;
5608     pRExC_state->runtime_code_qr = NULL;
5609
5610     DEBUG_COMPILE_r({
5611             SV *dsv= sv_newmortal();
5612             RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, 60);
5613             PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
5614                           PL_colors[4],PL_colors[5],s);
5615         });
5616
5617     if (0) {
5618       redo_first_pass:
5619         /* It's possible to write a regexp in ascii that represents Unicode
5620         codepoints outside of the byte range, such as via \x{100}. If we
5621         detect such a sequence we have to convert the entire pattern to utf8
5622         and then recompile, as our sizing calculation will have been based
5623         on 1 byte == 1 character, but we will need to use utf8 to encode
5624         at least some part of the pattern, and therefore must convert the whole
5625         thing.
5626         -- dmq */
5627
5628         S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen);
5629     }
5630
5631     if ((pm_flags & PMf_USE_RE_EVAL)
5632                 /* this second condition covers the non-regex literal case,
5633                  * i.e.  $foo =~ '(?{})'. */
5634                 || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
5635     )
5636         runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen);
5637
5638     /* return old regex if pattern hasn't changed */
5639     /* XXX: note in the below we have to check the flags as well as the pattern.
5640      *
5641      * Things get a touch tricky as we have to compare the utf8 flag independently
5642      * from the compile flags.
5643      */
5644
5645     if (   old_re
5646         && !recompile
5647         && !!RX_UTF8(old_re) == !!RExC_utf8
5648         && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) )
5649         && RX_PRECOMP(old_re)
5650         && RX_PRELEN(old_re) == plen
5651         && memEQ(RX_PRECOMP(old_re), exp, plen)
5652         && !runtime_code /* with runtime code, always recompile */ )
5653     {
5654         Safefree(pRExC_state->code_blocks);
5655         return old_re;
5656     }
5657
5658     rx_flags = orig_rx_flags;
5659
5660     if (initial_charset == REGEX_LOCALE_CHARSET) {
5661         RExC_contains_locale = 1;
5662     }
5663     else if (RExC_utf8 && initial_charset == REGEX_DEPENDS_CHARSET) {
5664
5665         /* Set to use unicode semantics if the pattern is in utf8 and has the
5666          * 'depends' charset specified, as it means unicode when utf8  */
5667         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
5668     }
5669
5670     RExC_precomp = exp;
5671     RExC_flags = rx_flags;
5672     RExC_pm_flags = pm_flags;
5673
5674     if (runtime_code) {
5675         if (TAINTING_get && TAINT_get)
5676             Perl_croak(aTHX_ "Eval-group in insecure regular expression");
5677
5678         if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
5679             /* whoops, we have a non-utf8 pattern, whilst run-time code
5680              * got compiled as utf8. Try again with a utf8 pattern */
5681             goto redo_first_pass;
5682         }
5683     }
5684     assert(!pRExC_state->runtime_code_qr);
5685
5686     RExC_sawback = 0;
5687
5688     RExC_seen = 0;
5689     RExC_in_lookbehind = 0;
5690     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
5691     RExC_extralen = 0;
5692     RExC_override_recoding = 0;
5693     RExC_in_multi_char_class = 0;
5694
5695     /* First pass: determine size, legality. */
5696     RExC_parse = exp;
5697     RExC_start = exp;
5698     RExC_end = exp + plen;
5699     RExC_naughty = 0;
5700     RExC_npar = 1;
5701     RExC_nestroot = 0;
5702     RExC_size = 0L;
5703     RExC_emit = &PL_regdummy;
5704     RExC_whilem_seen = 0;
5705     RExC_open_parens = NULL;
5706     RExC_close_parens = NULL;
5707     RExC_opend = NULL;
5708     RExC_paren_names = NULL;
5709 #ifdef DEBUGGING
5710     RExC_paren_name_list = NULL;
5711 #endif
5712     RExC_recurse = NULL;
5713     RExC_recurse_count = 0;
5714     pRExC_state->code_index = 0;
5715
5716 #if 0 /* REGC() is (currently) a NOP at the first pass.
5717        * Clever compilers notice this and complain. --jhi */
5718     REGC((U8)REG_MAGIC, (char*)RExC_emit);
5719 #endif
5720     DEBUG_PARSE_r(
5721         PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n");
5722         RExC_lastnum=0;
5723         RExC_lastparse=NULL;
5724     );
5725     /* reg may croak on us, not giving us a chance to free
5726        pRExC_state->code_blocks.  We cannot SAVEFREEPV it now, as we may
5727        need it to survive as long as the regexp (qr/(?{})/).
5728        We must check that code_blocksv is not already set, because we may
5729        have jumped back to restart the sizing pass. */
5730     if (pRExC_state->code_blocks && !code_blocksv) {
5731         code_blocksv = newSV_type(SVt_PV);
5732         SAVEFREESV(code_blocksv);
5733         SvPV_set(code_blocksv, (char *)pRExC_state->code_blocks);
5734         SvLEN_set(code_blocksv, 1); /*sufficient to make sv_clear free it*/
5735     }
5736     if (reg(pRExC_state, 0, &flags,1) == NULL) {
5737         if (flags & RESTART_UTF8) {
5738             goto redo_first_pass;
5739         }
5740         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for sizing pass, flags=%#X", flags);
5741     }
5742     if (code_blocksv)
5743         SvLEN_set(code_blocksv,0); /* no you can't have it, sv_clear */
5744
5745     DEBUG_PARSE_r({
5746         PerlIO_printf(Perl_debug_log, 
5747             "Required size %"IVdf" nodes\n"
5748             "Starting second pass (creation)\n", 
5749             (IV)RExC_size);
5750         RExC_lastnum=0; 
5751         RExC_lastparse=NULL; 
5752     });
5753
5754     /* The first pass could have found things that force Unicode semantics */
5755     if ((RExC_utf8 || RExC_uni_semantics)
5756          && get_regex_charset(rx_flags) == REGEX_DEPENDS_CHARSET)
5757     {
5758         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
5759     }
5760
5761     /* Small enough for pointer-storage convention?
5762        If extralen==0, this means that we will not need long jumps. */
5763     if (RExC_size >= 0x10000L && RExC_extralen)
5764         RExC_size += RExC_extralen;
5765     else
5766         RExC_extralen = 0;
5767     if (RExC_whilem_seen > 15)
5768         RExC_whilem_seen = 15;
5769
5770     /* Allocate space and zero-initialize. Note, the two step process 
5771        of zeroing when in debug mode, thus anything assigned has to 
5772        happen after that */
5773     rx = (REGEXP*) newSV_type(SVt_REGEXP);
5774     r = ReANY(rx);
5775     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
5776          char, regexp_internal);
5777     if ( r == NULL || ri == NULL )
5778         FAIL("Regexp out of space");
5779 #ifdef DEBUGGING
5780     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
5781     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char);
5782 #else 
5783     /* bulk initialize base fields with 0. */
5784     Zero(ri, sizeof(regexp_internal), char);        
5785 #endif
5786
5787     /* non-zero initialization begins here */
5788     RXi_SET( r, ri );
5789     r->engine= eng;
5790     r->extflags = rx_flags;
5791     RXp_COMPFLAGS(r) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK;
5792
5793     if (pm_flags & PMf_IS_QR) {
5794         ri->code_blocks = pRExC_state->code_blocks;
5795         ri->num_code_blocks = pRExC_state->num_code_blocks;
5796     }
5797     else
5798     {
5799         int n;
5800         for (n = 0; n < pRExC_state->num_code_blocks; n++)
5801             if (pRExC_state->code_blocks[n].src_regex)
5802                 SAVEFREESV(pRExC_state->code_blocks[n].src_regex);
5803         SAVEFREEPV(pRExC_state->code_blocks);
5804     }
5805
5806     {
5807         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
5808         bool has_charset = (get_regex_charset(r->extflags) != REGEX_DEPENDS_CHARSET);
5809
5810         /* The caret is output if there are any defaults: if not all the STD
5811          * flags are set, or if no character set specifier is needed */
5812         bool has_default =
5813                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
5814                     || ! has_charset);
5815         bool has_runon = ((RExC_seen & REG_SEEN_RUN_ON_COMMENT)==REG_SEEN_RUN_ON_COMMENT);
5816         U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD)
5817                             >> RXf_PMf_STD_PMMOD_SHIFT);
5818         const char *fptr = STD_PAT_MODS;        /*"msix"*/
5819         char *p;
5820         /* Allocate for the worst case, which is all the std flags are turned
5821          * on.  If more precision is desired, we could do a population count of
5822          * the flags set.  This could be done with a small lookup table, or by
5823          * shifting, masking and adding, or even, when available, assembly
5824          * language for a machine-language population count.
5825          * We never output a minus, as all those are defaults, so are
5826          * covered by the caret */
5827         const STRLEN wraplen = plen + has_p + has_runon
5828             + has_default       /* If needs a caret */
5829
5830                 /* If needs a character set specifier */
5831             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
5832             + (sizeof(STD_PAT_MODS) - 1)
5833             + (sizeof("(?:)") - 1);
5834
5835         Newx(p, wraplen + 1, char); /* +1 for the ending NUL */
5836         r->xpv_len_u.xpvlenu_pv = p;
5837         if (RExC_utf8)
5838             SvFLAGS(rx) |= SVf_UTF8;
5839         *p++='('; *p++='?';
5840
5841         /* If a default, cover it using the caret */
5842         if (has_default) {
5843             *p++= DEFAULT_PAT_MOD;
5844         }
5845         if (has_charset) {
5846             STRLEN len;
5847             const char* const name = get_regex_charset_name(r->extflags, &len);
5848             Copy(name, p, len, char);
5849             p += len;
5850         }
5851         if (has_p)
5852             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
5853         {
5854             char ch;
5855             while((ch = *fptr++)) {
5856                 if(reganch & 1)
5857                     *p++ = ch;
5858                 reganch >>= 1;
5859             }
5860         }
5861
5862         *p++ = ':';
5863         Copy(RExC_precomp, p, plen, char);
5864         assert ((RX_WRAPPED(rx) - p) < 16);
5865         r->pre_prefix = p - RX_WRAPPED(rx);
5866         p += plen;
5867         if (has_runon)
5868             *p++ = '\n';
5869         *p++ = ')';
5870         *p = 0;
5871         SvCUR_set(rx, p - RX_WRAPPED(rx));
5872     }
5873
5874     r->intflags = 0;
5875     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
5876     
5877     if (RExC_seen & REG_SEEN_RECURSE) {
5878         Newxz(RExC_open_parens, RExC_npar,regnode *);
5879         SAVEFREEPV(RExC_open_parens);
5880         Newxz(RExC_close_parens,RExC_npar,regnode *);
5881         SAVEFREEPV(RExC_close_parens);
5882     }
5883
5884     /* Useful during FAIL. */
5885 #ifdef RE_TRACK_PATTERN_OFFSETS
5886     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
5887     DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
5888                           "%s %"UVuf" bytes for offset annotations.\n",
5889                           ri->u.offsets ? "Got" : "Couldn't get",
5890                           (UV)((2*RExC_size+1) * sizeof(U32))));
5891 #endif
5892     SetProgLen(ri,RExC_size);
5893     RExC_rx_sv = rx;
5894     RExC_rx = r;
5895     RExC_rxi = ri;
5896
5897     /* Second pass: emit code. */
5898     RExC_flags = rx_flags;      /* don't let top level (?i) bleed */
5899     RExC_pm_flags = pm_flags;
5900     RExC_parse = exp;
5901     RExC_end = exp + plen;
5902     RExC_naughty = 0;
5903     RExC_npar = 1;
5904     RExC_emit_start = ri->program;
5905     RExC_emit = ri->program;
5906     RExC_emit_bound = ri->program + RExC_size + 1;
5907     pRExC_state->code_index = 0;
5908
5909     REGC((U8)REG_MAGIC, (char*) RExC_emit++);
5910     if (reg(pRExC_state, 0, &flags,1) == NULL) {
5911         ReREFCNT_dec(rx);   
5912         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for generation pass, flags=%#X", flags);
5913     }
5914     /* XXXX To minimize changes to RE engine we always allocate
5915        3-units-long substrs field. */
5916     Newx(r->substrs, 1, struct reg_substr_data);
5917     if (RExC_recurse_count) {
5918         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
5919         SAVEFREEPV(RExC_recurse);
5920     }
5921
5922 reStudy:
5923     r->minlen = minlen = sawlookahead = sawplus = sawopen = 0;
5924     Zero(r->substrs, 1, struct reg_substr_data);
5925
5926 #ifdef TRIE_STUDY_OPT
5927     if (!restudied) {
5928         StructCopy(&zero_scan_data, &data, scan_data_t);
5929         copyRExC_state = RExC_state;
5930     } else {
5931         U32 seen=RExC_seen;
5932         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
5933         
5934         RExC_state = copyRExC_state;
5935         if (seen & REG_TOP_LEVEL_BRANCHES) 
5936             RExC_seen |= REG_TOP_LEVEL_BRANCHES;
5937         else
5938             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES;
5939         StructCopy(&zero_scan_data, &data, scan_data_t);
5940     }
5941 #else
5942     StructCopy(&zero_scan_data, &data, scan_data_t);
5943 #endif    
5944
5945     /* Dig out information for optimizations. */
5946     r->extflags = RExC_flags; /* was pm_op */
5947     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
5948  
5949     if (UTF)
5950         SvUTF8_on(rx);  /* Unicode in it? */
5951     ri->regstclass = NULL;
5952     if (RExC_naughty >= 10)     /* Probably an expensive pattern. */
5953         r->intflags |= PREGf_NAUGHTY;
5954     scan = ri->program + 1;             /* First BRANCH. */
5955
5956     /* testing for BRANCH here tells us whether there is "must appear"
5957        data in the pattern. If there is then we can use it for optimisations */
5958     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /*  Only one top-level choice. */
5959         I32 fake;
5960         STRLEN longest_float_length, longest_fixed_length;
5961         struct regnode_charclass_class ch_class; /* pointed to by data */
5962         int stclass_flag;
5963         I32 last_close = 0; /* pointed to by data */
5964         regnode *first= scan;
5965         regnode *first_next= regnext(first);
5966         /*
5967          * Skip introductions and multiplicators >= 1
5968          * so that we can extract the 'meat' of the pattern that must 
5969          * match in the large if() sequence following.
5970          * NOTE that EXACT is NOT covered here, as it is normally
5971          * picked up by the optimiser separately. 
5972          *
5973          * This is unfortunate as the optimiser isnt handling lookahead
5974          * properly currently.
5975          *
5976          */
5977         while ((OP(first) == OPEN && (sawopen = 1)) ||
5978                /* An OR of *one* alternative - should not happen now. */
5979             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
5980             /* for now we can't handle lookbehind IFMATCH*/
5981             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
5982             (OP(first) == PLUS) ||
5983             (OP(first) == MINMOD) ||
5984                /* An {n,m} with n>0 */
5985             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
5986             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
5987         {
5988                 /* 
5989                  * the only op that could be a regnode is PLUS, all the rest
5990                  * will be regnode_1 or regnode_2.
5991                  *
5992                  */
5993                 if (OP(first) == PLUS)
5994                     sawplus = 1;
5995                 else
5996                     first += regarglen[OP(first)];
5997
5998                 first = NEXTOPER(first);
5999                 first_next= regnext(first);
6000         }
6001
6002         /* Starting-point info. */
6003       again:
6004         DEBUG_PEEP("first:",first,0);
6005         /* Ignore EXACT as we deal with it later. */
6006         if (PL_regkind[OP(first)] == EXACT) {
6007             if (OP(first) == EXACT)
6008                 NOOP;   /* Empty, get anchored substr later. */
6009             else
6010                 ri->regstclass = first;
6011         }
6012 #ifdef TRIE_STCLASS
6013         else if (PL_regkind[OP(first)] == TRIE &&
6014                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0) 
6015         {
6016             regnode *trie_op;
6017             /* this can happen only on restudy */
6018             if ( OP(first) == TRIE ) {
6019                 struct regnode_1 *trieop = (struct regnode_1 *)
6020                     PerlMemShared_calloc(1, sizeof(struct regnode_1));
6021                 StructCopy(first,trieop,struct regnode_1);
6022                 trie_op=(regnode *)trieop;
6023             } else {
6024                 struct regnode_charclass *trieop = (struct regnode_charclass *)
6025                     PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
6026                 StructCopy(first,trieop,struct regnode_charclass);
6027                 trie_op=(regnode *)trieop;
6028             }
6029             OP(trie_op)+=2;
6030             make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
6031             ri->regstclass = trie_op;
6032         }
6033 #endif
6034         else if (REGNODE_SIMPLE(OP(first)))
6035             ri->regstclass = first;
6036         else if (PL_regkind[OP(first)] == BOUND ||
6037                  PL_regkind[OP(first)] == NBOUND)
6038             ri->regstclass = first;
6039         else if (PL_regkind[OP(first)] == BOL) {
6040             r->extflags |= (OP(first) == MBOL
6041                            ? RXf_ANCH_MBOL
6042                            : (OP(first) == SBOL
6043                               ? RXf_ANCH_SBOL
6044                               : RXf_ANCH_BOL));
6045             first = NEXTOPER(first);
6046             goto again;
6047         }
6048         else if (OP(first) == GPOS) {
6049             r->extflags |= RXf_ANCH_GPOS;
6050             first = NEXTOPER(first);
6051             goto again;
6052         }
6053         else if ((!sawopen || !RExC_sawback) &&
6054             (OP(first) == STAR &&
6055             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
6056             !(r->extflags & RXf_ANCH) && !pRExC_state->num_code_blocks)
6057         {
6058             /* turn .* into ^.* with an implied $*=1 */
6059             const int type =
6060                 (OP(NEXTOPER(first)) == REG_ANY)
6061                     ? RXf_ANCH_MBOL
6062                     : RXf_ANCH_SBOL;
6063             r->extflags |= type;
6064             r->intflags |= PREGf_IMPLICIT;
6065             first = NEXTOPER(first);
6066             goto again;
6067         }
6068         if (sawplus && !sawlookahead && (!sawopen || !RExC_sawback)
6069             && !pRExC_state->num_code_blocks) /* May examine pos and $& */
6070             /* x+ must match at the 1st pos of run of x's */
6071             r->intflags |= PREGf_SKIP;
6072
6073         /* Scan is after the zeroth branch, first is atomic matcher. */
6074 #ifdef TRIE_STUDY_OPT
6075         DEBUG_PARSE_r(
6076             if (!restudied)
6077                 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
6078                               (IV)(first - scan + 1))
6079         );
6080 #else
6081         DEBUG_PARSE_r(
6082             PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
6083                 (IV)(first - scan + 1))
6084         );
6085 #endif
6086
6087
6088         /*
6089         * If there's something expensive in the r.e., find the
6090         * longest literal string that must appear and make it the
6091         * regmust.  Resolve ties in favor of later strings, since
6092         * the regstart check works with the beginning of the r.e.
6093         * and avoiding duplication strengthens checking.  Not a
6094         * strong reason, but sufficient in the absence of others.
6095         * [Now we resolve ties in favor of the earlier string if
6096         * it happens that c_offset_min has been invalidated, since the
6097         * earlier string may buy us something the later one won't.]
6098         */
6099
6100         data.longest_fixed = newSVpvs("");
6101         data.longest_float = newSVpvs("");
6102         data.last_found = newSVpvs("");
6103         data.longest = &(data.longest_fixed);
6104         ENTER_with_name("study_chunk");
6105         SAVEFREESV(data.longest_fixed);
6106         SAVEFREESV(data.longest_float);
6107         SAVEFREESV(data.last_found);
6108         first = scan;
6109         if (!ri->regstclass) {
6110             cl_init(pRExC_state, &ch_class);
6111             data.start_class = &ch_class;
6112             stclass_flag = SCF_DO_STCLASS_AND;
6113         } else                          /* XXXX Check for BOUND? */
6114             stclass_flag = 0;
6115         data.last_closep = &last_close;
6116         
6117         minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */
6118             &data, -1, NULL, NULL,
6119             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
6120
6121
6122         CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
6123
6124
6125         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
6126              && data.last_start_min == 0 && data.last_end > 0
6127              && !RExC_seen_zerolen
6128              && !(RExC_seen & REG_SEEN_VERBARG)
6129              && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
6130             r->extflags |= RXf_CHECK_ALL;
6131         scan_commit(pRExC_state, &data,&minlen,0);
6132
6133         longest_float_length = CHR_SVLEN(data.longest_float);
6134
6135         if (! ((SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
6136                    && data.offset_fixed == data.offset_float_min
6137                    && SvCUR(data.longest_fixed) == SvCUR(data.longest_float)))
6138             && S_setup_longest (aTHX_ pRExC_state,
6139                                     data.longest_float,
6140                                     &(r->float_utf8),
6141                                     &(r->float_substr),
6142                                     &(r->float_end_shift),
6143                                     data.lookbehind_float,
6144                                     data.offset_float_min,
6145                                     data.minlen_float,
6146                                     longest_float_length,
6147                                     cBOOL(data.flags & SF_FL_BEFORE_EOL),
6148                                     cBOOL(data.flags & SF_FL_BEFORE_MEOL)))
6149         {
6150             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
6151             r->float_max_offset = data.offset_float_max;
6152             if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
6153                 r->float_max_offset -= data.lookbehind_float;
6154             SvREFCNT_inc_simple_void_NN(data.longest_float);
6155         }
6156         else {
6157             r->float_substr = r->float_utf8 = NULL;
6158             longest_float_length = 0;
6159         }
6160
6161         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
6162
6163         if (S_setup_longest (aTHX_ pRExC_state,
6164                                 data.longest_fixed,
6165                                 &(r->anchored_utf8),
6166                                 &(r->anchored_substr),
6167                                 &(r->anchored_end_shift),
6168                                 data.lookbehind_fixed,
6169                                 data.offset_fixed,
6170                                 data.minlen_fixed,
6171                                 longest_fixed_length,
6172                                 cBOOL(data.flags & SF_FIX_BEFORE_EOL),
6173                                 cBOOL(data.flags & SF_FIX_BEFORE_MEOL)))
6174         {
6175             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
6176             SvREFCNT_inc_simple_void_NN(data.longest_fixed);
6177         }
6178         else {
6179             r->anchored_substr = r->anchored_utf8 = NULL;
6180             longest_fixed_length = 0;
6181         }
6182         LEAVE_with_name("study_chunk");
6183
6184         if (ri->regstclass
6185             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
6186             ri->regstclass = NULL;
6187
6188         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
6189             && stclass_flag
6190             && ! TEST_SSC_EOS(data.start_class)
6191             && !cl_is_anything(data.start_class))
6192         {
6193             const U32 n = add_data(pRExC_state, 1, "f");
6194             OP(data.start_class) = ANYOF_SYNTHETIC;
6195
6196             Newx(RExC_rxi->data->data[n], 1,
6197                 struct regnode_charclass_class);
6198             StructCopy(data.start_class,
6199                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
6200                        struct regnode_charclass_class);
6201             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
6202             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
6203             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
6204                       regprop(r, sv, (regnode*)data.start_class);
6205                       PerlIO_printf(Perl_debug_log,
6206                                     "synthetic stclass \"%s\".\n",
6207                                     SvPVX_const(sv));});
6208         }
6209
6210         /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
6211         if (longest_fixed_length > longest_float_length) {
6212             r->check_end_shift = r->anchored_end_shift;
6213             r->check_substr = r->anchored_substr;
6214             r->check_utf8 = r->anchored_utf8;
6215             r->check_offset_min = r->check_offset_max = r->anchored_offset;
6216             if (r->extflags & RXf_ANCH_SINGLE)
6217                 r->extflags |= RXf_NOSCAN;
6218         }
6219         else {
6220             r->check_end_shift = r->float_end_shift;
6221             r->check_substr = r->float_substr;
6222             r->check_utf8 = r->float_utf8;
6223             r->check_offset_min = r->float_min_offset;
6224             r->check_offset_max = r->float_max_offset;
6225         }
6226         /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
6227            This should be changed ASAP!  */
6228         if ((r->check_substr || r->check_utf8) && !(r->extflags & RXf_ANCH_GPOS)) {
6229             r->extflags |= RXf_USE_INTUIT;
6230             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
6231                 r->extflags |= RXf_INTUIT_TAIL;
6232         }
6233         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
6234         if ( (STRLEN)minlen < longest_float_length )
6235             minlen= longest_float_length;
6236         if ( (STRLEN)minlen < longest_fixed_length )
6237             minlen= longest_fixed_length;     
6238         */
6239     }
6240     else {
6241         /* Several toplevels. Best we can is to set minlen. */
6242         I32 fake;
6243         struct regnode_charclass_class ch_class;
6244         I32 last_close = 0;
6245
6246         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
6247
6248         scan = ri->program + 1;
6249         cl_init(pRExC_state, &ch_class);
6250         data.start_class = &ch_class;
6251         data.last_closep = &last_close;
6252
6253         
6254         minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
6255             &data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
6256         
6257         CHECK_RESTUDY_GOTO_butfirst(NOOP);
6258
6259         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
6260                 = r->float_substr = r->float_utf8 = NULL;
6261
6262         if (! TEST_SSC_EOS(data.start_class)
6263             && !cl_is_anything(data.start_class))
6264         {
6265             const U32 n = add_data(pRExC_state, 1, "f");
6266             OP(data.start_class) = ANYOF_SYNTHETIC;
6267
6268             Newx(RExC_rxi->data->data[n], 1,
6269                 struct regnode_charclass_class);
6270             StructCopy(data.start_class,
6271                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
6272                        struct regnode_charclass_class);
6273             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
6274             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
6275             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
6276                       regprop(r, sv, (regnode*)data.start_class);
6277                       PerlIO_printf(Perl_debug_log,
6278                                     "synthetic stclass \"%s\".\n",
6279                                     SvPVX_const(sv));});
6280         }
6281     }
6282
6283     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
6284        the "real" pattern. */
6285     DEBUG_OPTIMISE_r({
6286         PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n",
6287                       (IV)minlen, (IV)r->minlen);
6288     });
6289     r->minlenret = minlen;
6290     if (r->minlen < minlen) 
6291         r->minlen = minlen;
6292     
6293     if (RExC_seen & REG_SEEN_GPOS)
6294         r->extflags |= RXf_GPOS_SEEN;
6295     if (RExC_seen & REG_SEEN_LOOKBEHIND)
6296         r->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the lookbehind */
6297     if (pRExC_state->num_code_blocks)
6298         r->extflags |= RXf_EVAL_SEEN;
6299     if (RExC_seen & REG_SEEN_CANY)
6300         r->extflags |= RXf_CANY_SEEN;
6301     if (RExC_seen & REG_SEEN_VERBARG)
6302     {
6303         r->intflags |= PREGf_VERBARG_SEEN;
6304         r->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */
6305     }
6306     if (RExC_seen & REG_SEEN_CUTGROUP)
6307         r->intflags |= PREGf_CUTGROUP_SEEN;
6308     if (pm_flags & PMf_USE_RE_EVAL)
6309         r->intflags |= PREGf_USE_RE_EVAL;
6310     if (RExC_paren_names)
6311         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
6312     else
6313         RXp_PAREN_NAMES(r) = NULL;
6314
6315     {
6316         regnode *first = ri->program + 1;
6317         U8 fop = OP(first);
6318         regnode *next = NEXTOPER(first);
6319         U8 nop = OP(next);
6320
6321         if (PL_regkind[fop] == NOTHING && nop == END)
6322             r->extflags |= RXf_NULL;
6323         else if (PL_regkind[fop] == BOL && nop == END)
6324             r->extflags |= RXf_START_ONLY;
6325         else if (fop == PLUS && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE && OP(regnext(first)) == END)
6326             r->extflags |= RXf_WHITE;
6327         else if ( r->extflags & RXf_SPLIT && fop == EXACT && STR_LEN(first) == 1 && *(STRING(first)) == ' ' && OP(regnext(first)) == END )
6328             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
6329
6330     }
6331 #ifdef DEBUGGING
6332     if (RExC_paren_names) {
6333         ri->name_list_idx = add_data( pRExC_state, 1, "a" );
6334         ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list);
6335     } else
6336 #endif
6337         ri->name_list_idx = 0;
6338
6339     if (RExC_recurse_count) {
6340         for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
6341             const regnode *scan = RExC_recurse[RExC_recurse_count-1];
6342             ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
6343         }
6344     }
6345     Newxz(r->offs, RExC_npar, regexp_paren_pair);
6346     /* assume we don't need to swap parens around before we match */
6347
6348     DEBUG_DUMP_r({
6349         PerlIO_printf(Perl_debug_log,"Final program:\n");
6350         regdump(r);
6351     });
6352 #ifdef RE_TRACK_PATTERN_OFFSETS
6353     DEBUG_OFFSETS_r(if (ri->u.offsets) {
6354         const U32 len = ri->u.offsets[0];
6355         U32 i;
6356         GET_RE_DEBUG_FLAGS_DECL;
6357         PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
6358         for (i = 1; i <= len; i++) {
6359             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
6360                 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
6361                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
6362             }
6363         PerlIO_printf(Perl_debug_log, "\n");
6364     });
6365 #endif
6366
6367 #ifdef USE_ITHREADS
6368     /* under ithreads the ?pat? PMf_USED flag on the pmop is simulated
6369      * by setting the regexp SV to readonly-only instead. If the
6370      * pattern's been recompiled, the USEDness should remain. */
6371     if (old_re && SvREADONLY(old_re))
6372         SvREADONLY_on(rx);
6373 #endif
6374     return rx;
6375 }
6376
6377
6378 SV*
6379 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
6380                     const U32 flags)
6381 {
6382     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
6383
6384     PERL_UNUSED_ARG(value);
6385
6386     if (flags & RXapif_FETCH) {
6387         return reg_named_buff_fetch(rx, key, flags);
6388     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
6389         Perl_croak_no_modify();
6390         return NULL;
6391     } else if (flags & RXapif_EXISTS) {
6392         return reg_named_buff_exists(rx, key, flags)
6393             ? &PL_sv_yes
6394             : &PL_sv_no;
6395     } else if (flags & RXapif_REGNAMES) {
6396         return reg_named_buff_all(rx, flags);
6397     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
6398         return reg_named_buff_scalar(rx, flags);
6399     } else {
6400         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
6401         return NULL;
6402     }
6403 }
6404
6405 SV*
6406 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
6407                          const U32 flags)
6408 {
6409     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
6410     PERL_UNUSED_ARG(lastkey);
6411
6412     if (flags & RXapif_FIRSTKEY)
6413         return reg_named_buff_firstkey(rx, flags);
6414     else if (flags & RXapif_NEXTKEY)
6415         return reg_named_buff_nextkey(rx, flags);
6416     else {
6417         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter", (int)flags);
6418         return NULL;
6419     }
6420 }
6421
6422 SV*
6423 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
6424                           const U32 flags)
6425 {
6426     AV *retarray = NULL;
6427     SV *ret;
6428     struct regexp *const rx = ReANY(r);
6429
6430     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
6431
6432     if (flags & RXapif_ALL)
6433         retarray=newAV();
6434
6435     if (rx && RXp_PAREN_NAMES(rx)) {
6436         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
6437         if (he_str) {
6438             IV i;
6439             SV* sv_dat=HeVAL(he_str);
6440             I32 *nums=(I32*)SvPVX(sv_dat);
6441             for ( i=0; i<SvIVX(sv_dat); i++ ) {
6442                 if ((I32)(rx->nparens) >= nums[i]
6443                     && rx->offs[nums[i]].start != -1
6444                     && rx->offs[nums[i]].end != -1)
6445                 {
6446                     ret = newSVpvs("");
6447                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
6448                     if (!retarray)
6449                         return ret;
6450                 } else {
6451                     if (retarray)
6452                         ret = newSVsv(&PL_sv_undef);
6453                 }
6454                 if (retarray)
6455                     av_push(retarray, ret);
6456             }
6457             if (retarray)
6458                 return newRV_noinc(MUTABLE_SV(retarray));
6459         }
6460     }
6461     return NULL;
6462 }
6463
6464 bool
6465 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
6466                            const U32 flags)
6467 {
6468     struct regexp *const rx = ReANY(r);
6469
6470     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
6471
6472     if (rx && RXp_PAREN_NAMES(rx)) {
6473         if (flags & RXapif_ALL) {
6474             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
6475         } else {
6476             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
6477             if (sv) {
6478                 SvREFCNT_dec_NN(sv);
6479                 return TRUE;
6480             } else {
6481                 return FALSE;
6482             }
6483         }
6484     } else {
6485         return FALSE;
6486     }
6487 }
6488
6489 SV*
6490 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
6491 {
6492     struct regexp *const rx = ReANY(r);
6493
6494     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
6495
6496     if ( rx && RXp_PAREN_NAMES(rx) ) {
6497         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
6498
6499         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
6500     } else {
6501         return FALSE;
6502     }
6503 }
6504
6505 SV*
6506 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
6507 {
6508     struct regexp *const rx = ReANY(r);
6509     GET_RE_DEBUG_FLAGS_DECL;
6510
6511     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
6512
6513     if (rx && RXp_PAREN_NAMES(rx)) {
6514         HV *hv = RXp_PAREN_NAMES(rx);
6515         HE *temphe;
6516         while ( (temphe = hv_iternext_flags(hv,0)) ) {
6517             IV i;
6518             IV parno = 0;
6519             SV* sv_dat = HeVAL(temphe);
6520             I32 *nums = (I32*)SvPVX(sv_dat);
6521             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
6522                 if ((I32)(rx->lastparen) >= nums[i] &&
6523                     rx->offs[nums[i]].start != -1 &&
6524                     rx->offs[nums[i]].end != -1)
6525                 {
6526                     parno = nums[i];
6527                     break;
6528                 }
6529             }
6530             if (parno || flags & RXapif_ALL) {
6531                 return newSVhek(HeKEY_hek(temphe));
6532             }
6533         }
6534     }
6535     return NULL;
6536 }
6537
6538 SV*
6539 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
6540 {
6541     SV *ret;
6542     AV *av;
6543     I32 length;
6544     struct regexp *const rx = ReANY(r);
6545
6546     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
6547
6548     if (rx && RXp_PAREN_NAMES(rx)) {
6549         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
6550             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
6551         } else if (flags & RXapif_ONE) {
6552             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
6553             av = MUTABLE_AV(SvRV(ret));
6554             length = av_len(av);
6555             SvREFCNT_dec_NN(ret);
6556             return newSViv(length + 1);
6557         } else {
6558             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", (int)flags);
6559             return NULL;
6560         }
6561     }
6562     return &PL_sv_undef;
6563 }
6564
6565 SV*
6566 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
6567 {
6568     struct regexp *const rx = ReANY(r);
6569     AV *av = newAV();
6570
6571     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
6572
6573     if (rx && RXp_PAREN_NAMES(rx)) {
6574         HV *hv= RXp_PAREN_NAMES(rx);
6575         HE *temphe;
6576         (void)hv_iterinit(hv);
6577         while ( (temphe = hv_iternext_flags(hv,0)) ) {
6578             IV i;
6579             IV parno = 0;
6580             SV* sv_dat = HeVAL(temphe);
6581             I32 *nums = (I32*)SvPVX(sv_dat);
6582             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
6583                 if ((I32)(rx->lastparen) >= nums[i] &&
6584                     rx->offs[nums[i]].start != -1 &&
6585                     rx->offs[nums[i]].end != -1)
6586                 {
6587                     parno = nums[i];
6588                     break;
6589                 }
6590             }
6591             if (parno || flags & RXapif_ALL) {
6592                 av_push(av, newSVhek(HeKEY_hek(temphe)));
6593             }
6594         }
6595     }
6596
6597     return newRV_noinc(MUTABLE_SV(av));
6598 }
6599
6600 void
6601 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
6602                              SV * const sv)
6603 {
6604     struct regexp *const rx = ReANY(r);
6605     char *s = NULL;
6606     I32 i = 0;
6607     I32 s1, t1;
6608     I32 n = paren;
6609
6610     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
6611         
6612     if ( (    n == RX_BUFF_IDX_CARET_PREMATCH
6613            || n == RX_BUFF_IDX_CARET_FULLMATCH
6614            || n == RX_BUFF_IDX_CARET_POSTMATCH
6615          )
6616          && !(rx->extflags & RXf_PMf_KEEPCOPY)
6617     )
6618         goto ret_undef;
6619
6620     if (!rx->subbeg)
6621         goto ret_undef;
6622
6623     if (n == RX_BUFF_IDX_CARET_FULLMATCH)
6624         /* no need to distinguish between them any more */
6625         n = RX_BUFF_IDX_FULLMATCH;
6626
6627     if ((n == RX_BUFF_IDX_PREMATCH || n == RX_BUFF_IDX_CARET_PREMATCH)
6628         && rx->offs[0].start != -1)
6629     {
6630         /* $`, ${^PREMATCH} */
6631         i = rx->offs[0].start;
6632         s = rx->subbeg;
6633     }
6634     else 
6635     if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
6636         && rx->offs[0].end != -1)
6637     {
6638         /* $', ${^POSTMATCH} */
6639         s = rx->subbeg - rx->suboffset + rx->offs[0].end;
6640         i = rx->sublen + rx->suboffset - rx->offs[0].end;
6641     } 
6642     else
6643     if ( 0 <= n && n <= (I32)rx->nparens &&
6644         (s1 = rx->offs[n].start) != -1 &&
6645         (t1 = rx->offs[n].end) != -1)
6646     {
6647         /* $&, ${^MATCH},  $1 ... */
6648         i = t1 - s1;
6649         s = rx->subbeg + s1 - rx->suboffset;
6650     } else {
6651         goto ret_undef;
6652     }          
6653
6654     assert(s >= rx->subbeg);
6655     assert(rx->sublen >= (s - rx->subbeg) + i );
6656     if (i >= 0) {
6657 #if NO_TAINT_SUPPORT
6658         sv_setpvn(sv, s, i);
6659 #else
6660         const int oldtainted = TAINT_get;
6661         TAINT_NOT;
6662         sv_setpvn(sv, s, i);
6663         TAINT_set(oldtainted);
6664 #endif
6665         if ( (rx->extflags & RXf_CANY_SEEN)
6666             ? (RXp_MATCH_UTF8(rx)
6667                         && (!i || is_utf8_string((U8*)s, i)))
6668             : (RXp_MATCH_UTF8(rx)) )
6669         {
6670             SvUTF8_on(sv);
6671         }
6672         else
6673             SvUTF8_off(sv);
6674         if (TAINTING_get) {
6675             if (RXp_MATCH_TAINTED(rx)) {
6676                 if (SvTYPE(sv) >= SVt_PVMG) {
6677                     MAGIC* const mg = SvMAGIC(sv);
6678                     MAGIC* mgt;
6679                     TAINT;
6680                     SvMAGIC_set(sv, mg->mg_moremagic);
6681                     SvTAINT(sv);
6682                     if ((mgt = SvMAGIC(sv))) {
6683                         mg->mg_moremagic = mgt;
6684                         SvMAGIC_set(sv, mg);
6685                     }
6686                 } else {
6687                     TAINT;
6688                     SvTAINT(sv);
6689                 }
6690             } else 
6691                 SvTAINTED_off(sv);
6692         }
6693     } else {
6694       ret_undef:
6695         sv_setsv(sv,&PL_sv_undef);
6696         return;
6697     }
6698 }
6699
6700 void
6701 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
6702                                                          SV const * const value)
6703 {
6704     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
6705
6706     PERL_UNUSED_ARG(rx);
6707     PERL_UNUSED_ARG(paren);
6708     PERL_UNUSED_ARG(value);
6709
6710     if (!PL_localizing)
6711         Perl_croak_no_modify();
6712 }
6713
6714 I32
6715 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
6716                               const I32 paren)
6717 {
6718     struct regexp *const rx = ReANY(r);
6719     I32 i;
6720     I32 s1, t1;
6721
6722     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
6723
6724     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
6725     switch (paren) {
6726       case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */
6727          if (!(rx->extflags & RXf_PMf_KEEPCOPY))
6728             goto warn_undef;
6729         /*FALLTHROUGH*/
6730
6731       case RX_BUFF_IDX_PREMATCH:       /* $` */
6732         if (rx->offs[0].start != -1) {
6733                         i = rx->offs[0].start;
6734                         if (i > 0) {
6735                                 s1 = 0;
6736                                 t1 = i;
6737                                 goto getlen;
6738                         }
6739             }
6740         return 0;
6741
6742       case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */
6743          if (!(rx->extflags & RXf_PMf_KEEPCOPY))
6744             goto warn_undef;
6745       case RX_BUFF_IDX_POSTMATCH:       /* $' */
6746             if (rx->offs[0].end != -1) {
6747                         i = rx->sublen - rx->offs[0].end;
6748                         if (i > 0) {
6749                                 s1 = rx->offs[0].end;
6750                                 t1 = rx->sublen;
6751                                 goto getlen;
6752                         }
6753             }
6754         return 0;
6755
6756       case RX_BUFF_IDX_CARET_FULLMATCH: /* ${^MATCH} */
6757          if (!(rx->extflags & RXf_PMf_KEEPCOPY))
6758             goto warn_undef;
6759         /*FALLTHROUGH*/
6760
6761       /* $& / ${^MATCH}, $1, $2, ... */
6762       default:
6763             if (paren <= (I32)rx->nparens &&
6764             (s1 = rx->offs[paren].start) != -1 &&
6765             (t1 = rx->offs[paren].end) != -1)
6766             {
6767             i = t1 - s1;
6768             goto getlen;
6769         } else {
6770           warn_undef:
6771             if (ckWARN(WARN_UNINITIALIZED))
6772                 report_uninit((const SV *)sv);
6773             return 0;
6774         }
6775     }
6776   getlen:
6777     if (i > 0 && RXp_MATCH_UTF8(rx)) {
6778         const char * const s = rx->subbeg - rx->suboffset + s1;
6779         const U8 *ep;
6780         STRLEN el;
6781
6782         i = t1 - s1;
6783         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
6784                         i = el;
6785     }
6786     return i;
6787 }
6788
6789 SV*
6790 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
6791 {
6792     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
6793         PERL_UNUSED_ARG(rx);
6794         if (0)
6795             return NULL;
6796         else
6797             return newSVpvs("Regexp");
6798 }
6799
6800 /* Scans the name of a named buffer from the pattern.
6801  * If flags is REG_RSN_RETURN_NULL returns null.
6802  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
6803  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
6804  * to the parsed name as looked up in the RExC_paren_names hash.
6805  * If there is an error throws a vFAIL().. type exception.
6806  */
6807
6808 #define REG_RSN_RETURN_NULL    0
6809 #define REG_RSN_RETURN_NAME    1
6810 #define REG_RSN_RETURN_DATA    2
6811
6812 STATIC SV*
6813 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
6814 {
6815     char *name_start = RExC_parse;
6816
6817     PERL_ARGS_ASSERT_REG_SCAN_NAME;
6818
6819     if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
6820          /* skip IDFIRST by using do...while */
6821         if (UTF)
6822             do {
6823                 RExC_parse += UTF8SKIP(RExC_parse);
6824             } while (isWORDCHAR_utf8((U8*)RExC_parse));
6825         else
6826             do {
6827                 RExC_parse++;
6828             } while (isWORDCHAR(*RExC_parse));
6829     } else {
6830         RExC_parse++; /* so the <- from the vFAIL is after the offending character */
6831         vFAIL("Group name must start with a non-digit word character");
6832     }
6833     if ( flags ) {
6834         SV* sv_name
6835             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
6836                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
6837         if ( flags == REG_RSN_RETURN_NAME)
6838             return sv_name;
6839         else if (flags==REG_RSN_RETURN_DATA) {
6840             HE *he_str = NULL;
6841             SV *sv_dat = NULL;
6842             if ( ! sv_name )      /* should not happen*/
6843                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
6844             if (RExC_paren_names)
6845                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
6846             if ( he_str )
6847                 sv_dat = HeVAL(he_str);
6848             if ( ! sv_dat )
6849                 vFAIL("Reference to nonexistent named group");
6850             return sv_dat;
6851         }
6852         else {
6853             Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
6854                        (unsigned long) flags);
6855         }
6856         assert(0); /* NOT REACHED */
6857     }
6858     return NULL;
6859 }
6860
6861 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
6862     int rem=(int)(RExC_end - RExC_parse);                       \
6863     int cut;                                                    \
6864     int num;                                                    \
6865     int iscut=0;                                                \
6866     if (rem>10) {                                               \
6867         rem=10;                                                 \
6868         iscut=1;                                                \
6869     }                                                           \
6870     cut=10-rem;                                                 \
6871     if (RExC_lastparse!=RExC_parse)                             \
6872         PerlIO_printf(Perl_debug_log," >%.*s%-*s",              \
6873             rem, RExC_parse,                                    \
6874             cut + 4,                                            \
6875             iscut ? "..." : "<"                                 \
6876         );                                                      \
6877     else                                                        \
6878         PerlIO_printf(Perl_debug_log,"%16s","");                \
6879                                                                 \
6880     if (SIZE_ONLY)                                              \
6881        num = RExC_size + 1;                                     \
6882     else                                                        \
6883        num=REG_NODE_NUM(RExC_emit);                             \
6884     if (RExC_lastnum!=num)                                      \
6885        PerlIO_printf(Perl_debug_log,"|%4d",num);                \
6886     else                                                        \
6887        PerlIO_printf(Perl_debug_log,"|%4s","");                 \
6888     PerlIO_printf(Perl_debug_log,"|%*s%-4s",                    \
6889         (int)((depth*2)), "",                                   \
6890         (funcname)                                              \
6891     );                                                          \
6892     RExC_lastnum=num;                                           \
6893     RExC_lastparse=RExC_parse;                                  \
6894 })
6895
6896
6897
6898 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
6899     DEBUG_PARSE_MSG((funcname));                            \
6900     PerlIO_printf(Perl_debug_log,"%4s","\n");               \
6901 })
6902 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({           \
6903     DEBUG_PARSE_MSG((funcname));                            \
6904     PerlIO_printf(Perl_debug_log,fmt "\n",args);               \
6905 })
6906
6907 /* This section of code defines the inversion list object and its methods.  The
6908  * interfaces are highly subject to change, so as much as possible is static to
6909  * this file.  An inversion list is here implemented as a malloc'd C UV array
6910  * with some added info that is placed as UVs at the beginning in a header
6911  * portion.  An inversion list for Unicode is an array of code points, sorted
6912  * by ordinal number.  The zeroth element is the first code point in the list.
6913  * The 1th element is the first element beyond that not in the list.  In other
6914  * words, the first range is
6915  *  invlist[0]..(invlist[1]-1)
6916  * The other ranges follow.  Thus every element whose index is divisible by two
6917  * marks the beginning of a range that is in the list, and every element not
6918  * divisible by two marks the beginning of a range not in the list.  A single
6919  * element inversion list that contains the single code point N generally
6920  * consists of two elements
6921  *  invlist[0] == N
6922  *  invlist[1] == N+1
6923  * (The exception is when N is the highest representable value on the
6924  * machine, in which case the list containing just it would be a single
6925  * element, itself.  By extension, if the last range in the list extends to
6926  * infinity, then the first element of that range will be in the inversion list
6927  * at a position that is divisible by two, and is the final element in the
6928  * list.)
6929  * Taking the complement (inverting) an inversion list is quite simple, if the
6930  * first element is 0, remove it; otherwise add a 0 element at the beginning.
6931  * This implementation reserves an element at the beginning of each inversion
6932  * list to contain 0 when the list contains 0, and contains 1 otherwise.  The
6933  * actual beginning of the list is either that element if 0, or the next one if
6934  * 1.
6935  *
6936  * More about inversion lists can be found in "Unicode Demystified"
6937  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
6938  * More will be coming when functionality is added later.
6939  *
6940  * The inversion list data structure is currently implemented as an SV pointing
6941  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
6942  * array of UV whose memory management is automatically handled by the existing
6943  * facilities for SV's.
6944  *
6945  * Some of the methods should always be private to the implementation, and some
6946  * should eventually be made public */
6947
6948 /* The header definitions are in F<inline_invlist.c> */
6949 #define TO_INTERNAL_SIZE(x) (((x) + HEADER_LENGTH) * sizeof(UV))
6950 #define FROM_INTERNAL_SIZE(x) (((x)/ sizeof(UV)) - HEADER_LENGTH)
6951
6952 #define INVLIST_INITIAL_LEN 10
6953
6954 PERL_STATIC_INLINE UV*
6955 S__invlist_array_init(pTHX_ SV* const invlist, const bool will_have_0)
6956 {
6957     /* Returns a pointer to the first element in the inversion list's array.
6958      * This is called upon initialization of an inversion list.  Where the
6959      * array begins depends on whether the list has the code point U+0000
6960      * in it or not.  The other parameter tells it whether the code that
6961      * follows this call is about to put a 0 in the inversion list or not.
6962      * The first element is either the element with 0, if 0, or the next one,
6963      * if 1 */
6964
6965     UV* zero = get_invlist_zero_addr(invlist);
6966
6967     PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
6968
6969     /* Must be empty */
6970     assert(! *_get_invlist_len_addr(invlist));
6971
6972     /* 1^1 = 0; 1^0 = 1 */
6973     *zero = 1 ^ will_have_0;
6974     return zero + *zero;
6975 }
6976
6977 PERL_STATIC_INLINE UV*
6978 S_invlist_array(pTHX_ SV* const invlist)
6979 {
6980     /* Returns the pointer to the inversion list's array.  Every time the
6981      * length changes, this needs to be called in case malloc or realloc moved
6982      * it */
6983
6984     PERL_ARGS_ASSERT_INVLIST_ARRAY;
6985
6986     /* Must not be empty.  If these fail, you probably didn't check for <len>
6987      * being non-zero before trying to get the array */
6988     assert(*_get_invlist_len_addr(invlist));
6989     assert(*get_invlist_zero_addr(invlist) == 0
6990            || *get_invlist_zero_addr(invlist) == 1);
6991
6992     /* The array begins either at the element reserved for zero if the
6993      * list contains 0 (that element will be set to 0), or otherwise the next
6994      * element (in which case the reserved element will be set to 1). */
6995     return (UV *) (get_invlist_zero_addr(invlist)
6996                    + *get_invlist_zero_addr(invlist));
6997 }
6998
6999 PERL_STATIC_INLINE void
7000 S_invlist_set_len(pTHX_ SV* const invlist, const UV len)
7001 {
7002     /* Sets the current number of elements stored in the inversion list */
7003
7004     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
7005
7006     *_get_invlist_len_addr(invlist) = len;
7007
7008     assert(len <= SvLEN(invlist));
7009
7010     SvCUR_set(invlist, TO_INTERNAL_SIZE(len));
7011     /* If the list contains U+0000, that element is part of the header,
7012      * and should not be counted as part of the array.  It will contain
7013      * 0 in that case, and 1 otherwise.  So we could flop 0=>1, 1=>0 and
7014      * subtract:
7015      *  SvCUR_set(invlist,
7016      *            TO_INTERNAL_SIZE(len
7017      *                             - (*get_invlist_zero_addr(inv_list) ^ 1)));
7018      * But, this is only valid if len is not 0.  The consequences of not doing
7019      * this is that the memory allocation code may think that 1 more UV is
7020      * being used than actually is, and so might do an unnecessary grow.  That
7021      * seems worth not bothering to make this the precise amount.
7022      *
7023      * Note that when inverting, SvCUR shouldn't change */
7024 }
7025
7026 PERL_STATIC_INLINE IV*
7027 S_get_invlist_previous_index_addr(pTHX_ SV* invlist)
7028 {
7029     /* Return the address of the UV that is reserved to hold the cached index
7030      * */
7031
7032     PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR;
7033
7034     return (IV *) (SvPVX(invlist) + (INVLIST_PREVIOUS_INDEX_OFFSET * sizeof (UV)));
7035 }
7036
7037 PERL_STATIC_INLINE IV
7038 S_invlist_previous_index(pTHX_ SV* const invlist)
7039 {
7040     /* Returns cached index of previous search */
7041
7042     PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX;
7043
7044     return *get_invlist_previous_index_addr(invlist);
7045 }
7046
7047 PERL_STATIC_INLINE void
7048 S_invlist_set_previous_index(pTHX_ SV* const invlist, const IV index)
7049 {
7050     /* Caches <index> for later retrieval */
7051
7052     PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX;
7053
7054     assert(index == 0 || index < (int) _invlist_len(invlist));
7055
7056     *get_invlist_previous_index_addr(invlist) = index;
7057 }
7058
7059 PERL_STATIC_INLINE UV
7060 S_invlist_max(pTHX_ SV* const invlist)
7061 {
7062     /* Returns the maximum number of elements storable in the inversion list's
7063      * array, without having to realloc() */
7064
7065     PERL_ARGS_ASSERT_INVLIST_MAX;
7066
7067     return SvLEN(invlist) == 0  /* This happens under _new_invlist_C_array */
7068            ? _invlist_len(invlist)
7069            : FROM_INTERNAL_SIZE(SvLEN(invlist));
7070 }
7071
7072 PERL_STATIC_INLINE UV*
7073 S_get_invlist_zero_addr(pTHX_ SV* invlist)
7074 {
7075     /* Return the address of the UV that is reserved to hold 0 if the inversion
7076      * list contains 0.  This has to be the last element of the heading, as the
7077      * list proper starts with either it if 0, or the next element if not.
7078      * (But we force it to contain either 0 or 1) */
7079
7080     PERL_ARGS_ASSERT_GET_INVLIST_ZERO_ADDR;
7081
7082     return (UV *) (SvPVX(invlist) + (INVLIST_ZERO_OFFSET * sizeof (UV)));
7083 }
7084
7085 #ifndef PERL_IN_XSUB_RE
7086 SV*
7087 Perl__new_invlist(pTHX_ IV initial_size)
7088 {
7089
7090     /* Return a pointer to a newly constructed inversion list, with enough
7091      * space to store 'initial_size' elements.  If that number is negative, a
7092      * system default is used instead */
7093
7094     SV* new_list;
7095
7096     if (initial_size < 0) {
7097         initial_size = INVLIST_INITIAL_LEN;
7098     }
7099
7100     /* Allocate the initial space */
7101     new_list = newSV(TO_INTERNAL_SIZE(initial_size));
7102     invlist_set_len(new_list, 0);
7103
7104     /* Force iterinit() to be used to get iteration to work */
7105     *get_invlist_iter_addr(new_list) = UV_MAX;
7106
7107     /* This should force a segfault if a method doesn't initialize this
7108      * properly */
7109     *get_invlist_zero_addr(new_list) = UV_MAX;
7110
7111     *get_invlist_previous_index_addr(new_list) = 0;
7112     *get_invlist_version_id_addr(new_list) = INVLIST_VERSION_ID;
7113 #if HEADER_LENGTH != 5
7114 #   error Need to regenerate INVLIST_VERSION_ID by running perl -E 'say int(rand 2**31-1)', and then changing the #if to the new length
7115 #endif
7116
7117     return new_list;
7118 }
7119 #endif
7120
7121 STATIC SV*
7122 S__new_invlist_C_array(pTHX_ UV* list)
7123 {
7124     /* Return a pointer to a newly constructed inversion list, initialized to
7125      * point to <list>, which has to be in the exact correct inversion list
7126      * form, including internal fields.  Thus this is a dangerous routine that
7127      * should not be used in the wrong hands */
7128
7129     SV* invlist = newSV_type(SVt_PV);
7130
7131     PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
7132
7133     SvPV_set(invlist, (char *) list);
7134     SvLEN_set(invlist, 0);  /* Means we own the contents, and the system
7135                                shouldn't touch it */
7136     SvCUR_set(invlist, TO_INTERNAL_SIZE(_invlist_len(invlist)));
7137
7138     if (*get_invlist_version_id_addr(invlist) != INVLIST_VERSION_ID) {
7139         Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
7140     }
7141
7142     /* Initialize the iteration pointer.
7143      * XXX This could be done at compile time in charclass_invlists.h, but I
7144      * (khw) am not confident that the suffixes for specifying the C constant
7145      * UV_MAX are portable, e.g.  'ull' on a 32 bit machine that is configured
7146      * to use 64 bits; might need a Configure probe */
7147     invlist_iterfinish(invlist);
7148
7149     return invlist;
7150 }
7151
7152 STATIC void
7153 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
7154 {
7155     /* Grow the maximum size of an inversion list */
7156
7157     PERL_ARGS_ASSERT_INVLIST_EXTEND;
7158
7159     SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max));
7160 }
7161
7162 PERL_STATIC_INLINE void
7163 S_invlist_trim(pTHX_ SV* const invlist)
7164 {
7165     PERL_ARGS_ASSERT_INVLIST_TRIM;
7166
7167     /* Change the length of the inversion list to how many entries it currently
7168      * has */
7169
7170     SvPV_shrink_to_cur((SV *) invlist);
7171 }
7172
7173 #define _invlist_union_complement_2nd(a, b, output) _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
7174
7175 STATIC void
7176 S__append_range_to_invlist(pTHX_ SV* const invlist, const UV start, const UV end)
7177 {
7178    /* Subject to change or removal.  Append the range from 'start' to 'end' at
7179     * the end of the inversion list.  The range must be above any existing
7180     * ones. */
7181
7182     UV* array;
7183     UV max = invlist_max(invlist);
7184     UV len = _invlist_len(invlist);
7185
7186     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
7187
7188     if (len == 0) { /* Empty lists must be initialized */
7189         array = _invlist_array_init(invlist, start == 0);
7190     }
7191     else {
7192         /* Here, the existing list is non-empty. The current max entry in the
7193          * list is generally the first value not in the set, except when the
7194          * set extends to the end of permissible values, in which case it is
7195          * the first entry in that final set, and so this call is an attempt to
7196          * append out-of-order */
7197
7198         UV final_element = len - 1;
7199         array = invlist_array(invlist);
7200         if (array[final_element] > start
7201             || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
7202         {
7203             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",
7204                        array[final_element], start,
7205                        ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
7206         }
7207
7208         /* Here, it is a legal append.  If the new range begins with the first
7209          * value not in the set, it is extending the set, so the new first
7210          * value not in the set is one greater than the newly extended range.
7211          * */
7212         if (array[final_element] == start) {
7213             if (end != UV_MAX) {
7214                 array[final_element] = end + 1;
7215             }
7216             else {
7217                 /* But if the end is the maximum representable on the machine,
7218                  * just let the range that this would extend to have no end */
7219                 invlist_set_len(invlist, len - 1);
7220             }
7221             return;
7222         }
7223     }
7224
7225     /* Here the new range doesn't extend any existing set.  Add it */
7226
7227     len += 2;   /* Includes an element each for the start and end of range */
7228
7229     /* If overflows the existing space, extend, which may cause the array to be
7230      * moved */
7231     if (max < len) {
7232         invlist_extend(invlist, len);
7233         invlist_set_len(invlist, len);  /* Have to set len here to avoid assert
7234                                            failure in invlist_array() */
7235         array = invlist_array(invlist);
7236     }
7237     else {
7238         invlist_set_len(invlist, len);
7239     }
7240
7241     /* The next item on the list starts the range, the one after that is
7242      * one past the new range.  */
7243     array[len - 2] = start;
7244     if (end != UV_MAX) {
7245         array[len - 1] = end + 1;
7246     }
7247     else {
7248         /* But if the end is the maximum representable on the machine, just let
7249          * the range have no end */
7250         invlist_set_len(invlist, len - 1);
7251     }
7252 }
7253
7254 #ifndef PERL_IN_XSUB_RE
7255
7256 IV
7257 Perl__invlist_search(pTHX_ SV* const invlist, const UV cp)
7258 {
7259     /* Searches the inversion list for the entry that contains the input code
7260      * point <cp>.  If <cp> is not in the list, -1 is returned.  Otherwise, the
7261      * return value is the index into the list's array of the range that
7262      * contains <cp> */
7263
7264     IV low = 0;
7265     IV mid;
7266     IV high = _invlist_len(invlist);
7267     const IV highest_element = high - 1;
7268     const UV* array;
7269
7270     PERL_ARGS_ASSERT__INVLIST_SEARCH;
7271
7272     /* If list is empty, return failure. */
7273     if (high == 0) {
7274         return -1;
7275     }
7276
7277     /* (We can't get the array unless we know the list is non-empty) */
7278     array = invlist_array(invlist);
7279
7280     mid = invlist_previous_index(invlist);
7281     assert(mid >=0 && mid <= highest_element);
7282
7283     /* <mid> contains the cache of the result of the previous call to this
7284      * function (0 the first time).  See if this call is for the same result,
7285      * or if it is for mid-1.  This is under the theory that calls to this
7286      * function will often be for related code points that are near each other.
7287      * And benchmarks show that caching gives better results.  We also test
7288      * here if the code point is within the bounds of the list.  These tests
7289      * replace others that would have had to be made anyway to make sure that
7290      * the array bounds were not exceeded, and these give us extra information
7291      * at the same time */
7292     if (cp >= array[mid]) {
7293         if (cp >= array[highest_element]) {
7294             return highest_element;
7295         }
7296
7297         /* Here, array[mid] <= cp < array[highest_element].  This means that
7298          * the final element is not the answer, so can exclude it; it also
7299          * means that <mid> is not the final element, so can refer to 'mid + 1'
7300          * safely */
7301         if (cp < array[mid + 1]) {
7302             return mid;
7303         }
7304         high--;
7305         low = mid + 1;
7306     }
7307     else { /* cp < aray[mid] */
7308         if (cp < array[0]) { /* Fail if outside the array */
7309             return -1;
7310         }
7311         high = mid;
7312         if (cp >= array[mid - 1]) {
7313             goto found_entry;
7314         }
7315     }
7316
7317     /* Binary search.  What we are looking for is <i> such that
7318      *  array[i] <= cp < array[i+1]
7319      * The loop below converges on the i+1.  Note that there may not be an
7320      * (i+1)th element in the array, and things work nonetheless */
7321     while (low < high) {
7322         mid = (low + high) / 2;
7323         assert(mid <= highest_element);
7324         if (array[mid] <= cp) { /* cp >= array[mid] */
7325             low = mid + 1;
7326
7327             /* We could do this extra test to exit the loop early.
7328             if (cp < array[low]) {
7329                 return mid;
7330             }
7331             */
7332         }
7333         else { /* cp < array[mid] */
7334             high = mid;
7335         }
7336     }
7337
7338   found_entry:
7339     high--;
7340     invlist_set_previous_index(invlist, high);
7341     return high;
7342 }
7343
7344 void
7345 Perl__invlist_populate_swatch(pTHX_ SV* const invlist, const UV start, const UV end, U8* swatch)
7346 {
7347     /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
7348      * but is used when the swash has an inversion list.  This makes this much
7349      * faster, as it uses a binary search instead of a linear one.  This is
7350      * intimately tied to that function, and perhaps should be in utf8.c,
7351      * except it is intimately tied to inversion lists as well.  It assumes
7352      * that <swatch> is all 0's on input */
7353
7354     UV current = start;
7355     const IV len = _invlist_len(invlist);
7356     IV i;
7357     const UV * array;
7358
7359     PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
7360
7361     if (len == 0) { /* Empty inversion list */
7362         return;
7363     }
7364
7365     array = invlist_array(invlist);
7366
7367     /* Find which element it is */
7368     i = _invlist_search(invlist, start);
7369
7370     /* We populate from <start> to <end> */
7371     while (current < end) {
7372         UV upper;
7373
7374         /* The inversion list gives the results for every possible code point
7375          * after the first one in the list.  Only those ranges whose index is
7376          * even are ones that the inversion list matches.  For the odd ones,
7377          * and if the initial code point is not in the list, we have to skip
7378          * forward to the next element */
7379         if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
7380             i++;
7381             if (i >= len) { /* Finished if beyond the end of the array */
7382                 return;
7383             }
7384             current = array[i];
7385             if (current >= end) {   /* Finished if beyond the end of what we
7386                                        are populating */
7387                 if (LIKELY(end < UV_MAX)) {
7388                     return;
7389                 }
7390
7391                 /* We get here when the upper bound is the maximum
7392                  * representable on the machine, and we are looking for just
7393                  * that code point.  Have to special case it */
7394                 i = len;
7395                 goto join_end_of_list;
7396             }
7397         }
7398         assert(current >= start);
7399
7400         /* The current range ends one below the next one, except don't go past
7401          * <end> */
7402         i++;
7403         upper = (i < len && array[i] < end) ? array[i] : end;
7404
7405         /* Here we are in a range that matches.  Populate a bit in the 3-bit U8
7406          * for each code point in it */
7407         for (; current < upper; current++) {
7408             const STRLEN offset = (STRLEN)(current - start);
7409             swatch[offset >> 3] |= 1 << (offset & 7);
7410         }
7411
7412     join_end_of_list:
7413
7414         /* Quit if at the end of the list */
7415         if (i >= len) {
7416
7417             /* But first, have to deal with the highest possible code point on
7418              * the platform.  The previous code assumes that <end> is one
7419              * beyond where we want to populate, but that is impossible at the
7420              * platform's infinity, so have to handle it specially */
7421             if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
7422             {
7423                 const STRLEN offset = (STRLEN)(end - start);
7424                 swatch[offset >> 3] |= 1 << (offset & 7);
7425             }
7426             return;
7427         }
7428
7429         /* Advance to the next range, which will be for code points not in the
7430          * inversion list */
7431         current = array[i];
7432     }
7433
7434     return;
7435 }
7436
7437 void
7438 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** output)
7439 {
7440     /* Take the union of two inversion lists and point <output> to it.  *output
7441      * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
7442      * the reference count to that list will be decremented.  The first list,
7443      * <a>, may be NULL, in which case a copy of the second list is returned.
7444      * If <complement_b> is TRUE, the union is taken of the complement
7445      * (inversion) of <b> instead of b itself.
7446      *
7447      * The basis for this comes from "Unicode Demystified" Chapter 13 by
7448      * Richard Gillam, published by Addison-Wesley, and explained at some
7449      * length there.  The preface says to incorporate its examples into your
7450      * code at your own risk.
7451      *
7452      * The algorithm is like a merge sort.
7453      *
7454      * XXX A potential performance improvement is to keep track as we go along
7455      * if only one of the inputs contributes to the result, meaning the other
7456      * is a subset of that one.  In that case, we can skip the final copy and
7457      * return the larger of the input lists, but then outside code might need
7458      * to keep track of whether to free the input list or not */
7459
7460     UV* array_a;    /* a's array */
7461     UV* array_b;
7462     UV len_a;       /* length of a's array */
7463     UV len_b;
7464
7465     SV* u;                      /* the resulting union */
7466     UV* array_u;
7467     UV len_u;
7468
7469     UV i_a = 0;             /* current index into a's array */
7470     UV i_b = 0;
7471     UV i_u = 0;
7472
7473     /* running count, as explained in the algorithm source book; items are
7474      * stopped accumulating and are output when the count changes to/from 0.
7475      * The count is incremented when we start a range that's in the set, and
7476      * decremented when we start a range that's not in the set.  So its range
7477      * is 0 to 2.  Only when the count is zero is something not in the set.
7478      */
7479     UV count = 0;
7480
7481     PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
7482     assert(a != b);
7483
7484     /* If either one is empty, the union is the other one */
7485     if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
7486         if (*output == a) {
7487             if (a != NULL) {
7488                 SvREFCNT_dec_NN(a);
7489             }
7490         }
7491         if (*output != b) {
7492             *output = invlist_clone(b);
7493             if (complement_b) {
7494                 _invlist_invert(*output);
7495             }
7496         } /* else *output already = b; */
7497         return;
7498     }
7499     else if ((len_b = _invlist_len(b)) == 0) {
7500         if (*output == b) {
7501             SvREFCNT_dec_NN(b);
7502         }
7503
7504         /* The complement of an empty list is a list that has everything in it,
7505          * so the union with <a> includes everything too */
7506         if (complement_b) {
7507             if (a == *output) {
7508                 SvREFCNT_dec_NN(a);
7509             }
7510             *output = _new_invlist(1);
7511             _append_range_to_invlist(*output, 0, UV_MAX);
7512         }
7513         else if (*output != a) {
7514             *output = invlist_clone(a);
7515         }
7516         /* else *output already = a; */
7517         return;
7518     }
7519
7520     /* Here both lists exist and are non-empty */
7521     array_a = invlist_array(a);
7522     array_b = invlist_array(b);
7523
7524     /* If are to take the union of 'a' with the complement of b, set it
7525      * up so are looking at b's complement. */
7526     if (complement_b) {
7527
7528         /* To complement, we invert: if the first element is 0, remove it.  To
7529          * do this, we just pretend the array starts one later, and clear the
7530          * flag as we don't have to do anything else later */
7531         if (array_b[0] == 0) {
7532             array_b++;
7533             len_b--;
7534             complement_b = FALSE;
7535         }
7536         else {
7537
7538             /* But if the first element is not zero, we unshift a 0 before the
7539              * array.  The data structure reserves a space for that 0 (which
7540              * should be a '1' right now), so physical shifting is unneeded,
7541              * but temporarily change that element to 0.  Before exiting the
7542              * routine, we must restore the element to '1' */
7543             array_b--;
7544             len_b++;
7545             array_b[0] = 0;
7546         }
7547     }
7548
7549     /* Size the union for the worst case: that the sets are completely
7550      * disjoint */
7551     u = _new_invlist(len_a + len_b);
7552
7553     /* Will contain U+0000 if either component does */
7554     array_u = _invlist_array_init(u, (len_a > 0 && array_a[0] == 0)
7555                                       || (len_b > 0 && array_b[0] == 0));
7556
7557     /* Go through each list item by item, stopping when exhausted one of
7558      * them */
7559     while (i_a < len_a && i_b < len_b) {
7560         UV cp;      /* The element to potentially add to the union's array */
7561         bool cp_in_set;   /* is it in the the input list's set or not */
7562
7563         /* We need to take one or the other of the two inputs for the union.
7564          * Since we are merging two sorted lists, we take the smaller of the
7565          * next items.  In case of a tie, we take the one that is in its set
7566          * first.  If we took one not in the set first, it would decrement the
7567          * count, possibly to 0 which would cause it to be output as ending the
7568          * range, and the next time through we would take the same number, and
7569          * output it again as beginning the next range.  By doing it the
7570          * opposite way, there is no possibility that the count will be
7571          * momentarily decremented to 0, and thus the two adjoining ranges will
7572          * be seamlessly merged.  (In a tie and both are in the set or both not
7573          * in the set, it doesn't matter which we take first.) */
7574         if (array_a[i_a] < array_b[i_b]
7575             || (array_a[i_a] == array_b[i_b]
7576                 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
7577         {
7578             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
7579             cp= array_a[i_a++];
7580         }
7581         else {
7582             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
7583             cp = array_b[i_b++];
7584         }
7585
7586         /* Here, have chosen which of the two inputs to look at.  Only output
7587          * if the running count changes to/from 0, which marks the
7588          * beginning/end of a range in that's in the set */
7589         if (cp_in_set) {
7590             if (count == 0) {
7591                 array_u[i_u++] = cp;
7592             }
7593             count++;
7594         }
7595         else {
7596             count--;
7597             if (count == 0) {
7598                 array_u[i_u++] = cp;
7599             }
7600         }
7601     }
7602
7603     /* Here, we are finished going through at least one of the lists, which
7604      * means there is something remaining in at most one.  We check if the list
7605      * that hasn't been exhausted is positioned such that we are in the middle
7606      * of a range in its set or not.  (i_a and i_b point to the element beyond
7607      * the one we care about.) If in the set, we decrement 'count'; if 0, there
7608      * is potentially more to output.
7609      * There are four cases:
7610      *  1) Both weren't in their sets, count is 0, and remains 0.  What's left
7611      *     in the union is entirely from the non-exhausted set.
7612      *  2) Both were in their sets, count is 2.  Nothing further should
7613      *     be output, as everything that remains will be in the exhausted
7614      *     list's set, hence in the union; decrementing to 1 but not 0 insures
7615      *     that
7616      *  3) the exhausted was in its set, non-exhausted isn't, count is 1.
7617      *     Nothing further should be output because the union includes
7618      *     everything from the exhausted set.  Not decrementing ensures that.
7619      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1;
7620      *     decrementing to 0 insures that we look at the remainder of the
7621      *     non-exhausted set */
7622     if ((i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
7623         || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
7624     {
7625         count--;
7626     }
7627
7628     /* The final length is what we've output so far, plus what else is about to
7629      * be output.  (If 'count' is non-zero, then the input list we exhausted
7630      * has everything remaining up to the machine's limit in its set, and hence
7631      * in the union, so there will be no further output. */
7632     len_u = i_u;
7633     if (count == 0) {
7634         /* At most one of the subexpressions will be non-zero */
7635         len_u += (len_a - i_a) + (len_b - i_b);
7636     }
7637
7638     /* Set result to final length, which can change the pointer to array_u, so
7639      * re-find it */
7640     if (len_u != _invlist_len(u)) {
7641         invlist_set_len(u, len_u);
7642         invlist_trim(u);
7643         array_u = invlist_array(u);
7644     }
7645
7646     /* When 'count' is 0, the list that was exhausted (if one was shorter than
7647      * the other) ended with everything above it not in its set.  That means
7648      * that the remaining part of the union is precisely the same as the
7649      * non-exhausted list, so can just copy it unchanged.  (If both list were
7650      * exhausted at the same time, then the operations below will be both 0.)
7651      */
7652     if (count == 0) {
7653         IV copy_count; /* At most one will have a non-zero copy count */
7654         if ((copy_count = len_a - i_a) > 0) {
7655             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
7656         }
7657         else if ((copy_count = len_b - i_b) > 0) {
7658             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
7659         }
7660     }
7661
7662     /* If we've changed b, restore it */
7663     if (complement_b) {
7664         array_b[0] = 1;
7665     }
7666
7667     /*  We may be removing a reference to one of the inputs */
7668     if (a == *output || b == *output) {
7669         assert(! invlist_is_iterating(*output));
7670         SvREFCNT_dec_NN(*output);
7671     }
7672
7673     *output = u;
7674     return;
7675 }
7676
7677 void
7678 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** i)
7679 {
7680     /* Take the intersection of two inversion lists and point <i> to it.  *i
7681      * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
7682      * the reference count to that list will be decremented.
7683      * If <complement_b> is TRUE, the result will be the intersection of <a>
7684      * and the complement (or inversion) of <b> instead of <b> directly.
7685      *
7686      * The basis for this comes from "Unicode Demystified" Chapter 13 by
7687      * Richard Gillam, published by Addison-Wesley, and explained at some
7688      * length there.  The preface says to incorporate its examples into your
7689      * code at your own risk.  In fact, it had bugs
7690      *
7691      * The algorithm is like a merge sort, and is essentially the same as the
7692      * union above
7693      */
7694
7695     UV* array_a;                /* a's array */
7696     UV* array_b;
7697     UV len_a;   /* length of a's array */
7698     UV len_b;
7699
7700     SV* r;                   /* the resulting intersection */
7701     UV* array_r;
7702     UV len_r;
7703
7704     UV i_a = 0;             /* current index into a's array */
7705     UV i_b = 0;
7706     UV i_r = 0;
7707
7708     /* running count, as explained in the algorithm source book; items are
7709      * stopped accumulating and are output when the count changes to/from 2.
7710      * The count is incremented when we start a range that's in the set, and
7711      * decremented when we start a range that's not in the set.  So its range
7712      * is 0 to 2.  Only when the count is 2 is something in the intersection.
7713      */
7714     UV count = 0;
7715
7716     PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
7717     assert(a != b);
7718
7719     /* Special case if either one is empty */
7720     len_a = _invlist_len(a);
7721     if ((len_a == 0) || ((len_b = _invlist_len(b)) == 0)) {
7722
7723         if (len_a != 0 && complement_b) {
7724
7725             /* Here, 'a' is not empty, therefore from the above 'if', 'b' must
7726              * be empty.  Here, also we are using 'b's complement, which hence
7727              * must be every possible code point.  Thus the intersection is
7728              * simply 'a'. */
7729             if (*i != a) {
7730                 *i = invlist_clone(a);
7731
7732                 if (*i == b) {
7733                     SvREFCNT_dec_NN(b);
7734                 }
7735             }
7736             /* else *i is already 'a' */
7737             return;
7738         }
7739
7740         /* Here, 'a' or 'b' is empty and not using the complement of 'b'.  The
7741          * intersection must be empty */
7742         if (*i == a) {
7743             SvREFCNT_dec_NN(a);
7744         }
7745         else if (*i == b) {
7746             SvREFCNT_dec_NN(b);
7747         }
7748         *i = _new_invlist(0);
7749         return;
7750     }
7751
7752     /* Here both lists exist and are non-empty */
7753     array_a = invlist_array(a);
7754     array_b = invlist_array(b);
7755
7756     /* If are to take the intersection of 'a' with the complement of b, set it
7757      * up so are looking at b's complement. */
7758     if (complement_b) {
7759
7760         /* To complement, we invert: if the first element is 0, remove it.  To
7761          * do this, we just pretend the array starts one later, and clear the
7762          * flag as we don't have to do anything else later */
7763         if (array_b[0] == 0) {
7764             array_b++;
7765             len_b--;
7766             complement_b = FALSE;
7767         }
7768         else {
7769
7770             /* But if the first element is not zero, we unshift a 0 before the
7771              * array.  The data structure reserves a space for that 0 (which
7772              * should be a '1' right now), so physical shifting is unneeded,
7773              * but temporarily change that element to 0.  Before exiting the
7774              * routine, we must restore the element to '1' */
7775             array_b--;
7776             len_b++;
7777             array_b[0] = 0;
7778         }
7779     }
7780
7781     /* Size the intersection for the worst case: that the intersection ends up
7782      * fragmenting everything to be completely disjoint */
7783     r= _new_invlist(len_a + len_b);
7784
7785     /* Will contain U+0000 iff both components do */
7786     array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
7787                                      && len_b > 0 && array_b[0] == 0);
7788
7789     /* Go through each list item by item, stopping when exhausted one of
7790      * them */
7791     while (i_a < len_a && i_b < len_b) {
7792         UV cp;      /* The element to potentially add to the intersection's
7793                        array */
7794         bool cp_in_set; /* Is it in the input list's set or not */
7795
7796         /* We need to take one or the other of the two inputs for the
7797          * intersection.  Since we are merging two sorted lists, we take the
7798          * smaller of the next items.  In case of a tie, we take the one that
7799          * is not in its set first (a difference from the union algorithm).  If
7800          * we took one in the set first, it would increment the count, possibly
7801          * to 2 which would cause it to be output as starting a range in the
7802          * intersection, and the next time through we would take that same
7803          * number, and output it again as ending the set.  By doing it the
7804          * opposite of this, there is no possibility that the count will be
7805          * momentarily incremented to 2.  (In a tie and both are in the set or
7806          * both not in the set, it doesn't matter which we take first.) */
7807         if (array_a[i_a] < array_b[i_b]
7808             || (array_a[i_a] == array_b[i_b]
7809                 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
7810         {
7811             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
7812             cp= array_a[i_a++];
7813         }
7814         else {
7815             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
7816             cp= array_b[i_b++];
7817         }
7818
7819         /* Here, have chosen which of the two inputs to look at.  Only output
7820          * if the running count changes to/from 2, which marks the
7821          * beginning/end of a range that's in the intersection */
7822         if (cp_in_set) {
7823             count++;
7824             if (count == 2) {
7825                 array_r[i_r++] = cp;
7826             }
7827         }
7828         else {
7829             if (count == 2) {
7830                 array_r[i_r++] = cp;
7831             }
7832             count--;
7833         }
7834     }
7835
7836     /* Here, we are finished going through at least one of the lists, which
7837      * means there is something remaining in at most one.  We check if the list
7838      * that has been exhausted is positioned such that we are in the middle
7839      * of a range in its set or not.  (i_a and i_b point to elements 1 beyond
7840      * the ones we care about.)  There are four cases:
7841      *  1) Both weren't in their sets, count is 0, and remains 0.  There's
7842      *     nothing left in the intersection.
7843      *  2) Both were in their sets, count is 2 and perhaps is incremented to
7844      *     above 2.  What should be output is exactly that which is in the
7845      *     non-exhausted set, as everything it has is also in the intersection
7846      *     set, and everything it doesn't have can't be in the intersection
7847      *  3) The exhausted was in its set, non-exhausted isn't, count is 1, and
7848      *     gets incremented to 2.  Like the previous case, the intersection is
7849      *     everything that remains in the non-exhausted set.
7850      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1, and
7851      *     remains 1.  And the intersection has nothing more. */
7852     if ((i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
7853         || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
7854     {
7855         count++;
7856     }
7857
7858     /* The final length is what we've output so far plus what else is in the
7859      * intersection.  At most one of the subexpressions below will be non-zero */
7860     len_r = i_r;
7861     if (count >= 2) {
7862         len_r += (len_a - i_a) + (len_b - i_b);
7863     }
7864
7865     /* Set result to final length, which can change the pointer to array_r, so
7866      * re-find it */
7867     if (len_r != _invlist_len(r)) {
7868         invlist_set_len(r, len_r);
7869         invlist_trim(r);
7870         array_r = invlist_array(r);
7871     }
7872
7873     /* Finish outputting any remaining */
7874     if (count >= 2) { /* At most one will have a non-zero copy count */
7875         IV copy_count;
7876         if ((copy_count = len_a - i_a) > 0) {
7877             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
7878         }
7879         else if ((copy_count = len_b - i_b) > 0) {
7880             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
7881         }
7882     }
7883
7884     /* If we've changed b, restore it */
7885     if (complement_b) {
7886         array_b[0] = 1;
7887     }
7888
7889     /*  We may be removing a reference to one of the inputs */
7890     if (a == *i || b == *i) {
7891         assert(! invlist_is_iterating(*i));
7892         SvREFCNT_dec_NN(*i);
7893     }
7894
7895     *i = r;
7896     return;
7897 }
7898
7899 SV*
7900 Perl__add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end)
7901 {
7902     /* Add the range from 'start' to 'end' inclusive to the inversion list's
7903      * set.  A pointer to the inversion list is returned.  This may actually be
7904      * a new list, in which case the passed in one has been destroyed.  The
7905      * passed in inversion list can be NULL, in which case a new one is created
7906      * with just the one range in it */
7907
7908     SV* range_invlist;
7909     UV len;
7910
7911     if (invlist == NULL) {
7912         invlist = _new_invlist(2);
7913         len = 0;
7914     }
7915     else {
7916         len = _invlist_len(invlist);
7917     }
7918
7919     /* If comes after the final entry actually in the list, can just append it
7920      * to the end, */
7921     if (len == 0
7922         || (! ELEMENT_RANGE_MATCHES_INVLIST(len - 1)
7923             && start >= invlist_array(invlist)[len - 1]))
7924     {
7925         _append_range_to_invlist(invlist, start, end);
7926         return invlist;
7927     }
7928
7929     /* Here, can't just append things, create and return a new inversion list
7930      * which is the union of this range and the existing inversion list */
7931     range_invlist = _new_invlist(2);
7932     _append_range_to_invlist(range_invlist, start, end);
7933
7934     _invlist_union(invlist, range_invlist, &invlist);
7935
7936     /* The temporary can be freed */
7937     SvREFCNT_dec_NN(range_invlist);
7938
7939     return invlist;
7940 }
7941
7942 #endif
7943
7944 PERL_STATIC_INLINE SV*
7945 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
7946     return _add_range_to_invlist(invlist, cp, cp);
7947 }
7948
7949 #ifndef PERL_IN_XSUB_RE
7950 void
7951 Perl__invlist_invert(pTHX_ SV* const invlist)
7952 {
7953     /* Complement the input inversion list.  This adds a 0 if the list didn't
7954      * have a zero; removes it otherwise.  As described above, the data
7955      * structure is set up so that this is very efficient */
7956
7957     UV* len_pos = _get_invlist_len_addr(invlist);
7958
7959     PERL_ARGS_ASSERT__INVLIST_INVERT;
7960
7961     assert(! invlist_is_iterating(invlist));
7962
7963     /* The inverse of matching nothing is matching everything */
7964     if (*len_pos == 0) {
7965         _append_range_to_invlist(invlist, 0, UV_MAX);
7966         return;
7967     }
7968
7969     /* The exclusive or complents 0 to 1; and 1 to 0.  If the result is 1, the
7970      * zero element was a 0, so it is being removed, so the length decrements
7971      * by 1; and vice-versa.  SvCUR is unaffected */
7972     if (*get_invlist_zero_addr(invlist) ^= 1) {
7973         (*len_pos)--;
7974     }
7975     else {
7976         (*len_pos)++;
7977     }
7978 }
7979
7980 void
7981 Perl__invlist_invert_prop(pTHX_ SV* const invlist)
7982 {
7983     /* Complement the input inversion list (which must be a Unicode property,
7984      * all of which don't match above the Unicode maximum code point.)  And
7985      * Perl has chosen to not have the inversion match above that either.  This
7986      * adds a 0x110000 if the list didn't end with it, and removes it if it did
7987      */
7988
7989     UV len;
7990     UV* array;
7991
7992     PERL_ARGS_ASSERT__INVLIST_INVERT_PROP;
7993
7994     _invlist_invert(invlist);
7995
7996     len = _invlist_len(invlist);
7997
7998     if (len != 0) { /* If empty do nothing */
7999         array = invlist_array(invlist);
8000         if (array[len - 1] != PERL_UNICODE_MAX + 1) {
8001             /* Add 0x110000.  First, grow if necessary */
8002             len++;
8003             if (invlist_max(invlist) < len) {
8004                 invlist_extend(invlist, len);
8005                 array = invlist_array(invlist);
8006             }
8007             invlist_set_len(invlist, len);
8008             array[len - 1] = PERL_UNICODE_MAX + 1;
8009         }
8010         else {  /* Remove the 0x110000 */
8011             invlist_set_len(invlist, len - 1);
8012         }
8013     }
8014
8015     return;
8016 }
8017 #endif
8018
8019 PERL_STATIC_INLINE SV*
8020 S_invlist_clone(pTHX_ SV* const invlist)
8021 {
8022
8023     /* Return a new inversion list that is a copy of the input one, which is
8024      * unchanged */
8025
8026     /* Need to allocate extra space to accommodate Perl's addition of a
8027      * trailing NUL to SvPV's, since it thinks they are always strings */
8028     SV* new_invlist = _new_invlist(_invlist_len(invlist) + 1);
8029     STRLEN length = SvCUR(invlist);
8030
8031     PERL_ARGS_ASSERT_INVLIST_CLONE;
8032
8033     SvCUR_set(new_invlist, length); /* This isn't done automatically */
8034     Copy(SvPVX(invlist), SvPVX(new_invlist), length, char);
8035
8036     return new_invlist;
8037 }
8038
8039 PERL_STATIC_INLINE UV*
8040 S_get_invlist_iter_addr(pTHX_ SV* invlist)
8041 {
8042     /* Return the address of the UV that contains the current iteration
8043      * position */
8044
8045     PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
8046
8047     return (UV *) (SvPVX(invlist) + (INVLIST_ITER_OFFSET * sizeof (UV)));
8048 }
8049
8050 PERL_STATIC_INLINE UV*
8051 S_get_invlist_version_id_addr(pTHX_ SV* invlist)
8052 {
8053     /* Return the address of the UV that contains the version id. */
8054
8055     PERL_ARGS_ASSERT_GET_INVLIST_VERSION_ID_ADDR;
8056
8057     return (UV *) (SvPVX(invlist) + (INVLIST_VERSION_ID_OFFSET * sizeof (UV)));
8058 }
8059
8060 PERL_STATIC_INLINE void
8061 S_invlist_iterinit(pTHX_ SV* invlist)   /* Initialize iterator for invlist */
8062 {
8063     PERL_ARGS_ASSERT_INVLIST_ITERINIT;
8064
8065     *get_invlist_iter_addr(invlist) = 0;
8066 }
8067
8068 PERL_STATIC_INLINE void
8069 S_invlist_iterfinish(pTHX_ SV* invlist)
8070 {
8071     /* Terminate iterator for invlist.  This is to catch development errors.
8072      * Any iteration that is interrupted before completed should call this
8073      * function.  Functions that add code points anywhere else but to the end
8074      * of an inversion list assert that they are not in the middle of an
8075      * iteration.  If they were, the addition would make the iteration
8076      * problematical: if the iteration hadn't reached the place where things
8077      * were being added, it would be ok */
8078
8079     PERL_ARGS_ASSERT_INVLIST_ITERFINISH;
8080
8081     *get_invlist_iter_addr(invlist) = UV_MAX;
8082 }
8083
8084 STATIC bool
8085 S_invlist_iternext(pTHX_ SV* invlist, UV* start, UV* end)
8086 {
8087     /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
8088      * This call sets in <*start> and <*end>, the next range in <invlist>.
8089      * Returns <TRUE> if successful and the next call will return the next
8090      * range; <FALSE> if was already at the end of the list.  If the latter,
8091      * <*start> and <*end> are unchanged, and the next call to this function
8092      * will start over at the beginning of the list */
8093
8094     UV* pos = get_invlist_iter_addr(invlist);
8095     UV len = _invlist_len(invlist);
8096     UV *array;
8097
8098     PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
8099
8100     if (*pos >= len) {
8101         *pos = UV_MAX;  /* Force iterinit() to be required next time */
8102         return FALSE;
8103     }
8104
8105     array = invlist_array(invlist);
8106
8107     *start = array[(*pos)++];
8108
8109     if (*pos >= len) {
8110         *end = UV_MAX;
8111     }
8112     else {
8113         *end = array[(*pos)++] - 1;
8114     }
8115
8116     return TRUE;
8117 }
8118
8119 PERL_STATIC_INLINE bool
8120 S_invlist_is_iterating(pTHX_ SV* const invlist)
8121 {
8122     PERL_ARGS_ASSERT_INVLIST_IS_ITERATING;
8123
8124     return *(get_invlist_iter_addr(invlist)) < UV_MAX;
8125 }
8126
8127 PERL_STATIC_INLINE UV
8128 S_invlist_highest(pTHX_ SV* const invlist)
8129 {
8130     /* Returns the highest code point that matches an inversion list.  This API
8131      * has an ambiguity, as it returns 0 under either the highest is actually
8132      * 0, or if the list is empty.  If this distinction matters to you, check
8133      * for emptiness before calling this function */
8134
8135     UV len = _invlist_len(invlist);
8136     UV *array;
8137
8138     PERL_ARGS_ASSERT_INVLIST_HIGHEST;
8139
8140     if (len == 0) {
8141         return 0;
8142     }
8143
8144     array = invlist_array(invlist);
8145
8146     /* The last element in the array in the inversion list always starts a
8147      * range that goes to infinity.  That range may be for code points that are
8148      * matched in the inversion list, or it may be for ones that aren't
8149      * matched.  In the latter case, the highest code point in the set is one
8150      * less than the beginning of this range; otherwise it is the final element
8151      * of this range: infinity */
8152     return (ELEMENT_RANGE_MATCHES_INVLIST(len - 1))
8153            ? UV_MAX
8154            : array[len - 1] - 1;
8155 }
8156
8157 #ifndef PERL_IN_XSUB_RE
8158 SV *
8159 Perl__invlist_contents(pTHX_ SV* const invlist)
8160 {
8161     /* Get the contents of an inversion list into a string SV so that they can
8162      * be printed out.  It uses the format traditionally done for debug tracing
8163      */
8164
8165     UV start, end;
8166     SV* output = newSVpvs("\n");
8167
8168     PERL_ARGS_ASSERT__INVLIST_CONTENTS;
8169
8170     assert(! invlist_is_iterating(invlist));
8171
8172     invlist_iterinit(invlist);
8173     while (invlist_iternext(invlist, &start, &end)) {
8174         if (end == UV_MAX) {
8175             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\tINFINITY\n", start);
8176         }
8177         else if (end != start) {
8178             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\t%04"UVXf"\n",
8179                     start,       end);
8180         }
8181         else {
8182             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\n", start);
8183         }
8184     }
8185
8186     return output;
8187 }
8188 #endif
8189
8190 #ifdef PERL_ARGS_ASSERT__INVLIST_DUMP
8191 void
8192 Perl__invlist_dump(pTHX_ SV* const invlist, const char * const header)
8193 {
8194     /* Dumps out the ranges in an inversion list.  The string 'header'
8195      * if present is output on a line before the first range */
8196
8197     UV start, end;
8198
8199     PERL_ARGS_ASSERT__INVLIST_DUMP;
8200
8201     if (header && strlen(header)) {
8202         PerlIO_printf(Perl_debug_log, "%s\n", header);
8203     }
8204     if (invlist_is_iterating(invlist)) {
8205         PerlIO_printf(Perl_debug_log, "Can't dump because is in middle of iterating\n");
8206         return;
8207     }
8208
8209     invlist_iterinit(invlist);
8210     while (invlist_iternext(invlist, &start, &end)) {
8211         if (end == UV_MAX) {
8212             PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. INFINITY\n", start);
8213         }
8214         else if (end != start) {
8215             PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. 0x%04"UVXf"\n",
8216                                                  start,         end);
8217         }
8218         else {
8219             PerlIO_printf(Perl_debug_log, "0x%04"UVXf"\n", start);
8220         }
8221     }
8222 }
8223 #endif
8224
8225 #if 0
8226 bool
8227 S__invlistEQ(pTHX_ SV* const a, SV* const b, bool complement_b)
8228 {
8229     /* Return a boolean as to if the two passed in inversion lists are
8230      * identical.  The final argument, if TRUE, says to take the complement of
8231      * the second inversion list before doing the comparison */
8232
8233     UV* array_a = invlist_array(a);
8234     UV* array_b = invlist_array(b);
8235     UV len_a = _invlist_len(a);
8236     UV len_b = _invlist_len(b);
8237
8238     UV i = 0;               /* current index into the arrays */
8239     bool retval = TRUE;     /* Assume are identical until proven otherwise */
8240
8241     PERL_ARGS_ASSERT__INVLISTEQ;
8242
8243     /* If are to compare 'a' with the complement of b, set it
8244      * up so are looking at b's complement. */
8245     if (complement_b) {
8246
8247         /* The complement of nothing is everything, so <a> would have to have
8248          * just one element, starting at zero (ending at infinity) */
8249         if (len_b == 0) {
8250             return (len_a == 1 && array_a[0] == 0);
8251         }
8252         else if (array_b[0] == 0) {
8253
8254             /* Otherwise, to complement, we invert.  Here, the first element is
8255              * 0, just remove it.  To do this, we just pretend the array starts
8256              * one later, and clear the flag as we don't have to do anything
8257              * else later */
8258
8259             array_b++;
8260             len_b--;
8261             complement_b = FALSE;
8262         }
8263         else {
8264
8265             /* But if the first element is not zero, we unshift a 0 before the
8266              * array.  The data structure reserves a space for that 0 (which
8267              * should be a '1' right now), so physical shifting is unneeded,
8268              * but temporarily change that element to 0.  Before exiting the
8269              * routine, we must restore the element to '1' */
8270             array_b--;
8271             len_b++;
8272             array_b[0] = 0;
8273         }
8274     }
8275
8276     /* Make sure that the lengths are the same, as well as the final element
8277      * before looping through the remainder.  (Thus we test the length, final,
8278      * and first elements right off the bat) */
8279     if (len_a != len_b || array_a[len_a-1] != array_b[len_a-1]) {
8280         retval = FALSE;
8281     }
8282     else for (i = 0; i < len_a - 1; i++) {
8283         if (array_a[i] != array_b[i]) {
8284             retval = FALSE;
8285             break;
8286         }
8287     }
8288
8289     if (complement_b) {
8290         array_b[0] = 1;
8291     }
8292     return retval;
8293 }
8294 #endif
8295
8296 #undef HEADER_LENGTH
8297 #undef INVLIST_INITIAL_LENGTH
8298 #undef TO_INTERNAL_SIZE
8299 #undef FROM_INTERNAL_SIZE
8300 #undef INVLIST_LEN_OFFSET
8301 #undef INVLIST_ZERO_OFFSET
8302 #undef INVLIST_ITER_OFFSET
8303 #undef INVLIST_VERSION_ID
8304 #undef INVLIST_PREVIOUS_INDEX_OFFSET
8305
8306 /* End of inversion list object */
8307
8308 STATIC void
8309 S_parse_lparen_question_flags(pTHX_ struct RExC_state_t *pRExC_state)
8310 {
8311     /* This parses the flags that are in either the '(?foo)' or '(?foo:bar)'
8312      * constructs, and updates RExC_flags with them.  On input, RExC_parse
8313      * should point to the first flag; it is updated on output to point to the
8314      * final ')' or ':'.  There needs to be at least one flag, or this will
8315      * abort */
8316
8317     /* for (?g), (?gc), and (?o) warnings; warning
8318        about (?c) will warn about (?g) -- japhy    */
8319
8320 #define WASTED_O  0x01
8321 #define WASTED_G  0x02
8322 #define WASTED_C  0x04
8323 #define WASTED_GC (0x02|0x04)
8324     I32 wastedflags = 0x00;
8325     U32 posflags = 0, negflags = 0;
8326     U32 *flagsp = &posflags;
8327     char has_charset_modifier = '\0';
8328     regex_charset cs;
8329     bool has_use_defaults = FALSE;
8330     const char* const seqstart = RExC_parse - 1; /* Point to the '?' */
8331
8332     PERL_ARGS_ASSERT_PARSE_LPAREN_QUESTION_FLAGS;
8333
8334     /* '^' as an initial flag sets certain defaults */
8335     if (UCHARAT(RExC_parse) == '^') {
8336         RExC_parse++;
8337         has_use_defaults = TRUE;
8338         STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
8339         set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
8340                                         ? REGEX_UNICODE_CHARSET
8341                                         : REGEX_DEPENDS_CHARSET);
8342     }
8343
8344     cs = get_regex_charset(RExC_flags);
8345     if (cs == REGEX_DEPENDS_CHARSET
8346         && (RExC_utf8 || RExC_uni_semantics))
8347     {
8348         cs = REGEX_UNICODE_CHARSET;
8349     }
8350
8351     while (*RExC_parse) {
8352         /* && strchr("iogcmsx", *RExC_parse) */
8353         /* (?g), (?gc) and (?o) are useless here
8354            and must be globally applied -- japhy */
8355         switch (*RExC_parse) {
8356
8357             /* Code for the imsx flags */
8358             CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
8359
8360             case LOCALE_PAT_MOD:
8361                 if (has_charset_modifier) {
8362                     goto excess_modifier;
8363                 }
8364                 else if (flagsp == &negflags) {
8365                     goto neg_modifier;
8366                 }
8367                 cs = REGEX_LOCALE_CHARSET;
8368                 has_charset_modifier = LOCALE_PAT_MOD;
8369                 RExC_contains_locale = 1;
8370                 break;
8371             case UNICODE_PAT_MOD:
8372                 if (has_charset_modifier) {
8373                     goto excess_modifier;
8374                 }
8375                 else if (flagsp == &negflags) {
8376                     goto neg_modifier;
8377                 }
8378                 cs = REGEX_UNICODE_CHARSET;
8379                 has_charset_modifier = UNICODE_PAT_MOD;
8380                 break;
8381             case ASCII_RESTRICT_PAT_MOD:
8382                 if (flagsp == &negflags) {
8383                     goto neg_modifier;
8384                 }
8385                 if (has_charset_modifier) {
8386                     if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
8387                         goto excess_modifier;
8388                     }
8389                     /* Doubled modifier implies more restricted */
8390                     cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
8391                 }
8392                 else {
8393                     cs = REGEX_ASCII_RESTRICTED_CHARSET;
8394                 }
8395                 has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
8396                 break;
8397             case DEPENDS_PAT_MOD:
8398                 if (has_use_defaults) {
8399                     goto fail_modifiers;
8400                 }
8401                 else if (flagsp == &negflags) {
8402                     goto neg_modifier;
8403                 }
8404                 else if (has_charset_modifier) {
8405                     goto excess_modifier;
8406                 }
8407
8408                 /* The dual charset means unicode semantics if the
8409                  * pattern (or target, not known until runtime) are
8410                  * utf8, or something in the pattern indicates unicode
8411                  * semantics */
8412                 cs = (RExC_utf8 || RExC_uni_semantics)
8413                      ? REGEX_UNICODE_CHARSET
8414                      : REGEX_DEPENDS_CHARSET;
8415                 has_charset_modifier = DEPENDS_PAT_MOD;
8416                 break;
8417             excess_modifier:
8418                 RExC_parse++;
8419                 if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
8420                     vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
8421                 }
8422                 else if (has_charset_modifier == *(RExC_parse - 1)) {
8423                     vFAIL2("Regexp modifier \"%c\" may not appear twice", *(RExC_parse - 1));
8424                 }
8425                 else {
8426                     vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
8427                 }
8428                 /*NOTREACHED*/
8429             neg_modifier:
8430                 RExC_parse++;
8431                 vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", *(RExC_parse - 1));
8432                 /*NOTREACHED*/
8433             case ONCE_PAT_MOD: /* 'o' */
8434             case GLOBAL_PAT_MOD: /* 'g' */
8435                 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
8436                     const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
8437                     if (! (wastedflags & wflagbit) ) {
8438                         wastedflags |= wflagbit;
8439                         vWARN5(
8440                             RExC_parse + 1,
8441                             "Useless (%s%c) - %suse /%c modifier",
8442                             flagsp == &negflags ? "?-" : "?",
8443                             *RExC_parse,
8444                             flagsp == &negflags ? "don't " : "",
8445                             *RExC_parse
8446                         );
8447                     }
8448                 }
8449                 break;
8450
8451             case CONTINUE_PAT_MOD: /* 'c' */
8452                 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
8453                     if (! (wastedflags & WASTED_C) ) {
8454                         wastedflags |= WASTED_GC;
8455                         vWARN3(
8456                             RExC_parse + 1,
8457                             "Useless (%sc) - %suse /gc modifier",
8458                             flagsp == &negflags ? "?-" : "?",
8459                             flagsp == &negflags ? "don't " : ""
8460                         );
8461                     }
8462                 }
8463                 break;
8464             case KEEPCOPY_PAT_MOD: /* 'p' */
8465                 if (flagsp == &negflags) {
8466                     if (SIZE_ONLY)
8467                         ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
8468                 } else {
8469                     *flagsp |= RXf_PMf_KEEPCOPY;
8470                 }
8471                 break;
8472             case '-':
8473                 /* A flag is a default iff it is following a minus, so
8474                  * if there is a minus, it means will be trying to
8475                  * re-specify a default which is an error */
8476                 if (has_use_defaults || flagsp == &negflags) {
8477                     goto fail_modifiers;
8478                 }
8479                 flagsp = &negflags;
8480                 wastedflags = 0;  /* reset so (?g-c) warns twice */
8481                 break;
8482             case ':':
8483             case ')':
8484                 RExC_flags |= posflags;
8485                 RExC_flags &= ~negflags;
8486                 set_regex_charset(&RExC_flags, cs);
8487                 return;
8488                 /*NOTREACHED*/
8489             default:
8490             fail_modifiers:
8491                 RExC_parse++;
8492                 vFAIL3("Sequence (%.*s...) not recognized",
8493                        RExC_parse-seqstart, seqstart);
8494                 /*NOTREACHED*/
8495         }
8496
8497         ++RExC_parse;
8498     }
8499 }
8500
8501 /*
8502  - reg - regular expression, i.e. main body or parenthesized thing
8503  *
8504  * Caller must absorb opening parenthesis.
8505  *
8506  * Combining parenthesis handling with the base level of regular expression
8507  * is a trifle forced, but the need to tie the tails of the branches to what
8508  * follows makes it hard to avoid.
8509  */
8510 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
8511 #ifdef DEBUGGING
8512 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
8513 #else
8514 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
8515 #endif
8516
8517 /* Returns NULL, setting *flagp to TRYAGAIN at the end of (?) that only sets
8518    flags. Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan
8519    needs to be restarted.
8520    Otherwise would only return NULL if regbranch() returns NULL, which
8521    cannot happen.  */
8522 STATIC regnode *
8523 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
8524     /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
8525 {
8526     dVAR;
8527     regnode *ret;               /* Will be the head of the group. */
8528     regnode *br;
8529     regnode *lastbr;
8530     regnode *ender = NULL;
8531     I32 parno = 0;
8532     I32 flags;
8533     U32 oregflags = RExC_flags;
8534     bool have_branch = 0;
8535     bool is_open = 0;
8536     I32 freeze_paren = 0;
8537     I32 after_freeze = 0;
8538
8539     char * parse_start = RExC_parse; /* MJD */
8540     char * const oregcomp_parse = RExC_parse;
8541
8542     GET_RE_DEBUG_FLAGS_DECL;
8543
8544     PERL_ARGS_ASSERT_REG;
8545     DEBUG_PARSE("reg ");
8546
8547     *flagp = 0;                         /* Tentatively. */
8548
8549
8550     /* Make an OPEN node, if parenthesized. */
8551     if (paren) {
8552         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
8553             char *start_verb = RExC_parse;
8554             STRLEN verb_len = 0;
8555             char *start_arg = NULL;
8556             unsigned char op = 0;
8557             int argok = 1;
8558             int internal_argval = 0; /* internal_argval is only useful if !argok */
8559             while ( *RExC_parse && *RExC_parse != ')' ) {
8560                 if ( *RExC_parse == ':' ) {
8561                     start_arg = RExC_parse + 1;
8562                     break;
8563                 }
8564                 RExC_parse++;
8565             }
8566             ++start_verb;
8567             verb_len = RExC_parse - start_verb;
8568             if ( start_arg ) {
8569                 RExC_parse++;
8570                 while ( *RExC_parse && *RExC_parse != ')' ) 
8571                     RExC_parse++;
8572                 if ( *RExC_parse != ')' ) 
8573                     vFAIL("Unterminated verb pattern argument");
8574                 if ( RExC_parse == start_arg )
8575                     start_arg = NULL;
8576             } else {
8577                 if ( *RExC_parse != ')' )
8578                     vFAIL("Unterminated verb pattern");
8579             }
8580             
8581             switch ( *start_verb ) {
8582             case 'A':  /* (*ACCEPT) */
8583                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
8584                     op = ACCEPT;
8585                     internal_argval = RExC_nestroot;
8586                 }
8587                 break;
8588             case 'C':  /* (*COMMIT) */
8589                 if ( memEQs(start_verb,verb_len,"COMMIT") )
8590                     op = COMMIT;
8591                 break;
8592             case 'F':  /* (*FAIL) */
8593                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
8594                     op = OPFAIL;
8595                     argok = 0;
8596                 }
8597                 break;
8598             case ':':  /* (*:NAME) */
8599             case 'M':  /* (*MARK:NAME) */
8600                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
8601                     op = MARKPOINT;
8602                     argok = -1;
8603                 }
8604                 break;
8605             case 'P':  /* (*PRUNE) */
8606                 if ( memEQs(start_verb,verb_len,"PRUNE") )
8607                     op = PRUNE;
8608                 break;
8609             case 'S':   /* (*SKIP) */  
8610                 if ( memEQs(start_verb,verb_len,"SKIP") ) 
8611                     op = SKIP;
8612                 break;
8613             case 'T':  /* (*THEN) */
8614                 /* [19:06] <TimToady> :: is then */
8615                 if ( memEQs(start_verb,verb_len,"THEN") ) {
8616                     op = CUTGROUP;
8617                     RExC_seen |= REG_SEEN_CUTGROUP;
8618                 }
8619                 break;
8620             }
8621             if ( ! op ) {
8622                 RExC_parse++;
8623                 vFAIL3("Unknown verb pattern '%.*s'",
8624                     verb_len, start_verb);
8625             }
8626             if ( argok ) {
8627                 if ( start_arg && internal_argval ) {
8628                     vFAIL3("Verb pattern '%.*s' may not have an argument",
8629                         verb_len, start_verb); 
8630                 } else if ( argok < 0 && !start_arg ) {
8631                     vFAIL3("Verb pattern '%.*s' has a mandatory argument",
8632                         verb_len, start_verb);    
8633                 } else {
8634                     ret = reganode(pRExC_state, op, internal_argval);
8635                     if ( ! internal_argval && ! SIZE_ONLY ) {
8636                         if (start_arg) {
8637                             SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
8638                             ARG(ret) = add_data( pRExC_state, 1, "S" );
8639                             RExC_rxi->data->data[ARG(ret)]=(void*)sv;
8640                             ret->flags = 0;
8641                         } else {
8642                             ret->flags = 1; 
8643                         }
8644                     }               
8645                 }
8646                 if (!internal_argval)
8647                     RExC_seen |= REG_SEEN_VERBARG;
8648             } else if ( start_arg ) {
8649                 vFAIL3("Verb pattern '%.*s' may not have an argument",
8650                         verb_len, start_verb);    
8651             } else {
8652                 ret = reg_node(pRExC_state, op);
8653             }
8654             nextchar(pRExC_state);
8655             return ret;
8656         } else 
8657         if (*RExC_parse == '?') { /* (?...) */
8658             bool is_logical = 0;
8659             const char * const seqstart = RExC_parse;
8660
8661             RExC_parse++;
8662             paren = *RExC_parse++;
8663             ret = NULL;                 /* For look-ahead/behind. */
8664             switch (paren) {
8665
8666             case 'P':   /* (?P...) variants for those used to PCRE/Python */
8667                 paren = *RExC_parse++;
8668                 if ( paren == '<')         /* (?P<...>) named capture */
8669                     goto named_capture;
8670                 else if (paren == '>') {   /* (?P>name) named recursion */
8671                     goto named_recursion;
8672                 }
8673                 else if (paren == '=') {   /* (?P=...)  named backref */
8674                     /* this pretty much dupes the code for \k<NAME> in regatom(), if
8675                        you change this make sure you change that */
8676                     char* name_start = RExC_parse;
8677                     U32 num = 0;
8678                     SV *sv_dat = reg_scan_name(pRExC_state,
8679                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8680                     if (RExC_parse == name_start || *RExC_parse != ')')
8681                         vFAIL2("Sequence %.3s... not terminated",parse_start);
8682
8683                     if (!SIZE_ONLY) {
8684                         num = add_data( pRExC_state, 1, "S" );
8685                         RExC_rxi->data->data[num]=(void*)sv_dat;
8686                         SvREFCNT_inc_simple_void(sv_dat);
8687                     }
8688                     RExC_sawback = 1;
8689                     ret = reganode(pRExC_state,
8690                                    ((! FOLD)
8691                                      ? NREF
8692                                      : (ASCII_FOLD_RESTRICTED)
8693                                        ? NREFFA
8694                                        : (AT_LEAST_UNI_SEMANTICS)
8695                                          ? NREFFU
8696                                          : (LOC)
8697                                            ? NREFFL
8698                                            : NREFF),
8699                                     num);
8700                     *flagp |= HASWIDTH;
8701
8702                     Set_Node_Offset(ret, parse_start+1);
8703                     Set_Node_Cur_Length(ret); /* MJD */
8704
8705                     nextchar(pRExC_state);
8706                     return ret;
8707                 }
8708                 RExC_parse++;
8709                 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8710                 /*NOTREACHED*/
8711             case '<':           /* (?<...) */
8712                 if (*RExC_parse == '!')
8713                     paren = ',';
8714                 else if (*RExC_parse != '=') 
8715               named_capture:
8716                 {               /* (?<...>) */
8717                     char *name_start;
8718                     SV *svname;
8719                     paren= '>';
8720             case '\'':          /* (?'...') */
8721                     name_start= RExC_parse;
8722                     svname = reg_scan_name(pRExC_state,
8723                         SIZE_ONLY ?  /* reverse test from the others */
8724                         REG_RSN_RETURN_NAME : 
8725                         REG_RSN_RETURN_NULL);
8726                     if (RExC_parse == name_start) {
8727                         RExC_parse++;
8728                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8729                         /*NOTREACHED*/
8730                     }
8731                     if (*RExC_parse != paren)
8732                         vFAIL2("Sequence (?%c... not terminated",
8733                             paren=='>' ? '<' : paren);
8734                     if (SIZE_ONLY) {
8735                         HE *he_str;
8736                         SV *sv_dat = NULL;
8737                         if (!svname) /* shouldn't happen */
8738                             Perl_croak(aTHX_
8739                                 "panic: reg_scan_name returned NULL");
8740                         if (!RExC_paren_names) {
8741                             RExC_paren_names= newHV();
8742                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
8743 #ifdef DEBUGGING
8744                             RExC_paren_name_list= newAV();
8745                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
8746 #endif
8747                         }
8748                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
8749                         if ( he_str )
8750                             sv_dat = HeVAL(he_str);
8751                         if ( ! sv_dat ) {
8752                             /* croak baby croak */
8753                             Perl_croak(aTHX_
8754                                 "panic: paren_name hash element allocation failed");
8755                         } else if ( SvPOK(sv_dat) ) {
8756                             /* (?|...) can mean we have dupes so scan to check
8757                                its already been stored. Maybe a flag indicating
8758                                we are inside such a construct would be useful,
8759                                but the arrays are likely to be quite small, so
8760                                for now we punt -- dmq */
8761                             IV count = SvIV(sv_dat);
8762                             I32 *pv = (I32*)SvPVX(sv_dat);
8763                             IV i;
8764                             for ( i = 0 ; i < count ; i++ ) {
8765                                 if ( pv[i] == RExC_npar ) {
8766                                     count = 0;
8767                                     break;
8768                                 }
8769                             }
8770                             if ( count ) {
8771                                 pv = (I32*)SvGROW(sv_dat, SvCUR(sv_dat) + sizeof(I32)+1);
8772                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
8773                                 pv[count] = RExC_npar;
8774                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
8775                             }
8776                         } else {
8777                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
8778                             sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
8779                             SvIOK_on(sv_dat);
8780                             SvIV_set(sv_dat, 1);
8781                         }
8782 #ifdef DEBUGGING
8783                         /* Yes this does cause a memory leak in debugging Perls */
8784                         if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
8785                             SvREFCNT_dec_NN(svname);
8786 #endif
8787
8788                         /*sv_dump(sv_dat);*/
8789                     }
8790                     nextchar(pRExC_state);
8791                     paren = 1;
8792                     goto capturing_parens;
8793                 }
8794                 RExC_seen |= REG_SEEN_LOOKBEHIND;
8795                 RExC_in_lookbehind++;
8796                 RExC_parse++;
8797             case '=':           /* (?=...) */
8798                 RExC_seen_zerolen++;
8799                 break;
8800             case '!':           /* (?!...) */
8801                 RExC_seen_zerolen++;
8802                 if (*RExC_parse == ')') {
8803                     ret=reg_node(pRExC_state, OPFAIL);
8804                     nextchar(pRExC_state);
8805                     return ret;
8806                 }
8807                 break;
8808             case '|':           /* (?|...) */
8809                 /* branch reset, behave like a (?:...) except that
8810                    buffers in alternations share the same numbers */
8811                 paren = ':'; 
8812                 after_freeze = freeze_paren = RExC_npar;
8813                 break;
8814             case ':':           /* (?:...) */
8815             case '>':           /* (?>...) */
8816                 break;
8817             case '$':           /* (?$...) */
8818             case '@':           /* (?@...) */
8819                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
8820                 break;
8821             case '0' :           /* (?0) */
8822             case 'R' :           /* (?R) */
8823                 if (*RExC_parse != ')')
8824                     FAIL("Sequence (?R) not terminated");
8825                 ret = reg_node(pRExC_state, GOSTART);
8826                 *flagp |= POSTPONED;
8827                 nextchar(pRExC_state);
8828                 return ret;
8829                 /*notreached*/
8830             { /* named and numeric backreferences */
8831                 I32 num;
8832             case '&':            /* (?&NAME) */
8833                 parse_start = RExC_parse - 1;
8834               named_recursion:
8835                 {
8836                     SV *sv_dat = reg_scan_name(pRExC_state,
8837                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8838                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
8839                 }
8840                 goto gen_recurse_regop;
8841                 assert(0); /* NOT REACHED */
8842             case '+':
8843                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
8844                     RExC_parse++;
8845                     vFAIL("Illegal pattern");
8846                 }
8847                 goto parse_recursion;
8848                 /* NOT REACHED*/
8849             case '-': /* (?-1) */
8850                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
8851                     RExC_parse--; /* rewind to let it be handled later */
8852                     goto parse_flags;
8853                 } 
8854                 /*FALLTHROUGH */
8855             case '1': case '2': case '3': case '4': /* (?1) */
8856             case '5': case '6': case '7': case '8': case '9':
8857                 RExC_parse--;
8858               parse_recursion:
8859                 num = atoi(RExC_parse);
8860                 parse_start = RExC_parse - 1; /* MJD */
8861                 if (*RExC_parse == '-')
8862                     RExC_parse++;
8863                 while (isDIGIT(*RExC_parse))
8864                         RExC_parse++;
8865                 if (*RExC_parse!=')') 
8866                     vFAIL("Expecting close bracket");
8867
8868               gen_recurse_regop:
8869                 if ( paren == '-' ) {
8870                     /*
8871                     Diagram of capture buffer numbering.
8872                     Top line is the normal capture buffer numbers
8873                     Bottom line is the negative indexing as from
8874                     the X (the (?-2))
8875
8876                     +   1 2    3 4 5 X          6 7
8877                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
8878                     -   5 4    3 2 1 X          x x
8879
8880                     */
8881                     num = RExC_npar + num;
8882                     if (num < 1)  {
8883                         RExC_parse++;
8884                         vFAIL("Reference to nonexistent group");
8885                     }
8886                 } else if ( paren == '+' ) {
8887                     num = RExC_npar + num - 1;
8888                 }
8889
8890                 ret = reganode(pRExC_state, GOSUB, num);
8891                 if (!SIZE_ONLY) {
8892                     if (num > (I32)RExC_rx->nparens) {
8893                         RExC_parse++;
8894                         vFAIL("Reference to nonexistent group");
8895                     }
8896                     ARG2L_SET( ret, RExC_recurse_count++);
8897                     RExC_emit++;
8898                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
8899                         "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
8900                 } else {
8901                     RExC_size++;
8902                 }
8903                 RExC_seen |= REG_SEEN_RECURSE;
8904                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
8905                 Set_Node_Offset(ret, parse_start); /* MJD */
8906
8907                 *flagp |= POSTPONED;
8908                 nextchar(pRExC_state);
8909                 return ret;
8910             } /* named and numeric backreferences */
8911             assert(0); /* NOT REACHED */
8912
8913             case '?':           /* (??...) */
8914                 is_logical = 1;
8915                 if (*RExC_parse != '{') {
8916                     RExC_parse++;
8917                     vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8918                     /*NOTREACHED*/
8919                 }
8920                 *flagp |= POSTPONED;
8921                 paren = *RExC_parse++;
8922                 /* FALL THROUGH */
8923             case '{':           /* (?{...}) */
8924             {
8925                 U32 n = 0;
8926                 struct reg_code_block *cb;
8927
8928                 RExC_seen_zerolen++;
8929
8930                 if (   !pRExC_state->num_code_blocks
8931                     || pRExC_state->code_index >= pRExC_state->num_code_blocks
8932                     || pRExC_state->code_blocks[pRExC_state->code_index].start
8933                         != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
8934                             - RExC_start)
8935                 ) {
8936                     if (RExC_pm_flags & PMf_USE_RE_EVAL)
8937                         FAIL("panic: Sequence (?{...}): no code block found\n");
8938                     FAIL("Eval-group not allowed at runtime, use re 'eval'");
8939                 }
8940                 /* this is a pre-compiled code block (?{...}) */
8941                 cb = &pRExC_state->code_blocks[pRExC_state->code_index];
8942                 RExC_parse = RExC_start + cb->end;
8943                 if (!SIZE_ONLY) {
8944                     OP *o = cb->block;
8945                     if (cb->src_regex) {
8946                         n = add_data(pRExC_state, 2, "rl");
8947                         RExC_rxi->data->data[n] =
8948                             (void*)SvREFCNT_inc((SV*)cb->src_regex);
8949                         RExC_rxi->data->data[n+1] = (void*)o;
8950                     }
8951                     else {
8952                         n = add_data(pRExC_state, 1,
8953                                (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l");
8954                         RExC_rxi->data->data[n] = (void*)o;
8955                     }
8956                 }
8957                 pRExC_state->code_index++;
8958                 nextchar(pRExC_state);
8959
8960                 if (is_logical) {
8961                     regnode *eval;
8962                     ret = reg_node(pRExC_state, LOGICAL);
8963                     eval = reganode(pRExC_state, EVAL, n);
8964                     if (!SIZE_ONLY) {
8965                         ret->flags = 2;
8966                         /* for later propagation into (??{}) return value */
8967                         eval->flags = (U8) (RExC_flags & RXf_PMf_COMPILETIME);
8968                     }
8969                     REGTAIL(pRExC_state, ret, eval);
8970                     /* deal with the length of this later - MJD */
8971                     return ret;
8972                 }
8973                 ret = reganode(pRExC_state, EVAL, n);
8974                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
8975                 Set_Node_Offset(ret, parse_start);
8976                 return ret;
8977             }
8978             case '(':           /* (?(?{...})...) and (?(?=...)...) */
8979             {
8980                 int is_define= 0;
8981                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
8982                     if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
8983                         || RExC_parse[1] == '<'
8984                         || RExC_parse[1] == '{') { /* Lookahead or eval. */
8985                         I32 flag;
8986                         regnode *tail;
8987
8988                         ret = reg_node(pRExC_state, LOGICAL);
8989                         if (!SIZE_ONLY)
8990                             ret->flags = 1;
8991                         
8992                         tail = reg(pRExC_state, 1, &flag, depth+1);
8993                         if (flag & RESTART_UTF8) {
8994                             *flagp = RESTART_UTF8;
8995                             return NULL;
8996                         }
8997                         REGTAIL(pRExC_state, ret, tail);
8998                         goto insert_if;
8999                     }
9000                 }
9001                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
9002                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
9003                 {
9004                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
9005                     char *name_start= RExC_parse++;
9006                     U32 num = 0;
9007                     SV *sv_dat=reg_scan_name(pRExC_state,
9008                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
9009                     if (RExC_parse == name_start || *RExC_parse != ch)
9010                         vFAIL2("Sequence (?(%c... not terminated",
9011                             (ch == '>' ? '<' : ch));
9012                     RExC_parse++;
9013                     if (!SIZE_ONLY) {
9014                         num = add_data( pRExC_state, 1, "S" );
9015                         RExC_rxi->data->data[num]=(void*)sv_dat;
9016                         SvREFCNT_inc_simple_void(sv_dat);
9017                     }
9018                     ret = reganode(pRExC_state,NGROUPP,num);
9019                     goto insert_if_check_paren;
9020                 }
9021                 else if (RExC_parse[0] == 'D' &&
9022                          RExC_parse[1] == 'E' &&
9023                          RExC_parse[2] == 'F' &&
9024                          RExC_parse[3] == 'I' &&
9025                          RExC_parse[4] == 'N' &&
9026                          RExC_parse[5] == 'E')
9027                 {
9028                     ret = reganode(pRExC_state,DEFINEP,0);
9029                     RExC_parse +=6 ;
9030                     is_define = 1;
9031                     goto insert_if_check_paren;
9032                 }
9033                 else if (RExC_parse[0] == 'R') {
9034                     RExC_parse++;
9035                     parno = 0;
9036                     if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
9037                         parno = atoi(RExC_parse++);
9038                         while (isDIGIT(*RExC_parse))
9039                             RExC_parse++;
9040                     } else if (RExC_parse[0] == '&') {
9041                         SV *sv_dat;
9042                         RExC_parse++;
9043                         sv_dat = reg_scan_name(pRExC_state,
9044                             SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
9045                         parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
9046                     }
9047                     ret = reganode(pRExC_state,INSUBP,parno); 
9048                     goto insert_if_check_paren;
9049                 }
9050                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
9051                     /* (?(1)...) */
9052                     char c;
9053                     parno = atoi(RExC_parse++);
9054
9055                     while (isDIGIT(*RExC_parse))
9056                         RExC_parse++;
9057                     ret = reganode(pRExC_state, GROUPP, parno);
9058
9059                  insert_if_check_paren:
9060                     if ((c = *nextchar(pRExC_state)) != ')')
9061                         vFAIL("Switch condition not recognized");
9062                   insert_if:
9063                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
9064                     br = regbranch(pRExC_state, &flags, 1,depth+1);
9065                     if (br == NULL) {
9066                         if (flags & RESTART_UTF8) {
9067                             *flagp = RESTART_UTF8;
9068                             return NULL;
9069                         }
9070                         FAIL2("panic: regbranch returned NULL, flags=%#X",
9071                               flags);
9072                     } else
9073                         REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
9074                     c = *nextchar(pRExC_state);
9075                     if (flags&HASWIDTH)
9076                         *flagp |= HASWIDTH;
9077                     if (c == '|') {
9078                         if (is_define) 
9079                             vFAIL("(?(DEFINE)....) does not allow branches");
9080                         lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
9081                         if (!regbranch(pRExC_state, &flags, 1,depth+1)) {
9082                             if (flags & RESTART_UTF8) {
9083                                 *flagp = RESTART_UTF8;
9084                                 return NULL;
9085                             }
9086                             FAIL2("panic: regbranch returned NULL, flags=%#X",
9087                                   flags);
9088                         }
9089                         REGTAIL(pRExC_state, ret, lastbr);
9090                         if (flags&HASWIDTH)
9091                             *flagp |= HASWIDTH;
9092                         c = *nextchar(pRExC_state);
9093                     }
9094                     else
9095                         lastbr = NULL;
9096                     if (c != ')')
9097                         vFAIL("Switch (?(condition)... contains too many branches");
9098                     ender = reg_node(pRExC_state, TAIL);
9099                     REGTAIL(pRExC_state, br, ender);
9100                     if (lastbr) {
9101                         REGTAIL(pRExC_state, lastbr, ender);
9102                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
9103                     }
9104                     else
9105                         REGTAIL(pRExC_state, ret, ender);
9106                     RExC_size++; /* XXX WHY do we need this?!!
9107                                     For large programs it seems to be required
9108                                     but I can't figure out why. -- dmq*/
9109                     return ret;
9110                 }
9111                 else {
9112                     vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
9113                 }
9114             }
9115             case '[':           /* (?[ ... ]) */
9116                 return handle_regex_sets(pRExC_state, NULL, flagp, depth,
9117                                          oregcomp_parse);
9118             case 0:
9119                 RExC_parse--; /* for vFAIL to print correctly */
9120                 vFAIL("Sequence (? incomplete");
9121                 break;
9122             default: /* e.g., (?i) */
9123                 --RExC_parse;
9124               parse_flags:
9125                 parse_lparen_question_flags(pRExC_state);
9126                 if (UCHARAT(RExC_parse) != ':') {
9127                     nextchar(pRExC_state);
9128                     *flagp = TRYAGAIN;
9129                     return NULL;
9130                 }
9131                 paren = ':';
9132                 nextchar(pRExC_state);
9133                 ret = NULL;
9134                 goto parse_rest;
9135             } /* end switch */
9136         }
9137         else {                  /* (...) */
9138           capturing_parens:
9139             parno = RExC_npar;
9140             RExC_npar++;
9141             
9142             ret = reganode(pRExC_state, OPEN, parno);
9143             if (!SIZE_ONLY ){
9144                 if (!RExC_nestroot) 
9145                     RExC_nestroot = parno;
9146                 if (RExC_seen & REG_SEEN_RECURSE
9147                     && !RExC_open_parens[parno-1])
9148                 {
9149                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
9150                         "Setting open paren #%"IVdf" to %d\n", 
9151                         (IV)parno, REG_NODE_NUM(ret)));
9152                     RExC_open_parens[parno-1]= ret;
9153                 }
9154             }
9155             Set_Node_Length(ret, 1); /* MJD */
9156             Set_Node_Offset(ret, RExC_parse); /* MJD */
9157             is_open = 1;
9158         }
9159     }
9160     else                        /* ! paren */
9161         ret = NULL;
9162    
9163    parse_rest:
9164     /* Pick up the branches, linking them together. */
9165     parse_start = RExC_parse;   /* MJD */
9166     br = regbranch(pRExC_state, &flags, 1,depth+1);
9167
9168     /*     branch_len = (paren != 0); */
9169
9170     if (br == NULL) {
9171         if (flags & RESTART_UTF8) {
9172             *flagp = RESTART_UTF8;
9173             return NULL;
9174         }
9175         FAIL2("panic: regbranch returned NULL, flags=%#X", flags);
9176     }
9177     if (*RExC_parse == '|') {
9178         if (!SIZE_ONLY && RExC_extralen) {
9179             reginsert(pRExC_state, BRANCHJ, br, depth+1);
9180         }
9181         else {                  /* MJD */
9182             reginsert(pRExC_state, BRANCH, br, depth+1);
9183             Set_Node_Length(br, paren != 0);
9184             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
9185         }
9186         have_branch = 1;
9187         if (SIZE_ONLY)
9188             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
9189     }
9190     else if (paren == ':') {
9191         *flagp |= flags&SIMPLE;
9192     }
9193     if (is_open) {                              /* Starts with OPEN. */
9194         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
9195     }
9196     else if (paren != '?')              /* Not Conditional */
9197         ret = br;
9198     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
9199     lastbr = br;
9200     while (*RExC_parse == '|') {
9201         if (!SIZE_ONLY && RExC_extralen) {
9202             ender = reganode(pRExC_state, LONGJMP,0);
9203             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
9204         }
9205         if (SIZE_ONLY)
9206             RExC_extralen += 2;         /* Account for LONGJMP. */
9207         nextchar(pRExC_state);
9208         if (freeze_paren) {
9209             if (RExC_npar > after_freeze)
9210                 after_freeze = RExC_npar;
9211             RExC_npar = freeze_paren;       
9212         }
9213         br = regbranch(pRExC_state, &flags, 0, depth+1);
9214
9215         if (br == NULL) {
9216             if (flags & RESTART_UTF8) {
9217                 *flagp = RESTART_UTF8;
9218                 return NULL;
9219             }
9220             FAIL2("panic: regbranch returned NULL, flags=%#X", flags);
9221         }
9222         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
9223         lastbr = br;
9224         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
9225     }
9226
9227     if (have_branch || paren != ':') {
9228         /* Make a closing node, and hook it on the end. */
9229         switch (paren) {
9230         case ':':
9231             ender = reg_node(pRExC_state, TAIL);
9232             break;
9233         case 1:
9234             ender = reganode(pRExC_state, CLOSE, parno);
9235             if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
9236                 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
9237                         "Setting close paren #%"IVdf" to %d\n", 
9238                         (IV)parno, REG_NODE_NUM(ender)));
9239                 RExC_close_parens[parno-1]= ender;
9240                 if (RExC_nestroot == parno) 
9241                     RExC_nestroot = 0;
9242             }       
9243             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
9244             Set_Node_Length(ender,1); /* MJD */
9245             break;
9246         case '<':
9247         case ',':
9248         case '=':
9249         case '!':
9250             *flagp &= ~HASWIDTH;
9251             /* FALL THROUGH */
9252         case '>':
9253             ender = reg_node(pRExC_state, SUCCEED);
9254             break;
9255         case 0:
9256             ender = reg_node(pRExC_state, END);
9257             if (!SIZE_ONLY) {
9258                 assert(!RExC_opend); /* there can only be one! */
9259                 RExC_opend = ender;
9260             }
9261             break;
9262         }
9263         DEBUG_PARSE_r(if (!SIZE_ONLY) {
9264             SV * const mysv_val1=sv_newmortal();
9265             SV * const mysv_val2=sv_newmortal();
9266             DEBUG_PARSE_MSG("lsbr");
9267             regprop(RExC_rx, mysv_val1, lastbr);
9268             regprop(RExC_rx, mysv_val2, ender);
9269             PerlIO_printf(Perl_debug_log, "~ tying lastbr %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
9270                           SvPV_nolen_const(mysv_val1),
9271                           (IV)REG_NODE_NUM(lastbr),
9272                           SvPV_nolen_const(mysv_val2),
9273                           (IV)REG_NODE_NUM(ender),
9274                           (IV)(ender - lastbr)
9275             );
9276         });
9277         REGTAIL(pRExC_state, lastbr, ender);
9278
9279         if (have_branch && !SIZE_ONLY) {
9280             char is_nothing= 1;
9281             if (depth==1)
9282                 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
9283
9284             /* Hook the tails of the branches to the closing node. */
9285             for (br = ret; br; br = regnext(br)) {
9286                 const U8 op = PL_regkind[OP(br)];
9287                 if (op == BRANCH) {
9288                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
9289                     if (OP(NEXTOPER(br)) != NOTHING || regnext(NEXTOPER(br)) != ender)
9290                         is_nothing= 0;
9291                 }
9292                 else if (op == BRANCHJ) {
9293                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
9294                     /* for now we always disable this optimisation * /
9295                     if (OP(NEXTOPER(NEXTOPER(br))) != NOTHING || regnext(NEXTOPER(NEXTOPER(br))) != ender)
9296                     */
9297                         is_nothing= 0;
9298                 }
9299             }
9300             if (is_nothing) {
9301                 br= PL_regkind[OP(ret)] != BRANCH ? regnext(ret) : ret;
9302                 DEBUG_PARSE_r(if (!SIZE_ONLY) {
9303                     SV * const mysv_val1=sv_newmortal();
9304                     SV * const mysv_val2=sv_newmortal();
9305                     DEBUG_PARSE_MSG("NADA");
9306                     regprop(RExC_rx, mysv_val1, ret);
9307                     regprop(RExC_rx, mysv_val2, ender);
9308                     PerlIO_printf(Perl_debug_log, "~ converting ret %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
9309                                   SvPV_nolen_const(mysv_val1),
9310                                   (IV)REG_NODE_NUM(ret),
9311                                   SvPV_nolen_const(mysv_val2),
9312                                   (IV)REG_NODE_NUM(ender),
9313                                   (IV)(ender - ret)
9314                     );
9315                 });
9316                 OP(br)= NOTHING;
9317                 if (OP(ender) == TAIL) {
9318                     NEXT_OFF(br)= 0;
9319                     RExC_emit= br + 1;
9320                 } else {
9321                     regnode *opt;
9322                     for ( opt= br + 1; opt < ender ; opt++ )
9323                         OP(opt)= OPTIMIZED;
9324                     NEXT_OFF(br)= ender - br;
9325                 }
9326             }
9327         }
9328     }
9329
9330     {
9331         const char *p;
9332         static const char parens[] = "=!<,>";
9333
9334         if (paren && (p = strchr(parens, paren))) {
9335             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
9336             int flag = (p - parens) > 1;
9337
9338             if (paren == '>')
9339                 node = SUSPEND, flag = 0;
9340             reginsert(pRExC_state, node,ret, depth+1);
9341             Set_Node_Cur_Length(ret);
9342             Set_Node_Offset(ret, parse_start + 1);
9343             ret->flags = flag;
9344             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
9345         }
9346     }
9347
9348     /* Check for proper termination. */
9349     if (paren) {
9350         RExC_flags = oregflags;
9351         if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
9352             RExC_parse = oregcomp_parse;
9353             vFAIL("Unmatched (");
9354         }
9355     }
9356     else if (!paren && RExC_parse < RExC_end) {
9357         if (*RExC_parse == ')') {
9358             RExC_parse++;
9359             vFAIL("Unmatched )");
9360         }
9361         else
9362             FAIL("Junk on end of regexp");      /* "Can't happen". */
9363         assert(0); /* NOTREACHED */
9364     }
9365
9366     if (RExC_in_lookbehind) {
9367         RExC_in_lookbehind--;
9368     }
9369     if (after_freeze > RExC_npar)
9370         RExC_npar = after_freeze;
9371     return(ret);
9372 }
9373
9374 /*
9375  - regbranch - one alternative of an | operator
9376  *
9377  * Implements the concatenation operator.
9378  *
9379  * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
9380  * restarted.
9381  */
9382 STATIC regnode *
9383 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
9384 {
9385     dVAR;
9386     regnode *ret;
9387     regnode *chain = NULL;
9388     regnode *latest;
9389     I32 flags = 0, c = 0;
9390     GET_RE_DEBUG_FLAGS_DECL;
9391
9392     PERL_ARGS_ASSERT_REGBRANCH;
9393
9394     DEBUG_PARSE("brnc");
9395
9396     if (first)
9397         ret = NULL;
9398     else {
9399         if (!SIZE_ONLY && RExC_extralen)
9400             ret = reganode(pRExC_state, BRANCHJ,0);
9401         else {
9402             ret = reg_node(pRExC_state, BRANCH);
9403             Set_Node_Length(ret, 1);
9404         }
9405     }
9406
9407     if (!first && SIZE_ONLY)
9408         RExC_extralen += 1;                     /* BRANCHJ */
9409
9410     *flagp = WORST;                     /* Tentatively. */
9411
9412     RExC_parse--;
9413     nextchar(pRExC_state);
9414     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
9415         flags &= ~TRYAGAIN;
9416         latest = regpiece(pRExC_state, &flags,depth+1);
9417         if (latest == NULL) {
9418             if (flags & TRYAGAIN)
9419                 continue;
9420             if (flags & RESTART_UTF8) {
9421                 *flagp = RESTART_UTF8;
9422                 return NULL;
9423             }
9424             FAIL2("panic: regpiece returned NULL, flags=%#X", flags);
9425         }
9426         else if (ret == NULL)
9427             ret = latest;
9428         *flagp |= flags&(HASWIDTH|POSTPONED);
9429         if (chain == NULL)      /* First piece. */
9430             *flagp |= flags&SPSTART;
9431         else {
9432             RExC_naughty++;
9433             REGTAIL(pRExC_state, chain, latest);
9434         }
9435         chain = latest;
9436         c++;
9437     }
9438     if (chain == NULL) {        /* Loop ran zero times. */
9439         chain = reg_node(pRExC_state, NOTHING);
9440         if (ret == NULL)
9441             ret = chain;
9442     }
9443     if (c == 1) {
9444         *flagp |= flags&SIMPLE;
9445     }
9446
9447     return ret;
9448 }
9449
9450 /*
9451  - regpiece - something followed by possible [*+?]
9452  *
9453  * Note that the branching code sequences used for ? and the general cases
9454  * of * and + are somewhat optimized:  they use the same NOTHING node as
9455  * both the endmarker for their branch list and the body of the last branch.
9456  * It might seem that this node could be dispensed with entirely, but the
9457  * endmarker role is not redundant.
9458  *
9459  * Returns NULL, setting *flagp to TRYAGAIN if regatom() returns NULL with
9460  * TRYAGAIN.
9461  * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
9462  * restarted.
9463  */
9464 STATIC regnode *
9465 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
9466 {
9467     dVAR;
9468     regnode *ret;
9469     char op;
9470     char *next;
9471     I32 flags;
9472     const char * const origparse = RExC_parse;
9473     I32 min;
9474     I32 max = REG_INFTY;
9475 #ifdef RE_TRACK_PATTERN_OFFSETS
9476     char *parse_start;
9477 #endif
9478     const char *maxpos = NULL;
9479
9480     /* Save the original in case we change the emitted regop to a FAIL. */
9481     regnode * const orig_emit = RExC_emit;
9482
9483     GET_RE_DEBUG_FLAGS_DECL;
9484
9485     PERL_ARGS_ASSERT_REGPIECE;
9486
9487     DEBUG_PARSE("piec");
9488
9489     ret = regatom(pRExC_state, &flags,depth+1);
9490     if (ret == NULL) {
9491         if (flags & (TRYAGAIN|RESTART_UTF8))
9492             *flagp |= flags & (TRYAGAIN|RESTART_UTF8);
9493         else
9494             FAIL2("panic: regatom returned NULL, flags=%#X", flags);
9495         return(NULL);
9496     }
9497
9498     op = *RExC_parse;
9499
9500     if (op == '{' && regcurly(RExC_parse, FALSE)) {
9501         maxpos = NULL;
9502 #ifdef RE_TRACK_PATTERN_OFFSETS
9503         parse_start = RExC_parse; /* MJD */
9504 #endif
9505         next = RExC_parse + 1;
9506         while (isDIGIT(*next) || *next == ',') {
9507             if (*next == ',') {
9508                 if (maxpos)
9509                     break;
9510                 else
9511                     maxpos = next;
9512             }
9513             next++;
9514         }
9515         if (*next == '}') {             /* got one */
9516             if (!maxpos)
9517                 maxpos = next;
9518             RExC_parse++;
9519             min = atoi(RExC_parse);
9520             if (*maxpos == ',')
9521                 maxpos++;
9522             else
9523                 maxpos = RExC_parse;
9524             max = atoi(maxpos);
9525             if (!max && *maxpos != '0')
9526                 max = REG_INFTY;                /* meaning "infinity" */
9527             else if (max >= REG_INFTY)
9528                 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
9529             RExC_parse = next;
9530             nextchar(pRExC_state);
9531             if (max < min) {    /* If can't match, warn and optimize to fail
9532                                    unconditionally */
9533                 if (SIZE_ONLY) {
9534                     ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
9535
9536                     /* We can't back off the size because we have to reserve
9537                      * enough space for all the things we are about to throw
9538                      * away, but we can shrink it by the ammount we are about
9539                      * to re-use here */
9540                     RExC_size = PREVOPER(RExC_size) - regarglen[(U8)OPFAIL];
9541                 }
9542                 else {
9543                     RExC_emit = orig_emit;
9544                 }
9545                 ret = reg_node(pRExC_state, OPFAIL);
9546                 return ret;
9547             }
9548             else if (max == 0) {    /* replace {0} with a nothing node */
9549                 if (SIZE_ONLY) {
9550                     RExC_size = PREVOPER(RExC_size) - regarglen[(U8)NOTHING];
9551                 }
9552                 else {
9553                     RExC_emit = orig_emit;
9554                 }
9555                 ret = reg_node(pRExC_state, NOTHING);
9556                 return ret;
9557             }
9558
9559         do_curly:
9560             if ((flags&SIMPLE)) {
9561                 RExC_naughty += 2 + RExC_naughty / 2;
9562                 reginsert(pRExC_state, CURLY, ret, depth+1);
9563                 Set_Node_Offset(ret, parse_start+1); /* MJD */
9564                 Set_Node_Cur_Length(ret);
9565             }
9566             else {
9567                 regnode * const w = reg_node(pRExC_state, WHILEM);
9568
9569                 w->flags = 0;
9570                 REGTAIL(pRExC_state, ret, w);
9571                 if (!SIZE_ONLY && RExC_extralen) {
9572                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
9573                     reginsert(pRExC_state, NOTHING,ret, depth+1);
9574                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
9575                 }
9576                 reginsert(pRExC_state, CURLYX,ret, depth+1);
9577                                 /* MJD hk */
9578                 Set_Node_Offset(ret, parse_start+1);
9579                 Set_Node_Length(ret,
9580                                 op == '{' ? (RExC_parse - parse_start) : 1);
9581
9582                 if (!SIZE_ONLY && RExC_extralen)
9583                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
9584                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
9585                 if (SIZE_ONLY)
9586                     RExC_whilem_seen++, RExC_extralen += 3;
9587                 RExC_naughty += 4 + RExC_naughty;       /* compound interest */
9588             }
9589             ret->flags = 0;
9590
9591             if (min > 0)
9592                 *flagp = WORST;
9593             if (max > 0)
9594                 *flagp |= HASWIDTH;
9595             if (!SIZE_ONLY) {
9596                 ARG1_SET(ret, (U16)min);
9597                 ARG2_SET(ret, (U16)max);
9598             }
9599
9600             goto nest_check;
9601         }
9602     }
9603
9604     if (!ISMULT1(op)) {
9605         *flagp = flags;
9606         return(ret);
9607     }
9608
9609 #if 0                           /* Now runtime fix should be reliable. */
9610
9611     /* if this is reinstated, don't forget to put this back into perldiag:
9612
9613             =item Regexp *+ operand could be empty at {#} in regex m/%s/
9614
9615            (F) The part of the regexp subject to either the * or + quantifier
9616            could match an empty string. The {#} shows in the regular
9617            expression about where the problem was discovered.
9618
9619     */
9620
9621     if (!(flags&HASWIDTH) && op != '?')
9622       vFAIL("Regexp *+ operand could be empty");
9623 #endif
9624
9625 #ifdef RE_TRACK_PATTERN_OFFSETS
9626     parse_start = RExC_parse;
9627 #endif
9628     nextchar(pRExC_state);
9629
9630     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
9631
9632     if (op == '*' && (flags&SIMPLE)) {
9633         reginsert(pRExC_state, STAR, ret, depth+1);
9634         ret->flags = 0;
9635         RExC_naughty += 4;
9636     }
9637     else if (op == '*') {
9638         min = 0;
9639         goto do_curly;
9640     }
9641     else if (op == '+' && (flags&SIMPLE)) {
9642         reginsert(pRExC_state, PLUS, ret, depth+1);
9643         ret->flags = 0;
9644         RExC_naughty += 3;
9645     }
9646     else if (op == '+') {
9647         min = 1;
9648         goto do_curly;
9649     }
9650     else if (op == '?') {
9651         min = 0; max = 1;
9652         goto do_curly;
9653     }
9654   nest_check:
9655     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
9656         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
9657         ckWARN3reg(RExC_parse,
9658                    "%.*s matches null string many times",
9659                    (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
9660                    origparse);
9661         (void)ReREFCNT_inc(RExC_rx_sv);
9662     }
9663
9664     if (RExC_parse < RExC_end && *RExC_parse == '?') {
9665         nextchar(pRExC_state);
9666         reginsert(pRExC_state, MINMOD, ret, depth+1);
9667         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
9668     }
9669 #ifndef REG_ALLOW_MINMOD_SUSPEND
9670     else
9671 #endif
9672     if (RExC_parse < RExC_end && *RExC_parse == '+') {
9673         regnode *ender;
9674         nextchar(pRExC_state);
9675         ender = reg_node(pRExC_state, SUCCEED);
9676         REGTAIL(pRExC_state, ret, ender);
9677         reginsert(pRExC_state, SUSPEND, ret, depth+1);
9678         ret->flags = 0;
9679         ender = reg_node(pRExC_state, TAIL);
9680         REGTAIL(pRExC_state, ret, ender);
9681         /*ret= ender;*/
9682     }
9683
9684     if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
9685         RExC_parse++;
9686         vFAIL("Nested quantifiers");
9687     }
9688
9689     return(ret);
9690 }
9691
9692 STATIC bool
9693 S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, UV *valuep, I32 *flagp, U32 depth, bool in_char_class,
9694         const bool strict   /* Apply stricter parsing rules? */
9695     )
9696 {
9697    
9698  /* This is expected to be called by a parser routine that has recognized '\N'
9699    and needs to handle the rest. RExC_parse is expected to point at the first
9700    char following the N at the time of the call.  On successful return,
9701    RExC_parse has been updated to point to just after the sequence identified
9702    by this routine, and <*flagp> has been updated.
9703
9704    The \N may be inside (indicated by the boolean <in_char_class>) or outside a
9705    character class.
9706
9707    \N may begin either a named sequence, or if outside a character class, mean
9708    to match a non-newline.  For non single-quoted regexes, the tokenizer has
9709    attempted to decide which, and in the case of a named sequence, converted it
9710    into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...},
9711    where c1... are the characters in the sequence.  For single-quoted regexes,
9712    the tokenizer passes the \N sequence through unchanged; this code will not
9713    attempt to determine this nor expand those, instead raising a syntax error.
9714    The net effect is that if the beginning of the passed-in pattern isn't '{U+'
9715    or there is no '}', it signals that this \N occurrence means to match a
9716    non-newline.
9717
9718    Only the \N{U+...} form should occur in a character class, for the same
9719    reason that '.' inside a character class means to just match a period: it
9720    just doesn't make sense.
9721
9722    The function raises an error (via vFAIL), and doesn't return for various
9723    syntax errors.  Otherwise it returns TRUE and sets <node_p> or <valuep> on
9724    success; it returns FALSE otherwise. Returns FALSE, setting *flagp to
9725    RESTART_UTF8 if the sizing scan needs to be restarted. Such a restart is
9726    only possible if node_p is non-NULL.
9727
9728
9729    If <valuep> is non-null, it means the caller can accept an input sequence
9730    consisting of a just a single code point; <*valuep> is set to that value
9731    if the input is such.
9732
9733    If <node_p> is non-null it signifies that the caller can accept any other
9734    legal sequence (i.e., one that isn't just a single code point).  <*node_p>
9735    is set as follows:
9736     1) \N means not-a-NL: points to a newly created REG_ANY node;
9737     2) \N{}:              points to a new NOTHING node;
9738     3) otherwise:         points to a new EXACT node containing the resolved
9739                           string.
9740    Note that FALSE is returned for single code point sequences if <valuep> is
9741    null.
9742  */
9743
9744     char * endbrace;    /* '}' following the name */
9745     char* p;
9746     char *endchar;      /* Points to '.' or '}' ending cur char in the input
9747                            stream */
9748     bool has_multiple_chars; /* true if the input stream contains a sequence of
9749                                 more than one character */
9750
9751     GET_RE_DEBUG_FLAGS_DECL;
9752  
9753     PERL_ARGS_ASSERT_GROK_BSLASH_N;
9754
9755     GET_RE_DEBUG_FLAGS;
9756
9757     assert(cBOOL(node_p) ^ cBOOL(valuep));  /* Exactly one should be set */
9758
9759     /* The [^\n] meaning of \N ignores spaces and comments under the /x
9760      * modifier.  The other meaning does not */
9761     p = (RExC_flags & RXf_PMf_EXTENDED)
9762         ? regwhite( pRExC_state, RExC_parse )
9763         : RExC_parse;
9764
9765     /* Disambiguate between \N meaning a named character versus \N meaning
9766      * [^\n].  The former is assumed when it can't be the latter. */
9767     if (*p != '{' || regcurly(p, FALSE)) {
9768         RExC_parse = p;
9769         if (! node_p) {
9770             /* no bare \N in a charclass */
9771             if (in_char_class) {
9772                 vFAIL("\\N in a character class must be a named character: \\N{...}");
9773             }
9774             return FALSE;
9775         }
9776         nextchar(pRExC_state);
9777         *node_p = reg_node(pRExC_state, REG_ANY);
9778         *flagp |= HASWIDTH|SIMPLE;
9779         RExC_naughty++;
9780         RExC_parse--;
9781         Set_Node_Length(*node_p, 1); /* MJD */
9782         return TRUE;
9783     }
9784
9785     /* Here, we have decided it should be a named character or sequence */
9786
9787     /* The test above made sure that the next real character is a '{', but
9788      * under the /x modifier, it could be separated by space (or a comment and
9789      * \n) and this is not allowed (for consistency with \x{...} and the
9790      * tokenizer handling of \N{NAME}). */
9791     if (*RExC_parse != '{') {
9792         vFAIL("Missing braces on \\N{}");
9793     }
9794
9795     RExC_parse++;       /* Skip past the '{' */
9796
9797     if (! (endbrace = strchr(RExC_parse, '}')) /* no trailing brace */
9798         || ! (endbrace == RExC_parse            /* nothing between the {} */
9799               || (endbrace - RExC_parse >= 2    /* U+ (bad hex is checked below */
9800                   && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg) */
9801     {
9802         if (endbrace) RExC_parse = endbrace;    /* position msg's '<--HERE' */
9803         vFAIL("\\N{NAME} must be resolved by the lexer");
9804     }
9805
9806     if (endbrace == RExC_parse) {   /* empty: \N{} */
9807         bool ret = TRUE;
9808         if (node_p) {
9809             *node_p = reg_node(pRExC_state,NOTHING);
9810         }
9811         else if (in_char_class) {
9812             if (SIZE_ONLY && in_char_class) {
9813                 if (strict) {
9814                     RExC_parse++;   /* Position after the "}" */
9815                     vFAIL("Zero length \\N{}");
9816                 }
9817                 else {
9818                     ckWARNreg(RExC_parse,
9819                               "Ignoring zero length \\N{} in character class");
9820                 }
9821             }
9822             ret = FALSE;
9823         }
9824         else {
9825             return FALSE;
9826         }
9827         nextchar(pRExC_state);
9828         return ret;
9829     }
9830
9831     RExC_uni_semantics = 1; /* Unicode named chars imply Unicode semantics */
9832     RExC_parse += 2;    /* Skip past the 'U+' */
9833
9834     endchar = RExC_parse + strcspn(RExC_parse, ".}");
9835
9836     /* Code points are separated by dots.  If none, there is only one code
9837      * point, and is terminated by the brace */
9838     has_multiple_chars = (endchar < endbrace);
9839
9840     if (valuep && (! has_multiple_chars || in_char_class)) {
9841         /* We only pay attention to the first char of
9842         multichar strings being returned in char classes. I kinda wonder
9843         if this makes sense as it does change the behaviour
9844         from earlier versions, OTOH that behaviour was broken
9845         as well. XXX Solution is to recharacterize as
9846         [rest-of-class]|multi1|multi2... */
9847
9848         STRLEN length_of_hex = (STRLEN)(endchar - RExC_parse);
9849         I32 grok_hex_flags = PERL_SCAN_ALLOW_UNDERSCORES
9850             | PERL_SCAN_DISALLOW_PREFIX
9851             | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
9852
9853         *valuep = grok_hex(RExC_parse, &length_of_hex, &grok_hex_flags, NULL);
9854
9855         /* The tokenizer should have guaranteed validity, but it's possible to
9856          * bypass it by using single quoting, so check */
9857         if (length_of_hex == 0
9858             || length_of_hex != (STRLEN)(endchar - RExC_parse) )
9859         {
9860             RExC_parse += length_of_hex;        /* Includes all the valid */
9861             RExC_parse += (RExC_orig_utf8)      /* point to after 1st invalid */
9862                             ? UTF8SKIP(RExC_parse)
9863                             : 1;
9864             /* Guard against malformed utf8 */
9865             if (RExC_parse >= endchar) {
9866                 RExC_parse = endchar;
9867             }
9868             vFAIL("Invalid hexadecimal number in \\N{U+...}");
9869         }
9870
9871         if (in_char_class && has_multiple_chars) {
9872             if (strict) {
9873                 RExC_parse = endbrace;
9874                 vFAIL("\\N{} in character class restricted to one character");
9875             }
9876             else {
9877                 ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
9878             }
9879         }
9880
9881         RExC_parse = endbrace + 1;
9882     }
9883     else if (! node_p || ! has_multiple_chars) {
9884
9885         /* Here, the input is legal, but not according to the caller's
9886          * options.  We fail without advancing the parse, so that the
9887          * caller can try again */
9888         RExC_parse = p;
9889         return FALSE;
9890     }
9891     else {
9892
9893         /* What is done here is to convert this to a sub-pattern of the form
9894          * (?:\x{char1}\x{char2}...)
9895          * and then call reg recursively.  That way, it retains its atomicness,
9896          * while not having to worry about special handling that some code
9897          * points may have.  toke.c has converted the original Unicode values
9898          * to native, so that we can just pass on the hex values unchanged.  We
9899          * do have to set a flag to keep recoding from happening in the
9900          * recursion */
9901
9902         SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP);
9903         STRLEN len;
9904         char *orig_end = RExC_end;
9905         I32 flags;
9906
9907         while (RExC_parse < endbrace) {
9908
9909             /* Convert to notation the rest of the code understands */
9910             sv_catpv(substitute_parse, "\\x{");
9911             sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
9912             sv_catpv(substitute_parse, "}");
9913
9914             /* Point to the beginning of the next character in the sequence. */
9915             RExC_parse = endchar + 1;
9916             endchar = RExC_parse + strcspn(RExC_parse, ".}");
9917         }
9918         sv_catpv(substitute_parse, ")");
9919
9920         RExC_parse = SvPV(substitute_parse, len);
9921
9922         /* Don't allow empty number */
9923         if (len < 8) {
9924             vFAIL("Invalid hexadecimal number in \\N{U+...}");
9925         }
9926         RExC_end = RExC_parse + len;
9927
9928         /* The values are Unicode, and therefore not subject to recoding */
9929         RExC_override_recoding = 1;
9930
9931         if (!(*node_p = reg(pRExC_state, 1, &flags, depth+1))) {
9932             if (flags & RESTART_UTF8) {
9933                 *flagp = RESTART_UTF8;
9934                 return FALSE;
9935             }
9936             FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#X",
9937                   flags);
9938         } 
9939         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
9940
9941         RExC_parse = endbrace;
9942         RExC_end = orig_end;
9943         RExC_override_recoding = 0;
9944
9945         nextchar(pRExC_state);
9946     }
9947
9948     return TRUE;
9949 }
9950
9951
9952 /*
9953  * reg_recode
9954  *
9955  * It returns the code point in utf8 for the value in *encp.
9956  *    value: a code value in the source encoding
9957  *    encp:  a pointer to an Encode object
9958  *
9959  * If the result from Encode is not a single character,
9960  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
9961  */
9962 STATIC UV
9963 S_reg_recode(pTHX_ const char value, SV **encp)
9964 {
9965     STRLEN numlen = 1;
9966     SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP);
9967     const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
9968     const STRLEN newlen = SvCUR(sv);
9969     UV uv = UNICODE_REPLACEMENT;
9970
9971     PERL_ARGS_ASSERT_REG_RECODE;
9972
9973     if (newlen)
9974         uv = SvUTF8(sv)
9975              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
9976              : *(U8*)s;
9977
9978     if (!newlen || numlen != newlen) {
9979         uv = UNICODE_REPLACEMENT;
9980         *encp = NULL;
9981     }
9982     return uv;
9983 }
9984
9985 PERL_STATIC_INLINE U8
9986 S_compute_EXACTish(pTHX_ RExC_state_t *pRExC_state)
9987 {
9988     U8 op;
9989
9990     PERL_ARGS_ASSERT_COMPUTE_EXACTISH;
9991
9992     if (! FOLD) {
9993         return EXACT;
9994     }
9995
9996     op = get_regex_charset(RExC_flags);
9997     if (op >= REGEX_ASCII_RESTRICTED_CHARSET) {
9998         op--; /* /a is same as /u, and map /aa's offset to what /a's would have
9999                  been, so there is no hole */
10000     }
10001
10002     return op + EXACTF;
10003 }
10004
10005 PERL_STATIC_INLINE void
10006 S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state, regnode *node, I32* flagp, STRLEN len, UV code_point)
10007 {
10008     /* This knows the details about sizing an EXACTish node, setting flags for
10009      * it (by setting <*flagp>, and potentially populating it with a single
10010      * character.
10011      *
10012      * If <len> (the length in bytes) is non-zero, this function assumes that
10013      * the node has already been populated, and just does the sizing.  In this
10014      * case <code_point> should be the final code point that has already been
10015      * placed into the node.  This value will be ignored except that under some
10016      * circumstances <*flagp> is set based on it.
10017      *
10018      * If <len> is zero, the function assumes that the node is to contain only
10019      * the single character given by <code_point> and calculates what <len>
10020      * should be.  In pass 1, it sizes the node appropriately.  In pass 2, it
10021      * additionally will populate the node's STRING with <code_point>, if <len>
10022      * is 0.  In both cases <*flagp> is appropriately set
10023      *
10024      * It knows that under FOLD, UTF characters and the Latin Sharp S must be
10025      * folded (the latter only when the rules indicate it can match 'ss') */
10026
10027     bool len_passed_in = cBOOL(len != 0);
10028     U8 character[UTF8_MAXBYTES_CASE+1];
10029
10030     PERL_ARGS_ASSERT_ALLOC_MAYBE_POPULATE_EXACT;
10031
10032     if (! len_passed_in) {
10033         if (UTF) {
10034             if (FOLD) {
10035                 to_uni_fold(NATIVE_TO_UNI(code_point), character, &len);
10036             }
10037             else {
10038                 uvchr_to_utf8( character, code_point);
10039                 len = UTF8SKIP(character);
10040             }
10041         }
10042         else if (! FOLD
10043                  || code_point != LATIN_SMALL_LETTER_SHARP_S
10044                  || ASCII_FOLD_RESTRICTED
10045                  || ! AT_LEAST_UNI_SEMANTICS)
10046         {
10047             *character = (U8) code_point;
10048             len = 1;
10049         }
10050         else {
10051             *character = 's';
10052             *(character + 1) = 's';
10053             len = 2;
10054         }
10055     }
10056
10057     if (SIZE_ONLY) {
10058         RExC_size += STR_SZ(len);
10059     }
10060     else {
10061         RExC_emit += STR_SZ(len);
10062         STR_LEN(node) = len;
10063         if (! len_passed_in) {
10064             Copy((char *) character, STRING(node), len, char);
10065         }
10066     }
10067
10068     *flagp |= HASWIDTH;
10069
10070     /* A single character node is SIMPLE, except for the special-cased SHARP S
10071      * under /di. */
10072     if ((len == 1 || (UTF && len == UNISKIP(code_point)))
10073         && (code_point != LATIN_SMALL_LETTER_SHARP_S
10074             || ! FOLD || ! DEPENDS_SEMANTICS))
10075     {
10076         *flagp |= SIMPLE;
10077     }
10078 }
10079
10080 /*
10081  - regatom - the lowest level
10082
10083    Try to identify anything special at the start of the pattern. If there
10084    is, then handle it as required. This may involve generating a single regop,
10085    such as for an assertion; or it may involve recursing, such as to
10086    handle a () structure.
10087
10088    If the string doesn't start with something special then we gobble up
10089    as much literal text as we can.
10090
10091    Once we have been able to handle whatever type of thing started the
10092    sequence, we return.
10093
10094    Note: we have to be careful with escapes, as they can be both literal
10095    and special, and in the case of \10 and friends, context determines which.
10096
10097    A summary of the code structure is:
10098
10099    switch (first_byte) {
10100         cases for each special:
10101             handle this special;
10102             break;
10103         case '\\':
10104             switch (2nd byte) {
10105                 cases for each unambiguous special:
10106                     handle this special;
10107                     break;
10108                 cases for each ambigous special/literal:
10109                     disambiguate;
10110                     if (special)  handle here
10111                     else goto defchar;
10112                 default: // unambiguously literal:
10113                     goto defchar;
10114             }
10115         default:  // is a literal char
10116             // FALL THROUGH
10117         defchar:
10118             create EXACTish node for literal;
10119             while (more input and node isn't full) {
10120                 switch (input_byte) {
10121                    cases for each special;
10122                        make sure parse pointer is set so that the next call to
10123                            regatom will see this special first
10124                        goto loopdone; // EXACTish node terminated by prev. char
10125                    default:
10126                        append char to EXACTISH node;
10127                 }
10128                 get next input byte;
10129             }
10130         loopdone:
10131    }
10132    return the generated node;
10133
10134    Specifically there are two separate switches for handling
10135    escape sequences, with the one for handling literal escapes requiring
10136    a dummy entry for all of the special escapes that are actually handled
10137    by the other.
10138
10139    Returns NULL, setting *flagp to TRYAGAIN if reg() returns NULL with
10140    TRYAGAIN.  
10141    Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
10142    restarted.
10143    Otherwise does not return NULL.
10144 */
10145
10146 STATIC regnode *
10147 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
10148 {
10149     dVAR;
10150     regnode *ret = NULL;
10151     I32 flags = 0;
10152     char *parse_start = RExC_parse;
10153     U8 op;
10154     int invert = 0;
10155
10156     GET_RE_DEBUG_FLAGS_DECL;
10157
10158     *flagp = WORST;             /* Tentatively. */
10159
10160     DEBUG_PARSE("atom");
10161
10162     PERL_ARGS_ASSERT_REGATOM;
10163
10164 tryagain:
10165     switch ((U8)*RExC_parse) {
10166     case '^':
10167         RExC_seen_zerolen++;
10168         nextchar(pRExC_state);
10169         if (RExC_flags & RXf_PMf_MULTILINE)
10170             ret = reg_node(pRExC_state, MBOL);
10171         else if (RExC_flags & RXf_PMf_SINGLELINE)
10172             ret = reg_node(pRExC_state, SBOL);
10173         else
10174             ret = reg_node(pRExC_state, BOL);
10175         Set_Node_Length(ret, 1); /* MJD */
10176         break;
10177     case '$':
10178         nextchar(pRExC_state);
10179         if (*RExC_parse)
10180             RExC_seen_zerolen++;
10181         if (RExC_flags & RXf_PMf_MULTILINE)
10182             ret = reg_node(pRExC_state, MEOL);
10183         else if (RExC_flags & RXf_PMf_SINGLELINE)
10184             ret = reg_node(pRExC_state, SEOL);
10185         else
10186             ret = reg_node(pRExC_state, EOL);
10187         Set_Node_Length(ret, 1); /* MJD */
10188         break;
10189     case '.':
10190         nextchar(pRExC_state);
10191         if (RExC_flags & RXf_PMf_SINGLELINE)
10192             ret = reg_node(pRExC_state, SANY);
10193         else
10194             ret = reg_node(pRExC_state, REG_ANY);
10195         *flagp |= HASWIDTH|SIMPLE;
10196         RExC_naughty++;
10197         Set_Node_Length(ret, 1); /* MJD */
10198         break;
10199     case '[':
10200     {
10201         char * const oregcomp_parse = ++RExC_parse;
10202         ret = regclass(pRExC_state, flagp,depth+1,
10203                        FALSE, /* means parse the whole char class */
10204                        TRUE, /* allow multi-char folds */
10205                        FALSE, /* don't silence non-portable warnings. */
10206                        NULL);
10207         if (*RExC_parse != ']') {
10208             RExC_parse = oregcomp_parse;
10209             vFAIL("Unmatched [");
10210         }
10211         if (ret == NULL) {
10212             if (*flagp & RESTART_UTF8)
10213                 return NULL;
10214             FAIL2("panic: regclass returned NULL to regatom, flags=%#X",
10215                   *flagp);
10216         }
10217         nextchar(pRExC_state);
10218         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
10219         break;
10220     }
10221     case '(':
10222         nextchar(pRExC_state);
10223         ret = reg(pRExC_state, 1, &flags,depth+1);
10224         if (ret == NULL) {
10225                 if (flags & TRYAGAIN) {
10226                     if (RExC_parse == RExC_end) {
10227                          /* Make parent create an empty node if needed. */
10228                         *flagp |= TRYAGAIN;
10229                         return(NULL);
10230                     }
10231                     goto tryagain;
10232                 }
10233                 if (flags & RESTART_UTF8) {
10234                     *flagp = RESTART_UTF8;
10235                     return NULL;
10236                 }
10237                 FAIL2("panic: reg returned NULL to regatom, flags=%#X", flags);
10238         }
10239         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
10240         break;
10241     case '|':
10242     case ')':
10243         if (flags & TRYAGAIN) {
10244             *flagp |= TRYAGAIN;
10245             return NULL;
10246         }
10247         vFAIL("Internal urp");
10248                                 /* Supposed to be caught earlier. */
10249         break;
10250     case '{':
10251         if (!regcurly(RExC_parse, FALSE)) {
10252             RExC_parse++;
10253             goto defchar;
10254         }
10255         /* FALL THROUGH */
10256     case '?':
10257     case '+':
10258     case '*':
10259         RExC_parse++;
10260         vFAIL("Quantifier follows nothing");
10261         break;
10262     case '\\':
10263         /* Special Escapes
10264
10265            This switch handles escape sequences that resolve to some kind
10266            of special regop and not to literal text. Escape sequnces that
10267            resolve to literal text are handled below in the switch marked
10268            "Literal Escapes".
10269
10270            Every entry in this switch *must* have a corresponding entry
10271            in the literal escape switch. However, the opposite is not
10272            required, as the default for this switch is to jump to the
10273            literal text handling code.
10274         */
10275         switch ((U8)*++RExC_parse) {
10276             U8 arg;
10277         /* Special Escapes */
10278         case 'A':
10279             RExC_seen_zerolen++;
10280             ret = reg_node(pRExC_state, SBOL);
10281             *flagp |= SIMPLE;
10282             goto finish_meta_pat;
10283         case 'G':
10284             ret = reg_node(pRExC_state, GPOS);
10285             RExC_seen |= REG_SEEN_GPOS;
10286             *flagp |= SIMPLE;
10287             goto finish_meta_pat;
10288         case 'K':
10289             RExC_seen_zerolen++;
10290             ret = reg_node(pRExC_state, KEEPS);
10291             *flagp |= SIMPLE;
10292             /* XXX:dmq : disabling in-place substitution seems to
10293              * be necessary here to avoid cases of memory corruption, as
10294              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
10295              */
10296             RExC_seen |= REG_SEEN_LOOKBEHIND;
10297             goto finish_meta_pat;
10298         case 'Z':
10299             ret = reg_node(pRExC_state, SEOL);
10300             *flagp |= SIMPLE;
10301             RExC_seen_zerolen++;                /* Do not optimize RE away */
10302             goto finish_meta_pat;
10303         case 'z':
10304             ret = reg_node(pRExC_state, EOS);
10305             *flagp |= SIMPLE;
10306             RExC_seen_zerolen++;                /* Do not optimize RE away */
10307             goto finish_meta_pat;
10308         case 'C':
10309             ret = reg_node(pRExC_state, CANY);
10310             RExC_seen |= REG_SEEN_CANY;
10311             *flagp |= HASWIDTH|SIMPLE;
10312             goto finish_meta_pat;
10313         case 'X':
10314             ret = reg_node(pRExC_state, CLUMP);
10315             *flagp |= HASWIDTH;
10316             goto finish_meta_pat;
10317
10318         case 'W':
10319             invert = 1;
10320             /* FALLTHROUGH */
10321         case 'w':
10322             arg = ANYOF_WORDCHAR;
10323             goto join_posix;
10324
10325         case 'b':
10326             RExC_seen_zerolen++;
10327             RExC_seen |= REG_SEEN_LOOKBEHIND;
10328             op = BOUND + get_regex_charset(RExC_flags);
10329             if (op > BOUNDA) {  /* /aa is same as /a */
10330                 op = BOUNDA;
10331             }
10332             ret = reg_node(pRExC_state, op);
10333             FLAGS(ret) = get_regex_charset(RExC_flags);
10334             *flagp |= SIMPLE;
10335             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
10336                 ckWARNdep(RExC_parse, "\"\\b{\" is deprecated; use \"\\b\\{\" or \"\\b[{]\" instead");
10337             }
10338             goto finish_meta_pat;
10339         case 'B':
10340             RExC_seen_zerolen++;
10341             RExC_seen |= REG_SEEN_LOOKBEHIND;
10342             op = NBOUND + get_regex_charset(RExC_flags);
10343             if (op > NBOUNDA) { /* /aa is same as /a */
10344                 op = NBOUNDA;
10345             }
10346             ret = reg_node(pRExC_state, op);
10347             FLAGS(ret) = get_regex_charset(RExC_flags);
10348             *flagp |= SIMPLE;
10349             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
10350                 ckWARNdep(RExC_parse, "\"\\B{\" is deprecated; use \"\\B\\{\" or \"\\B[{]\" instead");
10351             }
10352             goto finish_meta_pat;
10353
10354         case 'D':
10355             invert = 1;
10356             /* FALLTHROUGH */
10357         case 'd':
10358             arg = ANYOF_DIGIT;
10359             goto join_posix;
10360
10361         case 'R':
10362             ret = reg_node(pRExC_state, LNBREAK);
10363             *flagp |= HASWIDTH|SIMPLE;
10364             goto finish_meta_pat;
10365
10366         case 'H':
10367             invert = 1;
10368             /* FALLTHROUGH */
10369         case 'h':
10370             arg = ANYOF_BLANK;
10371             op = POSIXU;
10372             goto join_posix_op_known;
10373
10374         case 'V':
10375             invert = 1;
10376             /* FALLTHROUGH */
10377         case 'v':
10378             arg = ANYOF_VERTWS;
10379             op = POSIXU;
10380             goto join_posix_op_known;
10381
10382         case 'S':
10383             invert = 1;
10384             /* FALLTHROUGH */
10385         case 's':
10386             arg = ANYOF_SPACE;
10387
10388         join_posix:
10389
10390             op = POSIXD + get_regex_charset(RExC_flags);
10391             if (op > POSIXA) {  /* /aa is same as /a */
10392                 op = POSIXA;
10393             }
10394
10395         join_posix_op_known:
10396
10397             if (invert) {
10398                 op += NPOSIXD - POSIXD;
10399             }
10400
10401             ret = reg_node(pRExC_state, op);
10402             if (! SIZE_ONLY) {
10403                 FLAGS(ret) = namedclass_to_classnum(arg);
10404             }
10405
10406             *flagp |= HASWIDTH|SIMPLE;
10407             /* FALL THROUGH */
10408
10409          finish_meta_pat:           
10410             nextchar(pRExC_state);
10411             Set_Node_Length(ret, 2); /* MJD */
10412             break;          
10413         case 'p':
10414         case 'P':
10415             {
10416 #ifdef DEBUGGING
10417                 char* parse_start = RExC_parse - 2;
10418 #endif
10419
10420                 RExC_parse--;
10421
10422                 ret = regclass(pRExC_state, flagp,depth+1,
10423                                TRUE, /* means just parse this element */
10424                                FALSE, /* don't allow multi-char folds */
10425                                FALSE, /* don't silence non-portable warnings.
10426                                          It would be a bug if these returned
10427                                          non-portables */
10428                                NULL);
10429                 /* regclass() can only return RESTART_UTF8 if multi-char folds
10430                    are allowed.  */
10431                 if (!ret)
10432                     FAIL2("panic: regclass returned NULL to regatom, flags=%#X",
10433                           *flagp);
10434
10435                 RExC_parse--;
10436
10437                 Set_Node_Offset(ret, parse_start + 2);
10438                 Set_Node_Cur_Length(ret);
10439                 nextchar(pRExC_state);
10440             }
10441             break;
10442         case 'N': 
10443             /* Handle \N and \N{NAME} with multiple code points here and not
10444              * below because it can be multicharacter. join_exact() will join
10445              * them up later on.  Also this makes sure that things like
10446              * /\N{BLAH}+/ and \N{BLAH} being multi char Just Happen. dmq.
10447              * The options to the grok function call causes it to fail if the
10448              * sequence is just a single code point.  We then go treat it as
10449              * just another character in the current EXACT node, and hence it
10450              * gets uniform treatment with all the other characters.  The
10451              * special treatment for quantifiers is not needed for such single
10452              * character sequences */
10453             ++RExC_parse;
10454             if (! grok_bslash_N(pRExC_state, &ret, NULL, flagp, depth, FALSE,
10455                                 FALSE /* not strict */ )) {
10456                 if (*flagp & RESTART_UTF8)
10457                     return NULL;
10458                 RExC_parse--;
10459                 goto defchar;
10460             }
10461             break;
10462         case 'k':    /* Handle \k<NAME> and \k'NAME' */
10463         parse_named_seq:
10464         {   
10465             char ch= RExC_parse[1];         
10466             if (ch != '<' && ch != '\'' && ch != '{') {
10467                 RExC_parse++;
10468                 vFAIL2("Sequence %.2s... not terminated",parse_start);
10469             } else {
10470                 /* this pretty much dupes the code for (?P=...) in reg(), if
10471                    you change this make sure you change that */
10472                 char* name_start = (RExC_parse += 2);
10473                 U32 num = 0;
10474                 SV *sv_dat = reg_scan_name(pRExC_state,
10475                     SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
10476                 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
10477                 if (RExC_parse == name_start || *RExC_parse != ch)
10478                     vFAIL2("Sequence %.3s... not terminated",parse_start);
10479
10480                 if (!SIZE_ONLY) {
10481                     num = add_data( pRExC_state, 1, "S" );
10482                     RExC_rxi->data->data[num]=(void*)sv_dat;
10483                     SvREFCNT_inc_simple_void(sv_dat);
10484                 }
10485
10486                 RExC_sawback = 1;
10487                 ret = reganode(pRExC_state,
10488                                ((! FOLD)
10489                                  ? NREF
10490                                  : (ASCII_FOLD_RESTRICTED)
10491                                    ? NREFFA
10492                                    : (AT_LEAST_UNI_SEMANTICS)
10493                                      ? NREFFU
10494                                      : (LOC)
10495                                        ? NREFFL
10496                                        : NREFF),
10497                                 num);
10498                 *flagp |= HASWIDTH;
10499
10500                 /* override incorrect value set in reganode MJD */
10501                 Set_Node_Offset(ret, parse_start+1);
10502                 Set_Node_Cur_Length(ret); /* MJD */
10503                 nextchar(pRExC_state);
10504
10505             }
10506             break;
10507         }
10508         case 'g': 
10509         case '1': case '2': case '3': case '4':
10510         case '5': case '6': case '7': case '8': case '9':
10511             {
10512                 I32 num;
10513                 bool isg = *RExC_parse == 'g';
10514                 bool isrel = 0; 
10515                 bool hasbrace = 0;
10516                 if (isg) {
10517                     RExC_parse++;
10518                     if (*RExC_parse == '{') {
10519                         RExC_parse++;
10520                         hasbrace = 1;
10521                     }
10522                     if (*RExC_parse == '-') {
10523                         RExC_parse++;
10524                         isrel = 1;
10525                     }
10526                     if (hasbrace && !isDIGIT(*RExC_parse)) {
10527                         if (isrel) RExC_parse--;
10528                         RExC_parse -= 2;                            
10529                         goto parse_named_seq;
10530                 }   }
10531                 num = atoi(RExC_parse);
10532                 if (isg && num == 0)
10533                     vFAIL("Reference to invalid group 0");
10534                 if (isrel) {
10535                     num = RExC_npar - num;
10536                     if (num < 1)
10537                         vFAIL("Reference to nonexistent or unclosed group");
10538                 }
10539                 if (!isg && num > 9 && num >= RExC_npar)
10540                     /* Probably a character specified in octal, e.g. \35 */
10541                     goto defchar;
10542                 else {
10543                     char * const parse_start = RExC_parse - 1; /* MJD */
10544                     while (isDIGIT(*RExC_parse))
10545                         RExC_parse++;
10546                     if (parse_start == RExC_parse - 1) 
10547                         vFAIL("Unterminated \\g... pattern");
10548                     if (hasbrace) {
10549                         if (*RExC_parse != '}') 
10550                             vFAIL("Unterminated \\g{...} pattern");
10551                         RExC_parse++;
10552                     }    
10553                     if (!SIZE_ONLY) {
10554                         if (num > (I32)RExC_rx->nparens)
10555                             vFAIL("Reference to nonexistent group");
10556                     }
10557                     RExC_sawback = 1;
10558                     ret = reganode(pRExC_state,
10559                                    ((! FOLD)
10560                                      ? REF
10561                                      : (ASCII_FOLD_RESTRICTED)
10562                                        ? REFFA
10563                                        : (AT_LEAST_UNI_SEMANTICS)
10564                                          ? REFFU
10565                                          : (LOC)
10566                                            ? REFFL
10567                                            : REFF),
10568                                     num);
10569                     *flagp |= HASWIDTH;
10570
10571                     /* override incorrect value set in reganode MJD */
10572                     Set_Node_Offset(ret, parse_start+1);
10573                     Set_Node_Cur_Length(ret); /* MJD */
10574                     RExC_parse--;
10575                     nextchar(pRExC_state);
10576                 }
10577             }
10578             break;
10579         case '\0':
10580             if (RExC_parse >= RExC_end)
10581                 FAIL("Trailing \\");
10582             /* FALL THROUGH */
10583         default:
10584             /* Do not generate "unrecognized" warnings here, we fall
10585                back into the quick-grab loop below */
10586             parse_start--;
10587             goto defchar;
10588         }
10589         break;
10590
10591     case '#':
10592         if (RExC_flags & RXf_PMf_EXTENDED) {
10593             if ( reg_skipcomment( pRExC_state ) )
10594                 goto tryagain;
10595         }
10596         /* FALL THROUGH */
10597
10598     default:
10599
10600             parse_start = RExC_parse - 1;
10601
10602             RExC_parse++;
10603
10604         defchar: {
10605             STRLEN len = 0;
10606             UV ender;
10607             char *p;
10608             char *s;
10609 #define MAX_NODE_STRING_SIZE 127
10610             char foldbuf[MAX_NODE_STRING_SIZE+UTF8_MAXBYTES_CASE];
10611             char *s0;
10612             U8 upper_parse = MAX_NODE_STRING_SIZE;
10613             STRLEN foldlen;
10614             U8 node_type;
10615             bool next_is_quantifier;
10616             char * oldp = NULL;
10617
10618             /* If a folding node contains only code points that don't
10619              * participate in folds, it can be changed into an EXACT node,
10620              * which allows the optimizer more things to look for */
10621             bool maybe_exact;
10622
10623             ender = 0;
10624             node_type = compute_EXACTish(pRExC_state);
10625             ret = reg_node(pRExC_state, node_type);
10626
10627             /* In pass1, folded, we use a temporary buffer instead of the
10628              * actual node, as the node doesn't exist yet */
10629             s = (SIZE_ONLY && FOLD) ? foldbuf : STRING(ret);
10630
10631             s0 = s;
10632
10633         reparse:
10634
10635             /* We do the EXACTFish to EXACT node only if folding, and not if in
10636              * locale, as whether a character folds or not isn't known until
10637              * runtime */
10638             maybe_exact = FOLD && ! LOC;
10639
10640             /* XXX The node can hold up to 255 bytes, yet this only goes to
10641              * 127.  I (khw) do not know why.  Keeping it somewhat less than
10642              * 255 allows us to not have to worry about overflow due to
10643              * converting to utf8 and fold expansion, but that value is
10644              * 255-UTF8_MAXBYTES_CASE.  join_exact() may join adjacent nodes
10645              * split up by this limit into a single one using the real max of
10646              * 255.  Even at 127, this breaks under rare circumstances.  If
10647              * folding, we do not want to split a node at a character that is a
10648              * non-final in a multi-char fold, as an input string could just
10649              * happen to want to match across the node boundary.  The join
10650              * would solve that problem if the join actually happens.  But a
10651              * series of more than two nodes in a row each of 127 would cause
10652              * the first join to succeed to get to 254, but then there wouldn't
10653              * be room for the next one, which could at be one of those split
10654              * multi-char folds.  I don't know of any fool-proof solution.  One
10655              * could back off to end with only a code point that isn't such a
10656              * non-final, but it is possible for there not to be any in the
10657              * entire node. */
10658             for (p = RExC_parse - 1;
10659                  len < upper_parse && p < RExC_end;
10660                  len++)
10661             {
10662                 oldp = p;
10663
10664                 if (RExC_flags & RXf_PMf_EXTENDED)
10665                     p = regwhite( pRExC_state, p );
10666                 switch ((U8)*p) {
10667                 case '^':
10668                 case '$':
10669                 case '.':
10670                 case '[':
10671                 case '(':
10672                 case ')':
10673                 case '|':
10674                     goto loopdone;
10675                 case '\\':
10676                     /* Literal Escapes Switch
10677
10678                        This switch is meant to handle escape sequences that
10679                        resolve to a literal character.
10680
10681                        Every escape sequence that represents something
10682                        else, like an assertion or a char class, is handled
10683                        in the switch marked 'Special Escapes' above in this
10684                        routine, but also has an entry here as anything that
10685                        isn't explicitly mentioned here will be treated as
10686                        an unescaped equivalent literal.
10687                     */
10688
10689                     switch ((U8)*++p) {
10690                     /* These are all the special escapes. */
10691                     case 'A':             /* Start assertion */
10692                     case 'b': case 'B':   /* Word-boundary assertion*/
10693                     case 'C':             /* Single char !DANGEROUS! */
10694                     case 'd': case 'D':   /* digit class */
10695                     case 'g': case 'G':   /* generic-backref, pos assertion */
10696                     case 'h': case 'H':   /* HORIZWS */
10697                     case 'k': case 'K':   /* named backref, keep marker */
10698                     case 'p': case 'P':   /* Unicode property */
10699                               case 'R':   /* LNBREAK */
10700                     case 's': case 'S':   /* space class */
10701                     case 'v': case 'V':   /* VERTWS */
10702                     case 'w': case 'W':   /* word class */
10703                     case 'X':             /* eXtended Unicode "combining character sequence" */
10704                     case 'z': case 'Z':   /* End of line/string assertion */
10705                         --p;
10706                         goto loopdone;
10707
10708                     /* Anything after here is an escape that resolves to a
10709                        literal. (Except digits, which may or may not)
10710                      */
10711                     case 'n':
10712                         ender = '\n';
10713                         p++;
10714                         break;
10715                     case 'N': /* Handle a single-code point named character. */
10716                         /* The options cause it to fail if a multiple code
10717                          * point sequence.  Handle those in the switch() above
10718                          * */
10719                         RExC_parse = p + 1;
10720                         if (! grok_bslash_N(pRExC_state, NULL, &ender,
10721                                             flagp, depth, FALSE,
10722                                             FALSE /* not strict */ ))
10723                         {
10724                             if (*flagp & RESTART_UTF8)
10725                                 FAIL("panic: grok_bslash_N set RESTART_UTF8");
10726                             RExC_parse = p = oldp;
10727                             goto loopdone;
10728                         }
10729                         p = RExC_parse;
10730                         if (ender > 0xff) {
10731                             REQUIRE_UTF8;
10732                         }
10733                         break;
10734                     case 'r':
10735                         ender = '\r';
10736                         p++;
10737                         break;
10738                     case 't':
10739                         ender = '\t';
10740                         p++;
10741                         break;
10742                     case 'f':
10743                         ender = '\f';
10744                         p++;
10745                         break;
10746                     case 'e':
10747                           ender = ASCII_TO_NATIVE('\033');
10748                         p++;
10749                         break;
10750                     case 'a':
10751                           ender = ASCII_TO_NATIVE('\007');
10752                         p++;
10753                         break;
10754                     case 'o':
10755                         {
10756                             UV result;
10757                             const char* error_msg;
10758
10759                             bool valid = grok_bslash_o(&p,
10760                                                        &result,
10761                                                        &error_msg,
10762                                                        TRUE, /* out warnings */
10763                                                        FALSE, /* not strict */
10764                                                        TRUE, /* Output warnings
10765                                                                 for non-
10766                                                                 portables */
10767                                                        UTF);
10768                             if (! valid) {
10769                                 RExC_parse = p; /* going to die anyway; point
10770                                                    to exact spot of failure */
10771                                 vFAIL(error_msg);
10772                             }
10773                             ender = result;
10774                             if (PL_encoding && ender < 0x100) {
10775                                 goto recode_encoding;
10776                             }
10777                             if (ender > 0xff) {
10778                                 REQUIRE_UTF8;
10779                             }
10780                             break;
10781                         }
10782                     case 'x':
10783                         {
10784                             UV result = UV_MAX; /* initialize to erroneous
10785                                                    value */
10786                             const char* error_msg;
10787
10788                             bool valid = grok_bslash_x(&p,
10789                                                        &result,
10790                                                        &error_msg,
10791                                                        TRUE, /* out warnings */
10792                                                        FALSE, /* not strict */
10793                                                        TRUE, /* Output warnings
10794                                                                 for non-
10795                                                                 portables */
10796                                                        UTF);
10797                             if (! valid) {
10798                                 RExC_parse = p; /* going to die anyway; point
10799                                                    to exact spot of failure */
10800                                 vFAIL(error_msg);
10801                             }
10802                             ender = result;
10803
10804                             if (PL_encoding && ender < 0x100) {
10805                                 goto recode_encoding;
10806                             }
10807                             if (ender > 0xff) {
10808                                 REQUIRE_UTF8;
10809                             }
10810                             break;
10811                         }
10812                     case 'c':
10813                         p++;
10814                         ender = grok_bslash_c(*p++, UTF, SIZE_ONLY);
10815                         break;
10816                     case '0': case '1': case '2': case '3':case '4':
10817                     case '5': case '6': case '7':
10818                         if (*p == '0' ||
10819                             (isDIGIT(p[1]) && atoi(p) >= RExC_npar))
10820                         {
10821                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
10822                             STRLEN numlen = 3;
10823                             ender = grok_oct(p, &numlen, &flags, NULL);
10824                             if (ender > 0xff) {
10825                                 REQUIRE_UTF8;
10826                             }
10827                             p += numlen;
10828                             if (SIZE_ONLY   /* like \08, \178 */
10829                                 && numlen < 3
10830                                 && p < RExC_end
10831                                 && isDIGIT(*p) && ckWARN(WARN_REGEXP))
10832                             {
10833                                 reg_warn_non_literal_string(
10834                                          p + 1,
10835                                          form_short_octal_warning(p, numlen));
10836                             }
10837                         }
10838                         else {  /* Not to be treated as an octal constant, go
10839                                    find backref */
10840                             --p;
10841                             goto loopdone;
10842                         }
10843                         if (PL_encoding && ender < 0x100)
10844                             goto recode_encoding;
10845                         break;
10846                     recode_encoding:
10847                         if (! RExC_override_recoding) {
10848                             SV* enc = PL_encoding;
10849                             ender = reg_recode((const char)(U8)ender, &enc);
10850                             if (!enc && SIZE_ONLY)
10851                                 ckWARNreg(p, "Invalid escape in the specified encoding");
10852                             REQUIRE_UTF8;
10853                         }
10854                         break;
10855                     case '\0':
10856                         if (p >= RExC_end)
10857                             FAIL("Trailing \\");
10858                         /* FALL THROUGH */
10859                     default:
10860                         if (!SIZE_ONLY&& isALPHANUMERIC(*p)) {
10861                             /* Include any { following the alpha to emphasize
10862                              * that it could be part of an escape at some point
10863                              * in the future */
10864                             int len = (isALPHA(*p) && *(p + 1) == '{') ? 2 : 1;
10865                             ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
10866                         }
10867                         goto normal_default;
10868                     } /* End of switch on '\' */
10869                     break;
10870                 default:    /* A literal character */
10871
10872                     if (! SIZE_ONLY
10873                         && RExC_flags & RXf_PMf_EXTENDED
10874                         && ckWARN(WARN_DEPRECATED)
10875                         && is_PATWS_non_low(p, UTF))
10876                     {
10877                         vWARN_dep(p + ((UTF) ? UTF8SKIP(p) : 1),
10878                                 "Escape literal pattern white space under /x");
10879                     }
10880
10881                   normal_default:
10882                     if (UTF8_IS_START(*p) && UTF) {
10883                         STRLEN numlen;
10884                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
10885                                                &numlen, UTF8_ALLOW_DEFAULT);
10886                         p += numlen;
10887                     }
10888                     else
10889                         ender = (U8) *p++;
10890                     break;
10891                 } /* End of switch on the literal */
10892
10893                 /* Here, have looked at the literal character and <ender>
10894                  * contains its ordinal, <p> points to the character after it
10895                  */
10896
10897                 if ( RExC_flags & RXf_PMf_EXTENDED)
10898                     p = regwhite( pRExC_state, p );
10899
10900                 /* If the next thing is a quantifier, it applies to this
10901                  * character only, which means that this character has to be in
10902                  * its own node and can't just be appended to the string in an
10903                  * existing node, so if there are already other characters in
10904                  * the node, close the node with just them, and set up to do
10905                  * this character again next time through, when it will be the
10906                  * only thing in its new node */
10907                 if ((next_is_quantifier = (p < RExC_end && ISMULT2(p))) && len)
10908                 {
10909                     p = oldp;
10910                     goto loopdone;
10911                 }
10912
10913                 if (FOLD) {
10914                     if (UTF
10915                             /* See comments for join_exact() as to why we fold
10916                              * this non-UTF at compile time */
10917                         || (node_type == EXACTFU
10918                             && ender == LATIN_SMALL_LETTER_SHARP_S))
10919                     {
10920
10921
10922                         /* Prime the casefolded buffer.  Locale rules, which
10923                          * apply only to code points < 256, aren't known until
10924                          * execution, so for them, just output the original
10925                          * character using utf8.  If we start to fold non-UTF
10926                          * patterns, be sure to update join_exact() */
10927                         if (LOC && ender < 256) {
10928                             if (UNI_IS_INVARIANT(ender)) {
10929                                 *s = (U8) ender;
10930                                 foldlen = 1;
10931                             } else {
10932                                 *s = UTF8_TWO_BYTE_HI(ender);
10933                                 *(s + 1) = UTF8_TWO_BYTE_LO(ender);
10934                                 foldlen = 2;
10935                             }
10936                         }
10937                         else {
10938                             UV folded = _to_uni_fold_flags(
10939                                            ender,
10940                                            (U8 *) s,
10941                                            &foldlen,
10942                                            FOLD_FLAGS_FULL
10943                                            | ((LOC) ?  FOLD_FLAGS_LOCALE
10944                                                     : (ASCII_FOLD_RESTRICTED)
10945                                                       ? FOLD_FLAGS_NOMIX_ASCII
10946                                                       : 0)
10947                                             );
10948
10949                             /* If this node only contains non-folding code
10950                              * points so far, see if this new one is also
10951                              * non-folding */
10952                             if (maybe_exact) {
10953                                 if (folded != ender) {
10954                                     maybe_exact = FALSE;
10955                                 }
10956                                 else {
10957                                     /* Here the fold is the original; we have
10958                                      * to check further to see if anything
10959                                      * folds to it */
10960                                     if (! PL_utf8_foldable) {
10961                                         SV* swash = swash_init("utf8",
10962                                                            "_Perl_Any_Folds",
10963                                                            &PL_sv_undef, 1, 0);
10964                                         PL_utf8_foldable =
10965                                                     _get_swash_invlist(swash);
10966                                         SvREFCNT_dec_NN(swash);
10967                                     }
10968                                     if (_invlist_contains_cp(PL_utf8_foldable,
10969                                                              ender))
10970                                     {
10971                                         maybe_exact = FALSE;
10972                                     }
10973                                 }
10974                             }
10975                             ender = folded;
10976                         }
10977                         s += foldlen;
10978
10979                         /* The loop increments <len> each time, as all but this
10980                          * path (and the one just below for UTF) through it add
10981                          * a single byte to the EXACTish node.  But this one
10982                          * has changed len to be the correct final value, so
10983                          * subtract one to cancel out the increment that
10984                          * follows */
10985                         len += foldlen - 1;
10986                     }
10987                     else {
10988                         *(s++) = (char) ender;
10989                         maybe_exact &= ! IS_IN_SOME_FOLD_L1(ender);
10990                     }
10991                 }
10992                 else if (UTF) {
10993                     const STRLEN unilen = reguni(pRExC_state, ender, s);
10994                     if (unilen > 0) {
10995                        s   += unilen;
10996                        len += unilen;
10997                     }
10998
10999                     /* See comment just above for - 1 */
11000                     len--;
11001                 }
11002                 else {
11003                     REGC((char)ender, s++);
11004                 }
11005
11006                 if (next_is_quantifier) {
11007
11008                     /* Here, the next input is a quantifier, and to get here,
11009                      * the current character is the only one in the node.
11010                      * Also, here <len> doesn't include the final byte for this
11011                      * character */
11012                     len++;
11013                     goto loopdone;
11014                 }
11015
11016             } /* End of loop through literal characters */
11017
11018             /* Here we have either exhausted the input or ran out of room in
11019              * the node.  (If we encountered a character that can't be in the
11020              * node, transfer is made directly to <loopdone>, and so we
11021              * wouldn't have fallen off the end of the loop.)  In the latter
11022              * case, we artificially have to split the node into two, because
11023              * we just don't have enough space to hold everything.  This
11024              * creates a problem if the final character participates in a
11025              * multi-character fold in the non-final position, as a match that
11026              * should have occurred won't, due to the way nodes are matched,
11027              * and our artificial boundary.  So back off until we find a non-
11028              * problematic character -- one that isn't at the beginning or
11029              * middle of such a fold.  (Either it doesn't participate in any
11030              * folds, or appears only in the final position of all the folds it
11031              * does participate in.)  A better solution with far fewer false
11032              * positives, and that would fill the nodes more completely, would
11033              * be to actually have available all the multi-character folds to
11034              * test against, and to back-off only far enough to be sure that
11035              * this node isn't ending with a partial one.  <upper_parse> is set
11036              * further below (if we need to reparse the node) to include just
11037              * up through that final non-problematic character that this code
11038              * identifies, so when it is set to less than the full node, we can
11039              * skip the rest of this */
11040             if (FOLD && p < RExC_end && upper_parse == MAX_NODE_STRING_SIZE) {
11041
11042                 const STRLEN full_len = len;
11043
11044                 assert(len >= MAX_NODE_STRING_SIZE);
11045
11046                 /* Here, <s> points to the final byte of the final character.
11047                  * Look backwards through the string until find a non-
11048                  * problematic character */
11049
11050                 if (! UTF) {
11051
11052                     /* These two have no multi-char folds to non-UTF characters
11053                      */
11054                     if (ASCII_FOLD_RESTRICTED || LOC) {
11055                         goto loopdone;
11056                     }
11057
11058                     while (--s >= s0 && IS_NON_FINAL_FOLD(*s)) { }
11059                     len = s - s0 + 1;
11060                 }
11061                 else {
11062                     if (!  PL_NonL1NonFinalFold) {
11063                         PL_NonL1NonFinalFold = _new_invlist_C_array(
11064                                         NonL1_Perl_Non_Final_Folds_invlist);
11065                     }
11066
11067                     /* Point to the first byte of the final character */
11068                     s = (char *) utf8_hop((U8 *) s, -1);
11069
11070                     while (s >= s0) {   /* Search backwards until find
11071                                            non-problematic char */
11072                         if (UTF8_IS_INVARIANT(*s)) {
11073
11074                             /* There are no ascii characters that participate
11075                              * in multi-char folds under /aa.  In EBCDIC, the
11076                              * non-ascii invariants are all control characters,
11077                              * so don't ever participate in any folds. */
11078                             if (ASCII_FOLD_RESTRICTED
11079                                 || ! IS_NON_FINAL_FOLD(*s))
11080                             {
11081                                 break;
11082                             }
11083                         }
11084                         else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
11085
11086                             /* No Latin1 characters participate in multi-char
11087                              * folds under /l */
11088                             if (LOC
11089                                 || ! IS_NON_FINAL_FOLD(TWO_BYTE_UTF8_TO_UNI(
11090                                                                 *s, *(s+1))))
11091                             {
11092                                 break;
11093                             }
11094                         }
11095                         else if (! _invlist_contains_cp(
11096                                         PL_NonL1NonFinalFold,
11097                                         valid_utf8_to_uvchr((U8 *) s, NULL)))
11098                         {
11099                             break;
11100                         }
11101
11102                         /* Here, the current character is problematic in that
11103                          * it does occur in the non-final position of some
11104                          * fold, so try the character before it, but have to
11105                          * special case the very first byte in the string, so
11106                          * we don't read outside the string */
11107                         s = (s == s0) ? s -1 : (char *) utf8_hop((U8 *) s, -1);
11108                     } /* End of loop backwards through the string */
11109
11110                     /* If there were only problematic characters in the string,
11111                      * <s> will point to before s0, in which case the length
11112                      * should be 0, otherwise include the length of the
11113                      * non-problematic character just found */
11114                     len = (s < s0) ? 0 : s - s0 + UTF8SKIP(s);
11115                 }
11116
11117                 /* Here, have found the final character, if any, that is
11118                  * non-problematic as far as ending the node without splitting
11119                  * it across a potential multi-char fold.  <len> contains the
11120                  * number of bytes in the node up-to and including that
11121                  * character, or is 0 if there is no such character, meaning
11122                  * the whole node contains only problematic characters.  In
11123                  * this case, give up and just take the node as-is.  We can't
11124                  * do any better */
11125                 if (len == 0) {
11126                     len = full_len;
11127                 } else {
11128
11129                     /* Here, the node does contain some characters that aren't
11130                      * problematic.  If one such is the final character in the
11131                      * node, we are done */
11132                     if (len == full_len) {
11133                         goto loopdone;
11134                     }
11135                     else if (len + ((UTF) ? UTF8SKIP(s) : 1) == full_len) {
11136
11137                         /* If the final character is problematic, but the
11138                          * penultimate is not, back-off that last character to
11139                          * later start a new node with it */
11140                         p = oldp;
11141                         goto loopdone;
11142                     }
11143
11144                     /* Here, the final non-problematic character is earlier
11145                      * in the input than the penultimate character.  What we do
11146                      * is reparse from the beginning, going up only as far as
11147                      * this final ok one, thus guaranteeing that the node ends
11148                      * in an acceptable character.  The reason we reparse is
11149                      * that we know how far in the character is, but we don't
11150                      * know how to correlate its position with the input parse.
11151                      * An alternate implementation would be to build that
11152                      * correlation as we go along during the original parse,
11153                      * but that would entail extra work for every node, whereas
11154                      * this code gets executed only when the string is too
11155                      * large for the node, and the final two characters are
11156                      * problematic, an infrequent occurrence.  Yet another
11157                      * possible strategy would be to save the tail of the
11158                      * string, and the next time regatom is called, initialize
11159                      * with that.  The problem with this is that unless you
11160                      * back off one more character, you won't be guaranteed
11161                      * regatom will get called again, unless regbranch,
11162                      * regpiece ... are also changed.  If you do back off that
11163                      * extra character, so that there is input guaranteed to
11164                      * force calling regatom, you can't handle the case where
11165                      * just the first character in the node is acceptable.  I
11166                      * (khw) decided to try this method which doesn't have that
11167                      * pitfall; if performance issues are found, we can do a
11168                      * combination of the current approach plus that one */
11169                     upper_parse = len;
11170                     len = 0;
11171                     s = s0;
11172                     goto reparse;
11173                 }
11174             }   /* End of verifying node ends with an appropriate char */
11175
11176         loopdone:   /* Jumped to when encounters something that shouldn't be in
11177                        the node */
11178
11179             /* If 'maybe_exact' is still set here, means there are no
11180              * code points in the node that participate in folds */
11181             if (FOLD && maybe_exact) {
11182                 OP(ret) = EXACT;
11183             }
11184
11185             /* I (khw) don't know if you can get here with zero length, but the
11186              * old code handled this situation by creating a zero-length EXACT
11187              * node.  Might as well be NOTHING instead */
11188             if (len == 0) {
11189                 OP(ret) = NOTHING;
11190             }
11191             else{
11192                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, len, ender);
11193             }
11194
11195             RExC_parse = p - 1;
11196             Set_Node_Cur_Length(ret); /* MJD */
11197             nextchar(pRExC_state);
11198             {
11199                 /* len is STRLEN which is unsigned, need to copy to signed */
11200                 IV iv = len;
11201                 if (iv < 0)
11202                     vFAIL("Internal disaster");
11203             }
11204
11205         } /* End of label 'defchar:' */
11206         break;
11207     } /* End of giant switch on input character */
11208
11209     return(ret);
11210 }
11211
11212 STATIC char *
11213 S_regwhite( RExC_state_t *pRExC_state, char *p )
11214 {
11215     const char *e = RExC_end;
11216
11217     PERL_ARGS_ASSERT_REGWHITE;
11218
11219     while (p < e) {
11220         if (isSPACE(*p))
11221             ++p;
11222         else if (*p == '#') {
11223             bool ended = 0;
11224             do {
11225                 if (*p++ == '\n') {
11226                     ended = 1;
11227                     break;
11228                 }
11229             } while (p < e);
11230             if (!ended)
11231                 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
11232         }
11233         else
11234             break;
11235     }
11236     return p;
11237 }
11238
11239 STATIC char *
11240 S_regpatws( RExC_state_t *pRExC_state, char *p , const bool recognize_comment )
11241 {
11242     /* Returns the next non-pattern-white space, non-comment character (the
11243      * latter only if 'recognize_comment is true) in the string p, which is
11244      * ended by RExC_end.  If there is no line break ending a comment,
11245      * RExC_seen has added the REG_SEEN_RUN_ON_COMMENT flag; */
11246     const char *e = RExC_end;
11247
11248     PERL_ARGS_ASSERT_REGPATWS;
11249
11250     while (p < e) {
11251         STRLEN len;
11252         if ((len = is_PATWS_safe(p, e, UTF))) {
11253             p += len;
11254         }
11255         else if (recognize_comment && *p == '#') {
11256             bool ended = 0;
11257             do {
11258                 p++;
11259                 if (is_LNBREAK_safe(p, e, UTF)) {
11260                     ended = 1;
11261                     break;
11262                 }
11263             } while (p < e);
11264             if (!ended)
11265                 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
11266         }
11267         else
11268             break;
11269     }
11270     return p;
11271 }
11272
11273 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
11274    Character classes ([:foo:]) can also be negated ([:^foo:]).
11275    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
11276    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
11277    but trigger failures because they are currently unimplemented. */
11278
11279 #define POSIXCC_DONE(c)   ((c) == ':')
11280 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
11281 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
11282
11283 PERL_STATIC_INLINE I32
11284 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value, const bool strict)
11285 {
11286     dVAR;
11287     I32 namedclass = OOB_NAMEDCLASS;
11288
11289     PERL_ARGS_ASSERT_REGPPOSIXCC;
11290
11291     if (value == '[' && RExC_parse + 1 < RExC_end &&
11292         /* I smell either [: or [= or [. -- POSIX has been here, right? */
11293         POSIXCC(UCHARAT(RExC_parse)))
11294     {
11295         const char c = UCHARAT(RExC_parse);
11296         char* const s = RExC_parse++;
11297
11298         while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
11299             RExC_parse++;
11300         if (RExC_parse == RExC_end) {
11301             if (strict) {
11302
11303                 /* Try to give a better location for the error (than the end of
11304                  * the string) by looking for the matching ']' */
11305                 RExC_parse = s;
11306                 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
11307                     RExC_parse++;
11308                 }
11309                 vFAIL2("Unmatched '%c' in POSIX class", c);
11310             }
11311             /* Grandfather lone [:, [=, [. */
11312             RExC_parse = s;
11313         }
11314         else {
11315             const char* const t = RExC_parse++; /* skip over the c */
11316             assert(*t == c);
11317
11318             if (UCHARAT(RExC_parse) == ']') {
11319                 const char *posixcc = s + 1;
11320                 RExC_parse++; /* skip over the ending ] */
11321
11322                 if (*s == ':') {
11323                     const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
11324                     const I32 skip = t - posixcc;
11325
11326                     /* Initially switch on the length of the name.  */
11327                     switch (skip) {
11328                     case 4:
11329                         if (memEQ(posixcc, "word", 4)) /* this is not POSIX,
11330                                                           this is the Perl \w
11331                                                         */
11332                             namedclass = ANYOF_WORDCHAR;
11333                         break;
11334                     case 5:
11335                         /* Names all of length 5.  */
11336                         /* alnum alpha ascii blank cntrl digit graph lower
11337                            print punct space upper  */
11338                         /* Offset 4 gives the best switch position.  */
11339                         switch (posixcc[4]) {
11340                         case 'a':
11341                             if (memEQ(posixcc, "alph", 4)) /* alpha */
11342                                 namedclass = ANYOF_ALPHA;
11343                             break;
11344                         case 'e':
11345                             if (memEQ(posixcc, "spac", 4)) /* space */
11346                                 namedclass = ANYOF_PSXSPC;
11347                             break;
11348                         case 'h':
11349                             if (memEQ(posixcc, "grap", 4)) /* graph */
11350                                 namedclass = ANYOF_GRAPH;
11351                             break;
11352                         case 'i':
11353                             if (memEQ(posixcc, "asci", 4)) /* ascii */
11354                                 namedclass = ANYOF_ASCII;
11355                             break;
11356                         case 'k':
11357                             if (memEQ(posixcc, "blan", 4)) /* blank */
11358                                 namedclass = ANYOF_BLANK;
11359                             break;
11360                         case 'l':
11361                             if (memEQ(posixcc, "cntr", 4)) /* cntrl */
11362                                 namedclass = ANYOF_CNTRL;
11363                             break;
11364                         case 'm':
11365                             if (memEQ(posixcc, "alnu", 4)) /* alnum */
11366                                 namedclass = ANYOF_ALPHANUMERIC;
11367                             break;
11368                         case 'r':
11369                             if (memEQ(posixcc, "lowe", 4)) /* lower */
11370                                 namedclass = (FOLD) ? ANYOF_CASED : ANYOF_LOWER;
11371                             else if (memEQ(posixcc, "uppe", 4)) /* upper */
11372                                 namedclass = (FOLD) ? ANYOF_CASED : ANYOF_UPPER;
11373                             break;
11374                         case 't':
11375                             if (memEQ(posixcc, "digi", 4)) /* digit */
11376                                 namedclass = ANYOF_DIGIT;
11377                             else if (memEQ(posixcc, "prin", 4)) /* print */
11378                                 namedclass = ANYOF_PRINT;
11379                             else if (memEQ(posixcc, "punc", 4)) /* punct */
11380                                 namedclass = ANYOF_PUNCT;
11381                             break;
11382                         }
11383                         break;
11384                     case 6:
11385                         if (memEQ(posixcc, "xdigit", 6))
11386                             namedclass = ANYOF_XDIGIT;
11387                         break;
11388                     }
11389
11390                     if (namedclass == OOB_NAMEDCLASS)
11391                         Simple_vFAIL3("POSIX class [:%.*s:] unknown",
11392                                       t - s - 1, s + 1);
11393
11394                     /* The #defines are structured so each complement is +1 to
11395                      * the normal one */
11396                     if (complement) {
11397                         namedclass++;
11398                     }
11399                     assert (posixcc[skip] == ':');
11400                     assert (posixcc[skip+1] == ']');
11401                 } else if (!SIZE_ONLY) {
11402                     /* [[=foo=]] and [[.foo.]] are still future. */
11403
11404                     /* adjust RExC_parse so the warning shows after
11405                        the class closes */
11406                     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
11407                         RExC_parse++;
11408                     vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
11409                 }
11410             } else {
11411                 /* Maternal grandfather:
11412                  * "[:" ending in ":" but not in ":]" */
11413                 if (strict) {
11414                     vFAIL("Unmatched '[' in POSIX class");
11415                 }
11416
11417                 /* Grandfather lone [:, [=, [. */
11418                 RExC_parse = s;
11419             }
11420         }
11421     }
11422
11423     return namedclass;
11424 }
11425
11426 STATIC bool
11427 S_could_it_be_a_POSIX_class(pTHX_ RExC_state_t *pRExC_state)
11428 {
11429     /* This applies some heuristics at the current parse position (which should
11430      * be at a '[') to see if what follows might be intended to be a [:posix:]
11431      * class.  It returns true if it really is a posix class, of course, but it
11432      * also can return true if it thinks that what was intended was a posix
11433      * class that didn't quite make it.
11434      *
11435      * It will return true for
11436      *      [:alphanumerics:
11437      *      [:alphanumerics]  (as long as the ] isn't followed immediately by a
11438      *                         ')' indicating the end of the (?[
11439      *      [:any garbage including %^&$ punctuation:]
11440      *
11441      * This is designed to be called only from S_handle_regex_sets; it could be
11442      * easily adapted to be called from the spot at the beginning of regclass()
11443      * that checks to see in a normal bracketed class if the surrounding []
11444      * have been omitted ([:word:] instead of [[:word:]]).  But doing so would
11445      * change long-standing behavior, so I (khw) didn't do that */
11446     char* p = RExC_parse + 1;
11447     char first_char = *p;
11448
11449     PERL_ARGS_ASSERT_COULD_IT_BE_A_POSIX_CLASS;
11450
11451     assert(*(p - 1) == '[');
11452
11453     if (! POSIXCC(first_char)) {
11454         return FALSE;
11455     }
11456
11457     p++;
11458     while (p < RExC_end && isWORDCHAR(*p)) p++;
11459
11460     if (p >= RExC_end) {
11461         return FALSE;
11462     }
11463
11464     if (p - RExC_parse > 2    /* Got at least 1 word character */
11465         && (*p == first_char
11466             || (*p == ']' && p + 1 < RExC_end && *(p + 1) != ')')))
11467     {
11468         return TRUE;
11469     }
11470
11471     p = (char *) memchr(RExC_parse, ']', RExC_end - RExC_parse);
11472
11473     return (p
11474             && p - RExC_parse > 2 /* [:] evaluates to colon;
11475                                       [::] is a bad posix class. */
11476             && first_char == *(p - 1));
11477 }
11478
11479 STATIC regnode *
11480 S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist, I32 *flagp, U32 depth,
11481                    char * const oregcomp_parse)
11482 {
11483     /* Handle the (?[...]) construct to do set operations */
11484
11485     U8 curchar;
11486     UV start, end;      /* End points of code point ranges */
11487     SV* result_string;
11488     char *save_end, *save_parse;
11489     SV* final;
11490     STRLEN len;
11491     regnode* node;
11492     AV* stack;
11493     const bool save_fold = FOLD;
11494
11495     GET_RE_DEBUG_FLAGS_DECL;
11496
11497     PERL_ARGS_ASSERT_HANDLE_REGEX_SETS;
11498
11499     if (LOC) {
11500         vFAIL("(?[...]) not valid in locale");
11501     }
11502     RExC_uni_semantics = 1;
11503
11504     /* This will return only an ANYOF regnode, or (unlikely) something smaller
11505      * (such as EXACT).  Thus we can skip most everything if just sizing.  We
11506      * call regclass to handle '[]' so as to not have to reinvent its parsing
11507      * rules here (throwing away the size it computes each time).  And, we exit
11508      * upon an unescaped ']' that isn't one ending a regclass.  To do both
11509      * these things, we need to realize that something preceded by a backslash
11510      * is escaped, so we have to keep track of backslashes */
11511     if (SIZE_ONLY) {
11512
11513         Perl_ck_warner_d(aTHX_
11514             packWARN(WARN_EXPERIMENTAL__REGEX_SETS),
11515             "The regex_sets feature is experimental" REPORT_LOCATION,
11516             (int) (RExC_parse - RExC_precomp) , RExC_precomp, RExC_parse);
11517
11518         while (RExC_parse < RExC_end) {
11519             SV* current = NULL;
11520             RExC_parse = regpatws(pRExC_state, RExC_parse,
11521                                 TRUE); /* means recognize comments */
11522             switch (*RExC_parse) {
11523                 default:
11524                     break;
11525                 case '\\':
11526                     /* Skip the next byte (which could cause us to end up in
11527                      * the middle of a UTF-8 character, but since none of those
11528                      * are confusable with anything we currently handle in this
11529                      * switch (invariants all), it's safe.  We'll just hit the
11530                      * default: case next time and keep on incrementing until
11531                      * we find one of the invariants we do handle. */
11532                     RExC_parse++;
11533                     break;
11534                 case '[':
11535                 {
11536                     /* If this looks like it is a [:posix:] class, leave the
11537                      * parse pointer at the '[' to fool regclass() into
11538                      * thinking it is part of a '[[:posix:]]'.  That function
11539                      * will use strict checking to force a syntax error if it
11540                      * doesn't work out to a legitimate class */
11541                     bool is_posix_class
11542                                     = could_it_be_a_POSIX_class(pRExC_state);
11543                     if (! is_posix_class) {
11544                         RExC_parse++;
11545                     }
11546
11547                     /* regclass() can only return RESTART_UTF8 if multi-char
11548                        folds are allowed.  */
11549                     if (!regclass(pRExC_state, flagp,depth+1,
11550                                   is_posix_class, /* parse the whole char
11551                                                      class only if not a
11552                                                      posix class */
11553                                   FALSE, /* don't allow multi-char folds */
11554                                   TRUE, /* silence non-portable warnings. */
11555                                   &current))
11556                         FAIL2("panic: regclass returned NULL to handle_sets, flags=%#X",
11557                               *flagp);
11558
11559                     /* function call leaves parse pointing to the ']', except
11560                      * if we faked it */
11561                     if (is_posix_class) {
11562                         RExC_parse--;
11563                     }
11564
11565                     SvREFCNT_dec(current);   /* In case it returned something */
11566                     break;
11567                 }
11568
11569                 case ']':
11570                     RExC_parse++;
11571                     if (RExC_parse < RExC_end
11572                         && *RExC_parse == ')')
11573                     {
11574                         node = reganode(pRExC_state, ANYOF, 0);
11575                         RExC_size += ANYOF_SKIP;
11576                         nextchar(pRExC_state);
11577                         Set_Node_Length(node,
11578                                 RExC_parse - oregcomp_parse + 1); /* MJD */
11579                         return node;
11580                     }
11581                     goto no_close;
11582             }
11583             RExC_parse++;
11584         }
11585
11586         no_close:
11587         FAIL("Syntax error in (?[...])");
11588     }
11589
11590     /* Pass 2 only after this.  Everything in this construct is a
11591      * metacharacter.  Operands begin with either a '\' (for an escape
11592      * sequence), or a '[' for a bracketed character class.  Any other
11593      * character should be an operator, or parenthesis for grouping.  Both
11594      * types of operands are handled by calling regclass() to parse them.  It
11595      * is called with a parameter to indicate to return the computed inversion
11596      * list.  The parsing here is implemented via a stack.  Each entry on the
11597      * stack is a single character representing one of the operators, or the
11598      * '('; or else a pointer to an operand inversion list. */
11599
11600 #define IS_OPERAND(a)  (! SvIOK(a))
11601
11602     /* The stack starts empty.  It is a syntax error if the first thing parsed
11603      * is a binary operator; everything else is pushed on the stack.  When an
11604      * operand is parsed, the top of the stack is examined.  If it is a binary
11605      * operator, the item before it should be an operand, and both are replaced
11606      * by the result of doing that operation on the new operand and the one on
11607      * the stack.   Thus a sequence of binary operands is reduced to a single
11608      * one before the next one is parsed.
11609      *
11610      * A unary operator may immediately follow a binary in the input, for
11611      * example
11612      *      [a] + ! [b]
11613      * When an operand is parsed and the top of the stack is a unary operator,
11614      * the operation is performed, and then the stack is rechecked to see if
11615      * this new operand is part of a binary operation; if so, it is handled as
11616      * above.
11617      *
11618      * A '(' is simply pushed on the stack; it is valid only if the stack is
11619      * empty, or the top element of the stack is an operator or another '('
11620      * (for which the parenthesized expression will become an operand).  By the
11621      * time the corresponding ')' is parsed everything in between should have
11622      * been parsed and evaluated to a single operand (or else is a syntax
11623      * error), and is handled as a regular operand */
11624
11625     stack = newAV();
11626
11627     while (RExC_parse < RExC_end) {
11628         I32 top_index = av_tindex(stack);
11629         SV** top_ptr;
11630         SV* current = NULL;
11631
11632         /* Skip white space */
11633         RExC_parse = regpatws(pRExC_state, RExC_parse,
11634                                 TRUE); /* means recognize comments */
11635         if (RExC_parse >= RExC_end) {
11636             Perl_croak(aTHX_ "panic: Read past end of '(?[ ])'");
11637         }
11638         if ((curchar = UCHARAT(RExC_parse)) == ']') {
11639             break;
11640         }
11641
11642         switch (curchar) {
11643
11644             case '?':
11645                 if (av_tindex(stack) >= 0   /* This makes sure that we can
11646                                                safely subtract 1 from
11647                                                RExC_parse in the next clause.
11648                                                If we have something on the
11649                                                stack, we have parsed something
11650                                              */
11651                     && UCHARAT(RExC_parse - 1) == '('
11652                     && RExC_parse < RExC_end)
11653                 {
11654                     /* If is a '(?', could be an embedded '(?flags:(?[...])'.
11655                      * This happens when we have some thing like
11656                      *
11657                      *   my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
11658                      *   ...
11659                      *   qr/(?[ \p{Digit} & $thai_or_lao ])/;
11660                      *
11661                      * Here we would be handling the interpolated
11662                      * '$thai_or_lao'.  We handle this by a recursive call to
11663                      * ourselves which returns the inversion list the
11664                      * interpolated expression evaluates to.  We use the flags
11665                      * from the interpolated pattern. */
11666                     U32 save_flags = RExC_flags;
11667                     const char * const save_parse = ++RExC_parse;
11668
11669                     parse_lparen_question_flags(pRExC_state);
11670
11671                     if (RExC_parse == save_parse  /* Makes sure there was at
11672                                                      least one flag (or this
11673                                                      embedding wasn't compiled)
11674                                                    */
11675                         || RExC_parse >= RExC_end - 4
11676                         || UCHARAT(RExC_parse) != ':'
11677                         || UCHARAT(++RExC_parse) != '('
11678                         || UCHARAT(++RExC_parse) != '?'
11679                         || UCHARAT(++RExC_parse) != '[')
11680                     {
11681
11682                         /* In combination with the above, this moves the
11683                          * pointer to the point just after the first erroneous
11684                          * character (or if there are no flags, to where they
11685                          * should have been) */
11686                         if (RExC_parse >= RExC_end - 4) {
11687                             RExC_parse = RExC_end;
11688                         }
11689                         else if (RExC_parse != save_parse) {
11690                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
11691                         }
11692                         vFAIL("Expecting '(?flags:(?[...'");
11693                     }
11694                     RExC_parse++;
11695                     (void) handle_regex_sets(pRExC_state, &current, flagp,
11696                                                     depth+1, oregcomp_parse);
11697
11698                     /* Here, 'current' contains the embedded expression's
11699                      * inversion list, and RExC_parse points to the trailing
11700                      * ']'; the next character should be the ')' which will be
11701                      * paired with the '(' that has been put on the stack, so
11702                      * the whole embedded expression reduces to '(operand)' */
11703                     RExC_parse++;
11704
11705                     RExC_flags = save_flags;
11706                     goto handle_operand;
11707                 }
11708                 /* FALL THROUGH */
11709
11710             default:
11711                 RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
11712                 vFAIL("Unexpected character");
11713
11714             case '\\':
11715                 /* regclass() can only return RESTART_UTF8 if multi-char
11716                    folds are allowed.  */
11717                 if (!regclass(pRExC_state, flagp,depth+1,
11718                               TRUE, /* means parse just the next thing */
11719                               FALSE, /* don't allow multi-char folds */
11720                               FALSE, /* don't silence non-portable warnings.  */
11721                               &current))
11722                     FAIL2("panic: regclass returned NULL to handle_sets, flags=%#X",
11723                           *flagp);
11724                 /* regclass() will return with parsing just the \ sequence,
11725                  * leaving the parse pointer at the next thing to parse */
11726                 RExC_parse--;
11727                 goto handle_operand;
11728
11729             case '[':   /* Is a bracketed character class */
11730             {
11731                 bool is_posix_class = could_it_be_a_POSIX_class(pRExC_state);
11732
11733                 if (! is_posix_class) {
11734                     RExC_parse++;
11735                 }
11736
11737                 /* regclass() can only return RESTART_UTF8 if multi-char
11738                    folds are allowed.  */
11739                 if(!regclass(pRExC_state, flagp,depth+1,
11740                              is_posix_class, /* parse the whole char class
11741                                                 only if not a posix class */
11742                              FALSE, /* don't allow multi-char folds */
11743                              FALSE, /* don't silence non-portable warnings.  */
11744                              &current))
11745                     FAIL2("panic: regclass returned NULL to handle_sets, flags=%#X",
11746                           *flagp);
11747                 /* function call leaves parse pointing to the ']', except if we
11748                  * faked it */
11749                 if (is_posix_class) {
11750                     RExC_parse--;
11751                 }
11752
11753                 goto handle_operand;
11754             }
11755
11756             case '&':
11757             case '|':
11758             case '+':
11759             case '-':
11760             case '^':
11761                 if (top_index < 0
11762                     || ( ! (top_ptr = av_fetch(stack, top_index, FALSE)))
11763                     || ! IS_OPERAND(*top_ptr))
11764                 {
11765                     RExC_parse++;
11766                     vFAIL2("Unexpected binary operator '%c' with no preceding operand", curchar);
11767                 }
11768                 av_push(stack, newSVuv(curchar));
11769                 break;
11770
11771             case '!':
11772                 av_push(stack, newSVuv(curchar));
11773                 break;
11774
11775             case '(':
11776                 if (top_index >= 0) {
11777                     top_ptr = av_fetch(stack, top_index, FALSE);
11778                     assert(top_ptr);
11779                     if (IS_OPERAND(*top_ptr)) {
11780                         RExC_parse++;
11781                         vFAIL("Unexpected '(' with no preceding operator");
11782                     }
11783                 }
11784                 av_push(stack, newSVuv(curchar));
11785                 break;
11786
11787             case ')':
11788             {
11789                 SV* lparen;
11790                 if (top_index < 1
11791                     || ! (current = av_pop(stack))
11792                     || ! IS_OPERAND(current)
11793                     || ! (lparen = av_pop(stack))
11794                     || IS_OPERAND(lparen)
11795                     || SvUV(lparen) != '(')
11796                 {
11797                     RExC_parse++;
11798                     vFAIL("Unexpected ')'");
11799                 }
11800                 top_index -= 2;
11801                 SvREFCNT_dec_NN(lparen);
11802
11803                 /* FALL THROUGH */
11804             }
11805
11806               handle_operand:
11807
11808                 /* Here, we have an operand to process, in 'current' */
11809
11810                 if (top_index < 0) {    /* Just push if stack is empty */
11811                     av_push(stack, current);
11812                 }
11813                 else {
11814                     SV* top = av_pop(stack);
11815                     char current_operator;
11816
11817                     if (IS_OPERAND(top)) {
11818                         vFAIL("Operand with no preceding operator");
11819                     }
11820                     current_operator = (char) SvUV(top);
11821                     switch (current_operator) {
11822                         case '(':   /* Push the '(' back on followed by the new
11823                                        operand */
11824                             av_push(stack, top);
11825                             av_push(stack, current);
11826                             SvREFCNT_inc(top);  /* Counters the '_dec' done
11827                                                    just after the 'break', so
11828                                                    it doesn't get wrongly freed
11829                                                  */
11830                             break;
11831
11832                         case '!':
11833                             _invlist_invert(current);
11834
11835                             /* Unlike binary operators, the top of the stack,
11836                              * now that this unary one has been popped off, may
11837                              * legally be an operator, and we now have operand
11838                              * for it. */
11839                             top_index--;
11840                             SvREFCNT_dec_NN(top);
11841                             goto handle_operand;
11842
11843                         case '&':
11844                             _invlist_intersection(av_pop(stack),
11845                                                    current,
11846                                                    &current);
11847                             av_push(stack, current);
11848                             break;
11849
11850                         case '|':
11851                         case '+':
11852                             _invlist_union(av_pop(stack), current, &current);
11853                             av_push(stack, current);
11854                             break;
11855
11856                         case '-':
11857                             _invlist_subtract(av_pop(stack), current, &current);
11858                             av_push(stack, current);
11859                             break;
11860
11861                         case '^':   /* The union minus the intersection */
11862                         {
11863                             SV* i = NULL;
11864                             SV* u = NULL;
11865                             SV* element;
11866
11867                             element = av_pop(stack);
11868                             _invlist_union(element, current, &u);
11869                             _invlist_intersection(element, current, &i);
11870                             _invlist_subtract(u, i, &current);
11871                             av_push(stack, current);
11872                             SvREFCNT_dec_NN(i);
11873                             SvREFCNT_dec_NN(u);
11874                             SvREFCNT_dec_NN(element);
11875                             break;
11876                         }
11877
11878                         default:
11879                             Perl_croak(aTHX_ "panic: Unexpected item on '(?[ ])' stack");
11880                 }
11881                 SvREFCNT_dec_NN(top);
11882             }
11883         }
11884
11885         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
11886     }
11887
11888     if (av_tindex(stack) < 0   /* Was empty */
11889         || ((final = av_pop(stack)) == NULL)
11890         || ! IS_OPERAND(final)
11891         || av_tindex(stack) >= 0)  /* More left on stack */
11892     {
11893         vFAIL("Incomplete expression within '(?[ ])'");
11894     }
11895
11896     /* Here, 'final' is the resultant inversion list from evaluating the
11897      * expression.  Return it if so requested */
11898     if (return_invlist) {
11899         *return_invlist = final;
11900         return END;
11901     }
11902
11903     /* Otherwise generate a resultant node, based on 'final'.  regclass() is
11904      * expecting a string of ranges and individual code points */
11905     invlist_iterinit(final);
11906     result_string = newSVpvs("");
11907     while (invlist_iternext(final, &start, &end)) {
11908         if (start == end) {
11909             Perl_sv_catpvf(aTHX_ result_string, "\\x{%"UVXf"}", start);
11910         }
11911         else {
11912             Perl_sv_catpvf(aTHX_ result_string, "\\x{%"UVXf"}-\\x{%"UVXf"}",
11913                                                      start,          end);
11914         }
11915     }
11916
11917     save_parse = RExC_parse;
11918     RExC_parse = SvPV(result_string, len);
11919     save_end = RExC_end;
11920     RExC_end = RExC_parse + len;
11921
11922     /* We turn off folding around the call, as the class we have constructed
11923      * already has all folding taken into consideration, and we don't want
11924      * regclass() to add to that */
11925     RExC_flags &= ~RXf_PMf_FOLD;
11926     /* regclass() can only return RESTART_UTF8 if multi-char folds are allowed.
11927      */
11928     node = regclass(pRExC_state, flagp,depth+1,
11929                     FALSE, /* means parse the whole char class */
11930                     FALSE, /* don't allow multi-char folds */
11931                     TRUE, /* silence non-portable warnings.  The above may very
11932                              well have generated non-portable code points, but
11933                              they're valid on this machine */
11934                     NULL);
11935     if (!node)
11936         FAIL2("panic: regclass returned NULL to handle_sets, flags=%#"UVxf,
11937                     PTR2UV(flagp));
11938     if (save_fold) {
11939         RExC_flags |= RXf_PMf_FOLD;
11940     }
11941     RExC_parse = save_parse + 1;
11942     RExC_end = save_end;
11943     SvREFCNT_dec_NN(final);
11944     SvREFCNT_dec_NN(result_string);
11945     SvREFCNT_dec_NN(stack);
11946
11947     nextchar(pRExC_state);
11948     Set_Node_Length(node, RExC_parse - oregcomp_parse + 1); /* MJD */
11949     return node;
11950 }
11951 #undef IS_OPERAND
11952
11953 /* The names of properties whose definitions are not known at compile time are
11954  * stored in this SV, after a constant heading.  So if the length has been
11955  * changed since initialization, then there is a run-time definition. */
11956 #define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION (SvCUR(listsv) != initial_listsv_len)
11957
11958 STATIC regnode *
11959 S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
11960                  const bool stop_at_1,  /* Just parse the next thing, don't
11961                                            look for a full character class */
11962                  bool allow_multi_folds,
11963                  const bool silence_non_portable,   /* Don't output warnings
11964                                                        about too large
11965                                                        characters */
11966                  SV** ret_invlist)  /* Return an inversion list, not a node */
11967 {
11968     /* parse a bracketed class specification.  Most of these will produce an
11969      * ANYOF node; but something like [a] will produce an EXACT node; [aA], an
11970      * EXACTFish node; [[:ascii:]], a POSIXA node; etc.  It is more complex
11971      * under /i with multi-character folds: it will be rewritten following the
11972      * paradigm of this example, where the <multi-fold>s are characters which
11973      * fold to multiple character sequences:
11974      *      /[abc\x{multi-fold1}def\x{multi-fold2}ghi]/i
11975      * gets effectively rewritten as:
11976      *      /(?:\x{multi-fold1}|\x{multi-fold2}|[abcdefghi]/i
11977      * reg() gets called (recursively) on the rewritten version, and this
11978      * function will return what it constructs.  (Actually the <multi-fold>s
11979      * aren't physically removed from the [abcdefghi], it's just that they are
11980      * ignored in the recursion by means of a flag:
11981      * <RExC_in_multi_char_class>.)
11982      *
11983      * ANYOF nodes contain a bit map for the first 256 characters, with the
11984      * corresponding bit set if that character is in the list.  For characters
11985      * above 255, a range list or swash is used.  There are extra bits for \w,
11986      * etc. in locale ANYOFs, as what these match is not determinable at
11987      * compile time
11988      *
11989      * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs
11990      * to be restarted.  This can only happen if ret_invlist is non-NULL.
11991      */
11992
11993     dVAR;
11994     UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE;
11995     IV range = 0;
11996     UV value = OOB_UNICODE, save_value = OOB_UNICODE;
11997     regnode *ret;
11998     STRLEN numlen;
11999     IV namedclass = OOB_NAMEDCLASS;
12000     char *rangebegin = NULL;
12001     bool need_class = 0;
12002     SV *listsv = NULL;
12003     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
12004                                       than just initialized.  */
12005     SV* properties = NULL;    /* Code points that match \p{} \P{} */
12006     SV* posixes = NULL;     /* Code points that match classes like, [:word:],
12007                                extended beyond the Latin1 range */
12008     UV element_count = 0;   /* Number of distinct elements in the class.
12009                                Optimizations may be possible if this is tiny */
12010     AV * multi_char_matches = NULL; /* Code points that fold to more than one
12011                                        character; used under /i */
12012     UV n;
12013     char * stop_ptr = RExC_end;    /* where to stop parsing */
12014     const bool skip_white = cBOOL(ret_invlist); /* ignore unescaped white
12015                                                    space? */
12016     const bool strict = cBOOL(ret_invlist); /* Apply strict parsing rules? */
12017
12018     /* Unicode properties are stored in a swash; this holds the current one
12019      * being parsed.  If this swash is the only above-latin1 component of the
12020      * character class, an optimization is to pass it directly on to the
12021      * execution engine.  Otherwise, it is set to NULL to indicate that there
12022      * are other things in the class that have to be dealt with at execution
12023      * time */
12024     SV* swash = NULL;           /* Code points that match \p{} \P{} */
12025
12026     /* Set if a component of this character class is user-defined; just passed
12027      * on to the engine */
12028     bool has_user_defined_property = FALSE;
12029
12030     /* inversion list of code points this node matches only when the target
12031      * string is in UTF-8.  (Because is under /d) */
12032     SV* depends_list = NULL;
12033
12034     /* inversion list of code points this node matches.  For much of the
12035      * function, it includes only those that match regardless of the utf8ness
12036      * of the target string */
12037     SV* cp_list = NULL;
12038
12039 #ifdef EBCDIC
12040     /* In a range, counts how many 0-2 of the ends of it came from literals,
12041      * not escapes.  Thus we can tell if 'A' was input vs \x{C1} */
12042     UV literal_endpoint = 0;
12043 #endif
12044     bool invert = FALSE;    /* Is this class to be complemented */
12045
12046     /* Is there any thing like \W or [:^digit:] that matches above the legal
12047      * Unicode range? */
12048     bool runtime_posix_matches_above_Unicode = FALSE;
12049
12050     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
12051         case we need to change the emitted regop to an EXACT. */
12052     const char * orig_parse = RExC_parse;
12053     const I32 orig_size = RExC_size;
12054     GET_RE_DEBUG_FLAGS_DECL;
12055
12056     PERL_ARGS_ASSERT_REGCLASS;
12057 #ifndef DEBUGGING
12058     PERL_UNUSED_ARG(depth);
12059 #endif
12060
12061     DEBUG_PARSE("clas");
12062
12063     /* Assume we are going to generate an ANYOF node. */
12064     ret = reganode(pRExC_state, ANYOF, 0);
12065
12066     if (SIZE_ONLY) {
12067         RExC_size += ANYOF_SKIP;
12068         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
12069     }
12070     else {
12071         ANYOF_FLAGS(ret) = 0;
12072
12073         RExC_emit += ANYOF_SKIP;
12074         if (LOC) {
12075             ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
12076         }
12077         listsv = newSVpvs_flags("# comment\n", SVs_TEMP);
12078         initial_listsv_len = SvCUR(listsv);
12079         SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated.  */
12080     }
12081
12082     if (skip_white) {
12083         RExC_parse = regpatws(pRExC_state, RExC_parse,
12084                               FALSE /* means don't recognize comments */);
12085     }
12086
12087     if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
12088         RExC_parse++;
12089         invert = TRUE;
12090         allow_multi_folds = FALSE;
12091         RExC_naughty++;
12092         if (skip_white) {
12093             RExC_parse = regpatws(pRExC_state, RExC_parse,
12094                                   FALSE /* means don't recognize comments */);
12095         }
12096     }
12097
12098     /* Check that they didn't say [:posix:] instead of [[:posix:]] */
12099     if (!SIZE_ONLY && RExC_parse < RExC_end && POSIXCC(UCHARAT(RExC_parse))) {
12100         const char *s = RExC_parse;
12101         const char  c = *s++;
12102
12103         while (isWORDCHAR(*s))
12104             s++;
12105         if (*s && c == *s && s[1] == ']') {
12106             SAVEFREESV(RExC_rx_sv);
12107             ckWARN3reg(s+2,
12108                        "POSIX syntax [%c %c] belongs inside character classes",
12109                        c, c);
12110             (void)ReREFCNT_inc(RExC_rx_sv);
12111         }
12112     }
12113
12114     /* If the caller wants us to just parse a single element, accomplish this
12115      * by faking the loop ending condition */
12116     if (stop_at_1 && RExC_end > RExC_parse) {
12117         stop_ptr = RExC_parse + 1;
12118     }
12119
12120     /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */
12121     if (UCHARAT(RExC_parse) == ']')
12122         goto charclassloop;
12123
12124 parseit:
12125     while (1) {
12126         if  (RExC_parse >= stop_ptr) {
12127             break;
12128         }
12129
12130         if (skip_white) {
12131             RExC_parse = regpatws(pRExC_state, RExC_parse,
12132                                   FALSE /* means don't recognize comments */);
12133         }
12134
12135         if  (UCHARAT(RExC_parse) == ']') {
12136             break;
12137         }
12138
12139     charclassloop:
12140
12141         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
12142         save_value = value;
12143         save_prevvalue = prevvalue;
12144
12145         if (!range) {
12146             rangebegin = RExC_parse;
12147             element_count++;
12148         }
12149         if (UTF) {
12150             value = utf8n_to_uvchr((U8*)RExC_parse,
12151                                    RExC_end - RExC_parse,
12152                                    &numlen, UTF8_ALLOW_DEFAULT);
12153             RExC_parse += numlen;
12154         }
12155         else
12156             value = UCHARAT(RExC_parse++);
12157
12158         if (value == '['
12159             && RExC_parse < RExC_end
12160             && POSIXCC(UCHARAT(RExC_parse)))
12161         {
12162             namedclass = regpposixcc(pRExC_state, value, strict);
12163         }
12164         else if (value == '\\') {
12165             if (UTF) {
12166                 value = utf8n_to_uvchr((U8*)RExC_parse,
12167                                    RExC_end - RExC_parse,
12168                                    &numlen, UTF8_ALLOW_DEFAULT);
12169                 RExC_parse += numlen;
12170             }
12171             else
12172                 value = UCHARAT(RExC_parse++);
12173
12174             /* Some compilers cannot handle switching on 64-bit integer
12175              * values, therefore value cannot be an UV.  Yes, this will
12176              * be a problem later if we want switch on Unicode.
12177              * A similar issue a little bit later when switching on
12178              * namedclass. --jhi */
12179
12180             /* If the \ is escaping white space when white space is being
12181              * skipped, it means that that white space is wanted literally, and
12182              * is already in 'value'.  Otherwise, need to translate the escape
12183              * into what it signifies. */
12184             if (! skip_white || ! is_PATWS_cp(value)) switch ((I32)value) {
12185
12186             case 'w':   namedclass = ANYOF_WORDCHAR;    break;
12187             case 'W':   namedclass = ANYOF_NWORDCHAR;   break;
12188             case 's':   namedclass = ANYOF_SPACE;       break;
12189             case 'S':   namedclass = ANYOF_NSPACE;      break;
12190             case 'd':   namedclass = ANYOF_DIGIT;       break;
12191             case 'D':   namedclass = ANYOF_NDIGIT;      break;
12192             case 'v':   namedclass = ANYOF_VERTWS;      break;
12193             case 'V':   namedclass = ANYOF_NVERTWS;     break;
12194             case 'h':   namedclass = ANYOF_HORIZWS;     break;
12195             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
12196             case 'N':  /* Handle \N{NAME} in class */
12197                 {
12198                     /* We only pay attention to the first char of 
12199                     multichar strings being returned. I kinda wonder
12200                     if this makes sense as it does change the behaviour
12201                     from earlier versions, OTOH that behaviour was broken
12202                     as well. */
12203                     if (! grok_bslash_N(pRExC_state, NULL, &value, flagp, depth,
12204                                       TRUE, /* => charclass */
12205                                       strict))
12206                     {
12207                         if (*flagp & RESTART_UTF8)
12208                             FAIL("panic: grok_bslash_N set RESTART_UTF8");
12209                         goto parseit;
12210                     }
12211                 }
12212                 break;
12213             case 'p':
12214             case 'P':
12215                 {
12216                 char *e;
12217
12218                 /* We will handle any undefined properties ourselves */
12219                 U8 swash_init_flags = _CORE_SWASH_INIT_RETURN_IF_UNDEF;
12220
12221                 if (RExC_parse >= RExC_end)
12222                     vFAIL2("Empty \\%c{}", (U8)value);
12223                 if (*RExC_parse == '{') {
12224                     const U8 c = (U8)value;
12225                     e = strchr(RExC_parse++, '}');
12226                     if (!e)
12227                         vFAIL2("Missing right brace on \\%c{}", c);
12228                     while (isSPACE(UCHARAT(RExC_parse)))
12229                         RExC_parse++;
12230                     if (e == RExC_parse)
12231                         vFAIL2("Empty \\%c{}", c);
12232                     n = e - RExC_parse;
12233                     while (isSPACE(UCHARAT(RExC_parse + n - 1)))
12234                         n--;
12235                 }
12236                 else {
12237                     e = RExC_parse;
12238                     n = 1;
12239                 }
12240                 if (!SIZE_ONLY) {
12241                     SV* invlist;
12242                     char* name;
12243
12244                     if (UCHARAT(RExC_parse) == '^') {
12245                          RExC_parse++;
12246                          n--;
12247                          /* toggle.  (The rhs xor gets the single bit that
12248                           * differs between P and p; the other xor inverts just
12249                           * that bit) */
12250                          value ^= 'P' ^ 'p';
12251
12252                          while (isSPACE(UCHARAT(RExC_parse))) {
12253                               RExC_parse++;
12254                               n--;
12255                          }
12256                     }
12257                     /* Try to get the definition of the property into
12258                      * <invlist>.  If /i is in effect, the effective property
12259                      * will have its name be <__NAME_i>.  The design is
12260                      * discussed in commit
12261                      * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
12262                     Newx(name, n + sizeof("_i__\n"), char);
12263
12264                     sprintf(name, "%s%.*s%s\n",
12265                                     (FOLD) ? "__" : "",
12266                                     (int)n,
12267                                     RExC_parse,
12268                                     (FOLD) ? "_i" : ""
12269                     );
12270
12271                     /* Look up the property name, and get its swash and
12272                      * inversion list, if the property is found  */
12273                     if (swash) {
12274                         SvREFCNT_dec_NN(swash);
12275                     }
12276                     swash = _core_swash_init("utf8", name, &PL_sv_undef,
12277                                              1, /* binary */
12278                                              0, /* not tr/// */
12279                                              NULL, /* No inversion list */
12280                                              &swash_init_flags
12281                                             );
12282                     if (! swash || ! (invlist = _get_swash_invlist(swash))) {
12283                         if (swash) {
12284                             SvREFCNT_dec_NN(swash);
12285                             swash = NULL;
12286                         }
12287
12288                         /* Here didn't find it.  It could be a user-defined
12289                          * property that will be available at run-time.  If we
12290                          * accept only compile-time properties, is an error;
12291                          * otherwise add it to the list for run-time look up */
12292                         if (ret_invlist) {
12293                             RExC_parse = e + 1;
12294                             vFAIL3("Property '%.*s' is unknown", (int) n, name);
12295                         }
12296                         Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s\n",
12297                                         (value == 'p' ? '+' : '!'),
12298                                         name);
12299                         has_user_defined_property = TRUE;
12300
12301                         /* We don't know yet, so have to assume that the
12302                          * property could match something in the Latin1 range,
12303                          * hence something that isn't utf8.  Note that this
12304                          * would cause things in <depends_list> to match
12305                          * inappropriately, except that any \p{}, including
12306                          * this one forces Unicode semantics, which means there
12307                          * is <no depends_list> */
12308                         ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
12309                     }
12310                     else {
12311
12312                         /* Here, did get the swash and its inversion list.  If
12313                          * the swash is from a user-defined property, then this
12314                          * whole character class should be regarded as such */
12315                         has_user_defined_property =
12316                                     (swash_init_flags
12317                                      & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY);
12318
12319                         /* Invert if asking for the complement */
12320                         if (value == 'P') {
12321                             _invlist_union_complement_2nd(properties,
12322                                                           invlist,
12323                                                           &properties);
12324
12325                             /* The swash can't be used as-is, because we've
12326                              * inverted things; delay removing it to here after
12327                              * have copied its invlist above */
12328                             SvREFCNT_dec_NN(swash);
12329                             swash = NULL;
12330                         }
12331                         else {
12332                             _invlist_union(properties, invlist, &properties);
12333                         }
12334                     }
12335                     Safefree(name);
12336                 }
12337                 RExC_parse = e + 1;
12338                 namedclass = ANYOF_UNIPROP;  /* no official name, but it's
12339                                                 named */
12340
12341                 /* \p means they want Unicode semantics */
12342                 RExC_uni_semantics = 1;
12343                 }
12344                 break;
12345             case 'n':   value = '\n';                   break;
12346             case 'r':   value = '\r';                   break;
12347             case 't':   value = '\t';                   break;
12348             case 'f':   value = '\f';                   break;
12349             case 'b':   value = '\b';                   break;
12350             case 'e':   value = ASCII_TO_NATIVE('\033');break;
12351             case 'a':   value = ASCII_TO_NATIVE('\007');break;
12352             case 'o':
12353                 RExC_parse--;   /* function expects to be pointed at the 'o' */
12354                 {
12355                     const char* error_msg;
12356                     bool valid = grok_bslash_o(&RExC_parse,
12357                                                &value,
12358                                                &error_msg,
12359                                                SIZE_ONLY,   /* warnings in pass
12360                                                                1 only */
12361                                                strict,
12362                                                silence_non_portable,
12363                                                UTF);
12364                     if (! valid) {
12365                         vFAIL(error_msg);
12366                     }
12367                 }
12368                 if (PL_encoding && value < 0x100) {
12369                     goto recode_encoding;
12370                 }
12371                 break;
12372             case 'x':
12373                 RExC_parse--;   /* function expects to be pointed at the 'x' */
12374                 {
12375                     const char* error_msg;
12376                     bool valid = grok_bslash_x(&RExC_parse,
12377                                                &value,
12378                                                &error_msg,
12379                                                TRUE, /* Output warnings */
12380                                                strict,
12381                                                silence_non_portable,
12382                                                UTF);
12383                     if (! valid) {
12384                         vFAIL(error_msg);
12385                     }
12386                 }
12387                 if (PL_encoding && value < 0x100)
12388                     goto recode_encoding;
12389                 break;
12390             case 'c':
12391                 value = grok_bslash_c(*RExC_parse++, UTF, SIZE_ONLY);
12392                 break;
12393             case '0': case '1': case '2': case '3': case '4':
12394             case '5': case '6': case '7':
12395                 {
12396                     /* Take 1-3 octal digits */
12397                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
12398                     numlen = (strict) ? 4 : 3;
12399                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
12400                     RExC_parse += numlen;
12401                     if (numlen != 3) {
12402                         if (strict) {
12403                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
12404                             vFAIL("Need exactly 3 octal digits");
12405                         }
12406                         else if (! SIZE_ONLY /* like \08, \178 */
12407                                  && numlen < 3
12408                                  && RExC_parse < RExC_end
12409                                  && isDIGIT(*RExC_parse)
12410                                  && ckWARN(WARN_REGEXP))
12411                         {
12412                             SAVEFREESV(RExC_rx_sv);
12413                             reg_warn_non_literal_string(
12414                                  RExC_parse + 1,
12415                                  form_short_octal_warning(RExC_parse, numlen));
12416                             (void)ReREFCNT_inc(RExC_rx_sv);
12417                         }
12418                     }
12419                     if (PL_encoding && value < 0x100)
12420                         goto recode_encoding;
12421                     break;
12422                 }
12423             recode_encoding:
12424                 if (! RExC_override_recoding) {
12425                     SV* enc = PL_encoding;
12426                     value = reg_recode((const char)(U8)value, &enc);
12427                     if (!enc) {
12428                         if (strict) {
12429                             vFAIL("Invalid escape in the specified encoding");
12430                         }
12431                         else if (SIZE_ONLY) {
12432                             ckWARNreg(RExC_parse,
12433                                   "Invalid escape in the specified encoding");
12434                         }
12435                     }
12436                     break;
12437                 }
12438             default:
12439                 /* Allow \_ to not give an error */
12440                 if (!SIZE_ONLY && isWORDCHAR(value) && value != '_') {
12441                     if (strict) {
12442                         vFAIL2("Unrecognized escape \\%c in character class",
12443                                (int)value);
12444                     }
12445                     else {
12446                         SAVEFREESV(RExC_rx_sv);
12447                         ckWARN2reg(RExC_parse,
12448                             "Unrecognized escape \\%c in character class passed through",
12449                             (int)value);
12450                         (void)ReREFCNT_inc(RExC_rx_sv);
12451                     }
12452                 }
12453                 break;
12454             }   /* End of switch on char following backslash */
12455         } /* end of handling backslash escape sequences */
12456 #ifdef EBCDIC
12457         else
12458             literal_endpoint++;
12459 #endif
12460
12461         /* Here, we have the current token in 'value' */
12462
12463         /* What matches in a locale is not known until runtime.  This includes
12464          * what the Posix classes (like \w, [:space:]) match.  Room must be
12465          * reserved (one time per class) to store such classes, either if Perl
12466          * is compiled so that locale nodes always should have this space, or
12467          * if there is such class info to be stored.  The space will contain a
12468          * bit for each named class that is to be matched against.  This isn't
12469          * needed for \p{} and pseudo-classes, as they are not affected by
12470          * locale, and hence are dealt with separately */
12471         if (LOC
12472             && ! need_class
12473             && (ANYOF_LOCALE == ANYOF_CLASS
12474                 || (namedclass > OOB_NAMEDCLASS && namedclass < ANYOF_MAX)))
12475         {
12476             need_class = 1;
12477             if (SIZE_ONLY) {
12478                 RExC_size += ANYOF_CLASS_SKIP - ANYOF_SKIP;
12479             }
12480             else {
12481                 RExC_emit += ANYOF_CLASS_SKIP - ANYOF_SKIP;
12482                 ANYOF_CLASS_ZERO(ret);
12483             }
12484             ANYOF_FLAGS(ret) |= ANYOF_CLASS;
12485         }
12486
12487         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
12488
12489             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
12490              * literal, as is the character that began the false range, i.e.
12491              * the 'a' in the examples */
12492             if (range) {
12493                 if (!SIZE_ONLY) {
12494                     const int w = (RExC_parse >= rangebegin)
12495                                   ? RExC_parse - rangebegin
12496                                   : 0;
12497                     if (strict) {
12498                         vFAIL4("False [] range \"%*.*s\"", w, w, rangebegin);
12499                     }
12500                     else {
12501                         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
12502                         ckWARN4reg(RExC_parse,
12503                                 "False [] range \"%*.*s\"",
12504                                 w, w, rangebegin);
12505                         (void)ReREFCNT_inc(RExC_rx_sv);
12506                         cp_list = add_cp_to_invlist(cp_list, '-');
12507                         cp_list = add_cp_to_invlist(cp_list, prevvalue);
12508                     }
12509                 }
12510
12511                 range = 0; /* this was not a true range */
12512                 element_count += 2; /* So counts for three values */
12513             }
12514
12515             if (! SIZE_ONLY) {
12516                 U8 classnum = namedclass_to_classnum(namedclass);
12517                 if (namedclass >= ANYOF_MAX) {  /* If a special class */
12518                     if (namedclass != ANYOF_UNIPROP) { /* UNIPROP = \p and \P */
12519
12520                         /* Here, should be \h, \H, \v, or \V.  Neither /d nor
12521                          * /l make a difference in what these match.  There
12522                          * would be problems if these characters had folds
12523                          * other than themselves, as cp_list is subject to
12524                          * folding. */
12525                         if (classnum != _CC_VERTSPACE) {
12526                             assert(   namedclass == ANYOF_HORIZWS
12527                                    || namedclass == ANYOF_NHORIZWS);
12528
12529                             /* It turns out that \h is just a synonym for
12530                              * XPosixBlank */
12531                             classnum = _CC_BLANK;
12532                         }
12533
12534                         _invlist_union_maybe_complement_2nd(
12535                                 cp_list,
12536                                 PL_XPosix_ptrs[classnum],
12537                                 cBOOL(namedclass % 2), /* Complement if odd
12538                                                           (NHORIZWS, NVERTWS)
12539                                                         */
12540                                 &cp_list);
12541                     }
12542                 }
12543                 else if (classnum == _CC_ASCII) {
12544 #ifdef HAS_ISASCII
12545                     if (LOC) {
12546                         ANYOF_CLASS_SET(ret, namedclass);
12547                     }
12548                     else
12549 #endif  /* Not isascii(); just use the hard-coded definition for it */
12550                         _invlist_union_maybe_complement_2nd(
12551                                 posixes,
12552                                 PL_ASCII,
12553                                 cBOOL(namedclass % 2), /* Complement if odd
12554                                                           (NASCII) */
12555                                 &posixes);
12556                 }
12557                 else {  /* Garden variety class */
12558
12559                     /* The ascii range inversion list */
12560                     SV* ascii_source = PL_Posix_ptrs[classnum];
12561
12562                     /* The full Latin1 range inversion list */
12563                     SV* l1_source = PL_L1Posix_ptrs[classnum];
12564
12565                     /* This code is structured into two major clauses.  The
12566                      * first is for classes whose complete definitions may not
12567                      * already be known.  It not, the Latin1 definition
12568                      * (guaranteed to already known) is used plus code is
12569                      * generated to load the rest at run-time (only if needed).
12570                      * If the complete definition is known, it drops down to
12571                      * the second clause, where the complete definition is
12572                      * known */
12573
12574                     if (classnum < _FIRST_NON_SWASH_CC) {
12575
12576                         /* Here, the class has a swash, which may or not
12577                          * already be loaded */
12578
12579                         /* The name of the property to use to match the full
12580                          * eXtended Unicode range swash for this character
12581                          * class */
12582                         const char *Xname = swash_property_names[classnum];
12583
12584                         /* If returning the inversion list, we can't defer
12585                          * getting this until runtime */
12586                         if (ret_invlist && !  PL_utf8_swash_ptrs[classnum]) {
12587                             PL_utf8_swash_ptrs[classnum] =
12588                                 _core_swash_init("utf8", Xname, &PL_sv_undef,
12589                                              1, /* binary */
12590                                              0, /* not tr/// */
12591                                              NULL, /* No inversion list */
12592                                              NULL  /* No flags */
12593                                             );
12594                             assert(PL_utf8_swash_ptrs[classnum]);
12595                         }
12596                         if ( !  PL_utf8_swash_ptrs[classnum]) {
12597                             if (namedclass % 2 == 0) { /* A non-complemented
12598                                                           class */
12599                                 /* If not /a matching, there are code points we
12600                                  * don't know at compile time.  Arrange for the
12601                                  * unknown matches to be loaded at run-time, if
12602                                  * needed */
12603                                 if (! AT_LEAST_ASCII_RESTRICTED) {
12604                                     Perl_sv_catpvf(aTHX_ listsv, "+utf8::%s\n",
12605                                                                  Xname);
12606                                 }
12607                                 if (LOC) {  /* Under locale, set run-time
12608                                                lookup */
12609                                     ANYOF_CLASS_SET(ret, namedclass);
12610                                 }
12611                                 else {
12612                                     /* Add the current class's code points to
12613                                      * the running total */
12614                                     _invlist_union(posixes,
12615                                                    (AT_LEAST_ASCII_RESTRICTED)
12616                                                         ? ascii_source
12617                                                         : l1_source,
12618                                                    &posixes);
12619                                 }
12620                             }
12621                             else {  /* A complemented class */
12622                                 if (AT_LEAST_ASCII_RESTRICTED) {
12623                                     /* Under /a should match everything above
12624                                      * ASCII, plus the complement of the set's
12625                                      * ASCII matches */
12626                                     _invlist_union_complement_2nd(posixes,
12627                                                                   ascii_source,
12628                                                                   &posixes);
12629                                 }
12630                                 else {
12631                                     /* Arrange for the unknown matches to be
12632                                      * loaded at run-time, if needed */
12633                                     Perl_sv_catpvf(aTHX_ listsv, "!utf8::%s\n",
12634                                                                  Xname);
12635                                     runtime_posix_matches_above_Unicode = TRUE;
12636                                     if (LOC) {
12637                                         ANYOF_CLASS_SET(ret, namedclass);
12638                                     }
12639                                     else {
12640
12641                                         /* We want to match everything in
12642                                          * Latin1, except those things that
12643                                          * l1_source matches */
12644                                         SV* scratch_list = NULL;
12645                                         _invlist_subtract(PL_Latin1, l1_source,
12646                                                           &scratch_list);
12647
12648                                         /* Add the list from this class to the
12649                                          * running total */
12650                                         if (! posixes) {
12651                                             posixes = scratch_list;
12652                                         }
12653                                         else {
12654                                             _invlist_union(posixes,
12655                                                            scratch_list,
12656                                                            &posixes);
12657                                             SvREFCNT_dec_NN(scratch_list);
12658                                         }
12659                                         if (DEPENDS_SEMANTICS) {
12660                                             ANYOF_FLAGS(ret)
12661                                                   |= ANYOF_NON_UTF8_LATIN1_ALL;
12662                                         }
12663                                     }
12664                                 }
12665                             }
12666                             goto namedclass_done;
12667                         }
12668
12669                         /* Here, there is a swash loaded for the class.  If no
12670                          * inversion list for it yet, get it */
12671                         if (! PL_XPosix_ptrs[classnum]) {
12672                             PL_XPosix_ptrs[classnum]
12673                              = _swash_to_invlist(PL_utf8_swash_ptrs[classnum]);
12674                         }
12675                     }
12676
12677                     /* Here there is an inversion list already loaded for the
12678                      * entire class */
12679
12680                     if (namedclass % 2 == 0) {  /* A non-complemented class,
12681                                                    like ANYOF_PUNCT */
12682                         if (! LOC) {
12683                             /* For non-locale, just add it to any existing list
12684                              * */
12685                             _invlist_union(posixes,
12686                                            (AT_LEAST_ASCII_RESTRICTED)
12687                                                ? ascii_source
12688                                                : PL_XPosix_ptrs[classnum],
12689                                            &posixes);
12690                         }
12691                         else {  /* Locale */
12692                             SV* scratch_list = NULL;
12693
12694                             /* For above Latin1 code points, we use the full
12695                              * Unicode range */
12696                             _invlist_intersection(PL_AboveLatin1,
12697                                                   PL_XPosix_ptrs[classnum],
12698                                                   &scratch_list);
12699                             /* And set the output to it, adding instead if
12700                              * there already is an output.  Checking if
12701                              * 'posixes' is NULL first saves an extra clone.
12702                              * Its reference count will be decremented at the
12703                              * next union, etc, or if this is the only
12704                              * instance, at the end of the routine */
12705                             if (! posixes) {
12706                                 posixes = scratch_list;
12707                             }
12708                             else {
12709                                 _invlist_union(posixes, scratch_list, &posixes);
12710                                 SvREFCNT_dec_NN(scratch_list);
12711                             }
12712
12713 #ifndef HAS_ISBLANK
12714                             if (namedclass != ANYOF_BLANK) {
12715 #endif
12716                                 /* Set this class in the node for runtime
12717                                  * matching */
12718                                 ANYOF_CLASS_SET(ret, namedclass);
12719 #ifndef HAS_ISBLANK
12720                             }
12721                             else {
12722                                 /* No isblank(), use the hard-coded ASCII-range
12723                                  * blanks, adding them to the running total. */
12724
12725                                 _invlist_union(posixes, ascii_source, &posixes);
12726                             }
12727 #endif
12728                         }
12729                     }
12730                     else {  /* A complemented class, like ANYOF_NPUNCT */
12731                         if (! LOC) {
12732                             _invlist_union_complement_2nd(
12733                                                 posixes,
12734                                                 (AT_LEAST_ASCII_RESTRICTED)
12735                                                     ? ascii_source
12736                                                     : PL_XPosix_ptrs[classnum],
12737                                                 &posixes);
12738                             /* Under /d, everything in the upper half of the
12739                              * Latin1 range matches this complement */
12740                             if (DEPENDS_SEMANTICS) {
12741                                 ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL;
12742                             }
12743                         }
12744                         else {  /* Locale */
12745                             SV* scratch_list = NULL;
12746                             _invlist_subtract(PL_AboveLatin1,
12747                                               PL_XPosix_ptrs[classnum],
12748                                               &scratch_list);
12749                             if (! posixes) {
12750                                 posixes = scratch_list;
12751                             }
12752                             else {
12753                                 _invlist_union(posixes, scratch_list, &posixes);
12754                                 SvREFCNT_dec_NN(scratch_list);
12755                             }
12756 #ifndef HAS_ISBLANK
12757                             if (namedclass != ANYOF_NBLANK) {
12758 #endif
12759                                 ANYOF_CLASS_SET(ret, namedclass);
12760 #ifndef HAS_ISBLANK
12761                             }
12762                             else {
12763                                 /* Get the list of all code points in Latin1
12764                                  * that are not ASCII blanks, and add them to
12765                                  * the running total */
12766                                 _invlist_subtract(PL_Latin1, ascii_source,
12767                                                   &scratch_list);
12768                                 _invlist_union(posixes, scratch_list, &posixes);
12769                                 SvREFCNT_dec_NN(scratch_list);
12770                             }
12771 #endif
12772                         }
12773                     }
12774                 }
12775               namedclass_done:
12776                 continue;   /* Go get next character */
12777             }
12778         } /* end of namedclass \blah */
12779
12780         /* Here, we have a single value.  If 'range' is set, it is the ending
12781          * of a range--check its validity.  Later, we will handle each
12782          * individual code point in the range.  If 'range' isn't set, this
12783          * could be the beginning of a range, so check for that by looking
12784          * ahead to see if the next real character to be processed is the range
12785          * indicator--the minus sign */
12786
12787         if (skip_white) {
12788             RExC_parse = regpatws(pRExC_state, RExC_parse,
12789                                 FALSE /* means don't recognize comments */);
12790         }
12791
12792         if (range) {
12793             if (prevvalue > value) /* b-a */ {
12794                 const int w = RExC_parse - rangebegin;
12795                 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
12796                 range = 0; /* not a valid range */
12797             }
12798         }
12799         else {
12800             prevvalue = value; /* save the beginning of the potential range */
12801             if (! stop_at_1     /* Can't be a range if parsing just one thing */
12802                 && *RExC_parse == '-')
12803             {
12804                 char* next_char_ptr = RExC_parse + 1;
12805                 if (skip_white) {   /* Get the next real char after the '-' */
12806                     next_char_ptr = regpatws(pRExC_state,
12807                                              RExC_parse + 1,
12808                                              FALSE); /* means don't recognize
12809                                                         comments */
12810                 }
12811
12812                 /* If the '-' is at the end of the class (just before the ']',
12813                  * it is a literal minus; otherwise it is a range */
12814                 if (next_char_ptr < RExC_end && *next_char_ptr != ']') {
12815                     RExC_parse = next_char_ptr;
12816
12817                     /* a bad range like \w-, [:word:]- ? */
12818                     if (namedclass > OOB_NAMEDCLASS) {
12819                         if (strict || ckWARN(WARN_REGEXP)) {
12820                             const int w =
12821                                 RExC_parse >= rangebegin ?
12822                                 RExC_parse - rangebegin : 0;
12823                             if (strict) {
12824                                 vFAIL4("False [] range \"%*.*s\"",
12825                                     w, w, rangebegin);
12826                             }
12827                             else {
12828                                 vWARN4(RExC_parse,
12829                                     "False [] range \"%*.*s\"",
12830                                     w, w, rangebegin);
12831                             }
12832                         }
12833                         if (!SIZE_ONLY) {
12834                             cp_list = add_cp_to_invlist(cp_list, '-');
12835                         }
12836                         element_count++;
12837                     } else
12838                         range = 1;      /* yeah, it's a range! */
12839                     continue;   /* but do it the next time */
12840                 }
12841             }
12842         }
12843
12844         /* Here, <prevvalue> is the beginning of the range, if any; or <value>
12845          * if not */
12846
12847         /* non-Latin1 code point implies unicode semantics.  Must be set in
12848          * pass1 so is there for the whole of pass 2 */
12849         if (value > 255) {
12850             RExC_uni_semantics = 1;
12851         }
12852
12853         /* Ready to process either the single value, or the completed range.
12854          * For single-valued non-inverted ranges, we consider the possibility
12855          * of multi-char folds.  (We made a conscious decision to not do this
12856          * for the other cases because it can often lead to non-intuitive
12857          * results.  For example, you have the peculiar case that:
12858          *  "s s" =~ /^[^\xDF]+$/i => Y
12859          *  "ss"  =~ /^[^\xDF]+$/i => N
12860          *
12861          * See [perl #89750] */
12862         if (FOLD && allow_multi_folds && value == prevvalue) {
12863             if (value == LATIN_SMALL_LETTER_SHARP_S
12864                 || (value > 255 && _invlist_contains_cp(PL_HasMultiCharFold,
12865                                                         value)))
12866             {
12867                 /* Here <value> is indeed a multi-char fold.  Get what it is */
12868
12869                 U8 foldbuf[UTF8_MAXBYTES_CASE];
12870                 STRLEN foldlen;
12871
12872                 UV folded = _to_uni_fold_flags(
12873                                 value,
12874                                 foldbuf,
12875                                 &foldlen,
12876                                 FOLD_FLAGS_FULL
12877                                 | ((LOC) ?  FOLD_FLAGS_LOCALE
12878                                             : (ASCII_FOLD_RESTRICTED)
12879                                               ? FOLD_FLAGS_NOMIX_ASCII
12880                                               : 0)
12881                                 );
12882
12883                 /* Here, <folded> should be the first character of the
12884                  * multi-char fold of <value>, with <foldbuf> containing the
12885                  * whole thing.  But, if this fold is not allowed (because of
12886                  * the flags), <fold> will be the same as <value>, and should
12887                  * be processed like any other character, so skip the special
12888                  * handling */
12889                 if (folded != value) {
12890
12891                     /* Skip if we are recursed, currently parsing the class
12892                      * again.  Otherwise add this character to the list of
12893                      * multi-char folds. */
12894                     if (! RExC_in_multi_char_class) {
12895                         AV** this_array_ptr;
12896                         AV* this_array;
12897                         STRLEN cp_count = utf8_length(foldbuf,
12898                                                       foldbuf + foldlen);
12899                         SV* multi_fold = sv_2mortal(newSVpvn("", 0));
12900
12901                         Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%"UVXf"}", value);
12902
12903
12904                         if (! multi_char_matches) {
12905                             multi_char_matches = newAV();
12906                         }
12907
12908                         /* <multi_char_matches> is actually an array of arrays.
12909                          * There will be one or two top-level elements: [2],
12910                          * and/or [3].  The [2] element is an array, each
12911                          * element thereof is a character which folds to two
12912                          * characters; likewise for [3].  (Unicode guarantees a
12913                          * maximum of 3 characters in any fold.)  When we
12914                          * rewrite the character class below, we will do so
12915                          * such that the longest folds are written first, so
12916                          * that it prefers the longest matching strings first.
12917                          * This is done even if it turns out that any
12918                          * quantifier is non-greedy, out of programmer
12919                          * laziness.  Tom Christiansen has agreed that this is
12920                          * ok.  This makes the test for the ligature 'ffi' come
12921                          * before the test for 'ff' */
12922                         if (av_exists(multi_char_matches, cp_count)) {
12923                             this_array_ptr = (AV**) av_fetch(multi_char_matches,
12924                                                              cp_count, FALSE);
12925                             this_array = *this_array_ptr;
12926                         }
12927                         else {
12928                             this_array = newAV();
12929                             av_store(multi_char_matches, cp_count,
12930                                      (SV*) this_array);
12931                         }
12932                         av_push(this_array, multi_fold);
12933                     }
12934
12935                     /* This element should not be processed further in this
12936                      * class */
12937                     element_count--;
12938                     value = save_value;
12939                     prevvalue = save_prevvalue;
12940                     continue;
12941                 }
12942             }
12943         }
12944
12945         /* Deal with this element of the class */
12946         if (! SIZE_ONLY) {
12947 #ifndef EBCDIC
12948             cp_list = _add_range_to_invlist(cp_list, prevvalue, value);
12949 #else
12950             SV* this_range = _new_invlist(1);
12951             _append_range_to_invlist(this_range, prevvalue, value);
12952
12953             /* In EBCDIC, the ranges 'A-Z' and 'a-z' are each not contiguous.
12954              * If this range was specified using something like 'i-j', we want
12955              * to include only the 'i' and the 'j', and not anything in
12956              * between, so exclude non-ASCII, non-alphabetics from it.
12957              * However, if the range was specified with something like
12958              * [\x89-\x91] or [\x89-j], all code points within it should be
12959              * included.  literal_endpoint==2 means both ends of the range used
12960              * a literal character, not \x{foo} */
12961             if (literal_endpoint == 2
12962                 && (prevvalue >= 'a' && value <= 'z')
12963                     || (prevvalue >= 'A' && value <= 'Z'))
12964             {
12965                 _invlist_intersection(this_range, PL_Posix_ptrs[_CC_ALPHA],
12966                                       &this_range);
12967             }
12968             _invlist_union(cp_list, this_range, &cp_list);
12969             literal_endpoint = 0;
12970 #endif
12971         }
12972
12973         range = 0; /* this range (if it was one) is done now */
12974     } /* End of loop through all the text within the brackets */
12975
12976     /* If anything in the class expands to more than one character, we have to
12977      * deal with them by building up a substitute parse string, and recursively
12978      * calling reg() on it, instead of proceeding */
12979     if (multi_char_matches) {
12980         SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
12981         I32 cp_count;
12982         STRLEN len;
12983         char *save_end = RExC_end;
12984         char *save_parse = RExC_parse;
12985         bool first_time = TRUE;     /* First multi-char occurrence doesn't get
12986                                        a "|" */
12987         I32 reg_flags;
12988
12989         assert(! invert);
12990 #if 0   /* Have decided not to deal with multi-char folds in inverted classes,
12991            because too confusing */
12992         if (invert) {
12993             sv_catpv(substitute_parse, "(?:");
12994         }
12995 #endif
12996
12997         /* Look at the longest folds first */
12998         for (cp_count = av_len(multi_char_matches); cp_count > 0; cp_count--) {
12999
13000             if (av_exists(multi_char_matches, cp_count)) {
13001                 AV** this_array_ptr;
13002                 SV* this_sequence;
13003
13004                 this_array_ptr = (AV**) av_fetch(multi_char_matches,
13005                                                  cp_count, FALSE);
13006                 while ((this_sequence = av_pop(*this_array_ptr)) !=
13007                                                                 &PL_sv_undef)
13008                 {
13009                     if (! first_time) {
13010                         sv_catpv(substitute_parse, "|");
13011                     }
13012                     first_time = FALSE;
13013
13014                     sv_catpv(substitute_parse, SvPVX(this_sequence));
13015                 }
13016             }
13017         }
13018
13019         /* If the character class contains anything else besides these
13020          * multi-character folds, have to include it in recursive parsing */
13021         if (element_count) {
13022             sv_catpv(substitute_parse, "|[");
13023             sv_catpvn(substitute_parse, orig_parse, RExC_parse - orig_parse);
13024             sv_catpv(substitute_parse, "]");
13025         }
13026
13027         sv_catpv(substitute_parse, ")");
13028 #if 0
13029         if (invert) {
13030             /* This is a way to get the parse to skip forward a whole named
13031              * sequence instead of matching the 2nd character when it fails the
13032              * first */
13033             sv_catpv(substitute_parse, "(*THEN)(*SKIP)(*FAIL)|.)");
13034         }
13035 #endif
13036
13037         RExC_parse = SvPV(substitute_parse, len);
13038         RExC_end = RExC_parse + len;
13039         RExC_in_multi_char_class = 1;
13040         RExC_emit = (regnode *)orig_emit;
13041
13042         ret = reg(pRExC_state, 1, &reg_flags, depth+1);
13043
13044         *flagp |= reg_flags&(HASWIDTH|SIMPLE|SPSTART|POSTPONED|RESTART_UTF8);
13045
13046         RExC_parse = save_parse;
13047         RExC_end = save_end;
13048         RExC_in_multi_char_class = 0;
13049         SvREFCNT_dec_NN(multi_char_matches);
13050         return ret;
13051     }
13052
13053     /* If the character class contains only a single element, it may be
13054      * optimizable into another node type which is smaller and runs faster.
13055      * Check if this is the case for this class */
13056     if (element_count == 1 && ! ret_invlist) {
13057         U8 op = END;
13058         U8 arg = 0;
13059
13060         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class, like \w or
13061                                               [:digit:] or \p{foo} */
13062
13063             /* All named classes are mapped into POSIXish nodes, with its FLAG
13064              * argument giving which class it is */
13065             switch ((I32)namedclass) {
13066                 case ANYOF_UNIPROP:
13067                     break;
13068
13069                 /* These don't depend on the charset modifiers.  They always
13070                  * match under /u rules */
13071                 case ANYOF_NHORIZWS:
13072                 case ANYOF_HORIZWS:
13073                     namedclass = ANYOF_BLANK + namedclass - ANYOF_HORIZWS;
13074                     /* FALLTHROUGH */
13075
13076                 case ANYOF_NVERTWS:
13077                 case ANYOF_VERTWS:
13078                     op = POSIXU;
13079                     goto join_posix;
13080
13081                 /* The actual POSIXish node for all the rest depends on the
13082                  * charset modifier.  The ones in the first set depend only on
13083                  * ASCII or, if available on this platform, locale */
13084                 case ANYOF_ASCII:
13085                 case ANYOF_NASCII:
13086 #ifdef HAS_ISASCII
13087                     op = (LOC) ? POSIXL : POSIXA;
13088 #else
13089                     op = POSIXA;
13090 #endif
13091                     goto join_posix;
13092
13093                 case ANYOF_NCASED:
13094                 case ANYOF_LOWER:
13095                 case ANYOF_NLOWER:
13096                 case ANYOF_UPPER:
13097                 case ANYOF_NUPPER:
13098                     /* under /a could be alpha */
13099                     if (FOLD) {
13100                         if (ASCII_RESTRICTED) {
13101                             namedclass = ANYOF_ALPHA + (namedclass % 2);
13102                         }
13103                         else if (! LOC) {
13104                             break;
13105                         }
13106                     }
13107                     /* FALLTHROUGH */
13108
13109                 /* The rest have more possibilities depending on the charset.
13110                  * We take advantage of the enum ordering of the charset
13111                  * modifiers to get the exact node type, */
13112                 default:
13113                     op = POSIXD + get_regex_charset(RExC_flags);
13114                     if (op > POSIXA) { /* /aa is same as /a */
13115                         op = POSIXA;
13116                     }
13117 #ifndef HAS_ISBLANK
13118                     if (op == POSIXL
13119                         && (namedclass == ANYOF_BLANK
13120                             || namedclass == ANYOF_NBLANK))
13121                     {
13122                         op = POSIXA;
13123                     }
13124 #endif
13125
13126                 join_posix:
13127                     /* The odd numbered ones are the complements of the
13128                      * next-lower even number one */
13129                     if (namedclass % 2 == 1) {
13130                         invert = ! invert;
13131                         namedclass--;
13132                     }
13133                     arg = namedclass_to_classnum(namedclass);
13134                     break;
13135             }
13136         }
13137         else if (value == prevvalue) {
13138
13139             /* Here, the class consists of just a single code point */
13140
13141             if (invert) {
13142                 if (! LOC && value == '\n') {
13143                     op = REG_ANY; /* Optimize [^\n] */
13144                     *flagp |= HASWIDTH|SIMPLE;
13145                     RExC_naughty++;
13146                 }
13147             }
13148             else if (value < 256 || UTF) {
13149
13150                 /* Optimize a single value into an EXACTish node, but not if it
13151                  * would require converting the pattern to UTF-8. */
13152                 op = compute_EXACTish(pRExC_state);
13153             }
13154         } /* Otherwise is a range */
13155         else if (! LOC) {   /* locale could vary these */
13156             if (prevvalue == '0') {
13157                 if (value == '9') {
13158                     arg = _CC_DIGIT;
13159                     op = POSIXA;
13160                 }
13161             }
13162         }
13163
13164         /* Here, we have changed <op> away from its initial value iff we found
13165          * an optimization */
13166         if (op != END) {
13167
13168             /* Throw away this ANYOF regnode, and emit the calculated one,
13169              * which should correspond to the beginning, not current, state of
13170              * the parse */
13171             const char * cur_parse = RExC_parse;
13172             RExC_parse = (char *)orig_parse;
13173             if ( SIZE_ONLY) {
13174                 if (! LOC) {
13175
13176                     /* To get locale nodes to not use the full ANYOF size would
13177                      * require moving the code above that writes the portions
13178                      * of it that aren't in other nodes to after this point.
13179                      * e.g.  ANYOF_CLASS_SET */
13180                     RExC_size = orig_size;
13181                 }
13182             }
13183             else {
13184                 RExC_emit = (regnode *)orig_emit;
13185                 if (PL_regkind[op] == POSIXD) {
13186                     if (invert) {
13187                         op += NPOSIXD - POSIXD;
13188                     }
13189                 }
13190             }
13191
13192             ret = reg_node(pRExC_state, op);
13193
13194             if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
13195                 if (! SIZE_ONLY) {
13196                     FLAGS(ret) = arg;
13197                 }
13198                 *flagp |= HASWIDTH|SIMPLE;
13199             }
13200             else if (PL_regkind[op] == EXACT) {
13201                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value);
13202             }
13203
13204             RExC_parse = (char *) cur_parse;
13205
13206             SvREFCNT_dec(posixes);
13207             SvREFCNT_dec(cp_list);
13208             return ret;
13209         }
13210     }
13211
13212     if (SIZE_ONLY)
13213         return ret;
13214     /****** !SIZE_ONLY (Pass 2) AFTER HERE *********/
13215
13216     /* If folding, we calculate all characters that could fold to or from the
13217      * ones already on the list */
13218     if (FOLD && cp_list) {
13219         UV start, end;  /* End points of code point ranges */
13220
13221         SV* fold_intersection = NULL;
13222
13223         /* If the highest code point is within Latin1, we can use the
13224          * compiled-in Alphas list, and not have to go out to disk.  This
13225          * yields two false positives, the masculine and feminine ordinal
13226          * indicators, which are weeded out below using the
13227          * IS_IN_SOME_FOLD_L1() macro */
13228         if (invlist_highest(cp_list) < 256) {
13229             _invlist_intersection(PL_L1Posix_ptrs[_CC_ALPHA], cp_list,
13230                                                            &fold_intersection);
13231         }
13232         else {
13233
13234             /* Here, there are non-Latin1 code points, so we will have to go
13235              * fetch the list of all the characters that participate in folds
13236              */
13237             if (! PL_utf8_foldable) {
13238                 SV* swash = swash_init("utf8", "_Perl_Any_Folds",
13239                                        &PL_sv_undef, 1, 0);
13240                 PL_utf8_foldable = _get_swash_invlist(swash);
13241                 SvREFCNT_dec_NN(swash);
13242             }
13243
13244             /* This is a hash that for a particular fold gives all characters
13245              * that are involved in it */
13246             if (! PL_utf8_foldclosures) {
13247
13248                 /* If we were unable to find any folds, then we likely won't be
13249                  * able to find the closures.  So just create an empty list.
13250                  * Folding will effectively be restricted to the non-Unicode
13251                  * rules hard-coded into Perl.  (This case happens legitimately
13252                  * during compilation of Perl itself before the Unicode tables
13253                  * are generated) */
13254                 if (_invlist_len(PL_utf8_foldable) == 0) {
13255                     PL_utf8_foldclosures = newHV();
13256                 }
13257                 else {
13258                     /* If the folds haven't been read in, call a fold function
13259                      * to force that */
13260                     if (! PL_utf8_tofold) {
13261                         U8 dummy[UTF8_MAXBYTES+1];
13262
13263                         /* This string is just a short named one above \xff */
13264                         to_utf8_fold((U8*) HYPHEN_UTF8, dummy, NULL);
13265                         assert(PL_utf8_tofold); /* Verify that worked */
13266                     }
13267                     PL_utf8_foldclosures =
13268                                     _swash_inversion_hash(PL_utf8_tofold);
13269                 }
13270             }
13271
13272             /* Only the characters in this class that participate in folds need
13273              * be checked.  Get the intersection of this class and all the
13274              * possible characters that are foldable.  This can quickly narrow
13275              * down a large class */
13276             _invlist_intersection(PL_utf8_foldable, cp_list,
13277                                   &fold_intersection);
13278         }
13279
13280         /* Now look at the foldable characters in this class individually */
13281         invlist_iterinit(fold_intersection);
13282         while (invlist_iternext(fold_intersection, &start, &end)) {
13283             UV j;
13284
13285             /* Locale folding for Latin1 characters is deferred until runtime */
13286             if (LOC && start < 256) {
13287                 start = 256;
13288             }
13289
13290             /* Look at every character in the range */
13291             for (j = start; j <= end; j++) {
13292
13293                 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
13294                 STRLEN foldlen;
13295                 SV** listp;
13296
13297                 if (j < 256) {
13298
13299                     /* We have the latin1 folding rules hard-coded here so that
13300                      * an innocent-looking character class, like /[ks]/i won't
13301                      * have to go out to disk to find the possible matches.
13302                      * XXX It would be better to generate these via regen, in
13303                      * case a new version of the Unicode standard adds new
13304                      * mappings, though that is not really likely, and may be
13305                      * caught by the default: case of the switch below. */
13306
13307                     if (IS_IN_SOME_FOLD_L1(j)) {
13308
13309                         /* ASCII is always matched; non-ASCII is matched only
13310                          * under Unicode rules */
13311                         if (isASCII(j) || AT_LEAST_UNI_SEMANTICS) {
13312                             cp_list =
13313                                 add_cp_to_invlist(cp_list, PL_fold_latin1[j]);
13314                         }
13315                         else {
13316                             depends_list =
13317                              add_cp_to_invlist(depends_list, PL_fold_latin1[j]);
13318                         }
13319                     }
13320
13321                     if (HAS_NONLATIN1_FOLD_CLOSURE(j)
13322                         && (! isASCII(j) || ! ASCII_FOLD_RESTRICTED))
13323                     {
13324                         /* Certain Latin1 characters have matches outside
13325                          * Latin1.  To get here, <j> is one of those
13326                          * characters.   None of these matches is valid for
13327                          * ASCII characters under /aa, which is why the 'if'
13328                          * just above excludes those.  These matches only
13329                          * happen when the target string is utf8.  The code
13330                          * below adds the single fold closures for <j> to the
13331                          * inversion list. */
13332                         switch (j) {
13333                             case 'k':
13334                             case 'K':
13335                                 cp_list =
13336                                     add_cp_to_invlist(cp_list, KELVIN_SIGN);
13337                                 break;
13338                             case 's':
13339                             case 'S':
13340                                 cp_list = add_cp_to_invlist(cp_list,
13341                                                     LATIN_SMALL_LETTER_LONG_S);
13342                                 break;
13343                             case MICRO_SIGN:
13344                                 cp_list = add_cp_to_invlist(cp_list,
13345                                                     GREEK_CAPITAL_LETTER_MU);
13346                                 cp_list = add_cp_to_invlist(cp_list,
13347                                                     GREEK_SMALL_LETTER_MU);
13348                                 break;
13349                             case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
13350                             case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
13351                                 cp_list =
13352                                     add_cp_to_invlist(cp_list, ANGSTROM_SIGN);
13353                                 break;
13354                             case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
13355                                 cp_list = add_cp_to_invlist(cp_list,
13356                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
13357                                 break;
13358                             case LATIN_SMALL_LETTER_SHARP_S:
13359                                 cp_list = add_cp_to_invlist(cp_list,
13360                                                 LATIN_CAPITAL_LETTER_SHARP_S);
13361                                 break;
13362                             case 'F': case 'f':
13363                             case 'I': case 'i':
13364                             case 'L': case 'l':
13365                             case 'T': case 't':
13366                             case 'A': case 'a':
13367                             case 'H': case 'h':
13368                             case 'J': case 'j':
13369                             case 'N': case 'n':
13370                             case 'W': case 'w':
13371                             case 'Y': case 'y':
13372                                 /* These all are targets of multi-character
13373                                  * folds from code points that require UTF8 to
13374                                  * express, so they can't match unless the
13375                                  * target string is in UTF-8, so no action here
13376                                  * is necessary, as regexec.c properly handles
13377                                  * the general case for UTF-8 matching and
13378                                  * multi-char folds */
13379                                 break;
13380                             default:
13381                                 /* Use deprecated warning to increase the
13382                                  * chances of this being output */
13383                                 ckWARN2regdep(RExC_parse, "Perl folding rules are not up-to-date for 0x%"UVXf"; please use the perlbug utility to report;", j);
13384                                 break;
13385                         }
13386                     }
13387                     continue;
13388                 }
13389
13390                 /* Here is an above Latin1 character.  We don't have the rules
13391                  * hard-coded for it.  First, get its fold.  This is the simple
13392                  * fold, as the multi-character folds have been handled earlier
13393                  * and separated out */
13394                 _to_uni_fold_flags(j, foldbuf, &foldlen,
13395                                                ((LOC)
13396                                                ? FOLD_FLAGS_LOCALE
13397                                                : (ASCII_FOLD_RESTRICTED)
13398                                                   ? FOLD_FLAGS_NOMIX_ASCII
13399                                                   : 0));
13400
13401                 /* Single character fold of above Latin1.  Add everything in
13402                  * its fold closure to the list that this node should match.
13403                  * The fold closures data structure is a hash with the keys
13404                  * being the UTF-8 of every character that is folded to, like
13405                  * 'k', and the values each an array of all code points that
13406                  * fold to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ].
13407                  * Multi-character folds are not included */
13408                 if ((listp = hv_fetch(PL_utf8_foldclosures,
13409                                       (char *) foldbuf, foldlen, FALSE)))
13410                 {
13411                     AV* list = (AV*) *listp;
13412                     IV k;
13413                     for (k = 0; k <= av_len(list); k++) {
13414                         SV** c_p = av_fetch(list, k, FALSE);
13415                         UV c;
13416                         if (c_p == NULL) {
13417                             Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
13418                         }
13419                         c = SvUV(*c_p);
13420
13421                         /* /aa doesn't allow folds between ASCII and non-; /l
13422                          * doesn't allow them between above and below 256 */
13423                         if ((ASCII_FOLD_RESTRICTED
13424                                   && (isASCII(c) != isASCII(j)))
13425                             || (LOC && ((c < 256) != (j < 256))))
13426                         {
13427                             continue;
13428                         }
13429
13430                         /* Folds involving non-ascii Latin1 characters
13431                          * under /d are added to a separate list */
13432                         if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS)
13433                         {
13434                             cp_list = add_cp_to_invlist(cp_list, c);
13435                         }
13436                         else {
13437                           depends_list = add_cp_to_invlist(depends_list, c);
13438                         }
13439                     }
13440                 }
13441             }
13442         }
13443         SvREFCNT_dec_NN(fold_intersection);
13444     }
13445
13446     /* And combine the result (if any) with any inversion list from posix
13447      * classes.  The lists are kept separate up to now because we don't want to
13448      * fold the classes (folding of those is automatically handled by the swash
13449      * fetching code) */
13450     if (posixes) {
13451         if (! DEPENDS_SEMANTICS) {
13452             if (cp_list) {
13453                 _invlist_union(cp_list, posixes, &cp_list);
13454                 SvREFCNT_dec_NN(posixes);
13455             }
13456             else {
13457                 cp_list = posixes;
13458             }
13459         }
13460         else {
13461             /* Under /d, we put into a separate list the Latin1 things that
13462              * match only when the target string is utf8 */
13463             SV* nonascii_but_latin1_properties = NULL;
13464             _invlist_intersection(posixes, PL_Latin1,
13465                                   &nonascii_but_latin1_properties);
13466             _invlist_subtract(nonascii_but_latin1_properties, PL_ASCII,
13467                               &nonascii_but_latin1_properties);
13468             _invlist_subtract(posixes, nonascii_but_latin1_properties,
13469                               &posixes);
13470             if (cp_list) {
13471                 _invlist_union(cp_list, posixes, &cp_list);
13472                 SvREFCNT_dec_NN(posixes);
13473             }
13474             else {
13475                 cp_list = posixes;
13476             }
13477
13478             if (depends_list) {
13479                 _invlist_union(depends_list, nonascii_but_latin1_properties,
13480                                &depends_list);
13481                 SvREFCNT_dec_NN(nonascii_but_latin1_properties);
13482             }
13483             else {
13484                 depends_list = nonascii_but_latin1_properties;
13485             }
13486         }
13487     }
13488
13489     /* And combine the result (if any) with any inversion list from properties.
13490      * The lists are kept separate up to now so that we can distinguish the two
13491      * in regards to matching above-Unicode.  A run-time warning is generated
13492      * if a Unicode property is matched against a non-Unicode code point. But,
13493      * we allow user-defined properties to match anything, without any warning,
13494      * and we also suppress the warning if there is a portion of the character
13495      * class that isn't a Unicode property, and which matches above Unicode, \W
13496      * or [\x{110000}] for example.
13497      * (Note that in this case, unlike the Posix one above, there is no
13498      * <depends_list>, because having a Unicode property forces Unicode
13499      * semantics */
13500     if (properties) {
13501         bool warn_super = ! has_user_defined_property;
13502         if (cp_list) {
13503
13504             /* If it matters to the final outcome, see if a non-property
13505              * component of the class matches above Unicode.  If so, the
13506              * warning gets suppressed.  This is true even if just a single
13507              * such code point is specified, as though not strictly correct if
13508              * another such code point is matched against, the fact that they
13509              * are using above-Unicode code points indicates they should know
13510              * the issues involved */
13511             if (warn_super) {
13512                 bool non_prop_matches_above_Unicode =
13513                             runtime_posix_matches_above_Unicode
13514                             | (invlist_highest(cp_list) > PERL_UNICODE_MAX);
13515                 if (invert) {
13516                     non_prop_matches_above_Unicode =
13517                                             !  non_prop_matches_above_Unicode;
13518                 }
13519                 warn_super = ! non_prop_matches_above_Unicode;
13520             }
13521
13522             _invlist_union(properties, cp_list, &cp_list);
13523             SvREFCNT_dec_NN(properties);
13524         }
13525         else {
13526             cp_list = properties;
13527         }
13528
13529         if (warn_super) {
13530             OP(ret) = ANYOF_WARN_SUPER;
13531         }
13532     }
13533
13534     /* Here, we have calculated what code points should be in the character
13535      * class.
13536      *
13537      * Now we can see about various optimizations.  Fold calculation (which we
13538      * did above) needs to take place before inversion.  Otherwise /[^k]/i
13539      * would invert to include K, which under /i would match k, which it
13540      * shouldn't.  Therefore we can't invert folded locale now, as it won't be
13541      * folded until runtime */
13542
13543     /* Optimize inverted simple patterns (e.g. [^a-z]) when everything is known
13544      * at compile time.  Besides not inverting folded locale now, we can't
13545      * invert if there are things such as \w, which aren't known until runtime
13546      * */
13547     if (invert
13548         && ! (LOC && (FOLD || (ANYOF_FLAGS(ret) & ANYOF_CLASS)))
13549         && ! depends_list
13550         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
13551     {
13552         _invlist_invert(cp_list);
13553
13554         /* Any swash can't be used as-is, because we've inverted things */
13555         if (swash) {
13556             SvREFCNT_dec_NN(swash);
13557             swash = NULL;
13558         }
13559
13560         /* Clear the invert flag since have just done it here */
13561         invert = FALSE;
13562     }
13563
13564     if (ret_invlist) {
13565         *ret_invlist = cp_list;
13566
13567         /* Discard the generated node */
13568         if (SIZE_ONLY) {
13569             RExC_size = orig_size;
13570         }
13571         else {
13572             RExC_emit = orig_emit;
13573         }
13574         return orig_emit;
13575     }
13576
13577     /* If we didn't do folding, it's because some information isn't available
13578      * until runtime; set the run-time fold flag for these.  (We don't have to
13579      * worry about properties folding, as that is taken care of by the swash
13580      * fetching) */
13581     if (FOLD && LOC)
13582     {
13583        ANYOF_FLAGS(ret) |= ANYOF_LOC_FOLD;
13584     }
13585
13586     /* Some character classes are equivalent to other nodes.  Such nodes take
13587      * up less room and generally fewer operations to execute than ANYOF nodes.
13588      * Above, we checked for and optimized into some such equivalents for
13589      * certain common classes that are easy to test.  Getting to this point in
13590      * the code means that the class didn't get optimized there.  Since this
13591      * code is only executed in Pass 2, it is too late to save space--it has
13592      * been allocated in Pass 1, and currently isn't given back.  But turning
13593      * things into an EXACTish node can allow the optimizer to join it to any
13594      * adjacent such nodes.  And if the class is equivalent to things like /./,
13595      * expensive run-time swashes can be avoided.  Now that we have more
13596      * complete information, we can find things necessarily missed by the
13597      * earlier code.  I (khw) am not sure how much to look for here.  It would
13598      * be easy, but perhaps too slow, to check any candidates against all the
13599      * node types they could possibly match using _invlistEQ(). */
13600
13601     if (cp_list
13602         && ! invert
13603         && ! depends_list
13604         && ! (ANYOF_FLAGS(ret) & ANYOF_CLASS)
13605         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
13606     {
13607         UV start, end;
13608         U8 op = END;  /* The optimzation node-type */
13609         const char * cur_parse= RExC_parse;
13610
13611         invlist_iterinit(cp_list);
13612         if (! invlist_iternext(cp_list, &start, &end)) {
13613
13614             /* Here, the list is empty.  This happens, for example, when a
13615              * Unicode property is the only thing in the character class, and
13616              * it doesn't match anything.  (perluniprops.pod notes such
13617              * properties) */
13618             op = OPFAIL;
13619             *flagp |= HASWIDTH|SIMPLE;
13620         }
13621         else if (start == end) {    /* The range is a single code point */
13622             if (! invlist_iternext(cp_list, &start, &end)
13623
13624                     /* Don't do this optimization if it would require changing
13625                      * the pattern to UTF-8 */
13626                 && (start < 256 || UTF))
13627             {
13628                 /* Here, the list contains a single code point.  Can optimize
13629                  * into an EXACT node */
13630
13631                 value = start;
13632
13633                 if (! FOLD) {
13634                     op = EXACT;
13635                 }
13636                 else if (LOC) {
13637
13638                     /* A locale node under folding with one code point can be
13639                      * an EXACTFL, as its fold won't be calculated until
13640                      * runtime */
13641                     op = EXACTFL;
13642                 }
13643                 else {
13644
13645                     /* Here, we are generally folding, but there is only one
13646                      * code point to match.  If we have to, we use an EXACT
13647                      * node, but it would be better for joining with adjacent
13648                      * nodes in the optimization pass if we used the same
13649                      * EXACTFish node that any such are likely to be.  We can
13650                      * do this iff the code point doesn't participate in any
13651                      * folds.  For example, an EXACTF of a colon is the same as
13652                      * an EXACT one, since nothing folds to or from a colon. */
13653                     if (value < 256) {
13654                         if (IS_IN_SOME_FOLD_L1(value)) {
13655                             op = EXACT;
13656                         }
13657                     }
13658                     else {
13659                         if (! PL_utf8_foldable) {
13660                             SV* swash = swash_init("utf8", "_Perl_Any_Folds",
13661                                                 &PL_sv_undef, 1, 0);
13662                             PL_utf8_foldable = _get_swash_invlist(swash);
13663                             SvREFCNT_dec_NN(swash);
13664                         }
13665                         if (_invlist_contains_cp(PL_utf8_foldable, value)) {
13666                             op = EXACT;
13667                         }
13668                     }
13669
13670                     /* If we haven't found the node type, above, it means we
13671                      * can use the prevailing one */
13672                     if (op == END) {
13673                         op = compute_EXACTish(pRExC_state);
13674                     }
13675                 }
13676             }
13677         }
13678         else if (start == 0) {
13679             if (end == UV_MAX) {
13680                 op = SANY;
13681                 *flagp |= HASWIDTH|SIMPLE;
13682                 RExC_naughty++;
13683             }
13684             else if (end == '\n' - 1
13685                     && invlist_iternext(cp_list, &start, &end)
13686                     && start == '\n' + 1 && end == UV_MAX)
13687             {
13688                 op = REG_ANY;
13689                 *flagp |= HASWIDTH|SIMPLE;
13690                 RExC_naughty++;
13691             }
13692         }
13693         invlist_iterfinish(cp_list);
13694
13695         if (op != END) {
13696             RExC_parse = (char *)orig_parse;
13697             RExC_emit = (regnode *)orig_emit;
13698
13699             ret = reg_node(pRExC_state, op);
13700
13701             RExC_parse = (char *)cur_parse;
13702
13703             if (PL_regkind[op] == EXACT) {
13704                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value);
13705             }
13706
13707             SvREFCNT_dec_NN(cp_list);
13708             return ret;
13709         }
13710     }
13711
13712     /* Here, <cp_list> contains all the code points we can determine at
13713      * compile time that match under all conditions.  Go through it, and
13714      * for things that belong in the bitmap, put them there, and delete from
13715      * <cp_list>.  While we are at it, see if everything above 255 is in the
13716      * list, and if so, set a flag to speed up execution */
13717     ANYOF_BITMAP_ZERO(ret);
13718     if (cp_list) {
13719
13720         /* This gets set if we actually need to modify things */
13721         bool change_invlist = FALSE;
13722
13723         UV start, end;
13724
13725         /* Start looking through <cp_list> */
13726         invlist_iterinit(cp_list);
13727         while (invlist_iternext(cp_list, &start, &end)) {
13728             UV high;
13729             int i;
13730
13731             if (end == UV_MAX && start <= 256) {
13732                 ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
13733             }
13734
13735             /* Quit if are above what we should change */
13736             if (start > 255) {
13737                 break;
13738             }
13739
13740             change_invlist = TRUE;
13741
13742             /* Set all the bits in the range, up to the max that we are doing */
13743             high = (end < 255) ? end : 255;
13744             for (i = start; i <= (int) high; i++) {
13745                 if (! ANYOF_BITMAP_TEST(ret, i)) {
13746                     ANYOF_BITMAP_SET(ret, i);
13747                     prevvalue = value;
13748                     value = i;
13749                 }
13750             }
13751         }
13752         invlist_iterfinish(cp_list);
13753
13754         /* Done with loop; remove any code points that are in the bitmap from
13755          * <cp_list> */
13756         if (change_invlist) {
13757             _invlist_subtract(cp_list, PL_Latin1, &cp_list);
13758         }
13759
13760         /* If have completely emptied it, remove it completely */
13761         if (_invlist_len(cp_list) == 0) {
13762             SvREFCNT_dec_NN(cp_list);
13763             cp_list = NULL;
13764         }
13765     }
13766
13767     if (invert) {
13768         ANYOF_FLAGS(ret) |= ANYOF_INVERT;
13769     }
13770
13771     /* Here, the bitmap has been populated with all the Latin1 code points that
13772      * always match.  Can now add to the overall list those that match only
13773      * when the target string is UTF-8 (<depends_list>). */
13774     if (depends_list) {
13775         if (cp_list) {
13776             _invlist_union(cp_list, depends_list, &cp_list);
13777             SvREFCNT_dec_NN(depends_list);
13778         }
13779         else {
13780             cp_list = depends_list;
13781         }
13782     }
13783
13784     /* If there is a swash and more than one element, we can't use the swash in
13785      * the optimization below. */
13786     if (swash && element_count > 1) {
13787         SvREFCNT_dec_NN(swash);
13788         swash = NULL;
13789     }
13790
13791     if (! cp_list
13792         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
13793     {
13794         ARG_SET(ret, ANYOF_NONBITMAP_EMPTY);
13795     }
13796     else {
13797         /* av[0] stores the character class description in its textual form:
13798          *       used later (regexec.c:Perl_regclass_swash()) to initialize the
13799          *       appropriate swash, and is also useful for dumping the regnode.
13800          * av[1] if NULL, is a placeholder to later contain the swash computed
13801          *       from av[0].  But if no further computation need be done, the
13802          *       swash is stored there now.
13803          * av[2] stores the cp_list inversion list for use in addition or
13804          *       instead of av[0]; used only if av[1] is NULL
13805          * av[3] is set if any component of the class is from a user-defined
13806          *       property; used only if av[1] is NULL */
13807         AV * const av = newAV();
13808         SV *rv;
13809
13810         av_store(av, 0, (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
13811                         ? SvREFCNT_inc(listsv) : &PL_sv_undef);
13812         if (swash) {
13813             av_store(av, 1, swash);
13814             SvREFCNT_dec_NN(cp_list);
13815         }
13816         else {
13817             av_store(av, 1, NULL);
13818             if (cp_list) {
13819                 av_store(av, 2, cp_list);
13820                 av_store(av, 3, newSVuv(has_user_defined_property));
13821             }
13822         }
13823
13824         rv = newRV_noinc(MUTABLE_SV(av));
13825         n = add_data(pRExC_state, 1, "s");
13826         RExC_rxi->data->data[n] = (void*)rv;
13827         ARG_SET(ret, n);
13828     }
13829
13830     *flagp |= HASWIDTH|SIMPLE;
13831     return ret;
13832 }
13833 #undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
13834
13835
13836 /* reg_skipcomment()
13837
13838    Absorbs an /x style # comments from the input stream.
13839    Returns true if there is more text remaining in the stream.
13840    Will set the REG_SEEN_RUN_ON_COMMENT flag if the comment
13841    terminates the pattern without including a newline.
13842
13843    Note its the callers responsibility to ensure that we are
13844    actually in /x mode
13845
13846 */
13847
13848 STATIC bool
13849 S_reg_skipcomment(pTHX_ RExC_state_t *pRExC_state)
13850 {
13851     bool ended = 0;
13852
13853     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
13854
13855     while (RExC_parse < RExC_end)
13856         if (*RExC_parse++ == '\n') {
13857             ended = 1;
13858             break;
13859         }
13860     if (!ended) {
13861         /* we ran off the end of the pattern without ending
13862            the comment, so we have to add an \n when wrapping */
13863         RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
13864         return 0;
13865     } else
13866         return 1;
13867 }
13868
13869 /* nextchar()
13870
13871    Advances the parse position, and optionally absorbs
13872    "whitespace" from the inputstream.
13873
13874    Without /x "whitespace" means (?#...) style comments only,
13875    with /x this means (?#...) and # comments and whitespace proper.
13876
13877    Returns the RExC_parse point from BEFORE the scan occurs.
13878
13879    This is the /x friendly way of saying RExC_parse++.
13880 */
13881
13882 STATIC char*
13883 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
13884 {
13885     char* const retval = RExC_parse++;
13886
13887     PERL_ARGS_ASSERT_NEXTCHAR;
13888
13889     for (;;) {
13890         if (RExC_end - RExC_parse >= 3
13891             && *RExC_parse == '('
13892             && RExC_parse[1] == '?'
13893             && RExC_parse[2] == '#')
13894         {
13895             while (*RExC_parse != ')') {
13896                 if (RExC_parse == RExC_end)
13897                     FAIL("Sequence (?#... not terminated");
13898                 RExC_parse++;
13899             }
13900             RExC_parse++;
13901             continue;
13902         }
13903         if (RExC_flags & RXf_PMf_EXTENDED) {
13904             if (isSPACE(*RExC_parse)) {
13905                 RExC_parse++;
13906                 continue;
13907             }
13908             else if (*RExC_parse == '#') {
13909                 if ( reg_skipcomment( pRExC_state ) )
13910                     continue;
13911             }
13912         }
13913         return retval;
13914     }
13915 }
13916
13917 /*
13918 - reg_node - emit a node
13919 */
13920 STATIC regnode *                        /* Location. */
13921 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
13922 {
13923     dVAR;
13924     regnode *ptr;
13925     regnode * const ret = RExC_emit;
13926     GET_RE_DEBUG_FLAGS_DECL;
13927
13928     PERL_ARGS_ASSERT_REG_NODE;
13929
13930     if (SIZE_ONLY) {
13931         SIZE_ALIGN(RExC_size);
13932         RExC_size += 1;
13933         return(ret);
13934     }
13935     if (RExC_emit >= RExC_emit_bound)
13936         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
13937                    op, RExC_emit, RExC_emit_bound);
13938
13939     NODE_ALIGN_FILL(ret);
13940     ptr = ret;
13941     FILL_ADVANCE_NODE(ptr, op);
13942 #ifdef RE_TRACK_PATTERN_OFFSETS
13943     if (RExC_offsets) {         /* MJD */
13944         MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n", 
13945               "reg_node", __LINE__, 
13946               PL_reg_name[op],
13947               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] 
13948                 ? "Overwriting end of array!\n" : "OK",
13949               (UV)(RExC_emit - RExC_emit_start),
13950               (UV)(RExC_parse - RExC_start),
13951               (UV)RExC_offsets[0])); 
13952         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
13953     }
13954 #endif
13955     RExC_emit = ptr;
13956     return(ret);
13957 }
13958
13959 /*
13960 - reganode - emit a node with an argument
13961 */
13962 STATIC regnode *                        /* Location. */
13963 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
13964 {
13965     dVAR;
13966     regnode *ptr;
13967     regnode * const ret = RExC_emit;
13968     GET_RE_DEBUG_FLAGS_DECL;
13969
13970     PERL_ARGS_ASSERT_REGANODE;
13971
13972     if (SIZE_ONLY) {
13973         SIZE_ALIGN(RExC_size);
13974         RExC_size += 2;
13975         /* 
13976            We can't do this:
13977            
13978            assert(2==regarglen[op]+1); 
13979
13980            Anything larger than this has to allocate the extra amount.
13981            If we changed this to be:
13982            
13983            RExC_size += (1 + regarglen[op]);
13984            
13985            then it wouldn't matter. Its not clear what side effect
13986            might come from that so its not done so far.
13987            -- dmq
13988         */
13989         return(ret);
13990     }
13991     if (RExC_emit >= RExC_emit_bound)
13992         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
13993                    op, RExC_emit, RExC_emit_bound);
13994
13995     NODE_ALIGN_FILL(ret);
13996     ptr = ret;
13997     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
13998 #ifdef RE_TRACK_PATTERN_OFFSETS
13999     if (RExC_offsets) {         /* MJD */
14000         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
14001               "reganode",
14002               __LINE__,
14003               PL_reg_name[op],
14004               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? 
14005               "Overwriting end of array!\n" : "OK",
14006               (UV)(RExC_emit - RExC_emit_start),
14007               (UV)(RExC_parse - RExC_start),
14008               (UV)RExC_offsets[0])); 
14009         Set_Cur_Node_Offset;
14010     }
14011 #endif            
14012     RExC_emit = ptr;
14013     return(ret);
14014 }
14015
14016 /*
14017 - reguni - emit (if appropriate) a Unicode character
14018 */
14019 STATIC STRLEN
14020 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
14021 {
14022     dVAR;
14023
14024     PERL_ARGS_ASSERT_REGUNI;
14025
14026     return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
14027 }
14028
14029 /*
14030 - reginsert - insert an operator in front of already-emitted operand
14031 *
14032 * Means relocating the operand.
14033 */
14034 STATIC void
14035 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
14036 {
14037     dVAR;
14038     regnode *src;
14039     regnode *dst;
14040     regnode *place;
14041     const int offset = regarglen[(U8)op];
14042     const int size = NODE_STEP_REGNODE + offset;
14043     GET_RE_DEBUG_FLAGS_DECL;
14044
14045     PERL_ARGS_ASSERT_REGINSERT;
14046     PERL_UNUSED_ARG(depth);
14047 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
14048     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
14049     if (SIZE_ONLY) {
14050         RExC_size += size;
14051         return;
14052     }
14053
14054     src = RExC_emit;
14055     RExC_emit += size;
14056     dst = RExC_emit;
14057     if (RExC_open_parens) {
14058         int paren;
14059         /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
14060         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
14061             if ( RExC_open_parens[paren] >= opnd ) {
14062                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
14063                 RExC_open_parens[paren] += size;
14064             } else {
14065                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
14066             }
14067             if ( RExC_close_parens[paren] >= opnd ) {
14068                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
14069                 RExC_close_parens[paren] += size;
14070             } else {
14071                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
14072             }
14073         }
14074     }
14075
14076     while (src > opnd) {
14077         StructCopy(--src, --dst, regnode);
14078 #ifdef RE_TRACK_PATTERN_OFFSETS
14079         if (RExC_offsets) {     /* MJD 20010112 */
14080             MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
14081                   "reg_insert",
14082                   __LINE__,
14083                   PL_reg_name[op],
14084                   (UV)(dst - RExC_emit_start) > RExC_offsets[0] 
14085                     ? "Overwriting end of array!\n" : "OK",
14086                   (UV)(src - RExC_emit_start),
14087                   (UV)(dst - RExC_emit_start),
14088                   (UV)RExC_offsets[0])); 
14089             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
14090             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
14091         }
14092 #endif
14093     }
14094     
14095
14096     place = opnd;               /* Op node, where operand used to be. */
14097 #ifdef RE_TRACK_PATTERN_OFFSETS
14098     if (RExC_offsets) {         /* MJD */
14099         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
14100               "reginsert",
14101               __LINE__,
14102               PL_reg_name[op],
14103               (UV)(place - RExC_emit_start) > RExC_offsets[0] 
14104               ? "Overwriting end of array!\n" : "OK",
14105               (UV)(place - RExC_emit_start),
14106               (UV)(RExC_parse - RExC_start),
14107               (UV)RExC_offsets[0]));
14108         Set_Node_Offset(place, RExC_parse);
14109         Set_Node_Length(place, 1);
14110     }
14111 #endif    
14112     src = NEXTOPER(place);
14113     FILL_ADVANCE_NODE(place, op);
14114     Zero(src, offset, regnode);
14115 }
14116
14117 /*
14118 - regtail - set the next-pointer at the end of a node chain of p to val.
14119 - SEE ALSO: regtail_study
14120 */
14121 /* TODO: All three parms should be const */
14122 STATIC void
14123 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
14124 {
14125     dVAR;
14126     regnode *scan;
14127     GET_RE_DEBUG_FLAGS_DECL;
14128
14129     PERL_ARGS_ASSERT_REGTAIL;
14130 #ifndef DEBUGGING
14131     PERL_UNUSED_ARG(depth);
14132 #endif
14133
14134     if (SIZE_ONLY)
14135         return;
14136
14137     /* Find last node. */
14138     scan = p;
14139     for (;;) {
14140         regnode * const temp = regnext(scan);
14141         DEBUG_PARSE_r({
14142             SV * const mysv=sv_newmortal();
14143             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
14144             regprop(RExC_rx, mysv, scan);
14145             PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
14146                 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
14147                     (temp == NULL ? "->" : ""),
14148                     (temp == NULL ? PL_reg_name[OP(val)] : "")
14149             );
14150         });
14151         if (temp == NULL)
14152             break;
14153         scan = temp;
14154     }
14155
14156     if (reg_off_by_arg[OP(scan)]) {
14157         ARG_SET(scan, val - scan);
14158     }
14159     else {
14160         NEXT_OFF(scan) = val - scan;
14161     }
14162 }
14163
14164 #ifdef DEBUGGING
14165 /*
14166 - regtail_study - set the next-pointer at the end of a node chain of p to val.
14167 - Look for optimizable sequences at the same time.
14168 - currently only looks for EXACT chains.
14169
14170 This is experimental code. The idea is to use this routine to perform 
14171 in place optimizations on branches and groups as they are constructed,
14172 with the long term intention of removing optimization from study_chunk so
14173 that it is purely analytical.
14174
14175 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
14176 to control which is which.
14177
14178 */
14179 /* TODO: All four parms should be const */
14180
14181 STATIC U8
14182 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
14183 {
14184     dVAR;
14185     regnode *scan;
14186     U8 exact = PSEUDO;
14187 #ifdef EXPERIMENTAL_INPLACESCAN
14188     I32 min = 0;
14189 #endif
14190     GET_RE_DEBUG_FLAGS_DECL;
14191
14192     PERL_ARGS_ASSERT_REGTAIL_STUDY;
14193
14194
14195     if (SIZE_ONLY)
14196         return exact;
14197
14198     /* Find last node. */
14199
14200     scan = p;
14201     for (;;) {
14202         regnode * const temp = regnext(scan);
14203 #ifdef EXPERIMENTAL_INPLACESCAN
14204         if (PL_regkind[OP(scan)] == EXACT) {
14205             bool has_exactf_sharp_s;    /* Unexamined in this routine */
14206             if (join_exact(pRExC_state,scan,&min, &has_exactf_sharp_s, 1,val,depth+1))
14207                 return EXACT;
14208         }
14209 #endif
14210         if ( exact ) {
14211             switch (OP(scan)) {
14212                 case EXACT:
14213                 case EXACTF:
14214                 case EXACTFA:
14215                 case EXACTFU:
14216                 case EXACTFU_SS:
14217                 case EXACTFU_TRICKYFOLD:
14218                 case EXACTFL:
14219                         if( exact == PSEUDO )
14220                             exact= OP(scan);
14221                         else if ( exact != OP(scan) )
14222                             exact= 0;
14223                 case NOTHING:
14224                     break;
14225                 default:
14226                     exact= 0;
14227             }
14228         }
14229         DEBUG_PARSE_r({
14230             SV * const mysv=sv_newmortal();
14231             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
14232             regprop(RExC_rx, mysv, scan);
14233             PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
14234                 SvPV_nolen_const(mysv),
14235                 REG_NODE_NUM(scan),
14236                 PL_reg_name[exact]);
14237         });
14238         if (temp == NULL)
14239             break;
14240         scan = temp;
14241     }
14242     DEBUG_PARSE_r({
14243         SV * const mysv_val=sv_newmortal();
14244         DEBUG_PARSE_MSG("");
14245         regprop(RExC_rx, mysv_val, val);
14246         PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
14247                       SvPV_nolen_const(mysv_val),
14248                       (IV)REG_NODE_NUM(val),
14249                       (IV)(val - scan)
14250         );
14251     });
14252     if (reg_off_by_arg[OP(scan)]) {
14253         ARG_SET(scan, val - scan);
14254     }
14255     else {
14256         NEXT_OFF(scan) = val - scan;
14257     }
14258
14259     return exact;
14260 }
14261 #endif
14262
14263 /*
14264  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
14265  */
14266 #ifdef DEBUGGING
14267 static void 
14268 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
14269 {
14270     int bit;
14271     int set=0;
14272     regex_charset cs;
14273
14274     for (bit=0; bit<32; bit++) {
14275         if (flags & (1<<bit)) {
14276             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
14277                 continue;
14278             }
14279             if (!set++ && lead) 
14280                 PerlIO_printf(Perl_debug_log, "%s",lead);
14281             PerlIO_printf(Perl_debug_log, "%s ",PL_reg_extflags_name[bit]);
14282         }               
14283     }      
14284     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
14285             if (!set++ && lead) {
14286                 PerlIO_printf(Perl_debug_log, "%s",lead);
14287             }
14288             switch (cs) {
14289                 case REGEX_UNICODE_CHARSET:
14290                     PerlIO_printf(Perl_debug_log, "UNICODE");
14291                     break;
14292                 case REGEX_LOCALE_CHARSET:
14293                     PerlIO_printf(Perl_debug_log, "LOCALE");
14294                     break;
14295                 case REGEX_ASCII_RESTRICTED_CHARSET:
14296                     PerlIO_printf(Perl_debug_log, "ASCII-RESTRICTED");
14297                     break;
14298                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
14299                     PerlIO_printf(Perl_debug_log, "ASCII-MORE_RESTRICTED");
14300                     break;
14301                 default:
14302                     PerlIO_printf(Perl_debug_log, "UNKNOWN CHARACTER SET");
14303                     break;
14304             }
14305     }
14306     if (lead)  {
14307         if (set) 
14308             PerlIO_printf(Perl_debug_log, "\n");
14309         else 
14310             PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
14311     }            
14312 }   
14313 #endif
14314
14315 void
14316 Perl_regdump(pTHX_ const regexp *r)
14317 {
14318 #ifdef DEBUGGING
14319     dVAR;
14320     SV * const sv = sv_newmortal();
14321     SV *dsv= sv_newmortal();
14322     RXi_GET_DECL(r,ri);
14323     GET_RE_DEBUG_FLAGS_DECL;
14324
14325     PERL_ARGS_ASSERT_REGDUMP;
14326
14327     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
14328
14329     /* Header fields of interest. */
14330     if (r->anchored_substr) {
14331         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr), 
14332             RE_SV_DUMPLEN(r->anchored_substr), 30);
14333         PerlIO_printf(Perl_debug_log,
14334                       "anchored %s%s at %"IVdf" ",
14335                       s, RE_SV_TAIL(r->anchored_substr),
14336                       (IV)r->anchored_offset);
14337     } else if (r->anchored_utf8) {
14338         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8), 
14339             RE_SV_DUMPLEN(r->anchored_utf8), 30);
14340         PerlIO_printf(Perl_debug_log,
14341                       "anchored utf8 %s%s at %"IVdf" ",
14342                       s, RE_SV_TAIL(r->anchored_utf8),
14343                       (IV)r->anchored_offset);
14344     }                 
14345     if (r->float_substr) {
14346         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr), 
14347             RE_SV_DUMPLEN(r->float_substr), 30);
14348         PerlIO_printf(Perl_debug_log,
14349                       "floating %s%s at %"IVdf"..%"UVuf" ",
14350                       s, RE_SV_TAIL(r->float_substr),
14351                       (IV)r->float_min_offset, (UV)r->float_max_offset);
14352     } else if (r->float_utf8) {
14353         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8), 
14354             RE_SV_DUMPLEN(r->float_utf8), 30);
14355         PerlIO_printf(Perl_debug_log,
14356                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
14357                       s, RE_SV_TAIL(r->float_utf8),
14358                       (IV)r->float_min_offset, (UV)r->float_max_offset);
14359     }
14360     if (r->check_substr || r->check_utf8)
14361         PerlIO_printf(Perl_debug_log,
14362                       (const char *)
14363                       (r->check_substr == r->float_substr
14364                        && r->check_utf8 == r->float_utf8
14365                        ? "(checking floating" : "(checking anchored"));
14366     if (r->extflags & RXf_NOSCAN)
14367         PerlIO_printf(Perl_debug_log, " noscan");
14368     if (r->extflags & RXf_CHECK_ALL)
14369         PerlIO_printf(Perl_debug_log, " isall");
14370     if (r->check_substr || r->check_utf8)
14371         PerlIO_printf(Perl_debug_log, ") ");
14372
14373     if (ri->regstclass) {
14374         regprop(r, sv, ri->regstclass);
14375         PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
14376     }
14377     if (r->extflags & RXf_ANCH) {
14378         PerlIO_printf(Perl_debug_log, "anchored");
14379         if (r->extflags & RXf_ANCH_BOL)
14380             PerlIO_printf(Perl_debug_log, "(BOL)");
14381         if (r->extflags & RXf_ANCH_MBOL)
14382             PerlIO_printf(Perl_debug_log, "(MBOL)");
14383         if (r->extflags & RXf_ANCH_SBOL)
14384             PerlIO_printf(Perl_debug_log, "(SBOL)");
14385         if (r->extflags & RXf_ANCH_GPOS)
14386             PerlIO_printf(Perl_debug_log, "(GPOS)");
14387         PerlIO_putc(Perl_debug_log, ' ');
14388     }
14389     if (r->extflags & RXf_GPOS_SEEN)
14390         PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
14391     if (r->intflags & PREGf_SKIP)
14392         PerlIO_printf(Perl_debug_log, "plus ");
14393     if (r->intflags & PREGf_IMPLICIT)
14394         PerlIO_printf(Perl_debug_log, "implicit ");
14395     PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
14396     if (r->extflags & RXf_EVAL_SEEN)
14397         PerlIO_printf(Perl_debug_log, "with eval ");
14398     PerlIO_printf(Perl_debug_log, "\n");
14399     DEBUG_FLAGS_r(regdump_extflags("r->extflags: ",r->extflags));            
14400 #else
14401     PERL_ARGS_ASSERT_REGDUMP;
14402     PERL_UNUSED_CONTEXT;
14403     PERL_UNUSED_ARG(r);
14404 #endif  /* DEBUGGING */
14405 }
14406
14407 /*
14408 - regprop - printable representation of opcode
14409 */
14410 #define EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags) \
14411 STMT_START { \
14412         if (do_sep) {                           \
14413             Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]); \
14414             if (flags & ANYOF_INVERT)           \
14415                 /*make sure the invert info is in each */ \
14416                 sv_catpvs(sv, "^");             \
14417             do_sep = 0;                         \
14418         }                                       \
14419 } STMT_END
14420
14421 void
14422 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
14423 {
14424 #ifdef DEBUGGING
14425     dVAR;
14426     int k;
14427
14428     /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
14429     static const char * const anyofs[] = {
14430 #if _CC_WORDCHAR != 0 || _CC_DIGIT != 1 || _CC_ALPHA != 2 || _CC_LOWER != 3 \
14431     || _CC_UPPER != 4 || _CC_PUNCT != 5 || _CC_PRINT != 6                   \
14432     || _CC_ALPHANUMERIC != 7 || _CC_GRAPH != 8 || _CC_CASED != 9            \
14433     || _CC_SPACE != 10 || _CC_BLANK != 11 || _CC_XDIGIT != 12               \
14434     || _CC_PSXSPC != 13 || _CC_CNTRL != 14 || _CC_ASCII != 15               \
14435     || _CC_VERTSPACE != 16
14436   #error Need to adjust order of anyofs[]
14437 #endif
14438         "[\\w]",
14439         "[\\W]",
14440         "[\\d]",
14441         "[\\D]",
14442         "[:alpha:]",
14443         "[:^alpha:]",
14444         "[:lower:]",
14445         "[:^lower:]",
14446         "[:upper:]",
14447         "[:^upper:]",
14448         "[:punct:]",
14449         "[:^punct:]",
14450         "[:print:]",
14451         "[:^print:]",
14452         "[:alnum:]",
14453         "[:^alnum:]",
14454         "[:graph:]",
14455         "[:^graph:]",
14456         "[:cased:]",
14457         "[:^cased:]",
14458         "[\\s]",
14459         "[\\S]",
14460         "[:blank:]",
14461         "[:^blank:]",
14462         "[:xdigit:]",
14463         "[:^xdigit:]",
14464         "[:space:]",
14465         "[:^space:]",
14466         "[:cntrl:]",
14467         "[:^cntrl:]",
14468         "[:ascii:]",
14469         "[:^ascii:]",
14470         "[\\v]",
14471         "[\\V]"
14472     };
14473     RXi_GET_DECL(prog,progi);
14474     GET_RE_DEBUG_FLAGS_DECL;
14475     
14476     PERL_ARGS_ASSERT_REGPROP;
14477
14478     sv_setpvs(sv, "");
14479
14480     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
14481         /* It would be nice to FAIL() here, but this may be called from
14482            regexec.c, and it would be hard to supply pRExC_state. */
14483         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
14484     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
14485
14486     k = PL_regkind[OP(o)];
14487
14488     if (k == EXACT) {
14489         sv_catpvs(sv, " ");
14490         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT) 
14491          * is a crude hack but it may be the best for now since 
14492          * we have no flag "this EXACTish node was UTF-8" 
14493          * --jhi */
14494         pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
14495                   PERL_PV_ESCAPE_UNI_DETECT |
14496                   PERL_PV_ESCAPE_NONASCII   |
14497                   PERL_PV_PRETTY_ELLIPSES   |
14498                   PERL_PV_PRETTY_LTGT       |
14499                   PERL_PV_PRETTY_NOCLEAR
14500                   );
14501     } else if (k == TRIE) {
14502         /* print the details of the trie in dumpuntil instead, as
14503          * progi->data isn't available here */
14504         const char op = OP(o);
14505         const U32 n = ARG(o);
14506         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
14507                (reg_ac_data *)progi->data->data[n] :
14508                NULL;
14509         const reg_trie_data * const trie
14510             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
14511         
14512         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
14513         DEBUG_TRIE_COMPILE_r(
14514             Perl_sv_catpvf(aTHX_ sv,
14515                 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
14516                 (UV)trie->startstate,
14517                 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
14518                 (UV)trie->wordcount,
14519                 (UV)trie->minlen,
14520                 (UV)trie->maxlen,
14521                 (UV)TRIE_CHARCOUNT(trie),
14522                 (UV)trie->uniquecharcount
14523             )
14524         );
14525         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
14526             int i;
14527             int rangestart = -1;
14528             U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
14529             sv_catpvs(sv, "[");
14530             for (i = 0; i <= 256; i++) {
14531                 if (i < 256 && BITMAP_TEST(bitmap,i)) {
14532                     if (rangestart == -1)
14533                         rangestart = i;
14534                 } else if (rangestart != -1) {
14535                     if (i <= rangestart + 3)
14536                         for (; rangestart < i; rangestart++)
14537                             put_byte(sv, rangestart);
14538                     else {
14539                         put_byte(sv, rangestart);
14540                         sv_catpvs(sv, "-");
14541                         put_byte(sv, i - 1);
14542                     }
14543                     rangestart = -1;
14544                 }
14545             }
14546             sv_catpvs(sv, "]");
14547         } 
14548          
14549     } else if (k == CURLY) {
14550         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
14551             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
14552         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
14553     }
14554     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
14555         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
14556     else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
14557         Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
14558         if ( RXp_PAREN_NAMES(prog) ) {
14559             if ( k != REF || (OP(o) < NREF)) {
14560                 AV *list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
14561                 SV **name= av_fetch(list, ARG(o), 0 );
14562                 if (name)
14563                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
14564             }       
14565             else {
14566                 AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]);
14567                 SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]);
14568                 I32 *nums=(I32*)SvPVX(sv_dat);
14569                 SV **name= av_fetch(list, nums[0], 0 );
14570                 I32 n;
14571                 if (name) {
14572                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
14573                         Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
14574                                     (n ? "," : ""), (IV)nums[n]);
14575                     }
14576                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
14577                 }
14578             }
14579         }            
14580     } else if (k == GOSUB) 
14581         Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
14582     else if (k == VERB) {
14583         if (!o->flags) 
14584             Perl_sv_catpvf(aTHX_ sv, ":%"SVf, 
14585                            SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
14586     } else if (k == LOGICAL)
14587         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);     /* 2: embedded, otherwise 1 */
14588     else if (k == ANYOF) {
14589         int i, rangestart = -1;
14590         const U8 flags = ANYOF_FLAGS(o);
14591         int do_sep = 0;
14592
14593
14594         if (flags & ANYOF_LOCALE)
14595             sv_catpvs(sv, "{loc}");
14596         if (flags & ANYOF_LOC_FOLD)
14597             sv_catpvs(sv, "{i}");
14598         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
14599         if (flags & ANYOF_INVERT)
14600             sv_catpvs(sv, "^");
14601
14602         /* output what the standard cp 0-255 bitmap matches */
14603         for (i = 0; i <= 256; i++) {
14604             if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
14605                 if (rangestart == -1)
14606                     rangestart = i;
14607             } else if (rangestart != -1) {
14608                 if (i <= rangestart + 3)
14609                     for (; rangestart < i; rangestart++)
14610                         put_byte(sv, rangestart);
14611                 else {
14612                     put_byte(sv, rangestart);
14613                     sv_catpvs(sv, "-");
14614                     put_byte(sv, i - 1);
14615                 }
14616                 do_sep = 1;
14617                 rangestart = -1;
14618             }
14619         }
14620         
14621         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
14622         /* output any special charclass tests (used entirely under use locale) */
14623         if (ANYOF_CLASS_TEST_ANY_SET(o))
14624             for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
14625                 if (ANYOF_CLASS_TEST(o,i)) {
14626                     sv_catpv(sv, anyofs[i]);
14627                     do_sep = 1;
14628                 }
14629         
14630         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
14631         
14632         if (flags & ANYOF_NON_UTF8_LATIN1_ALL) {
14633             sv_catpvs(sv, "{non-utf8-latin1-all}");
14634         }
14635
14636         /* output information about the unicode matching */
14637         if (flags & ANYOF_UNICODE_ALL)
14638             sv_catpvs(sv, "{unicode_all}");
14639         else if (ANYOF_NONBITMAP(o))
14640             sv_catpvs(sv, "{unicode}");
14641         if (flags & ANYOF_NONBITMAP_NON_UTF8)
14642             sv_catpvs(sv, "{outside bitmap}");
14643
14644         if (ANYOF_NONBITMAP(o)) {
14645             SV *lv; /* Set if there is something outside the bit map */
14646             SV * const sw = regclass_swash(prog, o, FALSE, &lv, NULL);
14647             bool byte_output = FALSE;   /* If something in the bitmap has been
14648                                            output */
14649
14650             if (lv && lv != &PL_sv_undef) {
14651                 if (sw) {
14652                     U8 s[UTF8_MAXBYTES_CASE+1];
14653
14654                     for (i = 0; i <= 256; i++) { /* Look at chars in bitmap */
14655                         uvchr_to_utf8(s, i);
14656
14657                         if (i < 256
14658                             && ! ANYOF_BITMAP_TEST(o, i)    /* Don't duplicate
14659                                                                things already
14660                                                                output as part
14661                                                                of the bitmap */
14662                             && swash_fetch(sw, s, TRUE))
14663                         {
14664                             if (rangestart == -1)
14665                                 rangestart = i;
14666                         } else if (rangestart != -1) {
14667                             byte_output = TRUE;
14668                             if (i <= rangestart + 3)
14669                                 for (; rangestart < i; rangestart++) {
14670                                     put_byte(sv, rangestart);
14671                                 }
14672                             else {
14673                                 put_byte(sv, rangestart);
14674                                 sv_catpvs(sv, "-");
14675                                 put_byte(sv, i-1);
14676                             }
14677                             rangestart = -1;
14678                         }
14679                     }
14680                 }
14681
14682                 {
14683                     char *s = savesvpv(lv);
14684                     char * const origs = s;
14685
14686                     while (*s && *s != '\n')
14687                         s++;
14688
14689                     if (*s == '\n') {
14690                         const char * const t = ++s;
14691
14692                         if (byte_output) {
14693                             sv_catpvs(sv, " ");
14694                         }
14695
14696                         while (*s) {
14697                             if (*s == '\n') {
14698
14699                                 /* Truncate very long output */
14700                                 if (s - origs > 256) {
14701                                     Perl_sv_catpvf(aTHX_ sv,
14702                                                    "%.*s...",
14703                                                    (int) (s - origs - 1),
14704                                                    t);
14705                                     goto out_dump;
14706                                 }
14707                                 *s = ' ';
14708                             }
14709                             else if (*s == '\t') {
14710                                 *s = '-';
14711                             }
14712                             s++;
14713                         }
14714                         if (s[-1] == ' ')
14715                             s[-1] = 0;
14716
14717                         sv_catpv(sv, t);
14718                     }
14719
14720                 out_dump:
14721
14722                     Safefree(origs);
14723                 }
14724                 SvREFCNT_dec_NN(lv);
14725             }
14726         }
14727
14728         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
14729     }
14730     else if (k == POSIXD || k == NPOSIXD) {
14731         U8 index = FLAGS(o) * 2;
14732         if (index > (sizeof(anyofs) / sizeof(anyofs[0]))) {
14733             Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
14734         }
14735         else {
14736             sv_catpv(sv, anyofs[index]);
14737         }
14738     }
14739     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
14740         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
14741 #else
14742     PERL_UNUSED_CONTEXT;
14743     PERL_UNUSED_ARG(sv);
14744     PERL_UNUSED_ARG(o);
14745     PERL_UNUSED_ARG(prog);
14746 #endif  /* DEBUGGING */
14747 }
14748
14749 SV *
14750 Perl_re_intuit_string(pTHX_ REGEXP * const r)
14751 {                               /* Assume that RE_INTUIT is set */
14752     dVAR;
14753     struct regexp *const prog = ReANY(r);
14754     GET_RE_DEBUG_FLAGS_DECL;
14755
14756     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
14757     PERL_UNUSED_CONTEXT;
14758
14759     DEBUG_COMPILE_r(
14760         {
14761             const char * const s = SvPV_nolen_const(prog->check_substr
14762                       ? prog->check_substr : prog->check_utf8);
14763
14764             if (!PL_colorset) reginitcolors();
14765             PerlIO_printf(Perl_debug_log,
14766                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
14767                       PL_colors[4],
14768                       prog->check_substr ? "" : "utf8 ",
14769                       PL_colors[5],PL_colors[0],
14770                       s,
14771                       PL_colors[1],
14772                       (strlen(s) > 60 ? "..." : ""));
14773         } );
14774
14775     return prog->check_substr ? prog->check_substr : prog->check_utf8;
14776 }
14777
14778 /* 
14779    pregfree() 
14780    
14781    handles refcounting and freeing the perl core regexp structure. When 
14782    it is necessary to actually free the structure the first thing it 
14783    does is call the 'free' method of the regexp_engine associated to
14784    the regexp, allowing the handling of the void *pprivate; member 
14785    first. (This routine is not overridable by extensions, which is why 
14786    the extensions free is called first.)
14787    
14788    See regdupe and regdupe_internal if you change anything here. 
14789 */
14790 #ifndef PERL_IN_XSUB_RE
14791 void
14792 Perl_pregfree(pTHX_ REGEXP *r)
14793 {
14794     SvREFCNT_dec(r);
14795 }
14796
14797 void
14798 Perl_pregfree2(pTHX_ REGEXP *rx)
14799 {
14800     dVAR;
14801     struct regexp *const r = ReANY(rx);
14802     GET_RE_DEBUG_FLAGS_DECL;
14803
14804     PERL_ARGS_ASSERT_PREGFREE2;
14805
14806     if (r->mother_re) {
14807         ReREFCNT_dec(r->mother_re);
14808     } else {
14809         CALLREGFREE_PVT(rx); /* free the private data */
14810         SvREFCNT_dec(RXp_PAREN_NAMES(r));
14811         Safefree(r->xpv_len_u.xpvlenu_pv);
14812     }        
14813     if (r->substrs) {
14814         SvREFCNT_dec(r->anchored_substr);
14815         SvREFCNT_dec(r->anchored_utf8);
14816         SvREFCNT_dec(r->float_substr);
14817         SvREFCNT_dec(r->float_utf8);
14818         Safefree(r->substrs);
14819     }
14820     RX_MATCH_COPY_FREE(rx);
14821 #ifdef PERL_ANY_COW
14822     SvREFCNT_dec(r->saved_copy);
14823 #endif
14824     Safefree(r->offs);
14825     SvREFCNT_dec(r->qr_anoncv);
14826     rx->sv_u.svu_rx = 0;
14827 }
14828
14829 /*  reg_temp_copy()
14830     
14831     This is a hacky workaround to the structural issue of match results
14832     being stored in the regexp structure which is in turn stored in
14833     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
14834     could be PL_curpm in multiple contexts, and could require multiple
14835     result sets being associated with the pattern simultaneously, such
14836     as when doing a recursive match with (??{$qr})
14837     
14838     The solution is to make a lightweight copy of the regexp structure 
14839     when a qr// is returned from the code executed by (??{$qr}) this
14840     lightweight copy doesn't actually own any of its data except for
14841     the starp/end and the actual regexp structure itself. 
14842     
14843 */    
14844     
14845     
14846 REGEXP *
14847 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
14848 {
14849     struct regexp *ret;
14850     struct regexp *const r = ReANY(rx);
14851     const bool islv = ret_x && SvTYPE(ret_x) == SVt_PVLV;
14852
14853     PERL_ARGS_ASSERT_REG_TEMP_COPY;
14854
14855     if (!ret_x)
14856         ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
14857     else {
14858         SvOK_off((SV *)ret_x);
14859         if (islv) {
14860             /* For PVLVs, SvANY points to the xpvlv body while sv_u points
14861                to the regexp.  (For SVt_REGEXPs, sv_upgrade has already
14862                made both spots point to the same regexp body.) */
14863             REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
14864             assert(!SvPVX(ret_x));
14865             ret_x->sv_u.svu_rx = temp->sv_any;
14866             temp->sv_any = NULL;
14867             SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
14868             SvREFCNT_dec_NN(temp);
14869             /* SvCUR still resides in the xpvlv struct, so the regexp copy-
14870                ing below will not set it. */
14871             SvCUR_set(ret_x, SvCUR(rx));
14872         }
14873     }
14874     /* This ensures that SvTHINKFIRST(sv) is true, and hence that
14875        sv_force_normal(sv) is called.  */
14876     SvFAKE_on(ret_x);
14877     ret = ReANY(ret_x);
14878     
14879     SvFLAGS(ret_x) |= SvUTF8(rx);
14880     /* We share the same string buffer as the original regexp, on which we
14881        hold a reference count, incremented when mother_re is set below.
14882        The string pointer is copied here, being part of the regexp struct.
14883      */
14884     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
14885            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
14886     if (r->offs) {
14887         const I32 npar = r->nparens+1;
14888         Newx(ret->offs, npar, regexp_paren_pair);
14889         Copy(r->offs, ret->offs, npar, regexp_paren_pair);
14890     }
14891     if (r->substrs) {
14892         Newx(ret->substrs, 1, struct reg_substr_data);
14893         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
14894
14895         SvREFCNT_inc_void(ret->anchored_substr);
14896         SvREFCNT_inc_void(ret->anchored_utf8);
14897         SvREFCNT_inc_void(ret->float_substr);
14898         SvREFCNT_inc_void(ret->float_utf8);
14899
14900         /* check_substr and check_utf8, if non-NULL, point to either their
14901            anchored or float namesakes, and don't hold a second reference.  */
14902     }
14903     RX_MATCH_COPIED_off(ret_x);
14904 #ifdef PERL_ANY_COW
14905     ret->saved_copy = NULL;
14906 #endif
14907     ret->mother_re = ReREFCNT_inc(r->mother_re ? r->mother_re : rx);
14908     SvREFCNT_inc_void(ret->qr_anoncv);
14909     
14910     return ret_x;
14911 }
14912 #endif
14913
14914 /* regfree_internal() 
14915
14916    Free the private data in a regexp. This is overloadable by 
14917    extensions. Perl takes care of the regexp structure in pregfree(), 
14918    this covers the *pprivate pointer which technically perl doesn't 
14919    know about, however of course we have to handle the 
14920    regexp_internal structure when no extension is in use. 
14921    
14922    Note this is called before freeing anything in the regexp 
14923    structure. 
14924  */
14925  
14926 void
14927 Perl_regfree_internal(pTHX_ REGEXP * const rx)
14928 {
14929     dVAR;
14930     struct regexp *const r = ReANY(rx);
14931     RXi_GET_DECL(r,ri);
14932     GET_RE_DEBUG_FLAGS_DECL;
14933
14934     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
14935
14936     DEBUG_COMPILE_r({
14937         if (!PL_colorset)
14938             reginitcolors();
14939         {
14940             SV *dsv= sv_newmortal();
14941             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
14942                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
14943             PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n", 
14944                 PL_colors[4],PL_colors[5],s);
14945         }
14946     });
14947 #ifdef RE_TRACK_PATTERN_OFFSETS
14948     if (ri->u.offsets)
14949         Safefree(ri->u.offsets);             /* 20010421 MJD */
14950 #endif
14951     if (ri->code_blocks) {
14952         int n;
14953         for (n = 0; n < ri->num_code_blocks; n++)
14954             SvREFCNT_dec(ri->code_blocks[n].src_regex);
14955         Safefree(ri->code_blocks);
14956     }
14957
14958     if (ri->data) {
14959         int n = ri->data->count;
14960
14961         while (--n >= 0) {
14962           /* If you add a ->what type here, update the comment in regcomp.h */
14963             switch (ri->data->what[n]) {
14964             case 'a':
14965             case 'r':
14966             case 's':
14967             case 'S':
14968             case 'u':
14969                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
14970                 break;
14971             case 'f':
14972                 Safefree(ri->data->data[n]);
14973                 break;
14974             case 'l':
14975             case 'L':
14976                 break;
14977             case 'T':           
14978                 { /* Aho Corasick add-on structure for a trie node.
14979                      Used in stclass optimization only */
14980                     U32 refcount;
14981                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
14982                     OP_REFCNT_LOCK;
14983                     refcount = --aho->refcount;
14984                     OP_REFCNT_UNLOCK;
14985                     if ( !refcount ) {
14986                         PerlMemShared_free(aho->states);
14987                         PerlMemShared_free(aho->fail);
14988                          /* do this last!!!! */
14989                         PerlMemShared_free(ri->data->data[n]);
14990                         PerlMemShared_free(ri->regstclass);
14991                     }
14992                 }
14993                 break;
14994             case 't':
14995                 {
14996                     /* trie structure. */
14997                     U32 refcount;
14998                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
14999                     OP_REFCNT_LOCK;
15000                     refcount = --trie->refcount;
15001                     OP_REFCNT_UNLOCK;
15002                     if ( !refcount ) {
15003                         PerlMemShared_free(trie->charmap);
15004                         PerlMemShared_free(trie->states);
15005                         PerlMemShared_free(trie->trans);
15006                         if (trie->bitmap)
15007                             PerlMemShared_free(trie->bitmap);
15008                         if (trie->jump)
15009                             PerlMemShared_free(trie->jump);
15010                         PerlMemShared_free(trie->wordinfo);
15011                         /* do this last!!!! */
15012                         PerlMemShared_free(ri->data->data[n]);
15013                     }
15014                 }
15015                 break;
15016             default:
15017                 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
15018             }
15019         }
15020         Safefree(ri->data->what);
15021         Safefree(ri->data);
15022     }
15023
15024     Safefree(ri);
15025 }
15026
15027 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
15028 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
15029 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
15030
15031 /* 
15032    re_dup - duplicate a regexp. 
15033    
15034    This routine is expected to clone a given regexp structure. It is only
15035    compiled under USE_ITHREADS.
15036
15037    After all of the core data stored in struct regexp is duplicated
15038    the regexp_engine.dupe method is used to copy any private data
15039    stored in the *pprivate pointer. This allows extensions to handle
15040    any duplication it needs to do.
15041
15042    See pregfree() and regfree_internal() if you change anything here. 
15043 */
15044 #if defined(USE_ITHREADS)
15045 #ifndef PERL_IN_XSUB_RE
15046 void
15047 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
15048 {
15049     dVAR;
15050     I32 npar;
15051     const struct regexp *r = ReANY(sstr);
15052     struct regexp *ret = ReANY(dstr);
15053     
15054     PERL_ARGS_ASSERT_RE_DUP_GUTS;
15055
15056     npar = r->nparens+1;
15057     Newx(ret->offs, npar, regexp_paren_pair);
15058     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
15059
15060     if (ret->substrs) {
15061         /* Do it this way to avoid reading from *r after the StructCopy().
15062            That way, if any of the sv_dup_inc()s dislodge *r from the L1
15063            cache, it doesn't matter.  */
15064         const bool anchored = r->check_substr
15065             ? r->check_substr == r->anchored_substr
15066             : r->check_utf8 == r->anchored_utf8;
15067         Newx(ret->substrs, 1, struct reg_substr_data);
15068         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
15069
15070         ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
15071         ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
15072         ret->float_substr = sv_dup_inc(ret->float_substr, param);
15073         ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
15074
15075         /* check_substr and check_utf8, if non-NULL, point to either their
15076            anchored or float namesakes, and don't hold a second reference.  */
15077
15078         if (ret->check_substr) {
15079             if (anchored) {
15080                 assert(r->check_utf8 == r->anchored_utf8);
15081                 ret->check_substr = ret->anchored_substr;
15082                 ret->check_utf8 = ret->anchored_utf8;
15083             } else {
15084                 assert(r->check_substr == r->float_substr);
15085                 assert(r->check_utf8 == r->float_utf8);
15086                 ret->check_substr = ret->float_substr;
15087                 ret->check_utf8 = ret->float_utf8;
15088             }
15089         } else if (ret->check_utf8) {
15090             if (anchored) {
15091                 ret->check_utf8 = ret->anchored_utf8;
15092             } else {
15093                 ret->check_utf8 = ret->float_utf8;
15094             }
15095         }
15096     }
15097
15098     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
15099     ret->qr_anoncv = MUTABLE_CV(sv_dup_inc((const SV *)ret->qr_anoncv, param));
15100
15101     if (ret->pprivate)
15102         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
15103
15104     if (RX_MATCH_COPIED(dstr))
15105         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
15106     else
15107         ret->subbeg = NULL;
15108 #ifdef PERL_ANY_COW
15109     ret->saved_copy = NULL;
15110 #endif
15111
15112     /* Whether mother_re be set or no, we need to copy the string.  We
15113        cannot refrain from copying it when the storage points directly to
15114        our mother regexp, because that's
15115                1: a buffer in a different thread
15116                2: something we no longer hold a reference on
15117                so we need to copy it locally.  */
15118     RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED(sstr), SvCUR(sstr)+1);
15119     ret->mother_re   = NULL;
15120     ret->gofs = 0;
15121 }
15122 #endif /* PERL_IN_XSUB_RE */
15123
15124 /*
15125    regdupe_internal()
15126    
15127    This is the internal complement to regdupe() which is used to copy
15128    the structure pointed to by the *pprivate pointer in the regexp.
15129    This is the core version of the extension overridable cloning hook.
15130    The regexp structure being duplicated will be copied by perl prior
15131    to this and will be provided as the regexp *r argument, however 
15132    with the /old/ structures pprivate pointer value. Thus this routine
15133    may override any copying normally done by perl.
15134    
15135    It returns a pointer to the new regexp_internal structure.
15136 */
15137
15138 void *
15139 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
15140 {
15141     dVAR;
15142     struct regexp *const r = ReANY(rx);
15143     regexp_internal *reti;
15144     int len;
15145     RXi_GET_DECL(r,ri);
15146
15147     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
15148     
15149     len = ProgLen(ri);
15150     
15151     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), char, regexp_internal);
15152     Copy(ri->program, reti->program, len+1, regnode);
15153
15154     reti->num_code_blocks = ri->num_code_blocks;
15155     if (ri->code_blocks) {
15156         int n;
15157         Newxc(reti->code_blocks, ri->num_code_blocks, struct reg_code_block,
15158                 struct reg_code_block);
15159         Copy(ri->code_blocks, reti->code_blocks, ri->num_code_blocks,
15160                 struct reg_code_block);
15161         for (n = 0; n < ri->num_code_blocks; n++)
15162              reti->code_blocks[n].src_regex = (REGEXP*)
15163                     sv_dup_inc((SV*)(ri->code_blocks[n].src_regex), param);
15164     }
15165     else
15166         reti->code_blocks = NULL;
15167
15168     reti->regstclass = NULL;
15169
15170     if (ri->data) {
15171         struct reg_data *d;
15172         const int count = ri->data->count;
15173         int i;
15174
15175         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
15176                 char, struct reg_data);
15177         Newx(d->what, count, U8);
15178
15179         d->count = count;
15180         for (i = 0; i < count; i++) {
15181             d->what[i] = ri->data->what[i];
15182             switch (d->what[i]) {
15183                 /* see also regcomp.h and regfree_internal() */
15184             case 'a': /* actually an AV, but the dup function is identical.  */
15185             case 'r':
15186             case 's':
15187             case 'S':
15188             case 'u': /* actually an HV, but the dup function is identical.  */
15189                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
15190                 break;
15191             case 'f':
15192                 /* This is cheating. */
15193                 Newx(d->data[i], 1, struct regnode_charclass_class);
15194                 StructCopy(ri->data->data[i], d->data[i],
15195                             struct regnode_charclass_class);
15196                 reti->regstclass = (regnode*)d->data[i];
15197                 break;
15198             case 'T':
15199                 /* Trie stclasses are readonly and can thus be shared
15200                  * without duplication. We free the stclass in pregfree
15201                  * when the corresponding reg_ac_data struct is freed.
15202                  */
15203                 reti->regstclass= ri->regstclass;
15204                 /* Fall through */
15205             case 't':
15206                 OP_REFCNT_LOCK;
15207                 ((reg_trie_data*)ri->data->data[i])->refcount++;
15208                 OP_REFCNT_UNLOCK;
15209                 /* Fall through */
15210             case 'l':
15211             case 'L':
15212                 d->data[i] = ri->data->data[i];
15213                 break;
15214             default:
15215                 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
15216             }
15217         }
15218
15219         reti->data = d;
15220     }
15221     else
15222         reti->data = NULL;
15223
15224     reti->name_list_idx = ri->name_list_idx;
15225
15226 #ifdef RE_TRACK_PATTERN_OFFSETS
15227     if (ri->u.offsets) {
15228         Newx(reti->u.offsets, 2*len+1, U32);
15229         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
15230     }
15231 #else
15232     SetProgLen(reti,len);
15233 #endif
15234
15235     return (void*)reti;
15236 }
15237
15238 #endif    /* USE_ITHREADS */
15239
15240 #ifndef PERL_IN_XSUB_RE
15241
15242 /*
15243  - regnext - dig the "next" pointer out of a node
15244  */
15245 regnode *
15246 Perl_regnext(pTHX_ regnode *p)
15247 {
15248     dVAR;
15249     I32 offset;
15250
15251     if (!p)
15252         return(NULL);
15253
15254     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
15255         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(p), (int)REGNODE_MAX);
15256     }
15257
15258     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
15259     if (offset == 0)
15260         return(NULL);
15261
15262     return(p+offset);
15263 }
15264 #endif
15265
15266 STATIC void
15267 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
15268 {
15269     va_list args;
15270     STRLEN l1 = strlen(pat1);
15271     STRLEN l2 = strlen(pat2);
15272     char buf[512];
15273     SV *msv;
15274     const char *message;
15275
15276     PERL_ARGS_ASSERT_RE_CROAK2;
15277
15278     if (l1 > 510)
15279         l1 = 510;
15280     if (l1 + l2 > 510)
15281         l2 = 510 - l1;
15282     Copy(pat1, buf, l1 , char);
15283     Copy(pat2, buf + l1, l2 , char);
15284     buf[l1 + l2] = '\n';
15285     buf[l1 + l2 + 1] = '\0';
15286 #ifdef I_STDARG
15287     /* ANSI variant takes additional second argument */
15288     va_start(args, pat2);
15289 #else
15290     va_start(args);
15291 #endif
15292     msv = vmess(buf, &args);
15293     va_end(args);
15294     message = SvPV_const(msv,l1);
15295     if (l1 > 512)
15296         l1 = 512;
15297     Copy(message, buf, l1 , char);
15298     buf[l1-1] = '\0';                   /* Overwrite \n */
15299     Perl_croak(aTHX_ "%s", buf);
15300 }
15301
15302 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
15303
15304 #ifndef PERL_IN_XSUB_RE
15305 void
15306 Perl_save_re_context(pTHX)
15307 {
15308     dVAR;
15309
15310     struct re_save_state *state;
15311
15312     SAVEVPTR(PL_curcop);
15313     SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
15314
15315     state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
15316     PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
15317     SSPUSHUV(SAVEt_RE_STATE);
15318
15319     Copy(&PL_reg_state, state, 1, struct re_save_state);
15320
15321     PL_reg_oldsaved = NULL;
15322     PL_reg_oldsavedlen = 0;
15323     PL_reg_oldsavedoffset = 0;
15324     PL_reg_oldsavedcoffset = 0;
15325     PL_reg_maxiter = 0;
15326     PL_reg_leftiter = 0;
15327     PL_reg_poscache = NULL;
15328     PL_reg_poscache_size = 0;
15329 #ifdef PERL_ANY_COW
15330     PL_nrs = NULL;
15331 #endif
15332
15333     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
15334     if (PL_curpm) {
15335         const REGEXP * const rx = PM_GETRE(PL_curpm);
15336         if (rx) {
15337             U32 i;
15338             for (i = 1; i <= RX_NPARENS(rx); i++) {
15339                 char digits[TYPE_CHARS(long)];
15340                 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
15341                 GV *const *const gvp
15342                     = (GV**)hv_fetch(PL_defstash, digits, len, 0);
15343
15344                 if (gvp) {
15345                     GV * const gv = *gvp;
15346                     if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
15347                         save_scalar(gv);
15348                 }
15349             }
15350         }
15351     }
15352 }
15353 #endif
15354
15355 #ifdef DEBUGGING
15356
15357 STATIC void
15358 S_put_byte(pTHX_ SV *sv, int c)
15359 {
15360     PERL_ARGS_ASSERT_PUT_BYTE;
15361
15362     /* Our definition of isPRINT() ignores locales, so only bytes that are
15363        not part of UTF-8 are considered printable. I assume that the same
15364        holds for UTF-EBCDIC.
15365        Also, code point 255 is not printable in either (it's E0 in EBCDIC,
15366        which Wikipedia says:
15367
15368        EO, or Eight Ones, is an 8-bit EBCDIC character code represented as all
15369        ones (binary 1111 1111, hexadecimal FF). It is similar, but not
15370        identical, to the ASCII delete (DEL) or rubout control character. ...
15371        it is typically mapped to hexadecimal code 9F, in order to provide a
15372        unique character mapping in both directions)
15373
15374        So the old condition can be simplified to !isPRINT(c)  */
15375     if (!isPRINT(c)) {
15376         if (c < 256) {
15377             Perl_sv_catpvf(aTHX_ sv, "\\x%02x", c);
15378         }
15379         else {
15380             Perl_sv_catpvf(aTHX_ sv, "\\x{%x}", c);
15381         }
15382     }
15383     else {
15384         const char string = c;
15385         if (c == '-' || c == ']' || c == '\\' || c == '^')
15386             sv_catpvs(sv, "\\");
15387         sv_catpvn(sv, &string, 1);
15388     }
15389 }
15390
15391
15392 #define CLEAR_OPTSTART \
15393     if (optstart) STMT_START { \
15394             DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
15395             optstart=NULL; \
15396     } STMT_END
15397
15398 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
15399
15400 STATIC const regnode *
15401 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
15402             const regnode *last, const regnode *plast, 
15403             SV* sv, I32 indent, U32 depth)
15404 {
15405     dVAR;
15406     U8 op = PSEUDO;     /* Arbitrary non-END op. */
15407     const regnode *next;
15408     const regnode *optstart= NULL;
15409     
15410     RXi_GET_DECL(r,ri);
15411     GET_RE_DEBUG_FLAGS_DECL;
15412
15413     PERL_ARGS_ASSERT_DUMPUNTIL;
15414
15415 #ifdef DEBUG_DUMPUNTIL
15416     PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
15417         last ? last-start : 0,plast ? plast-start : 0);
15418 #endif
15419             
15420     if (plast && plast < last) 
15421         last= plast;
15422
15423     while (PL_regkind[op] != END && (!last || node < last)) {
15424         /* While that wasn't END last time... */
15425         NODE_ALIGN(node);
15426         op = OP(node);
15427         if (op == CLOSE || op == WHILEM)
15428             indent--;
15429         next = regnext((regnode *)node);
15430
15431         /* Where, what. */
15432         if (OP(node) == OPTIMIZED) {
15433             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
15434                 optstart = node;
15435             else
15436                 goto after_print;
15437         } else
15438             CLEAR_OPTSTART;
15439
15440         regprop(r, sv, node);
15441         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
15442                       (int)(2*indent + 1), "", SvPVX_const(sv));
15443         
15444         if (OP(node) != OPTIMIZED) {                  
15445             if (next == NULL)           /* Next ptr. */
15446                 PerlIO_printf(Perl_debug_log, " (0)");
15447             else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
15448                 PerlIO_printf(Perl_debug_log, " (FAIL)");
15449             else 
15450                 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
15451             (void)PerlIO_putc(Perl_debug_log, '\n'); 
15452         }
15453         
15454       after_print:
15455         if (PL_regkind[(U8)op] == BRANCHJ) {
15456             assert(next);
15457             {
15458                 const regnode *nnode = (OP(next) == LONGJMP
15459                                        ? regnext((regnode *)next)
15460                                        : next);
15461                 if (last && nnode > last)
15462                     nnode = last;
15463                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
15464             }
15465         }
15466         else if (PL_regkind[(U8)op] == BRANCH) {
15467             assert(next);
15468             DUMPUNTIL(NEXTOPER(node), next);
15469         }
15470         else if ( PL_regkind[(U8)op]  == TRIE ) {
15471             const regnode *this_trie = node;
15472             const char op = OP(node);
15473             const U32 n = ARG(node);
15474             const reg_ac_data * const ac = op>=AHOCORASICK ?
15475                (reg_ac_data *)ri->data->data[n] :
15476                NULL;
15477             const reg_trie_data * const trie =
15478                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
15479 #ifdef DEBUGGING
15480             AV *const trie_words = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
15481 #endif
15482             const regnode *nextbranch= NULL;
15483             I32 word_idx;
15484             sv_setpvs(sv, "");
15485             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
15486                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
15487
15488                 PerlIO_printf(Perl_debug_log, "%*s%s ",
15489                    (int)(2*(indent+3)), "",
15490                     elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
15491                             PL_colors[0], PL_colors[1],
15492                             (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
15493                             PERL_PV_PRETTY_ELLIPSES    |
15494                             PERL_PV_PRETTY_LTGT
15495                             )
15496                             : "???"
15497                 );
15498                 if (trie->jump) {
15499                     U16 dist= trie->jump[word_idx+1];
15500                     PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
15501                                   (UV)((dist ? this_trie + dist : next) - start));
15502                     if (dist) {
15503                         if (!nextbranch)
15504                             nextbranch= this_trie + trie->jump[0];    
15505                         DUMPUNTIL(this_trie + dist, nextbranch);
15506                     }
15507                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
15508                         nextbranch= regnext((regnode *)nextbranch);
15509                 } else {
15510                     PerlIO_printf(Perl_debug_log, "\n");
15511                 }
15512             }
15513             if (last && next > last)
15514                 node= last;
15515             else
15516                 node= next;
15517         }
15518         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
15519             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
15520                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
15521         }
15522         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
15523             assert(next);
15524             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
15525         }
15526         else if ( op == PLUS || op == STAR) {
15527             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
15528         }
15529         else if (PL_regkind[(U8)op] == ANYOF) {
15530             /* arglen 1 + class block */
15531             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_CLASS)
15532                     ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
15533             node = NEXTOPER(node);
15534         }
15535         else if (PL_regkind[(U8)op] == EXACT) {
15536             /* Literal string, where present. */
15537             node += NODE_SZ_STR(node) - 1;
15538             node = NEXTOPER(node);
15539         }
15540         else {
15541             node = NEXTOPER(node);
15542             node += regarglen[(U8)op];
15543         }
15544         if (op == CURLYX || op == OPEN)
15545             indent++;
15546     }
15547     CLEAR_OPTSTART;
15548 #ifdef DEBUG_DUMPUNTIL    
15549     PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
15550 #endif
15551     return node;
15552 }
15553
15554 #endif  /* DEBUGGING */
15555
15556 /*
15557  * Local variables:
15558  * c-indentation-style: bsd
15559  * c-basic-offset: 4
15560  * indent-tabs-mode: nil
15561  * End:
15562  *
15563  * ex: set ts=8 sts=4 sw=4 et:
15564  */