]> git.vpit.fr Git - perl/modules/re-engine-Hooks.git/blob - src/5018004/orig/regcomp.c
Add support for perl 5.23.[01]
[perl/modules/re-engine-Hooks.git] / src / 5018004 / orig / regcomp.c
1 /*    regcomp.c
2  */
3
4 /*
5  * 'A fair jaw-cracker dwarf-language must be.'            --Samwise Gamgee
6  *
7  *     [p.285 of _The Lord of the Rings_, II/iii: "The Ring Goes South"]
8  */
9
10 /* This file contains functions for compiling a regular expression.  See
11  * also regexec.c which funnily enough, contains functions for executing
12  * a regular expression.
13  *
14  * This file is also copied at build time to ext/re/re_comp.c, where
15  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
16  * This causes the main functions to be compiled under new names and with
17  * debugging support added, which makes "use re 'debug'" work.
18  */
19
20 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
21  * confused with the original package (see point 3 below).  Thanks, Henry!
22  */
23
24 /* Additional note: this code is very heavily munged from Henry's version
25  * in places.  In some spots I've traded clarity for efficiency, so don't
26  * blame Henry for some of the lack of readability.
27  */
28
29 /* The names of the functions have been changed from regcomp and
30  * regexec to pregcomp and pregexec in order to avoid conflicts
31  * with the POSIX routines of the same names.
32 */
33
34 #ifdef PERL_EXT_RE_BUILD
35 #include "re_top.h"
36 #endif
37
38 /*
39  * pregcomp and pregexec -- regsub and regerror are not used in perl
40  *
41  *      Copyright (c) 1986 by University of Toronto.
42  *      Written by Henry Spencer.  Not derived from licensed software.
43  *
44  *      Permission is granted to anyone to use this software for any
45  *      purpose on any computer system, and to redistribute it freely,
46  *      subject to the following restrictions:
47  *
48  *      1. The author is not responsible for the consequences of use of
49  *              this software, no matter how awful, even if they arise
50  *              from defects in it.
51  *
52  *      2. The origin of this software must not be misrepresented, either
53  *              by explicit claim or by omission.
54  *
55  *      3. Altered versions must be plainly marked as such, and must not
56  *              be misrepresented as being the original software.
57  *
58  *
59  ****    Alterations to Henry's code are...
60  ****
61  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
62  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
63  ****    by Larry Wall and others
64  ****
65  ****    You may distribute under the terms of either the GNU General Public
66  ****    License or the Artistic License, as specified in the README file.
67
68  *
69  * Beware that some of this code is subtly aware of the way operator
70  * precedence is structured in regular expressions.  Serious changes in
71  * regular-expression syntax might require a total rethink.
72  */
73 #include "EXTERN.h"
74 #define PERL_IN_REGCOMP_C
75 #include "perl.h"
76
77 #ifndef PERL_IN_XSUB_RE
78 #  include "INTERN.h"
79 #endif
80
81 #define REG_COMP_C
82 #ifdef PERL_IN_XSUB_RE
83 #  include "re_comp.h"
84 extern const struct regexp_engine my_reg_engine;
85 #else
86 #  include "regcomp.h"
87 #endif
88
89 #include "dquote_static.c"
90 #include "charclass_invlists.h"
91 #include "inline_invlist.c"
92 #include "unicode_constants.h"
93
94 #define HAS_NONLATIN1_FOLD_CLOSURE(i) _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
95 #define IS_NON_FINAL_FOLD(c) _IS_NON_FINAL_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
96 #define IS_IN_SOME_FOLD_L1(c) _IS_IN_SOME_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
97
98 #ifdef op
99 #undef op
100 #endif /* op */
101
102 #ifdef MSDOS
103 #  if defined(BUGGY_MSC6)
104  /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
105 #    pragma optimize("a",off)
106  /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
107 #    pragma optimize("w",on )
108 #  endif /* BUGGY_MSC6 */
109 #endif /* MSDOS */
110
111 #ifndef STATIC
112 #define STATIC  static
113 #endif
114
115
116 typedef struct RExC_state_t {
117     U32         flags;                  /* RXf_* are we folding, multilining? */
118     U32         pm_flags;               /* PMf_* stuff from the calling PMOP */
119     char        *precomp;               /* uncompiled string. */
120     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
121     regexp      *rx;                    /* perl core regexp structure */
122     regexp_internal     *rxi;           /* internal data for regexp object pprivate field */        
123     char        *start;                 /* Start of input for compile */
124     char        *end;                   /* End of input for compile */
125     char        *parse;                 /* Input-scan pointer. */
126     I32         whilem_seen;            /* number of WHILEM in this expr */
127     regnode     *emit_start;            /* Start of emitted-code area */
128     regnode     *emit_bound;            /* First regnode outside of the allocated space */
129     regnode     *emit;                  /* Code-emit pointer; &regdummy = don't = compiling */
130     I32         naughty;                /* How bad is this pattern? */
131     I32         sawback;                /* Did we see \1, ...? */
132     U32         seen;
133     I32         size;                   /* Code size. */
134     I32         npar;                   /* Capture buffer count, (OPEN). */
135     I32         cpar;                   /* Capture buffer count, (CLOSE). */
136     I32         nestroot;               /* root parens we are in - used by accept */
137     I32         extralen;
138     I32         seen_zerolen;
139     regnode     **open_parens;          /* pointers to open parens */
140     regnode     **close_parens;         /* pointers to close parens */
141     regnode     *opend;                 /* END node in program */
142     I32         utf8;           /* whether the pattern is utf8 or not */
143     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
144                                 /* XXX use this for future optimisation of case
145                                  * where pattern must be upgraded to utf8. */
146     I32         uni_semantics;  /* If a d charset modifier should use unicode
147                                    rules, even if the pattern is not in
148                                    utf8 */
149     HV          *paren_names;           /* Paren names */
150     
151     regnode     **recurse;              /* Recurse regops */
152     I32         recurse_count;          /* Number of recurse regops */
153     I32         in_lookbehind;
154     I32         contains_locale;
155     I32         override_recoding;
156     I32         in_multi_char_class;
157     struct reg_code_block *code_blocks; /* positions of literal (?{})
158                                             within pattern */
159     int         num_code_blocks;        /* size of code_blocks[] */
160     int         code_index;             /* next code_blocks[] slot */
161 #if ADD_TO_REGEXEC
162     char        *starttry;              /* -Dr: where regtry was called. */
163 #define RExC_starttry   (pRExC_state->starttry)
164 #endif
165     SV          *runtime_code_qr;       /* qr with the runtime code blocks */
166 #ifdef DEBUGGING
167     const char  *lastparse;
168     I32         lastnum;
169     AV          *paren_name_list;       /* idx -> name */
170 #define RExC_lastparse  (pRExC_state->lastparse)
171 #define RExC_lastnum    (pRExC_state->lastnum)
172 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
173 #endif
174 } RExC_state_t;
175
176 #define RExC_flags      (pRExC_state->flags)
177 #define RExC_pm_flags   (pRExC_state->pm_flags)
178 #define RExC_precomp    (pRExC_state->precomp)
179 #define RExC_rx_sv      (pRExC_state->rx_sv)
180 #define RExC_rx         (pRExC_state->rx)
181 #define RExC_rxi        (pRExC_state->rxi)
182 #define RExC_start      (pRExC_state->start)
183 #define RExC_end        (pRExC_state->end)
184 #define RExC_parse      (pRExC_state->parse)
185 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
186 #ifdef RE_TRACK_PATTERN_OFFSETS
187 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the others */
188 #endif
189 #define RExC_emit       (pRExC_state->emit)
190 #define RExC_emit_start (pRExC_state->emit_start)
191 #define RExC_emit_bound (pRExC_state->emit_bound)
192 #define RExC_naughty    (pRExC_state->naughty)
193 #define RExC_sawback    (pRExC_state->sawback)
194 #define RExC_seen       (pRExC_state->seen)
195 #define RExC_size       (pRExC_state->size)
196 #define RExC_npar       (pRExC_state->npar)
197 #define RExC_nestroot   (pRExC_state->nestroot)
198 #define RExC_extralen   (pRExC_state->extralen)
199 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
200 #define RExC_utf8       (pRExC_state->utf8)
201 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
202 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
203 #define RExC_open_parens        (pRExC_state->open_parens)
204 #define RExC_close_parens       (pRExC_state->close_parens)
205 #define RExC_opend      (pRExC_state->opend)
206 #define RExC_paren_names        (pRExC_state->paren_names)
207 #define RExC_recurse    (pRExC_state->recurse)
208 #define RExC_recurse_count      (pRExC_state->recurse_count)
209 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
210 #define RExC_contains_locale    (pRExC_state->contains_locale)
211 #define RExC_override_recoding (pRExC_state->override_recoding)
212 #define RExC_in_multi_char_class (pRExC_state->in_multi_char_class)
213
214
215 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
216 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
217         ((*s) == '{' && regcurly(s, FALSE)))
218
219 #ifdef SPSTART
220 #undef SPSTART          /* dratted cpp namespace... */
221 #endif
222 /*
223  * Flags to be passed up and down.
224  */
225 #define WORST           0       /* Worst case. */
226 #define HASWIDTH        0x01    /* Known to match non-null strings. */
227
228 /* Simple enough to be STAR/PLUS operand; in an EXACTish node must be a single
229  * character.  (There needs to be a case: in the switch statement in regexec.c
230  * for any node marked SIMPLE.)  Note that this is not the same thing as
231  * REGNODE_SIMPLE */
232 #define SIMPLE          0x02
233 #define SPSTART         0x04    /* Starts with * or + */
234 #define POSTPONED       0x08    /* (?1),(?&name), (??{...}) or similar */
235 #define TRYAGAIN        0x10    /* Weeded out a declaration. */
236 #define RESTART_UTF8    0x20    /* Restart, need to calcuate sizes as UTF-8 */
237
238 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
239
240 /* whether trie related optimizations are enabled */
241 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
242 #define TRIE_STUDY_OPT
243 #define FULL_TRIE_STUDY
244 #define TRIE_STCLASS
245 #endif
246
247
248
249 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
250 #define PBITVAL(paren) (1 << ((paren) & 7))
251 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
252 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
253 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
254
255 #define REQUIRE_UTF8    STMT_START {                                       \
256                                      if (!UTF) {                           \
257                                          *flagp = RESTART_UTF8;            \
258                                          return NULL;                      \
259                                      }                                     \
260                         } STMT_END
261
262 /* This converts the named class defined in regcomp.h to its equivalent class
263  * number defined in handy.h. */
264 #define namedclass_to_classnum(class)  ((int) ((class) / 2))
265 #define classnum_to_namedclass(classnum)  ((classnum) * 2)
266
267 /* About scan_data_t.
268
269   During optimisation we recurse through the regexp program performing
270   various inplace (keyhole style) optimisations. In addition study_chunk
271   and scan_commit populate this data structure with information about
272   what strings MUST appear in the pattern. We look for the longest 
273   string that must appear at a fixed location, and we look for the
274   longest string that may appear at a floating location. So for instance
275   in the pattern:
276   
277     /FOO[xX]A.*B[xX]BAR/
278     
279   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
280   strings (because they follow a .* construct). study_chunk will identify
281   both FOO and BAR as being the longest fixed and floating strings respectively.
282   
283   The strings can be composites, for instance
284   
285      /(f)(o)(o)/
286      
287   will result in a composite fixed substring 'foo'.
288   
289   For each string some basic information is maintained:
290   
291   - offset or min_offset
292     This is the position the string must appear at, or not before.
293     It also implicitly (when combined with minlenp) tells us how many
294     characters must match before the string we are searching for.
295     Likewise when combined with minlenp and the length of the string it
296     tells us how many characters must appear after the string we have 
297     found.
298   
299   - max_offset
300     Only used for floating strings. This is the rightmost point that
301     the string can appear at. If set to I32 max it indicates that the
302     string can occur infinitely far to the right.
303   
304   - minlenp
305     A pointer to the minimum number of characters of the pattern that the
306     string was found inside. This is important as in the case of positive
307     lookahead or positive lookbehind we can have multiple patterns 
308     involved. Consider
309     
310     /(?=FOO).*F/
311     
312     The minimum length of the pattern overall is 3, the minimum length
313     of the lookahead part is 3, but the minimum length of the part that
314     will actually match is 1. So 'FOO's minimum length is 3, but the 
315     minimum length for the F is 1. This is important as the minimum length
316     is used to determine offsets in front of and behind the string being 
317     looked for.  Since strings can be composites this is the length of the
318     pattern at the time it was committed with a scan_commit. Note that
319     the length is calculated by study_chunk, so that the minimum lengths
320     are not known until the full pattern has been compiled, thus the 
321     pointer to the value.
322   
323   - lookbehind
324   
325     In the case of lookbehind the string being searched for can be
326     offset past the start point of the final matching string. 
327     If this value was just blithely removed from the min_offset it would
328     invalidate some of the calculations for how many chars must match
329     before or after (as they are derived from min_offset and minlen and
330     the length of the string being searched for). 
331     When the final pattern is compiled and the data is moved from the
332     scan_data_t structure into the regexp structure the information
333     about lookbehind is factored in, with the information that would 
334     have been lost precalculated in the end_shift field for the 
335     associated string.
336
337   The fields pos_min and pos_delta are used to store the minimum offset
338   and the delta to the maximum offset at the current point in the pattern.    
339
340 */
341
342 typedef struct scan_data_t {
343     /*I32 len_min;      unused */
344     /*I32 len_delta;    unused */
345     I32 pos_min;
346     I32 pos_delta;
347     SV *last_found;
348     I32 last_end;           /* min value, <0 unless valid. */
349     I32 last_start_min;
350     I32 last_start_max;
351     SV **longest;           /* Either &l_fixed, or &l_float. */
352     SV *longest_fixed;      /* longest fixed string found in pattern */
353     I32 offset_fixed;       /* offset where it starts */
354     I32 *minlen_fixed;      /* pointer to the minlen relevant to the string */
355     I32 lookbehind_fixed;   /* is the position of the string modfied by LB */
356     SV *longest_float;      /* longest floating string found in pattern */
357     I32 offset_float_min;   /* earliest point in string it can appear */
358     I32 offset_float_max;   /* latest point in string it can appear */
359     I32 *minlen_float;      /* pointer to the minlen relevant to the string */
360     I32 lookbehind_float;   /* is the position of the string modified by LB */
361     I32 flags;
362     I32 whilem_c;
363     I32 *last_closep;
364     struct regnode_charclass_class *start_class;
365 } scan_data_t;
366
367 /*
368  * Forward declarations for pregcomp()'s friends.
369  */
370
371 static const scan_data_t zero_scan_data =
372   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
373
374 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
375 #define SF_BEFORE_SEOL          0x0001
376 #define SF_BEFORE_MEOL          0x0002
377 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
378 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
379
380 #ifdef NO_UNARY_PLUS
381 #  define SF_FIX_SHIFT_EOL      (0+2)
382 #  define SF_FL_SHIFT_EOL               (0+4)
383 #else
384 #  define SF_FIX_SHIFT_EOL      (+2)
385 #  define SF_FL_SHIFT_EOL               (+4)
386 #endif
387
388 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
389 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
390
391 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
392 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
393 #define SF_IS_INF               0x0040
394 #define SF_HAS_PAR              0x0080
395 #define SF_IN_PAR               0x0100
396 #define SF_HAS_EVAL             0x0200
397 #define SCF_DO_SUBSTR           0x0400
398 #define SCF_DO_STCLASS_AND      0x0800
399 #define SCF_DO_STCLASS_OR       0x1000
400 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
401 #define SCF_WHILEM_VISITED_POS  0x2000
402
403 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
404 #define SCF_SEEN_ACCEPT         0x8000 
405
406 #define UTF cBOOL(RExC_utf8)
407
408 /* The enums for all these are ordered so things work out correctly */
409 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
410 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_DEPENDS_CHARSET)
411 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
412 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags) >= REGEX_UNICODE_CHARSET)
413 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_RESTRICTED_CHARSET)
414 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags) >= REGEX_ASCII_RESTRICTED_CHARSET)
415 #define ASCII_FOLD_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
416
417 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
418
419 #define OOB_NAMEDCLASS          -1
420
421 /* There is no code point that is out-of-bounds, so this is problematic.  But
422  * its only current use is to initialize a variable that is always set before
423  * looked at. */
424 #define OOB_UNICODE             0xDEADBEEF
425
426 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
427 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
428
429
430 /* length of regex to show in messages that don't mark a position within */
431 #define RegexLengthToShowInErrorMessages 127
432
433 /*
434  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
435  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
436  * op/pragma/warn/regcomp.
437  */
438 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
439 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
440
441 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
442
443 /*
444  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
445  * arg. Show regex, up to a maximum length. If it's too long, chop and add
446  * "...".
447  */
448 #define _FAIL(code) STMT_START {                                        \
449     const char *ellipses = "";                                          \
450     IV len = RExC_end - RExC_precomp;                                   \
451                                                                         \
452     if (!SIZE_ONLY)                                                     \
453         SAVEFREESV(RExC_rx_sv);                                         \
454     if (len > RegexLengthToShowInErrorMessages) {                       \
455         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
456         len = RegexLengthToShowInErrorMessages - 10;                    \
457         ellipses = "...";                                               \
458     }                                                                   \
459     code;                                                               \
460 } STMT_END
461
462 #define FAIL(msg) _FAIL(                            \
463     Perl_croak(aTHX_ "%s in regex m/%.*s%s/",       \
464             msg, (int)len, RExC_precomp, ellipses))
465
466 #define FAIL2(msg,arg) _FAIL(                       \
467     Perl_croak(aTHX_ msg " in regex m/%.*s%s/",     \
468             arg, (int)len, RExC_precomp, ellipses))
469
470 /*
471  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
472  */
473 #define Simple_vFAIL(m) STMT_START {                                    \
474     const IV offset = RExC_parse - RExC_precomp;                        \
475     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
476             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
477 } STMT_END
478
479 /*
480  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
481  */
482 #define vFAIL(m) STMT_START {                           \
483     if (!SIZE_ONLY)                                     \
484         SAVEFREESV(RExC_rx_sv);                         \
485     Simple_vFAIL(m);                                    \
486 } STMT_END
487
488 /*
489  * Like Simple_vFAIL(), but accepts two arguments.
490  */
491 #define Simple_vFAIL2(m,a1) STMT_START {                        \
492     const IV offset = RExC_parse - RExC_precomp;                        \
493     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1,                   \
494             (int)offset, RExC_precomp, RExC_precomp + offset);  \
495 } STMT_END
496
497 /*
498  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
499  */
500 #define vFAIL2(m,a1) STMT_START {                       \
501     if (!SIZE_ONLY)                                     \
502         SAVEFREESV(RExC_rx_sv);                         \
503     Simple_vFAIL2(m, a1);                               \
504 } STMT_END
505
506
507 /*
508  * Like Simple_vFAIL(), but accepts three arguments.
509  */
510 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
511     const IV offset = RExC_parse - RExC_precomp;                \
512     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2,               \
513             (int)offset, RExC_precomp, RExC_precomp + offset);  \
514 } STMT_END
515
516 /*
517  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
518  */
519 #define vFAIL3(m,a1,a2) STMT_START {                    \
520     if (!SIZE_ONLY)                                     \
521         SAVEFREESV(RExC_rx_sv);                         \
522     Simple_vFAIL3(m, a1, a2);                           \
523 } STMT_END
524
525 /*
526  * Like Simple_vFAIL(), but accepts four arguments.
527  */
528 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
529     const IV offset = RExC_parse - RExC_precomp;                \
530     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3,           \
531             (int)offset, RExC_precomp, RExC_precomp + offset);  \
532 } STMT_END
533
534 #define vFAIL4(m,a1,a2,a3) STMT_START {                 \
535     if (!SIZE_ONLY)                                     \
536         SAVEFREESV(RExC_rx_sv);                         \
537     Simple_vFAIL4(m, a1, a2, a3);                       \
538 } STMT_END
539
540 /* m is not necessarily a "literal string", in this macro */
541 #define reg_warn_non_literal_string(loc, m) STMT_START {                \
542     const IV offset = loc - RExC_precomp;                               \
543     Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s" REPORT_LOCATION,      \
544             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
545 } STMT_END
546
547 #define ckWARNreg(loc,m) STMT_START {                                   \
548     const IV offset = loc - RExC_precomp;                               \
549     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
550             (int)offset, RExC_precomp, RExC_precomp + offset);          \
551 } STMT_END
552
553 #define vWARN_dep(loc, m) STMT_START {                                  \
554     const IV offset = loc - RExC_precomp;                               \
555     Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), m REPORT_LOCATION,     \
556             (int)offset, RExC_precomp, RExC_precomp + offset);          \
557 } STMT_END
558
559 #define ckWARNdep(loc,m) STMT_START {                                   \
560     const IV offset = loc - RExC_precomp;                               \
561     Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),                   \
562             m REPORT_LOCATION,                                          \
563             (int)offset, RExC_precomp, RExC_precomp + offset);          \
564 } STMT_END
565
566 #define ckWARNregdep(loc,m) STMT_START {                                \
567     const IV offset = loc - RExC_precomp;                               \
568     Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),     \
569             m REPORT_LOCATION,                                          \
570             (int)offset, RExC_precomp, RExC_precomp + offset);          \
571 } STMT_END
572
573 #define ckWARN2regdep(loc,m, a1) STMT_START {                           \
574     const IV offset = loc - RExC_precomp;                               \
575     Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),     \
576             m REPORT_LOCATION,                                          \
577             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
578 } STMT_END
579
580 #define ckWARN2reg(loc, m, a1) STMT_START {                             \
581     const IV offset = loc - RExC_precomp;                               \
582     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
583             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
584 } STMT_END
585
586 #define vWARN3(loc, m, a1, a2) STMT_START {                             \
587     const IV offset = loc - RExC_precomp;                               \
588     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
589             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
590 } STMT_END
591
592 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                         \
593     const IV offset = loc - RExC_precomp;                               \
594     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
595             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
596 } STMT_END
597
598 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
599     const IV offset = loc - RExC_precomp;                               \
600     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
601             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
602 } STMT_END
603
604 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
605     const IV offset = loc - RExC_precomp;                               \
606     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
607             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
608 } STMT_END
609
610 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
611     const IV offset = loc - RExC_precomp;                               \
612     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
613             a1, a2, a3, a4, (int)offset, RExC_precomp, RExC_precomp + offset); \
614 } STMT_END
615
616
617 /* Allow for side effects in s */
618 #define REGC(c,s) STMT_START {                  \
619     if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
620 } STMT_END
621
622 /* Macros for recording node offsets.   20001227 mjd@plover.com 
623  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
624  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
625  * Element 0 holds the number n.
626  * Position is 1 indexed.
627  */
628 #ifndef RE_TRACK_PATTERN_OFFSETS
629 #define Set_Node_Offset_To_R(node,byte)
630 #define Set_Node_Offset(node,byte)
631 #define Set_Cur_Node_Offset
632 #define Set_Node_Length_To_R(node,len)
633 #define Set_Node_Length(node,len)
634 #define Set_Node_Cur_Length(node)
635 #define Node_Offset(n) 
636 #define Node_Length(n) 
637 #define Set_Node_Offset_Length(node,offset,len)
638 #define ProgLen(ri) ri->u.proglen
639 #define SetProgLen(ri,x) ri->u.proglen = x
640 #else
641 #define ProgLen(ri) ri->u.offsets[0]
642 #define SetProgLen(ri,x) ri->u.offsets[0] = x
643 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
644     if (! SIZE_ONLY) {                                                  \
645         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
646                     __LINE__, (int)(node), (int)(byte)));               \
647         if((node) < 0) {                                                \
648             Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \
649         } else {                                                        \
650             RExC_offsets[2*(node)-1] = (byte);                          \
651         }                                                               \
652     }                                                                   \
653 } STMT_END
654
655 #define Set_Node_Offset(node,byte) \
656     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
657 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
658
659 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
660     if (! SIZE_ONLY) {                                                  \
661         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
662                 __LINE__, (int)(node), (int)(len)));                    \
663         if((node) < 0) {                                                \
664             Perl_croak(aTHX_ "value of node is %d in Length macro", (int)(node)); \
665         } else {                                                        \
666             RExC_offsets[2*(node)] = (len);                             \
667         }                                                               \
668     }                                                                   \
669 } STMT_END
670
671 #define Set_Node_Length(node,len) \
672     Set_Node_Length_To_R((node)-RExC_emit_start, len)
673 #define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
674 #define Set_Node_Cur_Length(node) \
675     Set_Node_Length(node, RExC_parse - parse_start)
676
677 /* Get offsets and lengths */
678 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
679 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
680
681 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
682     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
683     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
684 } STMT_END
685 #endif
686
687 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
688 #define EXPERIMENTAL_INPLACESCAN
689 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
690
691 #define DEBUG_STUDYDATA(str,data,depth)                              \
692 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
693     PerlIO_printf(Perl_debug_log,                                    \
694         "%*s" str "Pos:%"IVdf"/%"IVdf                                \
695         " Flags: 0x%"UVXf" Whilem_c: %"IVdf" Lcp: %"IVdf" %s",       \
696         (int)(depth)*2, "",                                          \
697         (IV)((data)->pos_min),                                       \
698         (IV)((data)->pos_delta),                                     \
699         (UV)((data)->flags),                                         \
700         (IV)((data)->whilem_c),                                      \
701         (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
702         is_inf ? "INF " : ""                                         \
703     );                                                               \
704     if ((data)->last_found)                                          \
705         PerlIO_printf(Perl_debug_log,                                \
706             "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
707             " %sFloat: '%s' @ %"IVdf"/%"IVdf"",                      \
708             SvPVX_const((data)->last_found),                         \
709             (IV)((data)->last_end),                                  \
710             (IV)((data)->last_start_min),                            \
711             (IV)((data)->last_start_max),                            \
712             ((data)->longest &&                                      \
713              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
714             SvPVX_const((data)->longest_fixed),                      \
715             (IV)((data)->offset_fixed),                              \
716             ((data)->longest &&                                      \
717              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
718             SvPVX_const((data)->longest_float),                      \
719             (IV)((data)->offset_float_min),                          \
720             (IV)((data)->offset_float_max)                           \
721         );                                                           \
722     PerlIO_printf(Perl_debug_log,"\n");                              \
723 });
724
725 /* Mark that we cannot extend a found fixed substring at this point.
726    Update the longest found anchored substring and the longest found
727    floating substrings if needed. */
728
729 STATIC void
730 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp, int is_inf)
731 {
732     const STRLEN l = CHR_SVLEN(data->last_found);
733     const STRLEN old_l = CHR_SVLEN(*data->longest);
734     GET_RE_DEBUG_FLAGS_DECL;
735
736     PERL_ARGS_ASSERT_SCAN_COMMIT;
737
738     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
739         SvSetMagicSV(*data->longest, data->last_found);
740         if (*data->longest == data->longest_fixed) {
741             data->offset_fixed = l ? data->last_start_min : data->pos_min;
742             if (data->flags & SF_BEFORE_EOL)
743                 data->flags
744                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
745             else
746                 data->flags &= ~SF_FIX_BEFORE_EOL;
747             data->minlen_fixed=minlenp;
748             data->lookbehind_fixed=0;
749         }
750         else { /* *data->longest == data->longest_float */
751             data->offset_float_min = l ? data->last_start_min : data->pos_min;
752             data->offset_float_max = (l
753                                       ? data->last_start_max
754                                       : (data->pos_delta == I32_MAX ? I32_MAX : data->pos_min + data->pos_delta));
755             if (is_inf || (U32)data->offset_float_max > (U32)I32_MAX)
756                 data->offset_float_max = I32_MAX;
757             if (data->flags & SF_BEFORE_EOL)
758                 data->flags
759                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
760             else
761                 data->flags &= ~SF_FL_BEFORE_EOL;
762             data->minlen_float=minlenp;
763             data->lookbehind_float=0;
764         }
765     }
766     SvCUR_set(data->last_found, 0);
767     {
768         SV * const sv = data->last_found;
769         if (SvUTF8(sv) && SvMAGICAL(sv)) {
770             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
771             if (mg)
772                 mg->mg_len = 0;
773         }
774     }
775     data->last_end = -1;
776     data->flags &= ~SF_BEFORE_EOL;
777     DEBUG_STUDYDATA("commit: ",data,0);
778 }
779
780 /* These macros set, clear and test whether the synthetic start class ('ssc',
781  * given by the parameter) matches an empty string (EOS).  This uses the
782  * 'next_off' field in the node, to save a bit in the flags field.  The ssc
783  * stands alone, so there is never a next_off, so this field is otherwise
784  * unused.  The EOS information is used only for compilation, but theoretically
785  * it could be passed on to the execution code.  This could be used to store
786  * more than one bit of information, but only this one is currently used. */
787 #define SET_SSC_EOS(node)   STMT_START { (node)->next_off = TRUE; } STMT_END
788 #define CLEAR_SSC_EOS(node) STMT_START { (node)->next_off = FALSE; } STMT_END
789 #define TEST_SSC_EOS(node)  cBOOL((node)->next_off)
790
791 /* Can match anything (initialization) */
792 STATIC void
793 S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
794 {
795     PERL_ARGS_ASSERT_CL_ANYTHING;
796
797     ANYOF_BITMAP_SETALL(cl);
798     cl->flags = ANYOF_UNICODE_ALL;
799     SET_SSC_EOS(cl);
800
801     /* If any portion of the regex is to operate under locale rules,
802      * initialization includes it.  The reason this isn't done for all regexes
803      * is that the optimizer was written under the assumption that locale was
804      * all-or-nothing.  Given the complexity and lack of documentation in the
805      * optimizer, and that there are inadequate test cases for locale, so many
806      * parts of it may not work properly, it is safest to avoid locale unless
807      * necessary. */
808     if (RExC_contains_locale) {
809         ANYOF_CLASS_SETALL(cl);     /* /l uses class */
810         cl->flags |= ANYOF_LOCALE|ANYOF_CLASS|ANYOF_LOC_FOLD;
811     }
812     else {
813         ANYOF_CLASS_ZERO(cl);       /* Only /l uses class now */
814     }
815 }
816
817 /* Can match anything (initialization) */
818 STATIC int
819 S_cl_is_anything(const struct regnode_charclass_class *cl)
820 {
821     int value;
822
823     PERL_ARGS_ASSERT_CL_IS_ANYTHING;
824
825     for (value = 0; value < ANYOF_MAX; value += 2)
826         if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
827             return 1;
828     if (!(cl->flags & ANYOF_UNICODE_ALL))
829         return 0;
830     if (!ANYOF_BITMAP_TESTALLSET((const void*)cl))
831         return 0;
832     return 1;
833 }
834
835 /* Can match anything (initialization) */
836 STATIC void
837 S_cl_init(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
838 {
839     PERL_ARGS_ASSERT_CL_INIT;
840
841     Zero(cl, 1, struct regnode_charclass_class);
842     cl->type = ANYOF;
843     cl_anything(pRExC_state, cl);
844     ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
845 }
846
847 /* These two functions currently do the exact same thing */
848 #define cl_init_zero            S_cl_init
849
850 /* 'AND' a given class with another one.  Can create false positives.  'cl'
851  * should not be inverted.  'and_with->flags & ANYOF_CLASS' should be 0 if
852  * 'and_with' is a regnode_charclass instead of a regnode_charclass_class. */
853 STATIC void
854 S_cl_and(struct regnode_charclass_class *cl,
855         const struct regnode_charclass_class *and_with)
856 {
857     PERL_ARGS_ASSERT_CL_AND;
858
859     assert(PL_regkind[and_with->type] == ANYOF);
860
861     /* I (khw) am not sure all these restrictions are necessary XXX */
862     if (!(ANYOF_CLASS_TEST_ANY_SET(and_with))
863         && !(ANYOF_CLASS_TEST_ANY_SET(cl))
864         && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
865         && !(and_with->flags & ANYOF_LOC_FOLD)
866         && !(cl->flags & ANYOF_LOC_FOLD)) {
867         int i;
868
869         if (and_with->flags & ANYOF_INVERT)
870             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
871                 cl->bitmap[i] &= ~and_with->bitmap[i];
872         else
873             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
874                 cl->bitmap[i] &= and_with->bitmap[i];
875     } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
876
877     if (and_with->flags & ANYOF_INVERT) {
878
879         /* Here, the and'ed node is inverted.  Get the AND of the flags that
880          * aren't affected by the inversion.  Those that are affected are
881          * handled individually below */
882         U8 affected_flags = cl->flags & ~INVERSION_UNAFFECTED_FLAGS;
883         cl->flags &= (and_with->flags & INVERSION_UNAFFECTED_FLAGS);
884         cl->flags |= affected_flags;
885
886         /* We currently don't know how to deal with things that aren't in the
887          * bitmap, but we know that the intersection is no greater than what
888          * is already in cl, so let there be false positives that get sorted
889          * out after the synthetic start class succeeds, and the node is
890          * matched for real. */
891
892         /* The inversion of these two flags indicate that the resulting
893          * intersection doesn't have them */
894         if (and_with->flags & ANYOF_UNICODE_ALL) {
895             cl->flags &= ~ANYOF_UNICODE_ALL;
896         }
897         if (and_with->flags & ANYOF_NON_UTF8_LATIN1_ALL) {
898             cl->flags &= ~ANYOF_NON_UTF8_LATIN1_ALL;
899         }
900     }
901     else {   /* and'd node is not inverted */
902         U8 outside_bitmap_but_not_utf8; /* Temp variable */
903
904         if (! ANYOF_NONBITMAP(and_with)) {
905
906             /* Here 'and_with' doesn't match anything outside the bitmap
907              * (except possibly ANYOF_UNICODE_ALL), which means the
908              * intersection can't either, except for ANYOF_UNICODE_ALL, in
909              * which case we don't know what the intersection is, but it's no
910              * greater than what cl already has, so can just leave it alone,
911              * with possible false positives */
912             if (! (and_with->flags & ANYOF_UNICODE_ALL)) {
913                 ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
914                 cl->flags &= ~ANYOF_NONBITMAP_NON_UTF8;
915             }
916         }
917         else if (! ANYOF_NONBITMAP(cl)) {
918
919             /* Here, 'and_with' does match something outside the bitmap, and cl
920              * doesn't have a list of things to match outside the bitmap.  If
921              * cl can match all code points above 255, the intersection will
922              * be those above-255 code points that 'and_with' matches.  If cl
923              * can't match all Unicode code points, it means that it can't
924              * match anything outside the bitmap (since the 'if' that got us
925              * into this block tested for that), so we leave the bitmap empty.
926              */
927             if (cl->flags & ANYOF_UNICODE_ALL) {
928                 ARG_SET(cl, ARG(and_with));
929
930                 /* and_with's ARG may match things that don't require UTF8.
931                  * And now cl's will too, in spite of this being an 'and'.  See
932                  * the comments below about the kludge */
933                 cl->flags |= and_with->flags & ANYOF_NONBITMAP_NON_UTF8;
934             }
935         }
936         else {
937             /* Here, both 'and_with' and cl match something outside the
938              * bitmap.  Currently we do not do the intersection, so just match
939              * whatever cl had at the beginning.  */
940         }
941
942
943         /* Take the intersection of the two sets of flags.  However, the
944          * ANYOF_NONBITMAP_NON_UTF8 flag is treated as an 'or'.  This is a
945          * kludge around the fact that this flag is not treated like the others
946          * which are initialized in cl_anything().  The way the optimizer works
947          * is that the synthetic start class (SSC) is initialized to match
948          * anything, and then the first time a real node is encountered, its
949          * values are AND'd with the SSC's with the result being the values of
950          * the real node.  However, there are paths through the optimizer where
951          * the AND never gets called, so those initialized bits are set
952          * inappropriately, which is not usually a big deal, as they just cause
953          * false positives in the SSC, which will just mean a probably
954          * imperceptible slow down in execution.  However this bit has a
955          * higher false positive consequence in that it can cause utf8.pm,
956          * utf8_heavy.pl ... to be loaded when not necessary, which is a much
957          * bigger slowdown and also causes significant extra memory to be used.
958          * In order to prevent this, the code now takes a different tack.  The
959          * bit isn't set unless some part of the regular expression needs it,
960          * but once set it won't get cleared.  This means that these extra
961          * modules won't get loaded unless there was some path through the
962          * pattern that would have required them anyway, and  so any false
963          * positives that occur by not ANDing them out when they could be
964          * aren't as severe as they would be if we treated this bit like all
965          * the others */
966         outside_bitmap_but_not_utf8 = (cl->flags | and_with->flags)
967                                       & ANYOF_NONBITMAP_NON_UTF8;
968         cl->flags &= and_with->flags;
969         cl->flags |= outside_bitmap_but_not_utf8;
970     }
971 }
972
973 /* 'OR' a given class with another one.  Can create false positives.  'cl'
974  * should not be inverted.  'or_with->flags & ANYOF_CLASS' should be 0 if
975  * 'or_with' is a regnode_charclass instead of a regnode_charclass_class. */
976 STATIC void
977 S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
978 {
979     PERL_ARGS_ASSERT_CL_OR;
980
981     if (or_with->flags & ANYOF_INVERT) {
982
983         /* Here, the or'd node is to be inverted.  This means we take the
984          * complement of everything not in the bitmap, but currently we don't
985          * know what that is, so give up and match anything */
986         if (ANYOF_NONBITMAP(or_with)) {
987             cl_anything(pRExC_state, cl);
988         }
989         /* We do not use
990          * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
991          *   <= (B1 | !B2) | (CL1 | !CL2)
992          * which is wasteful if CL2 is small, but we ignore CL2:
993          *   (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
994          * XXXX Can we handle case-fold?  Unclear:
995          *   (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
996          *   (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
997          */
998         else if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
999              && !(or_with->flags & ANYOF_LOC_FOLD)
1000              && !(cl->flags & ANYOF_LOC_FOLD) ) {
1001             int i;
1002
1003             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
1004                 cl->bitmap[i] |= ~or_with->bitmap[i];
1005         } /* XXXX: logic is complicated otherwise */
1006         else {
1007             cl_anything(pRExC_state, cl);
1008         }
1009
1010         /* And, we can just take the union of the flags that aren't affected
1011          * by the inversion */
1012         cl->flags |= or_with->flags & INVERSION_UNAFFECTED_FLAGS;
1013
1014         /* For the remaining flags:
1015             ANYOF_UNICODE_ALL and inverted means to not match anything above
1016                     255, which means that the union with cl should just be
1017                     what cl has in it, so can ignore this flag
1018             ANYOF_NON_UTF8_LATIN1_ALL and inverted means if not utf8 and ord
1019                     is 127-255 to match them, but then invert that, so the
1020                     union with cl should just be what cl has in it, so can
1021                     ignore this flag
1022          */
1023     } else {    /* 'or_with' is not inverted */
1024         /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
1025         if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
1026              && (!(or_with->flags & ANYOF_LOC_FOLD)
1027                  || (cl->flags & ANYOF_LOC_FOLD)) ) {
1028             int i;
1029
1030             /* OR char bitmap and class bitmap separately */
1031             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
1032                 cl->bitmap[i] |= or_with->bitmap[i];
1033             if (or_with->flags & ANYOF_CLASS) {
1034                 ANYOF_CLASS_OR(or_with, cl);
1035             }
1036         }
1037         else { /* XXXX: logic is complicated, leave it along for a moment. */
1038             cl_anything(pRExC_state, cl);
1039         }
1040
1041         if (ANYOF_NONBITMAP(or_with)) {
1042
1043             /* Use the added node's outside-the-bit-map match if there isn't a
1044              * conflict.  If there is a conflict (both nodes match something
1045              * outside the bitmap, but what they match outside is not the same
1046              * pointer, and hence not easily compared until XXX we extend
1047              * inversion lists this far), give up and allow the start class to
1048              * match everything outside the bitmap.  If that stuff is all above
1049              * 255, can just set UNICODE_ALL, otherwise caould be anything. */
1050             if (! ANYOF_NONBITMAP(cl)) {
1051                 ARG_SET(cl, ARG(or_with));
1052             }
1053             else if (ARG(cl) != ARG(or_with)) {
1054
1055                 if ((or_with->flags & ANYOF_NONBITMAP_NON_UTF8)) {
1056                     cl_anything(pRExC_state, cl);
1057                 }
1058                 else {
1059                     cl->flags |= ANYOF_UNICODE_ALL;
1060                 }
1061             }
1062         }
1063
1064         /* Take the union */
1065         cl->flags |= or_with->flags;
1066     }
1067 }
1068
1069 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1070 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
1071 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1072 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list ? (TRIE_LIST_CUR( idx ) - 1) : 0 )
1073
1074
1075 #ifdef DEBUGGING
1076 /*
1077    dump_trie(trie,widecharmap,revcharmap)
1078    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1079    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1080
1081    These routines dump out a trie in a somewhat readable format.
1082    The _interim_ variants are used for debugging the interim
1083    tables that are used to generate the final compressed
1084    representation which is what dump_trie expects.
1085
1086    Part of the reason for their existence is to provide a form
1087    of documentation as to how the different representations function.
1088
1089 */
1090
1091 /*
1092   Dumps the final compressed table form of the trie to Perl_debug_log.
1093   Used for debugging make_trie().
1094 */
1095
1096 STATIC void
1097 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1098             AV *revcharmap, U32 depth)
1099 {
1100     U32 state;
1101     SV *sv=sv_newmortal();
1102     int colwidth= widecharmap ? 6 : 4;
1103     U16 word;
1104     GET_RE_DEBUG_FLAGS_DECL;
1105
1106     PERL_ARGS_ASSERT_DUMP_TRIE;
1107
1108     PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
1109         (int)depth * 2 + 2,"",
1110         "Match","Base","Ofs" );
1111
1112     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1113         SV ** const tmp = av_fetch( revcharmap, state, 0);
1114         if ( tmp ) {
1115             PerlIO_printf( Perl_debug_log, "%*s", 
1116                 colwidth,
1117                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1118                             PL_colors[0], PL_colors[1],
1119                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1120                             PERL_PV_ESCAPE_FIRSTCHAR 
1121                 ) 
1122             );
1123         }
1124     }
1125     PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
1126         (int)depth * 2 + 2,"");
1127
1128     for( state = 0 ; state < trie->uniquecharcount ; state++ )
1129         PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
1130     PerlIO_printf( Perl_debug_log, "\n");
1131
1132     for( state = 1 ; state < trie->statecount ; state++ ) {
1133         const U32 base = trie->states[ state ].trans.base;
1134
1135         PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state);
1136
1137         if ( trie->states[ state ].wordnum ) {
1138             PerlIO_printf( Perl_debug_log, " W%4X", trie->states[ state ].wordnum );
1139         } else {
1140             PerlIO_printf( Perl_debug_log, "%6s", "" );
1141         }
1142
1143         PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
1144
1145         if ( base ) {
1146             U32 ofs = 0;
1147
1148             while( ( base + ofs  < trie->uniquecharcount ) ||
1149                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
1150                      && trie->trans[ base + ofs - trie->uniquecharcount ].check != state))
1151                     ofs++;
1152
1153             PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
1154
1155             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
1156                 if ( ( base + ofs >= trie->uniquecharcount ) &&
1157                      ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
1158                      trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
1159                 {
1160                    PerlIO_printf( Perl_debug_log, "%*"UVXf,
1161                     colwidth,
1162                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
1163                 } else {
1164                     PerlIO_printf( Perl_debug_log, "%*s",colwidth,"   ." );
1165                 }
1166             }
1167
1168             PerlIO_printf( Perl_debug_log, "]");
1169
1170         }
1171         PerlIO_printf( Perl_debug_log, "\n" );
1172     }
1173     PerlIO_printf(Perl_debug_log, "%*sword_info N:(prev,len)=", (int)depth*2, "");
1174     for (word=1; word <= trie->wordcount; word++) {
1175         PerlIO_printf(Perl_debug_log, " %d:(%d,%d)",
1176             (int)word, (int)(trie->wordinfo[word].prev),
1177             (int)(trie->wordinfo[word].len));
1178     }
1179     PerlIO_printf(Perl_debug_log, "\n" );
1180 }    
1181 /*
1182   Dumps a fully constructed but uncompressed trie in list form.
1183   List tries normally only are used for construction when the number of 
1184   possible chars (trie->uniquecharcount) is very high.
1185   Used for debugging make_trie().
1186 */
1187 STATIC void
1188 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
1189                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
1190                          U32 depth)
1191 {
1192     U32 state;
1193     SV *sv=sv_newmortal();
1194     int colwidth= widecharmap ? 6 : 4;
1195     GET_RE_DEBUG_FLAGS_DECL;
1196
1197     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
1198
1199     /* print out the table precompression.  */
1200     PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
1201         (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
1202         "------:-----+-----------------\n" );
1203     
1204     for( state=1 ; state < next_alloc ; state ++ ) {
1205         U16 charid;
1206     
1207         PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
1208             (int)depth * 2 + 2,"", (UV)state  );
1209         if ( ! trie->states[ state ].wordnum ) {
1210             PerlIO_printf( Perl_debug_log, "%5s| ","");
1211         } else {
1212             PerlIO_printf( Perl_debug_log, "W%4x| ",
1213                 trie->states[ state ].wordnum
1214             );
1215         }
1216         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
1217             SV ** const tmp = av_fetch( revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
1218             if ( tmp ) {
1219                 PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
1220                     colwidth,
1221                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1222                             PL_colors[0], PL_colors[1],
1223                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1224                             PERL_PV_ESCAPE_FIRSTCHAR 
1225                     ) ,
1226                     TRIE_LIST_ITEM(state,charid).forid,
1227                     (UV)TRIE_LIST_ITEM(state,charid).newstate
1228                 );
1229                 if (!(charid % 10)) 
1230                     PerlIO_printf(Perl_debug_log, "\n%*s| ",
1231                         (int)((depth * 2) + 14), "");
1232             }
1233         }
1234         PerlIO_printf( Perl_debug_log, "\n");
1235     }
1236 }    
1237
1238 /*
1239   Dumps a fully constructed but uncompressed trie in table form.
1240   This is the normal DFA style state transition table, with a few 
1241   twists to facilitate compression later. 
1242   Used for debugging make_trie().
1243 */
1244 STATIC void
1245 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
1246                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
1247                           U32 depth)
1248 {
1249     U32 state;
1250     U16 charid;
1251     SV *sv=sv_newmortal();
1252     int colwidth= widecharmap ? 6 : 4;
1253     GET_RE_DEBUG_FLAGS_DECL;
1254
1255     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
1256     
1257     /*
1258        print out the table precompression so that we can do a visual check
1259        that they are identical.
1260      */
1261     
1262     PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
1263
1264     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1265         SV ** const tmp = av_fetch( revcharmap, charid, 0);
1266         if ( tmp ) {
1267             PerlIO_printf( Perl_debug_log, "%*s", 
1268                 colwidth,
1269                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1270                             PL_colors[0], PL_colors[1],
1271                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1272                             PERL_PV_ESCAPE_FIRSTCHAR 
1273                 ) 
1274             );
1275         }
1276     }
1277
1278     PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
1279
1280     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
1281         PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
1282     }
1283
1284     PerlIO_printf( Perl_debug_log, "\n" );
1285
1286     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
1287
1288         PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ", 
1289             (int)depth * 2 + 2,"",
1290             (UV)TRIE_NODENUM( state ) );
1291
1292         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1293             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
1294             if (v)
1295                 PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
1296             else
1297                 PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
1298         }
1299         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1300             PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check );
1301         } else {
1302             PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n", (UV)trie->trans[ state ].check,
1303             trie->states[ TRIE_NODENUM( state ) ].wordnum );
1304         }
1305     }
1306 }
1307
1308 #endif
1309
1310
1311 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
1312   startbranch: the first branch in the whole branch sequence
1313   first      : start branch of sequence of branch-exact nodes.
1314                May be the same as startbranch
1315   last       : Thing following the last branch.
1316                May be the same as tail.
1317   tail       : item following the branch sequence
1318   count      : words in the sequence
1319   flags      : currently the OP() type we will be building one of /EXACT(|F|Fl)/
1320   depth      : indent depth
1321
1322 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
1323
1324 A trie is an N'ary tree where the branches are determined by digital
1325 decomposition of the key. IE, at the root node you look up the 1st character and
1326 follow that branch repeat until you find the end of the branches. Nodes can be
1327 marked as "accepting" meaning they represent a complete word. Eg:
1328
1329   /he|she|his|hers/
1330
1331 would convert into the following structure. Numbers represent states, letters
1332 following numbers represent valid transitions on the letter from that state, if
1333 the number is in square brackets it represents an accepting state, otherwise it
1334 will be in parenthesis.
1335
1336       +-h->+-e->[3]-+-r->(8)-+-s->[9]
1337       |    |
1338       |   (2)
1339       |    |
1340      (1)   +-i->(6)-+-s->[7]
1341       |
1342       +-s->(3)-+-h->(4)-+-e->[5]
1343
1344       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
1345
1346 This shows that when matching against the string 'hers' we will begin at state 1
1347 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
1348 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
1349 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
1350 single traverse. We store a mapping from accepting to state to which word was
1351 matched, and then when we have multiple possibilities we try to complete the
1352 rest of the regex in the order in which they occured in the alternation.
1353
1354 The only prior NFA like behaviour that would be changed by the TRIE support is
1355 the silent ignoring of duplicate alternations which are of the form:
1356
1357  / (DUPE|DUPE) X? (?{ ... }) Y /x
1358
1359 Thus EVAL blocks following a trie may be called a different number of times with
1360 and without the optimisation. With the optimisations dupes will be silently
1361 ignored. This inconsistent behaviour of EVAL type nodes is well established as
1362 the following demonstrates:
1363
1364  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
1365
1366 which prints out 'word' three times, but
1367
1368  'words'=~/(word|word|word)(?{ print $1 })S/
1369
1370 which doesnt print it out at all. This is due to other optimisations kicking in.
1371
1372 Example of what happens on a structural level:
1373
1374 The regexp /(ac|ad|ab)+/ will produce the following debug output:
1375
1376    1: CURLYM[1] {1,32767}(18)
1377    5:   BRANCH(8)
1378    6:     EXACT <ac>(16)
1379    8:   BRANCH(11)
1380    9:     EXACT <ad>(16)
1381   11:   BRANCH(14)
1382   12:     EXACT <ab>(16)
1383   16:   SUCCEED(0)
1384   17:   NOTHING(18)
1385   18: END(0)
1386
1387 This would be optimizable with startbranch=5, first=5, last=16, tail=16
1388 and should turn into:
1389
1390    1: CURLYM[1] {1,32767}(18)
1391    5:   TRIE(16)
1392         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
1393           <ac>
1394           <ad>
1395           <ab>
1396   16:   SUCCEED(0)
1397   17:   NOTHING(18)
1398   18: END(0)
1399
1400 Cases where tail != last would be like /(?foo|bar)baz/:
1401
1402    1: BRANCH(4)
1403    2:   EXACT <foo>(8)
1404    4: BRANCH(7)
1405    5:   EXACT <bar>(8)
1406    7: TAIL(8)
1407    8: EXACT <baz>(10)
1408   10: END(0)
1409
1410 which would be optimizable with startbranch=1, first=1, last=7, tail=8
1411 and would end up looking like:
1412
1413     1: TRIE(8)
1414       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
1415         <foo>
1416         <bar>
1417    7: TAIL(8)
1418    8: EXACT <baz>(10)
1419   10: END(0)
1420
1421     d = uvuni_to_utf8_flags(d, uv, 0);
1422
1423 is the recommended Unicode-aware way of saying
1424
1425     *(d++) = uv;
1426 */
1427
1428 #define TRIE_STORE_REVCHAR(val)                                            \
1429     STMT_START {                                                           \
1430         if (UTF) {                                                         \
1431             SV *zlopp = newSV(7); /* XXX: optimize me */                   \
1432             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
1433             unsigned const char *const kapow = uvuni_to_utf8(flrbbbbb, val); \
1434             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
1435             SvPOK_on(zlopp);                                               \
1436             SvUTF8_on(zlopp);                                              \
1437             av_push(revcharmap, zlopp);                                    \
1438         } else {                                                           \
1439             char ooooff = (char)val;                                           \
1440             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
1441         }                                                                  \
1442         } STMT_END
1443
1444 #define TRIE_READ_CHAR STMT_START {                                                     \
1445     wordlen++;                                                                          \
1446     if ( UTF ) {                                                                        \
1447         /* if it is UTF then it is either already folded, or does not need folding */   \
1448         uvc = utf8n_to_uvuni( (const U8*) uc, UTF8_MAXLEN, &len, uniflags);             \
1449     }                                                                                   \
1450     else if (folder == PL_fold_latin1) {                                                \
1451         /* if we use this folder we have to obey unicode rules on latin-1 data */       \
1452         if ( foldlen > 0 ) {                                                            \
1453            uvc = utf8n_to_uvuni( (const U8*) scan, UTF8_MAXLEN, &len, uniflags );       \
1454            foldlen -= len;                                                              \
1455            scan += len;                                                                 \
1456            len = 0;                                                                     \
1457         } else {                                                                        \
1458             len = 1;                                                                    \
1459             uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, 1);                     \
1460             skiplen = UNISKIP(uvc);                                                     \
1461             foldlen -= skiplen;                                                         \
1462             scan = foldbuf + skiplen;                                                   \
1463         }                                                                               \
1464     } else {                                                                            \
1465         /* raw data, will be folded later if needed */                                  \
1466         uvc = (U32)*uc;                                                                 \
1467         len = 1;                                                                        \
1468     }                                                                                   \
1469 } STMT_END
1470
1471
1472
1473 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
1474     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
1475         U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
1476         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
1477     }                                                           \
1478     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
1479     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
1480     TRIE_LIST_CUR( state )++;                                   \
1481 } STMT_END
1482
1483 #define TRIE_LIST_NEW(state) STMT_START {                       \
1484     Newxz( trie->states[ state ].trans.list,               \
1485         4, reg_trie_trans_le );                                 \
1486      TRIE_LIST_CUR( state ) = 1;                                \
1487      TRIE_LIST_LEN( state ) = 4;                                \
1488 } STMT_END
1489
1490 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
1491     U16 dupe= trie->states[ state ].wordnum;                    \
1492     regnode * const noper_next = regnext( noper );              \
1493                                                                 \
1494     DEBUG_r({                                                   \
1495         /* store the word for dumping */                        \
1496         SV* tmp;                                                \
1497         if (OP(noper) != NOTHING)                               \
1498             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
1499         else                                                    \
1500             tmp = newSVpvn_utf8( "", 0, UTF );                  \
1501         av_push( trie_words, tmp );                             \
1502     });                                                         \
1503                                                                 \
1504     curword++;                                                  \
1505     trie->wordinfo[curword].prev   = 0;                         \
1506     trie->wordinfo[curword].len    = wordlen;                   \
1507     trie->wordinfo[curword].accept = state;                     \
1508                                                                 \
1509     if ( noper_next < tail ) {                                  \
1510         if (!trie->jump)                                        \
1511             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, sizeof(U16) ); \
1512         trie->jump[curword] = (U16)(noper_next - convert);      \
1513         if (!jumper)                                            \
1514             jumper = noper_next;                                \
1515         if (!nextbranch)                                        \
1516             nextbranch= regnext(cur);                           \
1517     }                                                           \
1518                                                                 \
1519     if ( dupe ) {                                               \
1520         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
1521         /* chain, so that when the bits of chain are later    */\
1522         /* linked together, the dups appear in the chain      */\
1523         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
1524         trie->wordinfo[dupe].prev = curword;                    \
1525     } else {                                                    \
1526         /* we haven't inserted this word yet.                */ \
1527         trie->states[ state ].wordnum = curword;                \
1528     }                                                           \
1529 } STMT_END
1530
1531
1532 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
1533      ( ( base + charid >=  ucharcount                                   \
1534          && base + charid < ubound                                      \
1535          && state == trie->trans[ base - ucharcount + charid ].check    \
1536          && trie->trans[ base - ucharcount + charid ].next )            \
1537            ? trie->trans[ base - ucharcount + charid ].next             \
1538            : ( state==1 ? special : 0 )                                 \
1539       )
1540
1541 #define MADE_TRIE       1
1542 #define MADE_JUMP_TRIE  2
1543 #define MADE_EXACT_TRIE 4
1544
1545 STATIC I32
1546 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth)
1547 {
1548     dVAR;
1549     /* first pass, loop through and scan words */
1550     reg_trie_data *trie;
1551     HV *widecharmap = NULL;
1552     AV *revcharmap = newAV();
1553     regnode *cur;
1554     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1555     STRLEN len = 0;
1556     UV uvc = 0;
1557     U16 curword = 0;
1558     U32 next_alloc = 0;
1559     regnode *jumper = NULL;
1560     regnode *nextbranch = NULL;
1561     regnode *convert = NULL;
1562     U32 *prev_states; /* temp array mapping each state to previous one */
1563     /* we just use folder as a flag in utf8 */
1564     const U8 * folder = NULL;
1565
1566 #ifdef DEBUGGING
1567     const U32 data_slot = add_data( pRExC_state, 4, "tuuu" );
1568     AV *trie_words = NULL;
1569     /* along with revcharmap, this only used during construction but both are
1570      * useful during debugging so we store them in the struct when debugging.
1571      */
1572 #else
1573     const U32 data_slot = add_data( pRExC_state, 2, "tu" );
1574     STRLEN trie_charcount=0;
1575 #endif
1576     SV *re_trie_maxbuff;
1577     GET_RE_DEBUG_FLAGS_DECL;
1578
1579     PERL_ARGS_ASSERT_MAKE_TRIE;
1580 #ifndef DEBUGGING
1581     PERL_UNUSED_ARG(depth);
1582 #endif
1583
1584     switch (flags) {
1585         case EXACT: break;
1586         case EXACTFA:
1587         case EXACTFU_SS:
1588         case EXACTFU_TRICKYFOLD:
1589         case EXACTFU: folder = PL_fold_latin1; break;
1590         case EXACTF:  folder = PL_fold; break;
1591         case EXACTFL: folder = PL_fold_locale; break;
1592         default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
1593     }
1594
1595     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
1596     trie->refcount = 1;
1597     trie->startstate = 1;
1598     trie->wordcount = word_count;
1599     RExC_rxi->data->data[ data_slot ] = (void*)trie;
1600     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
1601     if (flags == EXACT)
1602         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
1603     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
1604                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
1605
1606     DEBUG_r({
1607         trie_words = newAV();
1608     });
1609
1610     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
1611     if (!SvIOK(re_trie_maxbuff)) {
1612         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
1613     }
1614     DEBUG_TRIE_COMPILE_r({
1615                 PerlIO_printf( Perl_debug_log,
1616                   "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
1617                   (int)depth * 2 + 2, "", 
1618                   REG_NODE_NUM(startbranch),REG_NODE_NUM(first), 
1619                   REG_NODE_NUM(last), REG_NODE_NUM(tail),
1620                   (int)depth);
1621     });
1622    
1623    /* Find the node we are going to overwrite */
1624     if ( first == startbranch && OP( last ) != BRANCH ) {
1625         /* whole branch chain */
1626         convert = first;
1627     } else {
1628         /* branch sub-chain */
1629         convert = NEXTOPER( first );
1630     }
1631         
1632     /*  -- First loop and Setup --
1633
1634        We first traverse the branches and scan each word to determine if it
1635        contains widechars, and how many unique chars there are, this is
1636        important as we have to build a table with at least as many columns as we
1637        have unique chars.
1638
1639        We use an array of integers to represent the character codes 0..255
1640        (trie->charmap) and we use a an HV* to store Unicode characters. We use the
1641        native representation of the character value as the key and IV's for the
1642        coded index.
1643
1644        *TODO* If we keep track of how many times each character is used we can
1645        remap the columns so that the table compression later on is more
1646        efficient in terms of memory by ensuring the most common value is in the
1647        middle and the least common are on the outside.  IMO this would be better
1648        than a most to least common mapping as theres a decent chance the most
1649        common letter will share a node with the least common, meaning the node
1650        will not be compressible. With a middle is most common approach the worst
1651        case is when we have the least common nodes twice.
1652
1653      */
1654
1655     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1656         regnode *noper = NEXTOPER( cur );
1657         const U8 *uc = (U8*)STRING( noper );
1658         const U8 *e  = uc + STR_LEN( noper );
1659         STRLEN foldlen = 0;
1660         U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1661         STRLEN skiplen = 0;
1662         const U8 *scan = (U8*)NULL;
1663         U32 wordlen      = 0;         /* required init */
1664         STRLEN chars = 0;
1665         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the bitmap?*/
1666
1667         if (OP(noper) == NOTHING) {
1668             regnode *noper_next= regnext(noper);
1669             if (noper_next != tail && OP(noper_next) == flags) {
1670                 noper = noper_next;
1671                 uc= (U8*)STRING(noper);
1672                 e= uc + STR_LEN(noper);
1673                 trie->minlen= STR_LEN(noper);
1674             } else {
1675                 trie->minlen= 0;
1676                 continue;
1677             }
1678         }
1679
1680         if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
1681             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
1682                                           regardless of encoding */
1683             if (OP( noper ) == EXACTFU_SS) {
1684                 /* false positives are ok, so just set this */
1685                 TRIE_BITMAP_SET(trie,0xDF);
1686             }
1687         }
1688         for ( ; uc < e ; uc += len ) {
1689             TRIE_CHARCOUNT(trie)++;
1690             TRIE_READ_CHAR;
1691             chars++;
1692             if ( uvc < 256 ) {
1693                 if ( folder ) {
1694                     U8 folded= folder[ (U8) uvc ];
1695                     if ( !trie->charmap[ folded ] ) {
1696                         trie->charmap[ folded ]=( ++trie->uniquecharcount );
1697                         TRIE_STORE_REVCHAR( folded );
1698                     }
1699                 }
1700                 if ( !trie->charmap[ uvc ] ) {
1701                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
1702                     TRIE_STORE_REVCHAR( uvc );
1703                 }
1704                 if ( set_bit ) {
1705                     /* store the codepoint in the bitmap, and its folded
1706                      * equivalent. */
1707                     TRIE_BITMAP_SET(trie, uvc);
1708
1709                     /* store the folded codepoint */
1710                     if ( folder ) TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);
1711
1712                     if ( !UTF ) {
1713                         /* store first byte of utf8 representation of
1714                            variant codepoints */
1715                         if (! UNI_IS_INVARIANT(uvc)) {
1716                             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));
1717                         }
1718                     }
1719                     set_bit = 0; /* We've done our bit :-) */
1720                 }
1721             } else {
1722                 SV** svpp;
1723                 if ( !widecharmap )
1724                     widecharmap = newHV();
1725
1726                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
1727
1728                 if ( !svpp )
1729                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
1730
1731                 if ( !SvTRUE( *svpp ) ) {
1732                     sv_setiv( *svpp, ++trie->uniquecharcount );
1733                     TRIE_STORE_REVCHAR(uvc);
1734                 }
1735             }
1736         }
1737         if( cur == first ) {
1738             trie->minlen = chars;
1739             trie->maxlen = chars;
1740         } else if (chars < trie->minlen) {
1741             trie->minlen = chars;
1742         } else if (chars > trie->maxlen) {
1743             trie->maxlen = chars;
1744         }
1745         if (OP( noper ) == EXACTFU_SS) {
1746             /* XXX: workaround - 'ss' could match "\x{DF}" so minlen could be 1 and not 2*/
1747             if (trie->minlen > 1)
1748                 trie->minlen= 1;
1749         }
1750         if (OP( noper ) == EXACTFU_TRICKYFOLD) {
1751             /* XXX: workround - things like "\x{1FBE}\x{0308}\x{0301}" can match "\x{0390}" 
1752              *                - We assume that any such sequence might match a 2 byte string */
1753             if (trie->minlen > 2 )
1754                 trie->minlen= 2;
1755         }
1756
1757     } /* end first pass */
1758     DEBUG_TRIE_COMPILE_r(
1759         PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
1760                 (int)depth * 2 + 2,"",
1761                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
1762                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
1763                 (int)trie->minlen, (int)trie->maxlen )
1764     );
1765
1766     /*
1767         We now know what we are dealing with in terms of unique chars and
1768         string sizes so we can calculate how much memory a naive
1769         representation using a flat table  will take. If it's over a reasonable
1770         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
1771         conservative but potentially much slower representation using an array
1772         of lists.
1773
1774         At the end we convert both representations into the same compressed
1775         form that will be used in regexec.c for matching with. The latter
1776         is a form that cannot be used to construct with but has memory
1777         properties similar to the list form and access properties similar
1778         to the table form making it both suitable for fast searches and
1779         small enough that its feasable to store for the duration of a program.
1780
1781         See the comment in the code where the compressed table is produced
1782         inplace from the flat tabe representation for an explanation of how
1783         the compression works.
1784
1785     */
1786
1787
1788     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
1789     prev_states[1] = 0;
1790
1791     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1) > SvIV(re_trie_maxbuff) ) {
1792         /*
1793             Second Pass -- Array Of Lists Representation
1794
1795             Each state will be represented by a list of charid:state records
1796             (reg_trie_trans_le) the first such element holds the CUR and LEN
1797             points of the allocated array. (See defines above).
1798
1799             We build the initial structure using the lists, and then convert
1800             it into the compressed table form which allows faster lookups
1801             (but cant be modified once converted).
1802         */
1803
1804         STRLEN transcount = 1;
1805
1806         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
1807             "%*sCompiling trie using list compiler\n",
1808             (int)depth * 2 + 2, ""));
1809
1810         trie->states = (reg_trie_state *)
1811             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1812                                   sizeof(reg_trie_state) );
1813         TRIE_LIST_NEW(1);
1814         next_alloc = 2;
1815
1816         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1817
1818             regnode *noper   = NEXTOPER( cur );
1819             U8 *uc           = (U8*)STRING( noper );
1820             const U8 *e      = uc + STR_LEN( noper );
1821             U32 state        = 1;         /* required init */
1822             U16 charid       = 0;         /* sanity init */
1823             U8 *scan         = (U8*)NULL; /* sanity init */
1824             STRLEN foldlen   = 0;         /* required init */
1825             U32 wordlen      = 0;         /* required init */
1826             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1827             STRLEN skiplen   = 0;
1828
1829             if (OP(noper) == NOTHING) {
1830                 regnode *noper_next= regnext(noper);
1831                 if (noper_next != tail && OP(noper_next) == flags) {
1832                     noper = noper_next;
1833                     uc= (U8*)STRING(noper);
1834                     e= uc + STR_LEN(noper);
1835                 }
1836             }
1837
1838             if (OP(noper) != NOTHING) {
1839                 for ( ; uc < e ; uc += len ) {
1840
1841                     TRIE_READ_CHAR;
1842
1843                     if ( uvc < 256 ) {
1844                         charid = trie->charmap[ uvc ];
1845                     } else {
1846                         SV** const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1847                         if ( !svpp ) {
1848                             charid = 0;
1849                         } else {
1850                             charid=(U16)SvIV( *svpp );
1851                         }
1852                     }
1853                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
1854                     if ( charid ) {
1855
1856                         U16 check;
1857                         U32 newstate = 0;
1858
1859                         charid--;
1860                         if ( !trie->states[ state ].trans.list ) {
1861                             TRIE_LIST_NEW( state );
1862                         }
1863                         for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) {
1864                             if ( TRIE_LIST_ITEM( state, check ).forid == charid ) {
1865                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
1866                                 break;
1867                             }
1868                         }
1869                         if ( ! newstate ) {
1870                             newstate = next_alloc++;
1871                             prev_states[newstate] = state;
1872                             TRIE_LIST_PUSH( state, charid, newstate );
1873                             transcount++;
1874                         }
1875                         state = newstate;
1876                     } else {
1877                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1878                     }
1879                 }
1880             }
1881             TRIE_HANDLE_WORD(state);
1882
1883         } /* end second pass */
1884
1885         /* next alloc is the NEXT state to be allocated */
1886         trie->statecount = next_alloc; 
1887         trie->states = (reg_trie_state *)
1888             PerlMemShared_realloc( trie->states,
1889                                    next_alloc
1890                                    * sizeof(reg_trie_state) );
1891
1892         /* and now dump it out before we compress it */
1893         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
1894                                                          revcharmap, next_alloc,
1895                                                          depth+1)
1896         );
1897
1898         trie->trans = (reg_trie_trans *)
1899             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
1900         {
1901             U32 state;
1902             U32 tp = 0;
1903             U32 zp = 0;
1904
1905
1906             for( state=1 ; state < next_alloc ; state ++ ) {
1907                 U32 base=0;
1908
1909                 /*
1910                 DEBUG_TRIE_COMPILE_MORE_r(
1911                     PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
1912                 );
1913                 */
1914
1915                 if (trie->states[state].trans.list) {
1916                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
1917                     U16 maxid=minid;
1918                     U16 idx;
1919
1920                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1921                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
1922                         if ( forid < minid ) {
1923                             minid=forid;
1924                         } else if ( forid > maxid ) {
1925                             maxid=forid;
1926                         }
1927                     }
1928                     if ( transcount < tp + maxid - minid + 1) {
1929                         transcount *= 2;
1930                         trie->trans = (reg_trie_trans *)
1931                             PerlMemShared_realloc( trie->trans,
1932                                                      transcount
1933                                                      * sizeof(reg_trie_trans) );
1934                         Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans );
1935                     }
1936                     base = trie->uniquecharcount + tp - minid;
1937                     if ( maxid == minid ) {
1938                         U32 set = 0;
1939                         for ( ; zp < tp ; zp++ ) {
1940                             if ( ! trie->trans[ zp ].next ) {
1941                                 base = trie->uniquecharcount + zp - minid;
1942                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1943                                 trie->trans[ zp ].check = state;
1944                                 set = 1;
1945                                 break;
1946                             }
1947                         }
1948                         if ( !set ) {
1949                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1950                             trie->trans[ tp ].check = state;
1951                             tp++;
1952                             zp = tp;
1953                         }
1954                     } else {
1955                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1956                             const U32 tid = base -  trie->uniquecharcount + TRIE_LIST_ITEM( state, idx ).forid;
1957                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state, idx ).newstate;
1958                             trie->trans[ tid ].check = state;
1959                         }
1960                         tp += ( maxid - minid + 1 );
1961                     }
1962                     Safefree(trie->states[ state ].trans.list);
1963                 }
1964                 /*
1965                 DEBUG_TRIE_COMPILE_MORE_r(
1966                     PerlIO_printf( Perl_debug_log, " base: %d\n",base);
1967                 );
1968                 */
1969                 trie->states[ state ].trans.base=base;
1970             }
1971             trie->lasttrans = tp + 1;
1972         }
1973     } else {
1974         /*
1975            Second Pass -- Flat Table Representation.
1976
1977            we dont use the 0 slot of either trans[] or states[] so we add 1 to each.
1978            We know that we will need Charcount+1 trans at most to store the data
1979            (one row per char at worst case) So we preallocate both structures
1980            assuming worst case.
1981
1982            We then construct the trie using only the .next slots of the entry
1983            structs.
1984
1985            We use the .check field of the first entry of the node temporarily to
1986            make compression both faster and easier by keeping track of how many non
1987            zero fields are in the node.
1988
1989            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
1990            transition.
1991
1992            There are two terms at use here: state as a TRIE_NODEIDX() which is a
1993            number representing the first entry of the node, and state as a
1994            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1) and
1995            TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3) if there
1996            are 2 entrys per node. eg:
1997
1998              A B       A B
1999           1. 2 4    1. 3 7
2000           2. 0 3    3. 0 5
2001           3. 0 0    5. 0 0
2002           4. 0 0    7. 0 0
2003
2004            The table is internally in the right hand, idx form. However as we also
2005            have to deal with the states array which is indexed by nodenum we have to
2006            use TRIE_NODENUM() to convert.
2007
2008         */
2009         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
2010             "%*sCompiling trie using table compiler\n",
2011             (int)depth * 2 + 2, ""));
2012
2013         trie->trans = (reg_trie_trans *)
2014             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
2015                                   * trie->uniquecharcount + 1,
2016                                   sizeof(reg_trie_trans) );
2017         trie->states = (reg_trie_state *)
2018             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2019                                   sizeof(reg_trie_state) );
2020         next_alloc = trie->uniquecharcount + 1;
2021
2022
2023         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2024
2025             regnode *noper   = NEXTOPER( cur );
2026             const U8 *uc     = (U8*)STRING( noper );
2027             const U8 *e      = uc + STR_LEN( noper );
2028
2029             U32 state        = 1;         /* required init */
2030
2031             U16 charid       = 0;         /* sanity init */
2032             U32 accept_state = 0;         /* sanity init */
2033             U8 *scan         = (U8*)NULL; /* sanity init */
2034
2035             STRLEN foldlen   = 0;         /* required init */
2036             U32 wordlen      = 0;         /* required init */
2037             STRLEN skiplen   = 0;
2038             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2039
2040             if (OP(noper) == NOTHING) {
2041                 regnode *noper_next= regnext(noper);
2042                 if (noper_next != tail && OP(noper_next) == flags) {
2043                     noper = noper_next;
2044                     uc= (U8*)STRING(noper);
2045                     e= uc + STR_LEN(noper);
2046                 }
2047             }
2048
2049             if ( OP(noper) != NOTHING ) {
2050                 for ( ; uc < e ; uc += len ) {
2051
2052                     TRIE_READ_CHAR;
2053
2054                     if ( uvc < 256 ) {
2055                         charid = trie->charmap[ uvc ];
2056                     } else {
2057                         SV* const * const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
2058                         charid = svpp ? (U16)SvIV(*svpp) : 0;
2059                     }
2060                     if ( charid ) {
2061                         charid--;
2062                         if ( !trie->trans[ state + charid ].next ) {
2063                             trie->trans[ state + charid ].next = next_alloc;
2064                             trie->trans[ state ].check++;
2065                             prev_states[TRIE_NODENUM(next_alloc)]
2066                                     = TRIE_NODENUM(state);
2067                             next_alloc += trie->uniquecharcount;
2068                         }
2069                         state = trie->trans[ state + charid ].next;
2070                     } else {
2071                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
2072                     }
2073                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
2074                 }
2075             }
2076             accept_state = TRIE_NODENUM( state );
2077             TRIE_HANDLE_WORD(accept_state);
2078
2079         } /* end second pass */
2080
2081         /* and now dump it out before we compress it */
2082         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
2083                                                           revcharmap,
2084                                                           next_alloc, depth+1));
2085
2086         {
2087         /*
2088            * Inplace compress the table.*
2089
2090            For sparse data sets the table constructed by the trie algorithm will
2091            be mostly 0/FAIL transitions or to put it another way mostly empty.
2092            (Note that leaf nodes will not contain any transitions.)
2093
2094            This algorithm compresses the tables by eliminating most such
2095            transitions, at the cost of a modest bit of extra work during lookup:
2096
2097            - Each states[] entry contains a .base field which indicates the
2098            index in the state[] array wheres its transition data is stored.
2099
2100            - If .base is 0 there are no valid transitions from that node.
2101
2102            - If .base is nonzero then charid is added to it to find an entry in
2103            the trans array.
2104
2105            -If trans[states[state].base+charid].check!=state then the
2106            transition is taken to be a 0/Fail transition. Thus if there are fail
2107            transitions at the front of the node then the .base offset will point
2108            somewhere inside the previous nodes data (or maybe even into a node
2109            even earlier), but the .check field determines if the transition is
2110            valid.
2111
2112            XXX - wrong maybe?
2113            The following process inplace converts the table to the compressed
2114            table: We first do not compress the root node 1,and mark all its
2115            .check pointers as 1 and set its .base pointer as 1 as well. This
2116            allows us to do a DFA construction from the compressed table later,
2117            and ensures that any .base pointers we calculate later are greater
2118            than 0.
2119
2120            - We set 'pos' to indicate the first entry of the second node.
2121
2122            - We then iterate over the columns of the node, finding the first and
2123            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
2124            and set the .check pointers accordingly, and advance pos
2125            appropriately and repreat for the next node. Note that when we copy
2126            the next pointers we have to convert them from the original
2127            NODEIDX form to NODENUM form as the former is not valid post
2128            compression.
2129
2130            - If a node has no transitions used we mark its base as 0 and do not
2131            advance the pos pointer.
2132
2133            - If a node only has one transition we use a second pointer into the
2134            structure to fill in allocated fail transitions from other states.
2135            This pointer is independent of the main pointer and scans forward
2136            looking for null transitions that are allocated to a state. When it
2137            finds one it writes the single transition into the "hole".  If the
2138            pointer doesnt find one the single transition is appended as normal.
2139
2140            - Once compressed we can Renew/realloc the structures to release the
2141            excess space.
2142
2143            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
2144            specifically Fig 3.47 and the associated pseudocode.
2145
2146            demq
2147         */
2148         const U32 laststate = TRIE_NODENUM( next_alloc );
2149         U32 state, charid;
2150         U32 pos = 0, zp=0;
2151         trie->statecount = laststate;
2152
2153         for ( state = 1 ; state < laststate ; state++ ) {
2154             U8 flag = 0;
2155             const U32 stateidx = TRIE_NODEIDX( state );
2156             const U32 o_used = trie->trans[ stateidx ].check;
2157             U32 used = trie->trans[ stateidx ].check;
2158             trie->trans[ stateidx ].check = 0;
2159
2160             for ( charid = 0 ; used && charid < trie->uniquecharcount ; charid++ ) {
2161                 if ( flag || trie->trans[ stateidx + charid ].next ) {
2162                     if ( trie->trans[ stateidx + charid ].next ) {
2163                         if (o_used == 1) {
2164                             for ( ; zp < pos ; zp++ ) {
2165                                 if ( ! trie->trans[ zp ].next ) {
2166                                     break;
2167                                 }
2168                             }
2169                             trie->states[ state ].trans.base = zp + trie->uniquecharcount - charid ;
2170                             trie->trans[ zp ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2171                             trie->trans[ zp ].check = state;
2172                             if ( ++zp > pos ) pos = zp;
2173                             break;
2174                         }
2175                         used--;
2176                     }
2177                     if ( !flag ) {
2178                         flag = 1;
2179                         trie->states[ state ].trans.base = pos + trie->uniquecharcount - charid ;
2180                     }
2181                     trie->trans[ pos ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2182                     trie->trans[ pos ].check = state;
2183                     pos++;
2184                 }
2185             }
2186         }
2187         trie->lasttrans = pos + 1;
2188         trie->states = (reg_trie_state *)
2189             PerlMemShared_realloc( trie->states, laststate
2190                                    * sizeof(reg_trie_state) );
2191         DEBUG_TRIE_COMPILE_MORE_r(
2192                 PerlIO_printf( Perl_debug_log,
2193                     "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
2194                     (int)depth * 2 + 2,"",
2195                     (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1 ),
2196                     (IV)next_alloc,
2197                     (IV)pos,
2198                     ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
2199             );
2200
2201         } /* end table compress */
2202     }
2203     DEBUG_TRIE_COMPILE_MORE_r(
2204             PerlIO_printf(Perl_debug_log, "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
2205                 (int)depth * 2 + 2, "",
2206                 (UV)trie->statecount,
2207                 (UV)trie->lasttrans)
2208     );
2209     /* resize the trans array to remove unused space */
2210     trie->trans = (reg_trie_trans *)
2211         PerlMemShared_realloc( trie->trans, trie->lasttrans
2212                                * sizeof(reg_trie_trans) );
2213
2214     {   /* Modify the program and insert the new TRIE node */ 
2215         U8 nodetype =(U8)(flags & 0xFF);
2216         char *str=NULL;
2217         
2218 #ifdef DEBUGGING
2219         regnode *optimize = NULL;
2220 #ifdef RE_TRACK_PATTERN_OFFSETS
2221
2222         U32 mjd_offset = 0;
2223         U32 mjd_nodelen = 0;
2224 #endif /* RE_TRACK_PATTERN_OFFSETS */
2225 #endif /* DEBUGGING */
2226         /*
2227            This means we convert either the first branch or the first Exact,
2228            depending on whether the thing following (in 'last') is a branch
2229            or not and whther first is the startbranch (ie is it a sub part of
2230            the alternation or is it the whole thing.)
2231            Assuming its a sub part we convert the EXACT otherwise we convert
2232            the whole branch sequence, including the first.
2233          */
2234         /* Find the node we are going to overwrite */
2235         if ( first != startbranch || OP( last ) == BRANCH ) {
2236             /* branch sub-chain */
2237             NEXT_OFF( first ) = (U16)(last - first);
2238 #ifdef RE_TRACK_PATTERN_OFFSETS
2239             DEBUG_r({
2240                 mjd_offset= Node_Offset((convert));
2241                 mjd_nodelen= Node_Length((convert));
2242             });
2243 #endif
2244             /* whole branch chain */
2245         }
2246 #ifdef RE_TRACK_PATTERN_OFFSETS
2247         else {
2248             DEBUG_r({
2249                 const  regnode *nop = NEXTOPER( convert );
2250                 mjd_offset= Node_Offset((nop));
2251                 mjd_nodelen= Node_Length((nop));
2252             });
2253         }
2254         DEBUG_OPTIMISE_r(
2255             PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
2256                 (int)depth * 2 + 2, "",
2257                 (UV)mjd_offset, (UV)mjd_nodelen)
2258         );
2259 #endif
2260         /* But first we check to see if there is a common prefix we can 
2261            split out as an EXACT and put in front of the TRIE node.  */
2262         trie->startstate= 1;
2263         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
2264             U32 state;
2265             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
2266                 U32 ofs = 0;
2267                 I32 idx = -1;
2268                 U32 count = 0;
2269                 const U32 base = trie->states[ state ].trans.base;
2270
2271                 if ( trie->states[state].wordnum )
2272                         count = 1;
2273
2274                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2275                     if ( ( base + ofs >= trie->uniquecharcount ) &&
2276                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
2277                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
2278                     {
2279                         if ( ++count > 1 ) {
2280                             SV **tmp = av_fetch( revcharmap, ofs, 0);
2281                             const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
2282                             if ( state == 1 ) break;
2283                             if ( count == 2 ) {
2284                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
2285                                 DEBUG_OPTIMISE_r(
2286                                     PerlIO_printf(Perl_debug_log,
2287                                         "%*sNew Start State=%"UVuf" Class: [",
2288                                         (int)depth * 2 + 2, "",
2289                                         (UV)state));
2290                                 if (idx >= 0) {
2291                                     SV ** const tmp = av_fetch( revcharmap, idx, 0);
2292                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
2293
2294                                     TRIE_BITMAP_SET(trie,*ch);
2295                                     if ( folder )
2296                                         TRIE_BITMAP_SET(trie, folder[ *ch ]);
2297                                     DEBUG_OPTIMISE_r(
2298                                         PerlIO_printf(Perl_debug_log, "%s", (char*)ch)
2299                                     );
2300                                 }
2301                             }
2302                             TRIE_BITMAP_SET(trie,*ch);
2303                             if ( folder )
2304                                 TRIE_BITMAP_SET(trie,folder[ *ch ]);
2305                             DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
2306                         }
2307                         idx = ofs;
2308                     }
2309                 }
2310                 if ( count == 1 ) {
2311                     SV **tmp = av_fetch( revcharmap, idx, 0);
2312                     STRLEN len;
2313                     char *ch = SvPV( *tmp, len );
2314                     DEBUG_OPTIMISE_r({
2315                         SV *sv=sv_newmortal();
2316                         PerlIO_printf( Perl_debug_log,
2317                             "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
2318                             (int)depth * 2 + 2, "",
2319                             (UV)state, (UV)idx, 
2320                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6, 
2321                                 PL_colors[0], PL_colors[1],
2322                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2323                                 PERL_PV_ESCAPE_FIRSTCHAR 
2324                             )
2325                         );
2326                     });
2327                     if ( state==1 ) {
2328                         OP( convert ) = nodetype;
2329                         str=STRING(convert);
2330                         STR_LEN(convert)=0;
2331                     }
2332                     STR_LEN(convert) += len;
2333                     while (len--)
2334                         *str++ = *ch++;
2335                 } else {
2336 #ifdef DEBUGGING            
2337                     if (state>1)
2338                         DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
2339 #endif
2340                     break;
2341                 }
2342             }
2343             trie->prefixlen = (state-1);
2344             if (str) {
2345                 regnode *n = convert+NODE_SZ_STR(convert);
2346                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
2347                 trie->startstate = state;
2348                 trie->minlen -= (state - 1);
2349                 trie->maxlen -= (state - 1);
2350 #ifdef DEBUGGING
2351                /* At least the UNICOS C compiler choked on this
2352                 * being argument to DEBUG_r(), so let's just have
2353                 * it right here. */
2354                if (
2355 #ifdef PERL_EXT_RE_BUILD
2356                    1
2357 #else
2358                    DEBUG_r_TEST
2359 #endif
2360                    ) {
2361                    regnode *fix = convert;
2362                    U32 word = trie->wordcount;
2363                    mjd_nodelen++;
2364                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
2365                    while( ++fix < n ) {
2366                        Set_Node_Offset_Length(fix, 0, 0);
2367                    }
2368                    while (word--) {
2369                        SV ** const tmp = av_fetch( trie_words, word, 0 );
2370                        if (tmp) {
2371                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
2372                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
2373                            else
2374                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
2375                        }
2376                    }
2377                }
2378 #endif
2379                 if (trie->maxlen) {
2380                     convert = n;
2381                 } else {
2382                     NEXT_OFF(convert) = (U16)(tail - convert);
2383                     DEBUG_r(optimize= n);
2384                 }
2385             }
2386         }
2387         if (!jumper) 
2388             jumper = last; 
2389         if ( trie->maxlen ) {
2390             NEXT_OFF( convert ) = (U16)(tail - convert);
2391             ARG_SET( convert, data_slot );
2392             /* Store the offset to the first unabsorbed branch in 
2393                jump[0], which is otherwise unused by the jump logic. 
2394                We use this when dumping a trie and during optimisation. */
2395             if (trie->jump) 
2396                 trie->jump[0] = (U16)(nextbranch - convert);
2397             
2398             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
2399              *   and there is a bitmap
2400              *   and the first "jump target" node we found leaves enough room
2401              * then convert the TRIE node into a TRIEC node, with the bitmap
2402              * embedded inline in the opcode - this is hypothetically faster.
2403              */
2404             if ( !trie->states[trie->startstate].wordnum
2405                  && trie->bitmap
2406                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
2407             {
2408                 OP( convert ) = TRIEC;
2409                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
2410                 PerlMemShared_free(trie->bitmap);
2411                 trie->bitmap= NULL;
2412             } else 
2413                 OP( convert ) = TRIE;
2414
2415             /* store the type in the flags */
2416             convert->flags = nodetype;
2417             DEBUG_r({
2418             optimize = convert 
2419                       + NODE_STEP_REGNODE 
2420                       + regarglen[ OP( convert ) ];
2421             });
2422             /* XXX We really should free up the resource in trie now, 
2423                    as we won't use them - (which resources?) dmq */
2424         }
2425         /* needed for dumping*/
2426         DEBUG_r(if (optimize) {
2427             regnode *opt = convert;
2428
2429             while ( ++opt < optimize) {
2430                 Set_Node_Offset_Length(opt,0,0);
2431             }
2432             /* 
2433                 Try to clean up some of the debris left after the 
2434                 optimisation.
2435              */
2436             while( optimize < jumper ) {
2437                 mjd_nodelen += Node_Length((optimize));
2438                 OP( optimize ) = OPTIMIZED;
2439                 Set_Node_Offset_Length(optimize,0,0);
2440                 optimize++;
2441             }
2442             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
2443         });
2444     } /* end node insert */
2445
2446     /*  Finish populating the prev field of the wordinfo array.  Walk back
2447      *  from each accept state until we find another accept state, and if
2448      *  so, point the first word's .prev field at the second word. If the
2449      *  second already has a .prev field set, stop now. This will be the
2450      *  case either if we've already processed that word's accept state,
2451      *  or that state had multiple words, and the overspill words were
2452      *  already linked up earlier.
2453      */
2454     {
2455         U16 word;
2456         U32 state;
2457         U16 prev;
2458
2459         for (word=1; word <= trie->wordcount; word++) {
2460             prev = 0;
2461             if (trie->wordinfo[word].prev)
2462                 continue;
2463             state = trie->wordinfo[word].accept;
2464             while (state) {
2465                 state = prev_states[state];
2466                 if (!state)
2467                     break;
2468                 prev = trie->states[state].wordnum;
2469                 if (prev)
2470                     break;
2471             }
2472             trie->wordinfo[word].prev = prev;
2473         }
2474         Safefree(prev_states);
2475     }
2476
2477
2478     /* and now dump out the compressed format */
2479     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
2480
2481     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
2482 #ifdef DEBUGGING
2483     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
2484     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
2485 #else
2486     SvREFCNT_dec_NN(revcharmap);
2487 #endif
2488     return trie->jump 
2489            ? MADE_JUMP_TRIE 
2490            : trie->startstate>1 
2491              ? MADE_EXACT_TRIE 
2492              : MADE_TRIE;
2493 }
2494
2495 STATIC void
2496 S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source,  regnode *stclass, U32 depth)
2497 {
2498 /* The Trie is constructed and compressed now so we can build a fail array if it's needed
2499
2500    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
2501    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
2502    ISBN 0-201-10088-6
2503
2504    We find the fail state for each state in the trie, this state is the longest proper
2505    suffix of the current state's 'word' that is also a proper prefix of another word in our
2506    trie. State 1 represents the word '' and is thus the default fail state. This allows
2507    the DFA not to have to restart after its tried and failed a word at a given point, it
2508    simply continues as though it had been matching the other word in the first place.
2509    Consider
2510       'abcdgu'=~/abcdefg|cdgu/
2511    When we get to 'd' we are still matching the first word, we would encounter 'g' which would
2512    fail, which would bring us to the state representing 'd' in the second word where we would
2513    try 'g' and succeed, proceeding to match 'cdgu'.
2514  */
2515  /* add a fail transition */
2516     const U32 trie_offset = ARG(source);
2517     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
2518     U32 *q;
2519     const U32 ucharcount = trie->uniquecharcount;
2520     const U32 numstates = trie->statecount;
2521     const U32 ubound = trie->lasttrans + ucharcount;
2522     U32 q_read = 0;
2523     U32 q_write = 0;
2524     U32 charid;
2525     U32 base = trie->states[ 1 ].trans.base;
2526     U32 *fail;
2527     reg_ac_data *aho;
2528     const U32 data_slot = add_data( pRExC_state, 1, "T" );
2529     GET_RE_DEBUG_FLAGS_DECL;
2530
2531     PERL_ARGS_ASSERT_MAKE_TRIE_FAILTABLE;
2532 #ifndef DEBUGGING
2533     PERL_UNUSED_ARG(depth);
2534 #endif
2535
2536
2537     ARG_SET( stclass, data_slot );
2538     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
2539     RExC_rxi->data->data[ data_slot ] = (void*)aho;
2540     aho->trie=trie_offset;
2541     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
2542     Copy( trie->states, aho->states, numstates, reg_trie_state );
2543     Newxz( q, numstates, U32);
2544     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
2545     aho->refcount = 1;
2546     fail = aho->fail;
2547     /* initialize fail[0..1] to be 1 so that we always have
2548        a valid final fail state */
2549     fail[ 0 ] = fail[ 1 ] = 1;
2550
2551     for ( charid = 0; charid < ucharcount ; charid++ ) {
2552         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
2553         if ( newstate ) {
2554             q[ q_write ] = newstate;
2555             /* set to point at the root */
2556             fail[ q[ q_write++ ] ]=1;
2557         }
2558     }
2559     while ( q_read < q_write) {
2560         const U32 cur = q[ q_read++ % numstates ];
2561         base = trie->states[ cur ].trans.base;
2562
2563         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
2564             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
2565             if (ch_state) {
2566                 U32 fail_state = cur;
2567                 U32 fail_base;
2568                 do {
2569                     fail_state = fail[ fail_state ];
2570                     fail_base = aho->states[ fail_state ].trans.base;
2571                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
2572
2573                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
2574                 fail[ ch_state ] = fail_state;
2575                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
2576                 {
2577                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
2578                 }
2579                 q[ q_write++ % numstates] = ch_state;
2580             }
2581         }
2582     }
2583     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
2584        when we fail in state 1, this allows us to use the
2585        charclass scan to find a valid start char. This is based on the principle
2586        that theres a good chance the string being searched contains lots of stuff
2587        that cant be a start char.
2588      */
2589     fail[ 0 ] = fail[ 1 ] = 0;
2590     DEBUG_TRIE_COMPILE_r({
2591         PerlIO_printf(Perl_debug_log,
2592                       "%*sStclass Failtable (%"UVuf" states): 0", 
2593                       (int)(depth * 2), "", (UV)numstates
2594         );
2595         for( q_read=1; q_read<numstates; q_read++ ) {
2596             PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
2597         }
2598         PerlIO_printf(Perl_debug_log, "\n");
2599     });
2600     Safefree(q);
2601     /*RExC_seen |= REG_SEEN_TRIEDFA;*/
2602 }
2603
2604
2605 /*
2606  * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2607  * These need to be revisited when a newer toolchain becomes available.
2608  */
2609 #if defined(__sparc64__) && defined(__GNUC__)
2610 #   if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2611 #       undef  SPARC64_GCC_WORKAROUND
2612 #       define SPARC64_GCC_WORKAROUND 1
2613 #   endif
2614 #endif
2615
2616 #define DEBUG_PEEP(str,scan,depth) \
2617     DEBUG_OPTIMISE_r({if (scan){ \
2618        SV * const mysv=sv_newmortal(); \
2619        regnode *Next = regnext(scan); \
2620        regprop(RExC_rx, mysv, scan); \
2621        PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
2622        (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
2623        Next ? (REG_NODE_NUM(Next)) : 0 ); \
2624    }});
2625
2626
2627 /* The below joins as many adjacent EXACTish nodes as possible into a single
2628  * one.  The regop may be changed if the node(s) contain certain sequences that
2629  * require special handling.  The joining is only done if:
2630  * 1) there is room in the current conglomerated node to entirely contain the
2631  *    next one.
2632  * 2) they are the exact same node type
2633  *
2634  * The adjacent nodes actually may be separated by NOTHING-kind nodes, and
2635  * these get optimized out
2636  *
2637  * If a node is to match under /i (folded), the number of characters it matches
2638  * can be different than its character length if it contains a multi-character
2639  * fold.  *min_subtract is set to the total delta of the input nodes.
2640  *
2641  * And *has_exactf_sharp_s is set to indicate whether or not the node is EXACTF
2642  * and contains LATIN SMALL LETTER SHARP S
2643  *
2644  * This is as good a place as any to discuss the design of handling these
2645  * multi-character fold sequences.  It's been wrong in Perl for a very long
2646  * time.  There are three code points in Unicode whose multi-character folds
2647  * were long ago discovered to mess things up.  The previous designs for
2648  * dealing with these involved assigning a special node for them.  This
2649  * approach doesn't work, as evidenced by this example:
2650  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
2651  * Both these fold to "sss", but if the pattern is parsed to create a node that
2652  * would match just the \xDF, it won't be able to handle the case where a
2653  * successful match would have to cross the node's boundary.  The new approach
2654  * that hopefully generally solves the problem generates an EXACTFU_SS node
2655  * that is "sss".
2656  *
2657  * It turns out that there are problems with all multi-character folds, and not
2658  * just these three.  Now the code is general, for all such cases, but the
2659  * three still have some special handling.  The approach taken is:
2660  * 1)   This routine examines each EXACTFish node that could contain multi-
2661  *      character fold sequences.  It returns in *min_subtract how much to
2662  *      subtract from the the actual length of the string to get a real minimum
2663  *      match length; it is 0 if there are no multi-char folds.  This delta is
2664  *      used by the caller to adjust the min length of the match, and the delta
2665  *      between min and max, so that the optimizer doesn't reject these
2666  *      possibilities based on size constraints.
2667  * 2)   Certain of these sequences require special handling by the trie code,
2668  *      so, if found, this code changes the joined node type to special ops:
2669  *      EXACTFU_TRICKYFOLD and EXACTFU_SS.
2670  * 3)   For the sequence involving the Sharp s (\xDF), the node type EXACTFU_SS
2671  *      is used for an EXACTFU node that contains at least one "ss" sequence in
2672  *      it.  For non-UTF-8 patterns and strings, this is the only case where
2673  *      there is a possible fold length change.  That means that a regular
2674  *      EXACTFU node without UTF-8 involvement doesn't have to concern itself
2675  *      with length changes, and so can be processed faster.  regexec.c takes
2676  *      advantage of this.  Generally, an EXACTFish node that is in UTF-8 is
2677  *      pre-folded by regcomp.c.  This saves effort in regex matching.
2678  *      However, the pre-folding isn't done for non-UTF8 patterns because the
2679  *      fold of the MICRO SIGN requires UTF-8, and we don't want to slow things
2680  *      down by forcing the pattern into UTF8 unless necessary.  Also what
2681  *      EXACTF and EXACTFL nodes fold to isn't known until runtime.  The fold
2682  *      possibilities for the non-UTF8 patterns are quite simple, except for
2683  *      the sharp s.  All the ones that don't involve a UTF-8 target string are
2684  *      members of a fold-pair, and arrays are set up for all of them so that
2685  *      the other member of the pair can be found quickly.  Code elsewhere in
2686  *      this file makes sure that in EXACTFU nodes, the sharp s gets folded to
2687  *      'ss', even if the pattern isn't UTF-8.  This avoids the issues
2688  *      described in the next item.
2689  * 4)   A problem remains for the sharp s in EXACTF nodes.  Whether it matches
2690  *      'ss' or not is not knowable at compile time.  It will match iff the
2691  *      target string is in UTF-8, unlike the EXACTFU nodes, where it always
2692  *      matches; and the EXACTFL and EXACTFA nodes where it never does.  Thus
2693  *      it can't be folded to "ss" at compile time, unlike EXACTFU does (as
2694  *      described in item 3).  An assumption that the optimizer part of
2695  *      regexec.c (probably unwittingly) makes is that a character in the
2696  *      pattern corresponds to at most a single character in the target string.
2697  *      (And I do mean character, and not byte here, unlike other parts of the
2698  *      documentation that have never been updated to account for multibyte
2699  *      Unicode.)  This assumption is wrong only in this case, as all other
2700  *      cases are either 1-1 folds when no UTF-8 is involved; or is true by
2701  *      virtue of having this file pre-fold UTF-8 patterns.   I'm
2702  *      reluctant to try to change this assumption, so instead the code punts.
2703  *      This routine examines EXACTF nodes for the sharp s, and returns a
2704  *      boolean indicating whether or not the node is an EXACTF node that
2705  *      contains a sharp s.  When it is true, the caller sets a flag that later
2706  *      causes the optimizer in this file to not set values for the floating
2707  *      and fixed string lengths, and thus avoids the optimizer code in
2708  *      regexec.c that makes the invalid assumption.  Thus, there is no
2709  *      optimization based on string lengths for EXACTF nodes that contain the
2710  *      sharp s.  This only happens for /id rules (which means the pattern
2711  *      isn't in UTF-8).
2712  */
2713
2714 #define JOIN_EXACT(scan,min_subtract,has_exactf_sharp_s, flags) \
2715     if (PL_regkind[OP(scan)] == EXACT) \
2716         join_exact(pRExC_state,(scan),(min_subtract),has_exactf_sharp_s, (flags),NULL,depth+1)
2717
2718 STATIC U32
2719 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, UV *min_subtract, bool *has_exactf_sharp_s, U32 flags,regnode *val, U32 depth) {
2720     /* Merge several consecutive EXACTish nodes into one. */
2721     regnode *n = regnext(scan);
2722     U32 stringok = 1;
2723     regnode *next = scan + NODE_SZ_STR(scan);
2724     U32 merged = 0;
2725     U32 stopnow = 0;
2726 #ifdef DEBUGGING
2727     regnode *stop = scan;
2728     GET_RE_DEBUG_FLAGS_DECL;
2729 #else
2730     PERL_UNUSED_ARG(depth);
2731 #endif
2732
2733     PERL_ARGS_ASSERT_JOIN_EXACT;
2734 #ifndef EXPERIMENTAL_INPLACESCAN
2735     PERL_UNUSED_ARG(flags);
2736     PERL_UNUSED_ARG(val);
2737 #endif
2738     DEBUG_PEEP("join",scan,depth);
2739
2740     /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
2741      * EXACT ones that are mergeable to the current one. */
2742     while (n
2743            && (PL_regkind[OP(n)] == NOTHING
2744                || (stringok && OP(n) == OP(scan)))
2745            && NEXT_OFF(n)
2746            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
2747     {
2748         
2749         if (OP(n) == TAIL || n > next)
2750             stringok = 0;
2751         if (PL_regkind[OP(n)] == NOTHING) {
2752             DEBUG_PEEP("skip:",n,depth);
2753             NEXT_OFF(scan) += NEXT_OFF(n);
2754             next = n + NODE_STEP_REGNODE;
2755 #ifdef DEBUGGING
2756             if (stringok)
2757                 stop = n;
2758 #endif
2759             n = regnext(n);
2760         }
2761         else if (stringok) {
2762             const unsigned int oldl = STR_LEN(scan);
2763             regnode * const nnext = regnext(n);
2764
2765             /* XXX I (khw) kind of doubt that this works on platforms where
2766              * U8_MAX is above 255 because of lots of other assumptions */
2767             /* Don't join if the sum can't fit into a single node */
2768             if (oldl + STR_LEN(n) > U8_MAX)
2769                 break;
2770             
2771             DEBUG_PEEP("merg",n,depth);
2772             merged++;
2773
2774             NEXT_OFF(scan) += NEXT_OFF(n);
2775             STR_LEN(scan) += STR_LEN(n);
2776             next = n + NODE_SZ_STR(n);
2777             /* Now we can overwrite *n : */
2778             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
2779 #ifdef DEBUGGING
2780             stop = next - 1;
2781 #endif
2782             n = nnext;
2783             if (stopnow) break;
2784         }
2785
2786 #ifdef EXPERIMENTAL_INPLACESCAN
2787         if (flags && !NEXT_OFF(n)) {
2788             DEBUG_PEEP("atch", val, depth);
2789             if (reg_off_by_arg[OP(n)]) {
2790                 ARG_SET(n, val - n);
2791             }
2792             else {
2793                 NEXT_OFF(n) = val - n;
2794             }
2795             stopnow = 1;
2796         }
2797 #endif
2798     }
2799
2800     *min_subtract = 0;
2801     *has_exactf_sharp_s = FALSE;
2802
2803     /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
2804      * can now analyze for sequences of problematic code points.  (Prior to
2805      * this final joining, sequences could have been split over boundaries, and
2806      * hence missed).  The sequences only happen in folding, hence for any
2807      * non-EXACT EXACTish node */
2808     if (OP(scan) != EXACT) {
2809         const U8 * const s0 = (U8*) STRING(scan);
2810         const U8 * s = s0;
2811         const U8 * const s_end = s0 + STR_LEN(scan);
2812
2813         /* One pass is made over the node's string looking for all the
2814          * possibilities.  to avoid some tests in the loop, there are two main
2815          * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
2816          * non-UTF-8 */
2817         if (UTF) {
2818
2819             /* Examine the string for a multi-character fold sequence.  UTF-8
2820              * patterns have all characters pre-folded by the time this code is
2821              * executed */
2822             while (s < s_end - 1) /* Can stop 1 before the end, as minimum
2823                                      length sequence we are looking for is 2 */
2824             {
2825                 int count = 0;
2826                 int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
2827                 if (! len) {    /* Not a multi-char fold: get next char */
2828                     s += UTF8SKIP(s);
2829                     continue;
2830                 }
2831
2832                 /* Nodes with 'ss' require special handling, except for EXACTFL
2833                  * and EXACTFA for which there is no multi-char fold to this */
2834                 if (len == 2 && *s == 's' && *(s+1) == 's'
2835                     && OP(scan) != EXACTFL && OP(scan) != EXACTFA)
2836                 {
2837                     count = 2;
2838                     OP(scan) = EXACTFU_SS;
2839                     s += 2;
2840                 }
2841                 else if (len == 6   /* len is the same in both ASCII and EBCDIC for these */
2842                          && (memEQ(s, GREEK_SMALL_LETTER_IOTA_UTF8
2843                                       COMBINING_DIAERESIS_UTF8
2844                                       COMBINING_ACUTE_ACCENT_UTF8,
2845                                    6)
2846                              || memEQ(s, GREEK_SMALL_LETTER_UPSILON_UTF8
2847                                          COMBINING_DIAERESIS_UTF8
2848                                          COMBINING_ACUTE_ACCENT_UTF8,
2849                                      6)))
2850                 {
2851                     count = 3;
2852
2853                     /* These two folds require special handling by trie's, so
2854                      * change the node type to indicate this.  If EXACTFA and
2855                      * EXACTFL were ever to be handled by trie's, this would
2856                      * have to be changed.  If this node has already been
2857                      * changed to EXACTFU_SS in this loop, leave it as is.  (I
2858                      * (khw) think it doesn't matter in regexec.c for UTF
2859                      * patterns, but no need to change it */
2860                     if (OP(scan) == EXACTFU) {
2861                         OP(scan) = EXACTFU_TRICKYFOLD;
2862                     }
2863                     s += 6;
2864                 }
2865                 else { /* Here is a generic multi-char fold. */
2866                     const U8* multi_end  = s + len;
2867
2868                     /* Count how many characters in it.  In the case of /l and
2869                      * /aa, no folds which contain ASCII code points are
2870                      * allowed, so check for those, and skip if found.  (In
2871                      * EXACTFL, no folds are allowed to any Latin1 code point,
2872                      * not just ASCII.  But there aren't any of these
2873                      * currently, nor ever likely, so don't take the time to
2874                      * test for them.  The code that generates the
2875                      * is_MULTI_foo() macros croaks should one actually get put
2876                      * into Unicode .) */
2877                     if (OP(scan) != EXACTFL && OP(scan) != EXACTFA) {
2878                         count = utf8_length(s, multi_end);
2879                         s = multi_end;
2880                     }
2881                     else {
2882                         while (s < multi_end) {
2883                             if (isASCII(*s)) {
2884                                 s++;
2885                                 goto next_iteration;
2886                             }
2887                             else {
2888                                 s += UTF8SKIP(s);
2889                             }
2890                             count++;
2891                         }
2892                     }
2893                 }
2894
2895                 /* The delta is how long the sequence is minus 1 (1 is how long
2896                  * the character that folds to the sequence is) */
2897                 *min_subtract += count - 1;
2898             next_iteration: ;
2899             }
2900         }
2901         else if (OP(scan) != EXACTFL && OP(scan) != EXACTFA) {
2902
2903             /* Here, the pattern is not UTF-8.  Look for the multi-char folds
2904              * that are all ASCII.  As in the above case, EXACTFL and EXACTFA
2905              * nodes can't have multi-char folds to this range (and there are
2906              * no existing ones in the upper latin1 range).  In the EXACTF
2907              * case we look also for the sharp s, which can be in the final
2908              * position.  Otherwise we can stop looking 1 byte earlier because
2909              * have to find at least two characters for a multi-fold */
2910             const U8* upper = (OP(scan) == EXACTF) ? s_end : s_end -1;
2911
2912             /* The below is perhaps overboard, but this allows us to save a
2913              * test each time through the loop at the expense of a mask.  This
2914              * is because on both EBCDIC and ASCII machines, 'S' and 's' differ
2915              * by a single bit.  On ASCII they are 32 apart; on EBCDIC, they
2916              * are 64.  This uses an exclusive 'or' to find that bit and then
2917              * inverts it to form a mask, with just a single 0, in the bit
2918              * position where 'S' and 's' differ. */
2919             const U8 S_or_s_mask = (U8) ~ ('S' ^ 's');
2920             const U8 s_masked = 's' & S_or_s_mask;
2921
2922             while (s < upper) {
2923                 int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end);
2924                 if (! len) {    /* Not a multi-char fold. */
2925                     if (*s == LATIN_SMALL_LETTER_SHARP_S && OP(scan) == EXACTF)
2926                     {
2927                         *has_exactf_sharp_s = TRUE;
2928                     }
2929                     s++;
2930                     continue;
2931                 }
2932
2933                 if (len == 2
2934                     && ((*s & S_or_s_mask) == s_masked)
2935                     && ((*(s+1) & S_or_s_mask) == s_masked))
2936                 {
2937
2938                     /* EXACTF nodes need to know that the minimum length
2939                      * changed so that a sharp s in the string can match this
2940                      * ss in the pattern, but they remain EXACTF nodes, as they
2941                      * won't match this unless the target string is is UTF-8,
2942                      * which we don't know until runtime */
2943                     if (OP(scan) != EXACTF) {
2944                         OP(scan) = EXACTFU_SS;
2945                     }
2946                 }
2947
2948                 *min_subtract += len - 1;
2949                 s += len;
2950             }
2951         }
2952     }
2953
2954 #ifdef DEBUGGING
2955     /* Allow dumping but overwriting the collection of skipped
2956      * ops and/or strings with fake optimized ops */
2957     n = scan + NODE_SZ_STR(scan);
2958     while (n <= stop) {
2959         OP(n) = OPTIMIZED;
2960         FLAGS(n) = 0;
2961         NEXT_OFF(n) = 0;
2962         n++;
2963     }
2964 #endif
2965     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
2966     return stopnow;
2967 }
2968
2969 /* REx optimizer.  Converts nodes into quicker variants "in place".
2970    Finds fixed substrings.  */
2971
2972 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
2973    to the position after last scanned or to NULL. */
2974
2975 #define INIT_AND_WITHP \
2976     assert(!and_withp); \
2977     Newx(and_withp,1,struct regnode_charclass_class); \
2978     SAVEFREEPV(and_withp)
2979
2980 /* this is a chain of data about sub patterns we are processing that
2981    need to be handled separately/specially in study_chunk. Its so
2982    we can simulate recursion without losing state.  */
2983 struct scan_frame;
2984 typedef struct scan_frame {
2985     regnode *last;  /* last node to process in this frame */
2986     regnode *next;  /* next node to process when last is reached */
2987     struct scan_frame *prev; /*previous frame*/
2988     I32 stop; /* what stopparen do we use */
2989 } scan_frame;
2990
2991
2992 #define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf)
2993
2994 STATIC I32
2995 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
2996                         I32 *minlenp, I32 *deltap,
2997                         regnode *last,
2998                         scan_data_t *data,
2999                         I32 stopparen,
3000                         U8* recursed,
3001                         struct regnode_charclass_class *and_withp,
3002                         U32 flags, U32 depth)
3003                         /* scanp: Start here (read-write). */
3004                         /* deltap: Write maxlen-minlen here. */
3005                         /* last: Stop before this one. */
3006                         /* data: string data about the pattern */
3007                         /* stopparen: treat close N as END */
3008                         /* recursed: which subroutines have we recursed into */
3009                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
3010 {
3011     dVAR;
3012     I32 min = 0;    /* There must be at least this number of characters to match */
3013     I32 pars = 0, code;
3014     regnode *scan = *scanp, *next;
3015     I32 delta = 0;
3016     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
3017     int is_inf_internal = 0;            /* The studied chunk is infinite */
3018     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
3019     scan_data_t data_fake;
3020     SV *re_trie_maxbuff = NULL;
3021     regnode *first_non_open = scan;
3022     I32 stopmin = I32_MAX;
3023     scan_frame *frame = NULL;
3024     GET_RE_DEBUG_FLAGS_DECL;
3025
3026     PERL_ARGS_ASSERT_STUDY_CHUNK;
3027
3028 #ifdef DEBUGGING
3029     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
3030 #endif
3031
3032     if ( depth == 0 ) {
3033         while (first_non_open && OP(first_non_open) == OPEN)
3034             first_non_open=regnext(first_non_open);
3035     }
3036
3037
3038   fake_study_recurse:
3039     while ( scan && OP(scan) != END && scan < last ){
3040         UV min_subtract = 0;    /* How mmany chars to subtract from the minimum
3041                                    node length to get a real minimum (because
3042                                    the folded version may be shorter) */
3043         bool has_exactf_sharp_s = FALSE;
3044         /* Peephole optimizer: */
3045         DEBUG_STUDYDATA("Peep:", data,depth);
3046         DEBUG_PEEP("Peep",scan,depth);
3047
3048         /* Its not clear to khw or hv why this is done here, and not in the
3049          * clauses that deal with EXACT nodes.  khw's guess is that it's
3050          * because of a previous design */
3051         JOIN_EXACT(scan,&min_subtract, &has_exactf_sharp_s, 0);
3052
3053         /* Follow the next-chain of the current node and optimize
3054            away all the NOTHINGs from it.  */
3055         if (OP(scan) != CURLYX) {
3056             const int max = (reg_off_by_arg[OP(scan)]
3057                        ? I32_MAX
3058                        /* I32 may be smaller than U16 on CRAYs! */
3059                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
3060             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
3061             int noff;
3062             regnode *n = scan;
3063
3064             /* Skip NOTHING and LONGJMP. */
3065             while ((n = regnext(n))
3066                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
3067                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
3068                    && off + noff < max)
3069                 off += noff;
3070             if (reg_off_by_arg[OP(scan)])
3071                 ARG(scan) = off;
3072             else
3073                 NEXT_OFF(scan) = off;
3074         }
3075
3076
3077
3078         /* The principal pseudo-switch.  Cannot be a switch, since we
3079            look into several different things.  */
3080         if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
3081                    || OP(scan) == IFTHEN) {
3082             next = regnext(scan);
3083             code = OP(scan);
3084             /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
3085
3086             if (OP(next) == code || code == IFTHEN) {
3087                 /* NOTE - There is similar code to this block below for handling
3088                    TRIE nodes on a re-study.  If you change stuff here check there
3089                    too. */
3090                 I32 max1 = 0, min1 = I32_MAX, num = 0;
3091                 struct regnode_charclass_class accum;
3092                 regnode * const startbranch=scan;
3093
3094                 if (flags & SCF_DO_SUBSTR)
3095                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
3096                 if (flags & SCF_DO_STCLASS)
3097                     cl_init_zero(pRExC_state, &accum);
3098
3099                 while (OP(scan) == code) {
3100                     I32 deltanext, minnext, f = 0, fake;
3101                     struct regnode_charclass_class this_class;
3102
3103                     num++;
3104                     data_fake.flags = 0;
3105                     if (data) {
3106                         data_fake.whilem_c = data->whilem_c;
3107                         data_fake.last_closep = data->last_closep;
3108                     }
3109                     else
3110                         data_fake.last_closep = &fake;
3111
3112                     data_fake.pos_delta = delta;
3113                     next = regnext(scan);
3114                     scan = NEXTOPER(scan);
3115                     if (code != BRANCH)
3116                         scan = NEXTOPER(scan);
3117                     if (flags & SCF_DO_STCLASS) {
3118                         cl_init(pRExC_state, &this_class);
3119                         data_fake.start_class = &this_class;
3120                         f = SCF_DO_STCLASS_AND;
3121                     }
3122                     if (flags & SCF_WHILEM_VISITED_POS)
3123                         f |= SCF_WHILEM_VISITED_POS;
3124
3125                     /* we suppose the run is continuous, last=next...*/
3126                     minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
3127                                           next, &data_fake,
3128                                           stopparen, recursed, NULL, f,depth+1);
3129                     if (min1 > minnext)
3130                         min1 = minnext;
3131                     if (deltanext == I32_MAX) {
3132                         is_inf = is_inf_internal = 1;
3133                         max1 = I32_MAX;
3134                     } else if (max1 < minnext + deltanext)
3135                         max1 = minnext + deltanext;
3136                     scan = next;
3137                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3138                         pars++;
3139                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
3140                         if ( stopmin > minnext) 
3141                             stopmin = min + min1;
3142                         flags &= ~SCF_DO_SUBSTR;
3143                         if (data)
3144                             data->flags |= SCF_SEEN_ACCEPT;
3145                     }
3146                     if (data) {
3147                         if (data_fake.flags & SF_HAS_EVAL)
3148                             data->flags |= SF_HAS_EVAL;
3149                         data->whilem_c = data_fake.whilem_c;
3150                     }
3151                     if (flags & SCF_DO_STCLASS)
3152                         cl_or(pRExC_state, &accum, &this_class);
3153                 }
3154                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
3155                     min1 = 0;
3156                 if (flags & SCF_DO_SUBSTR) {
3157                     data->pos_min += min1;
3158                     if (data->pos_delta >= I32_MAX - (max1 - min1))
3159                         data->pos_delta = I32_MAX;
3160                     else
3161                         data->pos_delta += max1 - min1;
3162                     if (max1 != min1 || is_inf)
3163                         data->longest = &(data->longest_float);
3164                 }
3165                 min += min1;
3166                 if (delta == I32_MAX || I32_MAX - delta - (max1 - min1) < 0)
3167                     delta = I32_MAX;
3168                 else
3169                     delta += max1 - min1;
3170                 if (flags & SCF_DO_STCLASS_OR) {
3171                     cl_or(pRExC_state, data->start_class, &accum);
3172                     if (min1) {
3173                         cl_and(data->start_class, and_withp);
3174                         flags &= ~SCF_DO_STCLASS;
3175                     }
3176                 }
3177                 else if (flags & SCF_DO_STCLASS_AND) {
3178                     if (min1) {
3179                         cl_and(data->start_class, &accum);
3180                         flags &= ~SCF_DO_STCLASS;
3181                     }
3182                     else {
3183                         /* Switch to OR mode: cache the old value of
3184                          * data->start_class */
3185                         INIT_AND_WITHP;
3186                         StructCopy(data->start_class, and_withp,
3187                                    struct regnode_charclass_class);
3188                         flags &= ~SCF_DO_STCLASS_AND;
3189                         StructCopy(&accum, data->start_class,
3190                                    struct regnode_charclass_class);
3191                         flags |= SCF_DO_STCLASS_OR;
3192                         SET_SSC_EOS(data->start_class);
3193                     }
3194                 }
3195
3196                 if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) == BRANCH ) {
3197                 /* demq.
3198
3199                    Assuming this was/is a branch we are dealing with: 'scan' now
3200                    points at the item that follows the branch sequence, whatever
3201                    it is. We now start at the beginning of the sequence and look
3202                    for subsequences of
3203
3204                    BRANCH->EXACT=>x1
3205                    BRANCH->EXACT=>x2
3206                    tail
3207
3208                    which would be constructed from a pattern like /A|LIST|OF|WORDS/
3209
3210                    If we can find such a subsequence we need to turn the first
3211                    element into a trie and then add the subsequent branch exact
3212                    strings to the trie.
3213
3214                    We have two cases
3215
3216                      1. patterns where the whole set of branches can be converted. 
3217
3218                      2. patterns where only a subset can be converted.
3219
3220                    In case 1 we can replace the whole set with a single regop
3221                    for the trie. In case 2 we need to keep the start and end
3222                    branches so
3223
3224                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
3225                      becomes BRANCH TRIE; BRANCH X;
3226
3227                   There is an additional case, that being where there is a 
3228                   common prefix, which gets split out into an EXACT like node
3229                   preceding the TRIE node.
3230
3231                   If x(1..n)==tail then we can do a simple trie, if not we make
3232                   a "jump" trie, such that when we match the appropriate word
3233                   we "jump" to the appropriate tail node. Essentially we turn
3234                   a nested if into a case structure of sorts.
3235
3236                 */
3237
3238                     int made=0;
3239                     if (!re_trie_maxbuff) {
3240                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
3241                         if (!SvIOK(re_trie_maxbuff))
3242                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
3243                     }
3244                     if ( SvIV(re_trie_maxbuff)>=0  ) {
3245                         regnode *cur;
3246                         regnode *first = (regnode *)NULL;
3247                         regnode *last = (regnode *)NULL;
3248                         regnode *tail = scan;
3249                         U8 trietype = 0;
3250                         U32 count=0;
3251
3252 #ifdef DEBUGGING
3253                         SV * const mysv = sv_newmortal();       /* for dumping */
3254 #endif
3255                         /* var tail is used because there may be a TAIL
3256                            regop in the way. Ie, the exacts will point to the
3257                            thing following the TAIL, but the last branch will
3258                            point at the TAIL. So we advance tail. If we
3259                            have nested (?:) we may have to move through several
3260                            tails.
3261                          */
3262
3263                         while ( OP( tail ) == TAIL ) {
3264                             /* this is the TAIL generated by (?:) */
3265                             tail = regnext( tail );
3266                         }
3267
3268                         
3269                         DEBUG_TRIE_COMPILE_r({
3270                             regprop(RExC_rx, mysv, tail );
3271                             PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
3272                                 (int)depth * 2 + 2, "", 
3273                                 "Looking for TRIE'able sequences. Tail node is: ", 
3274                                 SvPV_nolen_const( mysv )
3275                             );
3276                         });
3277                         
3278                         /*
3279
3280                             Step through the branches
3281                                 cur represents each branch,
3282                                 noper is the first thing to be matched as part of that branch
3283                                 noper_next is the regnext() of that node.
3284
3285                             We normally handle a case like this /FOO[xyz]|BAR[pqr]/
3286                             via a "jump trie" but we also support building with NOJUMPTRIE,
3287                             which restricts the trie logic to structures like /FOO|BAR/.
3288
3289                             If noper is a trieable nodetype then the branch is a possible optimization
3290                             target. If we are building under NOJUMPTRIE then we require that noper_next
3291                             is the same as scan (our current position in the regex program).
3292
3293                             Once we have two or more consecutive such branches we can create a
3294                             trie of the EXACT's contents and stitch it in place into the program.
3295
3296                             If the sequence represents all of the branches in the alternation we
3297                             replace the entire thing with a single TRIE node.
3298
3299                             Otherwise when it is a subsequence we need to stitch it in place and
3300                             replace only the relevant branches. This means the first branch has
3301                             to remain as it is used by the alternation logic, and its next pointer,
3302                             and needs to be repointed at the item on the branch chain following
3303                             the last branch we have optimized away.
3304
3305                             This could be either a BRANCH, in which case the subsequence is internal,
3306                             or it could be the item following the branch sequence in which case the
3307                             subsequence is at the end (which does not necessarily mean the first node
3308                             is the start of the alternation).
3309
3310                             TRIE_TYPE(X) is a define which maps the optype to a trietype.
3311
3312                                 optype          |  trietype
3313                                 ----------------+-----------
3314                                 NOTHING         | NOTHING
3315                                 EXACT           | EXACT
3316                                 EXACTFU         | EXACTFU
3317                                 EXACTFU_SS      | EXACTFU
3318                                 EXACTFU_TRICKYFOLD | EXACTFU
3319                                 EXACTFA         | 0
3320
3321
3322                         */
3323 #define TRIE_TYPE(X) ( ( NOTHING == (X) ) ? NOTHING :   \
3324                        ( EXACT == (X) )   ? EXACT :        \
3325                        ( EXACTFU == (X) || EXACTFU_SS == (X) || EXACTFU_TRICKYFOLD == (X) ) ? EXACTFU :        \
3326                        0 )
3327
3328                         /* dont use tail as the end marker for this traverse */
3329                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
3330                             regnode * const noper = NEXTOPER( cur );
3331                             U8 noper_type = OP( noper );
3332                             U8 noper_trietype = TRIE_TYPE( noper_type );
3333 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
3334                             regnode * const noper_next = regnext( noper );
3335                             U8 noper_next_type = (noper_next && noper_next != tail) ? OP(noper_next) : 0;
3336                             U8 noper_next_trietype = (noper_next && noper_next != tail) ? TRIE_TYPE( noper_next_type ) :0;
3337 #endif
3338
3339                             DEBUG_TRIE_COMPILE_r({
3340                                 regprop(RExC_rx, mysv, cur);
3341                                 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
3342                                    (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
3343
3344                                 regprop(RExC_rx, mysv, noper);
3345                                 PerlIO_printf( Perl_debug_log, " -> %s",
3346                                     SvPV_nolen_const(mysv));
3347
3348                                 if ( noper_next ) {
3349                                   regprop(RExC_rx, mysv, noper_next );
3350                                   PerlIO_printf( Perl_debug_log,"\t=> %s\t",
3351                                     SvPV_nolen_const(mysv));
3352                                 }
3353                                 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d,tt==%s,nt==%s,nnt==%s)\n",
3354                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
3355                                    PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype] 
3356                                 );
3357                             });
3358
3359                             /* Is noper a trieable nodetype that can be merged with the
3360                              * current trie (if there is one)? */
3361                             if ( noper_trietype
3362                                   &&
3363                                   (
3364                                         ( noper_trietype == NOTHING)
3365                                         || ( trietype == NOTHING )
3366                                         || ( trietype == noper_trietype )
3367                                   )
3368 #ifdef NOJUMPTRIE
3369                                   && noper_next == tail
3370 #endif
3371                                   && count < U16_MAX)
3372                             {
3373                                 /* Handle mergable triable node
3374                                  * Either we are the first node in a new trieable sequence,
3375                                  * in which case we do some bookkeeping, otherwise we update
3376                                  * the end pointer. */
3377                                 if ( !first ) {
3378                                     first = cur;
3379                                     if ( noper_trietype == NOTHING ) {
3380 #if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
3381                                         regnode * const noper_next = regnext( noper );
3382                                         U8 noper_next_type = (noper_next && noper_next!=tail) ? OP(noper_next) : 0;
3383                                         U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
3384 #endif
3385
3386                                         if ( noper_next_trietype ) {
3387                                             trietype = noper_next_trietype;
3388                                         } else if (noper_next_type)  {
3389                                             /* a NOTHING regop is 1 regop wide. We need at least two
3390                                              * for a trie so we can't merge this in */
3391                                             first = NULL;
3392                                         }
3393                                     } else {
3394                                         trietype = noper_trietype;
3395                                     }
3396                                 } else {
3397                                     if ( trietype == NOTHING )
3398                                         trietype = noper_trietype;
3399                                     last = cur;
3400                                 }
3401                                 if (first)
3402                                     count++;
3403                             } /* end handle mergable triable node */
3404                             else {
3405                                 /* handle unmergable node -
3406                                  * noper may either be a triable node which can not be tried
3407                                  * together with the current trie, or a non triable node */
3408                                 if ( last ) {
3409                                     /* If last is set and trietype is not NOTHING then we have found
3410                                      * at least two triable branch sequences in a row of a similar
3411                                      * trietype so we can turn them into a trie. If/when we
3412                                      * allow NOTHING to start a trie sequence this condition will be
3413                                      * required, and it isn't expensive so we leave it in for now. */
3414                                     if ( trietype && trietype != NOTHING )
3415                                         make_trie( pRExC_state,
3416                                                 startbranch, first, cur, tail, count,
3417                                                 trietype, depth+1 );
3418                                     last = NULL; /* note: we clear/update first, trietype etc below, so we dont do it here */
3419                                 }
3420                                 if ( noper_trietype
3421 #ifdef NOJUMPTRIE
3422                                      && noper_next == tail
3423 #endif
3424                                 ){
3425                                     /* noper is triable, so we can start a new trie sequence */
3426                                     count = 1;
3427                                     first = cur;
3428                                     trietype = noper_trietype;
3429                                 } else if (first) {
3430                                     /* if we already saw a first but the current node is not triable then we have
3431                                      * to reset the first information. */
3432                                     count = 0;
3433                                     first = NULL;
3434                                     trietype = 0;
3435                                 }
3436                             } /* end handle unmergable node */
3437                         } /* loop over branches */
3438                         DEBUG_TRIE_COMPILE_r({
3439                             regprop(RExC_rx, mysv, cur);
3440                             PerlIO_printf( Perl_debug_log,
3441                               "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
3442                               "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3443
3444                         });
3445                         if ( last && trietype ) {
3446                             if ( trietype != NOTHING ) {
3447                                 /* the last branch of the sequence was part of a trie,
3448                                  * so we have to construct it here outside of the loop
3449                                  */
3450                                 made= make_trie( pRExC_state, startbranch, first, scan, tail, count, trietype, depth+1 );
3451 #ifdef TRIE_STUDY_OPT
3452                                 if ( ((made == MADE_EXACT_TRIE &&
3453                                      startbranch == first)
3454                                      || ( first_non_open == first )) &&
3455                                      depth==0 ) {
3456                                     flags |= SCF_TRIE_RESTUDY;
3457                                     if ( startbranch == first
3458                                          && scan == tail )
3459                                     {
3460                                         RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
3461                                     }
3462                                 }
3463 #endif
3464                             } else {
3465                                 /* at this point we know whatever we have is a NOTHING sequence/branch
3466                                  * AND if 'startbranch' is 'first' then we can turn the whole thing into a NOTHING
3467                                  */
3468                                 if ( startbranch == first ) {
3469                                     regnode *opt;
3470                                     /* the entire thing is a NOTHING sequence, something like this:
3471                                      * (?:|) So we can turn it into a plain NOTHING op. */
3472                                     DEBUG_TRIE_COMPILE_r({
3473                                         regprop(RExC_rx, mysv, cur);
3474                                         PerlIO_printf( Perl_debug_log,
3475                                           "%*s- %s (%d) <NOTHING BRANCH SEQUENCE>\n", (int)depth * 2 + 2,
3476                                           "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3477
3478                                     });
3479                                     OP(startbranch)= NOTHING;
3480                                     NEXT_OFF(startbranch)= tail - startbranch;
3481                                     for ( opt= startbranch + 1; opt < tail ; opt++ )
3482                                         OP(opt)= OPTIMIZED;
3483                                 }
3484                             }
3485                         } /* end if ( last) */
3486                     } /* TRIE_MAXBUF is non zero */
3487                     
3488                 } /* do trie */
3489                 
3490             }
3491             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
3492                 scan = NEXTOPER(NEXTOPER(scan));
3493             } else                      /* single branch is optimized. */
3494                 scan = NEXTOPER(scan);
3495             continue;
3496         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
3497             scan_frame *newframe = NULL;
3498             I32 paren;
3499             regnode *start;
3500             regnode *end;
3501
3502             if (OP(scan) != SUSPEND) {
3503             /* set the pointer */
3504                 if (OP(scan) == GOSUB) {
3505                     paren = ARG(scan);
3506                     RExC_recurse[ARG2L(scan)] = scan;
3507                     start = RExC_open_parens[paren-1];
3508                     end   = RExC_close_parens[paren-1];
3509                 } else {
3510                     paren = 0;
3511                     start = RExC_rxi->program + 1;
3512                     end   = RExC_opend;
3513                 }
3514                 if (!recursed) {
3515                     Newxz(recursed, (((RExC_npar)>>3) +1), U8);
3516                     SAVEFREEPV(recursed);
3517                 }
3518                 if (!PAREN_TEST(recursed,paren+1)) {
3519                     PAREN_SET(recursed,paren+1);
3520                     Newx(newframe,1,scan_frame);
3521                 } else {
3522                     if (flags & SCF_DO_SUBSTR) {
3523                         SCAN_COMMIT(pRExC_state,data,minlenp);
3524                         data->longest = &(data->longest_float);
3525                     }
3526                     is_inf = is_inf_internal = 1;
3527                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3528                         cl_anything(pRExC_state, data->start_class);
3529                     flags &= ~SCF_DO_STCLASS;
3530                 }
3531             } else {
3532                 Newx(newframe,1,scan_frame);
3533                 paren = stopparen;
3534                 start = scan+2;
3535                 end = regnext(scan);
3536             }
3537             if (newframe) {
3538                 assert(start);
3539                 assert(end);
3540                 SAVEFREEPV(newframe);
3541                 newframe->next = regnext(scan);
3542                 newframe->last = last;
3543                 newframe->stop = stopparen;
3544                 newframe->prev = frame;
3545
3546                 frame = newframe;
3547                 scan =  start;
3548                 stopparen = paren;
3549                 last = end;
3550
3551                 continue;
3552             }
3553         }
3554         else if (OP(scan) == EXACT) {
3555             I32 l = STR_LEN(scan);
3556             UV uc;
3557             if (UTF) {
3558                 const U8 * const s = (U8*)STRING(scan);
3559                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
3560                 l = utf8_length(s, s + l);
3561             } else {
3562                 uc = *((U8*)STRING(scan));
3563             }
3564             min += l;
3565             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
3566                 /* The code below prefers earlier match for fixed
3567                    offset, later match for variable offset.  */
3568                 if (data->last_end == -1) { /* Update the start info. */
3569                     data->last_start_min = data->pos_min;
3570                     data->last_start_max = is_inf
3571                         ? I32_MAX : data->pos_min + data->pos_delta;
3572                 }
3573                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
3574                 if (UTF)
3575                     SvUTF8_on(data->last_found);
3576                 {
3577                     SV * const sv = data->last_found;
3578                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3579                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
3580                     if (mg && mg->mg_len >= 0)
3581                         mg->mg_len += utf8_length((U8*)STRING(scan),
3582                                                   (U8*)STRING(scan)+STR_LEN(scan));
3583                 }
3584                 data->last_end = data->pos_min + l;
3585                 data->pos_min += l; /* As in the first entry. */
3586                 data->flags &= ~SF_BEFORE_EOL;
3587             }
3588             if (flags & SCF_DO_STCLASS_AND) {
3589                 /* Check whether it is compatible with what we know already! */
3590                 int compat = 1;
3591
3592
3593                 /* If compatible, we or it in below.  It is compatible if is
3594                  * in the bitmp and either 1) its bit or its fold is set, or 2)
3595                  * it's for a locale.  Even if there isn't unicode semantics
3596                  * here, at runtime there may be because of matching against a
3597                  * utf8 string, so accept a possible false positive for
3598                  * latin1-range folds */
3599                 if (uc >= 0x100 ||
3600                     (!(data->start_class->flags & ANYOF_LOCALE)
3601                     && !ANYOF_BITMAP_TEST(data->start_class, uc)
3602                     && (!(data->start_class->flags & ANYOF_LOC_FOLD)
3603                         || !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3604                     )
3605                 {
3606                     compat = 0;
3607                 }
3608                 ANYOF_CLASS_ZERO(data->start_class);
3609                 ANYOF_BITMAP_ZERO(data->start_class);
3610                 if (compat)
3611                     ANYOF_BITMAP_SET(data->start_class, uc);
3612                 else if (uc >= 0x100) {
3613                     int i;
3614
3615                     /* Some Unicode code points fold to the Latin1 range; as
3616                      * XXX temporary code, instead of figuring out if this is
3617                      * one, just assume it is and set all the start class bits
3618                      * that could be some such above 255 code point's fold
3619                      * which will generate fals positives.  As the code
3620                      * elsewhere that does compute the fold settles down, it
3621                      * can be extracted out and re-used here */
3622                     for (i = 0; i < 256; i++){
3623                         if (HAS_NONLATIN1_FOLD_CLOSURE(i)) {
3624                             ANYOF_BITMAP_SET(data->start_class, i);
3625                         }
3626                     }
3627                 }
3628                 CLEAR_SSC_EOS(data->start_class);
3629                 if (uc < 0x100)
3630                   data->start_class->flags &= ~ANYOF_UNICODE_ALL;
3631             }
3632             else if (flags & SCF_DO_STCLASS_OR) {
3633                 /* false positive possible if the class is case-folded */
3634                 if (uc < 0x100)
3635                     ANYOF_BITMAP_SET(data->start_class, uc);
3636                 else
3637                     data->start_class->flags |= ANYOF_UNICODE_ALL;
3638                 CLEAR_SSC_EOS(data->start_class);
3639                 cl_and(data->start_class, and_withp);
3640             }
3641             flags &= ~SCF_DO_STCLASS;
3642         }
3643         else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
3644             I32 l = STR_LEN(scan);
3645             UV uc = *((U8*)STRING(scan));
3646
3647             /* Search for fixed substrings supports EXACT only. */
3648             if (flags & SCF_DO_SUBSTR) {
3649                 assert(data);
3650                 SCAN_COMMIT(pRExC_state, data, minlenp);
3651             }
3652             if (UTF) {
3653                 const U8 * const s = (U8 *)STRING(scan);
3654                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
3655                 l = utf8_length(s, s + l);
3656             }
3657             if (has_exactf_sharp_s) {
3658                 RExC_seen |= REG_SEEN_EXACTF_SHARP_S;
3659             }
3660             min += l - min_subtract;
3661             assert (min >= 0);
3662             delta += min_subtract;
3663             if (flags & SCF_DO_SUBSTR) {
3664                 data->pos_min += l - min_subtract;
3665                 if (data->pos_min < 0) {
3666                     data->pos_min = 0;
3667                 }
3668                 data->pos_delta += min_subtract;
3669                 if (min_subtract) {
3670                     data->longest = &(data->longest_float);
3671                 }
3672             }
3673             if (flags & SCF_DO_STCLASS_AND) {
3674                 /* Check whether it is compatible with what we know already! */
3675                 int compat = 1;
3676                 if (uc >= 0x100 ||
3677                  (!(data->start_class->flags & ANYOF_LOCALE)
3678                   && !ANYOF_BITMAP_TEST(data->start_class, uc)
3679                   && !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3680                 {
3681                     compat = 0;
3682                 }
3683                 ANYOF_CLASS_ZERO(data->start_class);
3684                 ANYOF_BITMAP_ZERO(data->start_class);
3685                 if (compat) {
3686                     ANYOF_BITMAP_SET(data->start_class, uc);
3687                     CLEAR_SSC_EOS(data->start_class);
3688                     if (OP(scan) == EXACTFL) {
3689                         /* XXX This set is probably no longer necessary, and
3690                          * probably wrong as LOCALE now is on in the initial
3691                          * state */
3692                         data->start_class->flags |= ANYOF_LOCALE|ANYOF_LOC_FOLD;
3693                     }
3694                     else {
3695
3696                         /* Also set the other member of the fold pair.  In case
3697                          * that unicode semantics is called for at runtime, use
3698                          * the full latin1 fold.  (Can't do this for locale,
3699                          * because not known until runtime) */
3700                         ANYOF_BITMAP_SET(data->start_class, PL_fold_latin1[uc]);
3701
3702                         /* All other (EXACTFL handled above) folds except under
3703                          * /iaa that include s, S, and sharp_s also may include
3704                          * the others */
3705                         if (OP(scan) != EXACTFA) {
3706                             if (uc == 's' || uc == 'S') {
3707                                 ANYOF_BITMAP_SET(data->start_class,
3708                                                  LATIN_SMALL_LETTER_SHARP_S);
3709                             }
3710                             else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3711                                 ANYOF_BITMAP_SET(data->start_class, 's');
3712                                 ANYOF_BITMAP_SET(data->start_class, 'S');
3713                             }
3714                         }
3715                     }
3716                 }
3717                 else if (uc >= 0x100) {
3718                     int i;
3719                     for (i = 0; i < 256; i++){
3720                         if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3721                             ANYOF_BITMAP_SET(data->start_class, i);
3722                         }
3723                     }
3724                 }
3725             }
3726             else if (flags & SCF_DO_STCLASS_OR) {
3727                 if (data->start_class->flags & ANYOF_LOC_FOLD) {
3728                     /* false positive possible if the class is case-folded.
3729                        Assume that the locale settings are the same... */
3730                     if (uc < 0x100) {
3731                         ANYOF_BITMAP_SET(data->start_class, uc);
3732                         if (OP(scan) != EXACTFL) {
3733
3734                             /* And set the other member of the fold pair, but
3735                              * can't do that in locale because not known until
3736                              * run-time */
3737                             ANYOF_BITMAP_SET(data->start_class,
3738                                              PL_fold_latin1[uc]);
3739
3740                             /* All folds except under /iaa that include s, S,
3741                              * and sharp_s also may include the others */
3742                             if (OP(scan) != EXACTFA) {
3743                                 if (uc == 's' || uc == 'S') {
3744                                     ANYOF_BITMAP_SET(data->start_class,
3745                                                    LATIN_SMALL_LETTER_SHARP_S);
3746                                 }
3747                                 else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3748                                     ANYOF_BITMAP_SET(data->start_class, 's');
3749                                     ANYOF_BITMAP_SET(data->start_class, 'S');
3750                                 }
3751                             }
3752                         }
3753                     }
3754                     CLEAR_SSC_EOS(data->start_class);
3755                 }
3756                 cl_and(data->start_class, and_withp);
3757             }
3758             flags &= ~SCF_DO_STCLASS;
3759         }
3760         else if (REGNODE_VARIES(OP(scan))) {
3761             I32 mincount, maxcount, minnext, deltanext, fl = 0;
3762             I32 f = flags, pos_before = 0;
3763             regnode * const oscan = scan;
3764             struct regnode_charclass_class this_class;
3765             struct regnode_charclass_class *oclass = NULL;
3766             I32 next_is_eval = 0;
3767
3768             switch (PL_regkind[OP(scan)]) {
3769             case WHILEM:                /* End of (?:...)* . */
3770                 scan = NEXTOPER(scan);
3771                 goto finish;
3772             case PLUS:
3773                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
3774                     next = NEXTOPER(scan);
3775                     if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
3776                         mincount = 1;
3777                         maxcount = REG_INFTY;
3778                         next = regnext(scan);
3779                         scan = NEXTOPER(scan);
3780                         goto do_curly;
3781                     }
3782                 }
3783                 if (flags & SCF_DO_SUBSTR)
3784                     data->pos_min++;
3785                 min++;
3786                 /* Fall through. */
3787             case STAR:
3788                 if (flags & SCF_DO_STCLASS) {
3789                     mincount = 0;
3790                     maxcount = REG_INFTY;
3791                     next = regnext(scan);
3792                     scan = NEXTOPER(scan);
3793                     goto do_curly;
3794                 }
3795                 is_inf = is_inf_internal = 1;
3796                 scan = regnext(scan);
3797                 if (flags & SCF_DO_SUBSTR) {
3798                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
3799                     data->longest = &(data->longest_float);
3800                 }
3801                 goto optimize_curly_tail;
3802             case CURLY:
3803                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
3804                     && (scan->flags == stopparen))
3805                 {
3806                     mincount = 1;
3807                     maxcount = 1;
3808                 } else {
3809                     mincount = ARG1(scan);
3810                     maxcount = ARG2(scan);
3811                 }
3812                 next = regnext(scan);
3813                 if (OP(scan) == CURLYX) {
3814                     I32 lp = (data ? *(data->last_closep) : 0);
3815                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
3816                 }
3817                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3818                 next_is_eval = (OP(scan) == EVAL);
3819               do_curly:
3820                 if (flags & SCF_DO_SUBSTR) {
3821                     if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
3822                     pos_before = data->pos_min;
3823                 }
3824                 if (data) {
3825                     fl = data->flags;
3826                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
3827                     if (is_inf)
3828                         data->flags |= SF_IS_INF;
3829                 }
3830                 if (flags & SCF_DO_STCLASS) {
3831                     cl_init(pRExC_state, &this_class);
3832                     oclass = data->start_class;
3833                     data->start_class = &this_class;
3834                     f |= SCF_DO_STCLASS_AND;
3835                     f &= ~SCF_DO_STCLASS_OR;
3836                 }
3837                 /* Exclude from super-linear cache processing any {n,m}
3838                    regops for which the combination of input pos and regex
3839                    pos is not enough information to determine if a match
3840                    will be possible.
3841
3842                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
3843                    regex pos at the \s*, the prospects for a match depend not
3844                    only on the input position but also on how many (bar\s*)
3845                    repeats into the {4,8} we are. */
3846                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
3847                     f &= ~SCF_WHILEM_VISITED_POS;
3848
3849                 /* This will finish on WHILEM, setting scan, or on NULL: */
3850                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, 
3851                                       last, data, stopparen, recursed, NULL,
3852                                       (mincount == 0
3853                                         ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
3854
3855                 if (flags & SCF_DO_STCLASS)
3856                     data->start_class = oclass;
3857                 if (mincount == 0 || minnext == 0) {
3858                     if (flags & SCF_DO_STCLASS_OR) {
3859                         cl_or(pRExC_state, data->start_class, &this_class);
3860                     }
3861                     else if (flags & SCF_DO_STCLASS_AND) {
3862                         /* Switch to OR mode: cache the old value of
3863                          * data->start_class */
3864                         INIT_AND_WITHP;
3865                         StructCopy(data->start_class, and_withp,
3866                                    struct regnode_charclass_class);
3867                         flags &= ~SCF_DO_STCLASS_AND;
3868                         StructCopy(&this_class, data->start_class,
3869                                    struct regnode_charclass_class);
3870                         flags |= SCF_DO_STCLASS_OR;
3871                         SET_SSC_EOS(data->start_class);
3872                     }
3873                 } else {                /* Non-zero len */
3874                     if (flags & SCF_DO_STCLASS_OR) {
3875                         cl_or(pRExC_state, data->start_class, &this_class);
3876                         cl_and(data->start_class, and_withp);
3877                     }
3878                     else if (flags & SCF_DO_STCLASS_AND)
3879                         cl_and(data->start_class, &this_class);
3880                     flags &= ~SCF_DO_STCLASS;
3881                 }
3882                 if (!scan)              /* It was not CURLYX, but CURLY. */
3883                     scan = next;
3884                 if ( /* ? quantifier ok, except for (?{ ... }) */
3885                     (next_is_eval || !(mincount == 0 && maxcount == 1))
3886                     && (minnext == 0) && (deltanext == 0)
3887                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
3888                     && maxcount <= REG_INFTY/3) /* Complement check for big count */
3889                 {
3890                     /* Fatal warnings may leak the regexp without this: */
3891                     SAVEFREESV(RExC_rx_sv);
3892                     ckWARNreg(RExC_parse,
3893                               "Quantifier unexpected on zero-length expression");
3894                     (void)ReREFCNT_inc(RExC_rx_sv);
3895                 }
3896
3897                 min += minnext * mincount;
3898                 is_inf_internal |= deltanext == I32_MAX
3899                                      || (maxcount == REG_INFTY && minnext + deltanext > 0);
3900                 is_inf |= is_inf_internal;
3901                 if (is_inf)
3902                     delta = I32_MAX;
3903                 else
3904                     delta += (minnext + deltanext) * maxcount - minnext * mincount;
3905
3906                 /* Try powerful optimization CURLYX => CURLYN. */
3907                 if (  OP(oscan) == CURLYX && data
3908                       && data->flags & SF_IN_PAR
3909                       && !(data->flags & SF_HAS_EVAL)
3910                       && !deltanext && minnext == 1 ) {
3911                     /* Try to optimize to CURLYN.  */
3912                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
3913                     regnode * const nxt1 = nxt;
3914 #ifdef DEBUGGING
3915                     regnode *nxt2;
3916 #endif
3917
3918                     /* Skip open. */
3919                     nxt = regnext(nxt);
3920                     if (!REGNODE_SIMPLE(OP(nxt))
3921                         && !(PL_regkind[OP(nxt)] == EXACT
3922                              && STR_LEN(nxt) == 1))
3923                         goto nogo;
3924 #ifdef DEBUGGING
3925                     nxt2 = nxt;
3926 #endif
3927                     nxt = regnext(nxt);
3928                     if (OP(nxt) != CLOSE)
3929                         goto nogo;
3930                     if (RExC_open_parens) {
3931                         RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3932                         RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
3933                     }
3934                     /* Now we know that nxt2 is the only contents: */
3935                     oscan->flags = (U8)ARG(nxt);
3936                     OP(oscan) = CURLYN;
3937                     OP(nxt1) = NOTHING; /* was OPEN. */
3938
3939 #ifdef DEBUGGING
3940                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3941                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
3942                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
3943                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
3944                     OP(nxt + 1) = OPTIMIZED; /* was count. */
3945                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
3946 #endif
3947                 }
3948               nogo:
3949
3950                 /* Try optimization CURLYX => CURLYM. */
3951                 if (  OP(oscan) == CURLYX && data
3952                       && !(data->flags & SF_HAS_PAR)
3953                       && !(data->flags & SF_HAS_EVAL)
3954                       && !deltanext     /* atom is fixed width */
3955                       && minnext != 0   /* CURLYM can't handle zero width */
3956                       && ! (RExC_seen & REG_SEEN_EXACTF_SHARP_S) /* Nor \xDF */
3957                 ) {
3958                     /* XXXX How to optimize if data == 0? */
3959                     /* Optimize to a simpler form.  */
3960                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
3961                     regnode *nxt2;
3962
3963                     OP(oscan) = CURLYM;
3964                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
3965                             && (OP(nxt2) != WHILEM))
3966                         nxt = nxt2;
3967                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
3968                     /* Need to optimize away parenths. */
3969                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
3970                         /* Set the parenth number.  */
3971                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
3972
3973                         oscan->flags = (U8)ARG(nxt);
3974                         if (RExC_open_parens) {
3975                             RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3976                             RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
3977                         }
3978                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
3979                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
3980
3981 #ifdef DEBUGGING
3982                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3983                         OP(nxt + 1) = OPTIMIZED; /* was count. */
3984                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
3985                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
3986 #endif
3987 #if 0
3988                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
3989                             regnode *nnxt = regnext(nxt1);
3990                             if (nnxt == nxt) {
3991                                 if (reg_off_by_arg[OP(nxt1)])
3992                                     ARG_SET(nxt1, nxt2 - nxt1);
3993                                 else if (nxt2 - nxt1 < U16_MAX)
3994                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
3995                                 else
3996                                     OP(nxt) = NOTHING;  /* Cannot beautify */
3997                             }
3998                             nxt1 = nnxt;
3999                         }
4000 #endif
4001                         /* Optimize again: */
4002                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
4003                                     NULL, stopparen, recursed, NULL, 0,depth+1);
4004                     }
4005                     else
4006                         oscan->flags = 0;
4007                 }
4008                 else if ((OP(oscan) == CURLYX)
4009                          && (flags & SCF_WHILEM_VISITED_POS)
4010                          /* See the comment on a similar expression above.
4011                             However, this time it's not a subexpression
4012                             we care about, but the expression itself. */
4013                          && (maxcount == REG_INFTY)
4014                          && data && ++data->whilem_c < 16) {
4015                     /* This stays as CURLYX, we can put the count/of pair. */
4016                     /* Find WHILEM (as in regexec.c) */
4017                     regnode *nxt = oscan + NEXT_OFF(oscan);
4018
4019                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
4020                         nxt += ARG(nxt);
4021                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
4022                         | (RExC_whilem_seen << 4)); /* On WHILEM */
4023                 }
4024                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
4025                     pars++;
4026                 if (flags & SCF_DO_SUBSTR) {
4027                     SV *last_str = NULL;
4028                     int counted = mincount != 0;
4029
4030                     if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
4031 #if defined(SPARC64_GCC_WORKAROUND)
4032                         I32 b = 0;
4033                         STRLEN l = 0;
4034                         const char *s = NULL;
4035                         I32 old = 0;
4036
4037                         if (pos_before >= data->last_start_min)
4038                             b = pos_before;
4039                         else
4040                             b = data->last_start_min;
4041
4042                         l = 0;
4043                         s = SvPV_const(data->last_found, l);
4044                         old = b - data->last_start_min;
4045
4046 #else
4047                         I32 b = pos_before >= data->last_start_min
4048                             ? pos_before : data->last_start_min;
4049                         STRLEN l;
4050                         const char * const s = SvPV_const(data->last_found, l);
4051                         I32 old = b - data->last_start_min;
4052 #endif
4053
4054                         if (UTF)
4055                             old = utf8_hop((U8*)s, old) - (U8*)s;
4056                         l -= old;
4057                         /* Get the added string: */
4058                         last_str = newSVpvn_utf8(s  + old, l, UTF);
4059                         if (deltanext == 0 && pos_before == b) {
4060                             /* What was added is a constant string */
4061                             if (mincount > 1) {
4062                                 SvGROW(last_str, (mincount * l) + 1);
4063                                 repeatcpy(SvPVX(last_str) + l,
4064                                           SvPVX_const(last_str), l, mincount - 1);
4065                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
4066                                 /* Add additional parts. */
4067                                 SvCUR_set(data->last_found,
4068                                           SvCUR(data->last_found) - l);
4069                                 sv_catsv(data->last_found, last_str);
4070                                 {
4071                                     SV * sv = data->last_found;
4072                                     MAGIC *mg =
4073                                         SvUTF8(sv) && SvMAGICAL(sv) ?
4074                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
4075                                     if (mg && mg->mg_len >= 0)
4076                                         mg->mg_len += CHR_SVLEN(last_str) - l;
4077                                 }
4078                                 data->last_end += l * (mincount - 1);
4079                             }
4080                         } else {
4081                             /* start offset must point into the last copy */
4082                             data->last_start_min += minnext * (mincount - 1);
4083                             data->last_start_max += is_inf ? I32_MAX
4084                                 : (maxcount - 1) * (minnext + data->pos_delta);
4085                         }
4086                     }
4087                     /* It is counted once already... */
4088                     data->pos_min += minnext * (mincount - counted);
4089 #if 0
4090 PerlIO_printf(Perl_debug_log, "counted=%d deltanext=%d I32_MAX=%d minnext=%d maxcount=%d mincount=%d\n",
4091     counted, deltanext, I32_MAX, minnext, maxcount, mincount);
4092 if (deltanext != I32_MAX)
4093 PerlIO_printf(Perl_debug_log, "LHS=%d RHS=%d\n", -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount, I32_MAX - data->pos_delta);
4094 #endif
4095                     if (deltanext == I32_MAX || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= I32_MAX - data->pos_delta)
4096                         data->pos_delta = I32_MAX;
4097                     else
4098                         data->pos_delta += - counted * deltanext +
4099                         (minnext + deltanext) * maxcount - minnext * mincount;
4100                     if (mincount != maxcount) {
4101                          /* Cannot extend fixed substrings found inside
4102                             the group.  */
4103                         SCAN_COMMIT(pRExC_state,data,minlenp);
4104                         if (mincount && last_str) {
4105                             SV * const sv = data->last_found;
4106                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4107                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
4108
4109                             if (mg)
4110                                 mg->mg_len = -1;
4111                             sv_setsv(sv, last_str);
4112                             data->last_end = data->pos_min;
4113                             data->last_start_min =
4114                                 data->pos_min - CHR_SVLEN(last_str);
4115                             data->last_start_max = is_inf
4116                                 ? I32_MAX
4117                                 : data->pos_min + data->pos_delta
4118                                 - CHR_SVLEN(last_str);
4119                         }
4120                         data->longest = &(data->longest_float);
4121                     }
4122                     SvREFCNT_dec(last_str);
4123                 }
4124                 if (data && (fl & SF_HAS_EVAL))
4125                     data->flags |= SF_HAS_EVAL;
4126               optimize_curly_tail:
4127                 if (OP(oscan) != CURLYX) {
4128                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
4129                            && NEXT_OFF(next))
4130                         NEXT_OFF(oscan) += NEXT_OFF(next);
4131                 }
4132                 continue;
4133             default:                    /* REF, and CLUMP only? */
4134                 if (flags & SCF_DO_SUBSTR) {
4135                     SCAN_COMMIT(pRExC_state,data,minlenp);      /* Cannot expect anything... */
4136                     data->longest = &(data->longest_float);
4137                 }
4138                 is_inf = is_inf_internal = 1;
4139                 if (flags & SCF_DO_STCLASS_OR)
4140                     cl_anything(pRExC_state, data->start_class);
4141                 flags &= ~SCF_DO_STCLASS;
4142                 break;
4143             }
4144         }
4145         else if (OP(scan) == LNBREAK) {
4146             if (flags & SCF_DO_STCLASS) {
4147                 int value = 0;
4148                 CLEAR_SSC_EOS(data->start_class); /* No match on empty */
4149                 if (flags & SCF_DO_STCLASS_AND) {
4150                     for (value = 0; value < 256; value++)
4151                         if (!is_VERTWS_cp(value))
4152                             ANYOF_BITMAP_CLEAR(data->start_class, value);
4153                 }
4154                 else {
4155                     for (value = 0; value < 256; value++)
4156                         if (is_VERTWS_cp(value))
4157                             ANYOF_BITMAP_SET(data->start_class, value);
4158                 }
4159                 if (flags & SCF_DO_STCLASS_OR)
4160                     cl_and(data->start_class, and_withp);
4161                 flags &= ~SCF_DO_STCLASS;
4162             }
4163             min++;
4164             delta++;    /* Because of the 2 char string cr-lf */
4165             if (flags & SCF_DO_SUBSTR) {
4166                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
4167                 data->pos_min += 1;
4168                 data->pos_delta += 1;
4169                 data->longest = &(data->longest_float);
4170             }
4171         }
4172         else if (REGNODE_SIMPLE(OP(scan))) {
4173             int value = 0;
4174
4175             if (flags & SCF_DO_SUBSTR) {
4176                 SCAN_COMMIT(pRExC_state,data,minlenp);
4177                 data->pos_min++;
4178             }
4179             min++;
4180             if (flags & SCF_DO_STCLASS) {
4181                 int loop_max = 256;
4182                 CLEAR_SSC_EOS(data->start_class); /* No match on empty */
4183
4184                 /* Some of the logic below assumes that switching
4185                    locale on will only add false positives. */
4186                 switch (PL_regkind[OP(scan)]) {
4187                     U8 classnum;
4188
4189                 case SANY:
4190                 default:
4191 #ifdef DEBUGGING
4192                    Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan));
4193 #endif
4194                  do_default:
4195                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4196                         cl_anything(pRExC_state, data->start_class);
4197                     break;
4198                 case REG_ANY:
4199                     if (OP(scan) == SANY)
4200                         goto do_default;
4201                     if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
4202                         value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
4203                                 || ANYOF_CLASS_TEST_ANY_SET(data->start_class));
4204                         cl_anything(pRExC_state, data->start_class);
4205                     }
4206                     if (flags & SCF_DO_STCLASS_AND || !value)
4207                         ANYOF_BITMAP_CLEAR(data->start_class,'\n');
4208                     break;
4209                 case ANYOF:
4210                     if (flags & SCF_DO_STCLASS_AND)
4211                         cl_and(data->start_class,
4212                                (struct regnode_charclass_class*)scan);
4213                     else
4214                         cl_or(pRExC_state, data->start_class,
4215                               (struct regnode_charclass_class*)scan);
4216                     break;
4217                 case POSIXA:
4218                     loop_max = 128;
4219                     /* FALL THROUGH */
4220                 case POSIXL:
4221                 case POSIXD:
4222                 case POSIXU:
4223                     classnum = FLAGS(scan);
4224                     if (flags & SCF_DO_STCLASS_AND) {
4225                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
4226                             ANYOF_CLASS_CLEAR(data->start_class, classnum_to_namedclass(classnum) + 1);
4227                             for (value = 0; value < loop_max; value++) {
4228                                 if (! _generic_isCC(UNI_TO_NATIVE(value), classnum)) {
4229                                     ANYOF_BITMAP_CLEAR(data->start_class, UNI_TO_NATIVE(value));
4230                                 }
4231                             }
4232                         }
4233                     }
4234                     else {
4235                         if (data->start_class->flags & ANYOF_LOCALE) {
4236                             ANYOF_CLASS_SET(data->start_class, classnum_to_namedclass(classnum));
4237                         }
4238                         else {
4239
4240                         /* Even if under locale, set the bits for non-locale
4241                          * in case it isn't a true locale-node.  This will
4242                          * create false positives if it truly is locale */
4243                         for (value = 0; value < loop_max; value++) {
4244                             if (_generic_isCC(UNI_TO_NATIVE(value), classnum)) {
4245                                 ANYOF_BITMAP_SET(data->start_class, UNI_TO_NATIVE(value));
4246                             }
4247                         }
4248                         }
4249                     }
4250                     break;
4251                 case NPOSIXA:
4252                     loop_max = 128;
4253                     /* FALL THROUGH */
4254                 case NPOSIXL:
4255                 case NPOSIXU:
4256                 case NPOSIXD:
4257                     classnum = FLAGS(scan);
4258                     if (flags & SCF_DO_STCLASS_AND) {
4259                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
4260                             ANYOF_CLASS_CLEAR(data->start_class, classnum_to_namedclass(classnum));
4261                             for (value = 0; value < loop_max; value++) {
4262                                 if (_generic_isCC(UNI_TO_NATIVE(value), classnum)) {
4263                                     ANYOF_BITMAP_CLEAR(data->start_class, UNI_TO_NATIVE(value));
4264                                 }
4265                             }
4266                         }
4267                     }
4268                     else {
4269                         if (data->start_class->flags & ANYOF_LOCALE) {
4270                             ANYOF_CLASS_SET(data->start_class, classnum_to_namedclass(classnum) + 1);
4271                         }
4272                         else {
4273
4274                         /* Even if under locale, set the bits for non-locale in
4275                          * case it isn't a true locale-node.  This will create
4276                          * false positives if it truly is locale */
4277                         for (value = 0; value < loop_max; value++) {
4278                             if (! _generic_isCC(UNI_TO_NATIVE(value), classnum)) {
4279                                 ANYOF_BITMAP_SET(data->start_class, UNI_TO_NATIVE(value));
4280                             }
4281                         }
4282                         if (PL_regkind[OP(scan)] == NPOSIXD) {
4283                             data->start_class->flags |= ANYOF_NON_UTF8_LATIN1_ALL;
4284                         }
4285                         }
4286                     }
4287                     break;
4288                 }
4289                 if (flags & SCF_DO_STCLASS_OR)
4290                     cl_and(data->start_class, and_withp);
4291                 flags &= ~SCF_DO_STCLASS;
4292             }
4293         }
4294         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
4295             data->flags |= (OP(scan) == MEOL
4296                             ? SF_BEFORE_MEOL
4297                             : SF_BEFORE_SEOL);
4298             SCAN_COMMIT(pRExC_state, data, minlenp);
4299
4300         }
4301         else if (  PL_regkind[OP(scan)] == BRANCHJ
4302                  /* Lookbehind, or need to calculate parens/evals/stclass: */
4303                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
4304                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
4305             if ( OP(scan) == UNLESSM &&
4306                  scan->flags == 0 &&
4307                  OP(NEXTOPER(NEXTOPER(scan))) == NOTHING &&
4308                  OP(regnext(NEXTOPER(NEXTOPER(scan)))) == SUCCEED
4309             ) {
4310                 regnode *opt;
4311                 regnode *upto= regnext(scan);
4312                 DEBUG_PARSE_r({
4313                     SV * const mysv_val=sv_newmortal();
4314                     DEBUG_STUDYDATA("OPFAIL",data,depth);
4315
4316                     /*DEBUG_PARSE_MSG("opfail");*/
4317                     regprop(RExC_rx, mysv_val, upto);
4318                     PerlIO_printf(Perl_debug_log, "~ replace with OPFAIL pointed at %s (%"IVdf") offset %"IVdf"\n",
4319                                   SvPV_nolen_const(mysv_val),
4320                                   (IV)REG_NODE_NUM(upto),
4321                                   (IV)(upto - scan)
4322                     );
4323                 });
4324                 OP(scan) = OPFAIL;
4325                 NEXT_OFF(scan) = upto - scan;
4326                 for (opt= scan + 1; opt < upto ; opt++)
4327                     OP(opt) = OPTIMIZED;
4328                 scan= upto;
4329                 continue;
4330             }
4331             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY 
4332                 || OP(scan) == UNLESSM )
4333             {
4334                 /* Negative Lookahead/lookbehind
4335                    In this case we can't do fixed string optimisation.
4336                 */
4337
4338                 I32 deltanext, minnext, fake = 0;
4339                 regnode *nscan;
4340                 struct regnode_charclass_class intrnl;
4341                 int f = 0;
4342
4343                 data_fake.flags = 0;
4344                 if (data) {
4345                     data_fake.whilem_c = data->whilem_c;
4346                     data_fake.last_closep = data->last_closep;
4347                 }
4348                 else
4349                     data_fake.last_closep = &fake;
4350                 data_fake.pos_delta = delta;
4351                 if ( flags & SCF_DO_STCLASS && !scan->flags
4352                      && OP(scan) == IFMATCH ) { /* Lookahead */
4353                     cl_init(pRExC_state, &intrnl);
4354                     data_fake.start_class = &intrnl;
4355                     f |= SCF_DO_STCLASS_AND;
4356                 }
4357                 if (flags & SCF_WHILEM_VISITED_POS)
4358                     f |= SCF_WHILEM_VISITED_POS;
4359                 next = regnext(scan);
4360                 nscan = NEXTOPER(NEXTOPER(scan));
4361                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext, 
4362                     last, &data_fake, stopparen, recursed, NULL, f, depth+1);
4363                 if (scan->flags) {
4364                     if (deltanext) {
4365                         FAIL("Variable length lookbehind not implemented");
4366                     }
4367                     else if (minnext > (I32)U8_MAX) {
4368                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4369                     }
4370                     scan->flags = (U8)minnext;
4371                 }
4372                 if (data) {
4373                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4374                         pars++;
4375                     if (data_fake.flags & SF_HAS_EVAL)
4376                         data->flags |= SF_HAS_EVAL;
4377                     data->whilem_c = data_fake.whilem_c;
4378                 }
4379                 if (f & SCF_DO_STCLASS_AND) {
4380                     if (flags & SCF_DO_STCLASS_OR) {
4381                         /* OR before, AND after: ideally we would recurse with
4382                          * data_fake to get the AND applied by study of the
4383                          * remainder of the pattern, and then derecurse;
4384                          * *** HACK *** for now just treat as "no information".
4385                          * See [perl #56690].
4386                          */
4387                         cl_init(pRExC_state, data->start_class);
4388                     }  else {
4389                         /* AND before and after: combine and continue */
4390                         const int was = TEST_SSC_EOS(data->start_class);
4391
4392                         cl_and(data->start_class, &intrnl);
4393                         if (was)
4394                             SET_SSC_EOS(data->start_class);
4395                     }
4396                 }
4397             }
4398 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
4399             else {
4400                 /* Positive Lookahead/lookbehind
4401                    In this case we can do fixed string optimisation,
4402                    but we must be careful about it. Note in the case of
4403                    lookbehind the positions will be offset by the minimum
4404                    length of the pattern, something we won't know about
4405                    until after the recurse.
4406                 */
4407                 I32 deltanext, fake = 0;
4408                 regnode *nscan;
4409                 struct regnode_charclass_class intrnl;
4410                 int f = 0;
4411                 /* We use SAVEFREEPV so that when the full compile 
4412                     is finished perl will clean up the allocated 
4413                     minlens when it's all done. This way we don't
4414                     have to worry about freeing them when we know
4415                     they wont be used, which would be a pain.
4416                  */
4417                 I32 *minnextp;
4418                 Newx( minnextp, 1, I32 );
4419                 SAVEFREEPV(minnextp);
4420
4421                 if (data) {
4422                     StructCopy(data, &data_fake, scan_data_t);
4423                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
4424                         f |= SCF_DO_SUBSTR;
4425                         if (scan->flags) 
4426                             SCAN_COMMIT(pRExC_state, &data_fake,minlenp);
4427                         data_fake.last_found=newSVsv(data->last_found);
4428                     }
4429                 }
4430                 else
4431                     data_fake.last_closep = &fake;
4432                 data_fake.flags = 0;
4433                 data_fake.pos_delta = delta;
4434                 if (is_inf)
4435                     data_fake.flags |= SF_IS_INF;
4436                 if ( flags & SCF_DO_STCLASS && !scan->flags
4437                      && OP(scan) == IFMATCH ) { /* Lookahead */
4438                     cl_init(pRExC_state, &intrnl);
4439                     data_fake.start_class = &intrnl;
4440                     f |= SCF_DO_STCLASS_AND;
4441                 }
4442                 if (flags & SCF_WHILEM_VISITED_POS)
4443                     f |= SCF_WHILEM_VISITED_POS;
4444                 next = regnext(scan);
4445                 nscan = NEXTOPER(NEXTOPER(scan));
4446
4447                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext, 
4448                     last, &data_fake, stopparen, recursed, NULL, f,depth+1);
4449                 if (scan->flags) {
4450                     if (deltanext) {
4451                         FAIL("Variable length lookbehind not implemented");
4452                     }
4453                     else if (*minnextp > (I32)U8_MAX) {
4454                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4455                     }
4456                     scan->flags = (U8)*minnextp;
4457                 }
4458
4459                 *minnextp += min;
4460
4461                 if (f & SCF_DO_STCLASS_AND) {
4462                     const int was = TEST_SSC_EOS(data.start_class);
4463
4464                     cl_and(data->start_class, &intrnl);
4465                     if (was)
4466                         SET_SSC_EOS(data->start_class);
4467                 }
4468                 if (data) {
4469                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4470                         pars++;
4471                     if (data_fake.flags & SF_HAS_EVAL)
4472                         data->flags |= SF_HAS_EVAL;
4473                     data->whilem_c = data_fake.whilem_c;
4474                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
4475                         if (RExC_rx->minlen<*minnextp)
4476                             RExC_rx->minlen=*minnextp;
4477                         SCAN_COMMIT(pRExC_state, &data_fake, minnextp);
4478                         SvREFCNT_dec_NN(data_fake.last_found);
4479                         
4480                         if ( data_fake.minlen_fixed != minlenp ) 
4481                         {
4482                             data->offset_fixed= data_fake.offset_fixed;
4483                             data->minlen_fixed= data_fake.minlen_fixed;
4484                             data->lookbehind_fixed+= scan->flags;
4485                         }
4486                         if ( data_fake.minlen_float != minlenp )
4487                         {
4488                             data->minlen_float= data_fake.minlen_float;
4489                             data->offset_float_min=data_fake.offset_float_min;
4490                             data->offset_float_max=data_fake.offset_float_max;
4491                             data->lookbehind_float+= scan->flags;
4492                         }
4493                     }
4494                 }
4495             }
4496 #endif
4497         }
4498         else if (OP(scan) == OPEN) {
4499             if (stopparen != (I32)ARG(scan))
4500                 pars++;
4501         }
4502         else if (OP(scan) == CLOSE) {
4503             if (stopparen == (I32)ARG(scan)) {
4504                 break;
4505             }
4506             if ((I32)ARG(scan) == is_par) {
4507                 next = regnext(scan);
4508
4509                 if ( next && (OP(next) != WHILEM) && next < last)
4510                     is_par = 0;         /* Disable optimization */
4511             }
4512             if (data)
4513                 *(data->last_closep) = ARG(scan);
4514         }
4515         else if (OP(scan) == EVAL) {
4516                 if (data)
4517                     data->flags |= SF_HAS_EVAL;
4518         }
4519         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
4520             if (flags & SCF_DO_SUBSTR) {
4521                 SCAN_COMMIT(pRExC_state,data,minlenp);
4522                 flags &= ~SCF_DO_SUBSTR;
4523             }
4524             if (data && OP(scan)==ACCEPT) {
4525                 data->flags |= SCF_SEEN_ACCEPT;
4526                 if (stopmin > min)
4527                     stopmin = min;
4528             }
4529         }
4530         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
4531         {
4532                 if (flags & SCF_DO_SUBSTR) {
4533                     SCAN_COMMIT(pRExC_state,data,minlenp);
4534                     data->longest = &(data->longest_float);
4535                 }
4536                 is_inf = is_inf_internal = 1;
4537                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4538                     cl_anything(pRExC_state, data->start_class);
4539                 flags &= ~SCF_DO_STCLASS;
4540         }
4541         else if (OP(scan) == GPOS) {
4542             if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) &&
4543                 !(delta || is_inf || (data && data->pos_delta))) 
4544             {
4545                 if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR))
4546                     RExC_rx->extflags |= RXf_ANCH_GPOS;
4547                 if (RExC_rx->gofs < (U32)min)
4548                     RExC_rx->gofs = min;
4549             } else {
4550                 RExC_rx->extflags |= RXf_GPOS_FLOAT;
4551                 RExC_rx->gofs = 0;
4552             }       
4553         }
4554 #ifdef TRIE_STUDY_OPT
4555 #ifdef FULL_TRIE_STUDY
4556         else if (PL_regkind[OP(scan)] == TRIE) {
4557             /* NOTE - There is similar code to this block above for handling
4558                BRANCH nodes on the initial study.  If you change stuff here
4559                check there too. */
4560             regnode *trie_node= scan;
4561             regnode *tail= regnext(scan);
4562             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4563             I32 max1 = 0, min1 = I32_MAX;
4564             struct regnode_charclass_class accum;
4565
4566             if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
4567                 SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
4568             if (flags & SCF_DO_STCLASS)
4569                 cl_init_zero(pRExC_state, &accum);
4570                 
4571             if (!trie->jump) {
4572                 min1= trie->minlen;
4573                 max1= trie->maxlen;
4574             } else {
4575                 const regnode *nextbranch= NULL;
4576                 U32 word;
4577                 
4578                 for ( word=1 ; word <= trie->wordcount ; word++) 
4579                 {
4580                     I32 deltanext=0, minnext=0, f = 0, fake;
4581                     struct regnode_charclass_class this_class;
4582                     
4583                     data_fake.flags = 0;
4584                     if (data) {
4585                         data_fake.whilem_c = data->whilem_c;
4586                         data_fake.last_closep = data->last_closep;
4587                     }
4588                     else
4589                         data_fake.last_closep = &fake;
4590                     data_fake.pos_delta = delta;
4591                     if (flags & SCF_DO_STCLASS) {
4592                         cl_init(pRExC_state, &this_class);
4593                         data_fake.start_class = &this_class;
4594                         f = SCF_DO_STCLASS_AND;
4595                     }
4596                     if (flags & SCF_WHILEM_VISITED_POS)
4597                         f |= SCF_WHILEM_VISITED_POS;
4598     
4599                     if (trie->jump[word]) {
4600                         if (!nextbranch)
4601                             nextbranch = trie_node + trie->jump[0];
4602                         scan= trie_node + trie->jump[word];
4603                         /* We go from the jump point to the branch that follows
4604                            it. Note this means we need the vestigal unused branches
4605                            even though they arent otherwise used.
4606                          */
4607                         minnext = study_chunk(pRExC_state, &scan, minlenp, 
4608                             &deltanext, (regnode *)nextbranch, &data_fake, 
4609                             stopparen, recursed, NULL, f,depth+1);
4610                     }
4611                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
4612                         nextbranch= regnext((regnode*)nextbranch);
4613                     
4614                     if (min1 > (I32)(minnext + trie->minlen))
4615                         min1 = minnext + trie->minlen;
4616                     if (deltanext == I32_MAX) {
4617                         is_inf = is_inf_internal = 1;
4618                         max1 = I32_MAX;
4619                     } else if (max1 < (I32)(minnext + deltanext + trie->maxlen))
4620                         max1 = minnext + deltanext + trie->maxlen;
4621                     
4622                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4623                         pars++;
4624                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4625                         if ( stopmin > min + min1) 
4626                             stopmin = min + min1;
4627                         flags &= ~SCF_DO_SUBSTR;
4628                         if (data)
4629                             data->flags |= SCF_SEEN_ACCEPT;
4630                     }
4631                     if (data) {
4632                         if (data_fake.flags & SF_HAS_EVAL)
4633                             data->flags |= SF_HAS_EVAL;
4634                         data->whilem_c = data_fake.whilem_c;
4635                     }
4636                     if (flags & SCF_DO_STCLASS)
4637                         cl_or(pRExC_state, &accum, &this_class);
4638                 }
4639             }
4640             if (flags & SCF_DO_SUBSTR) {
4641                 data->pos_min += min1;
4642                 data->pos_delta += max1 - min1;
4643                 if (max1 != min1 || is_inf)
4644                     data->longest = &(data->longest_float);
4645             }
4646             min += min1;
4647             delta += max1 - min1;
4648             if (flags & SCF_DO_STCLASS_OR) {
4649                 cl_or(pRExC_state, data->start_class, &accum);
4650                 if (min1) {
4651                     cl_and(data->start_class, and_withp);
4652                     flags &= ~SCF_DO_STCLASS;
4653                 }
4654             }
4655             else if (flags & SCF_DO_STCLASS_AND) {
4656                 if (min1) {
4657                     cl_and(data->start_class, &accum);
4658                     flags &= ~SCF_DO_STCLASS;
4659                 }
4660                 else {
4661                     /* Switch to OR mode: cache the old value of
4662                      * data->start_class */
4663                     INIT_AND_WITHP;
4664                     StructCopy(data->start_class, and_withp,
4665                                struct regnode_charclass_class);
4666                     flags &= ~SCF_DO_STCLASS_AND;
4667                     StructCopy(&accum, data->start_class,
4668                                struct regnode_charclass_class);
4669                     flags |= SCF_DO_STCLASS_OR;
4670                     SET_SSC_EOS(data->start_class);
4671                 }
4672             }
4673             scan= tail;
4674             continue;
4675         }
4676 #else
4677         else if (PL_regkind[OP(scan)] == TRIE) {
4678             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4679             U8*bang=NULL;
4680             
4681             min += trie->minlen;
4682             delta += (trie->maxlen - trie->minlen);
4683             flags &= ~SCF_DO_STCLASS; /* xxx */
4684             if (flags & SCF_DO_SUBSTR) {
4685                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
4686                 data->pos_min += trie->minlen;
4687                 data->pos_delta += (trie->maxlen - trie->minlen);
4688                 if (trie->maxlen != trie->minlen)
4689                     data->longest = &(data->longest_float);
4690             }
4691             if (trie->jump) /* no more substrings -- for now /grr*/
4692                 flags &= ~SCF_DO_SUBSTR; 
4693         }
4694 #endif /* old or new */
4695 #endif /* TRIE_STUDY_OPT */
4696
4697         /* Else: zero-length, ignore. */
4698         scan = regnext(scan);
4699     }
4700     if (frame) {
4701         last = frame->last;
4702         scan = frame->next;
4703         stopparen = frame->stop;
4704         frame = frame->prev;
4705         goto fake_study_recurse;
4706     }
4707
4708   finish:
4709     assert(!frame);
4710     DEBUG_STUDYDATA("pre-fin:",data,depth);
4711
4712     *scanp = scan;
4713     *deltap = is_inf_internal ? I32_MAX : delta;
4714     if (flags & SCF_DO_SUBSTR && is_inf)
4715         data->pos_delta = I32_MAX - data->pos_min;
4716     if (is_par > (I32)U8_MAX)
4717         is_par = 0;
4718     if (is_par && pars==1 && data) {
4719         data->flags |= SF_IN_PAR;
4720         data->flags &= ~SF_HAS_PAR;
4721     }
4722     else if (pars && data) {
4723         data->flags |= SF_HAS_PAR;
4724         data->flags &= ~SF_IN_PAR;
4725     }
4726     if (flags & SCF_DO_STCLASS_OR)
4727         cl_and(data->start_class, and_withp);
4728     if (flags & SCF_TRIE_RESTUDY)
4729         data->flags |=  SCF_TRIE_RESTUDY;
4730     
4731     DEBUG_STUDYDATA("post-fin:",data,depth);
4732     
4733     return min < stopmin ? min : stopmin;
4734 }
4735
4736 STATIC U32
4737 S_add_data(RExC_state_t *pRExC_state, U32 n, const char *s)
4738 {
4739     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
4740
4741     PERL_ARGS_ASSERT_ADD_DATA;
4742
4743     Renewc(RExC_rxi->data,
4744            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
4745            char, struct reg_data);
4746     if(count)
4747         Renew(RExC_rxi->data->what, count + n, U8);
4748     else
4749         Newx(RExC_rxi->data->what, n, U8);
4750     RExC_rxi->data->count = count + n;
4751     Copy(s, RExC_rxi->data->what + count, n, U8);
4752     return count;
4753 }
4754
4755 /*XXX: todo make this not included in a non debugging perl */
4756 #ifndef PERL_IN_XSUB_RE
4757 void
4758 Perl_reginitcolors(pTHX)
4759 {
4760     dVAR;
4761     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
4762     if (s) {
4763         char *t = savepv(s);
4764         int i = 0;
4765         PL_colors[0] = t;
4766         while (++i < 6) {
4767             t = strchr(t, '\t');
4768             if (t) {
4769                 *t = '\0';
4770                 PL_colors[i] = ++t;
4771             }
4772             else
4773                 PL_colors[i] = t = (char *)"";
4774         }
4775     } else {
4776         int i = 0;
4777         while (i < 6)
4778             PL_colors[i++] = (char *)"";
4779     }
4780     PL_colorset = 1;
4781 }
4782 #endif
4783
4784
4785 #ifdef TRIE_STUDY_OPT
4786 #define CHECK_RESTUDY_GOTO_butfirst(dOsomething)            \
4787     STMT_START {                                            \
4788         if (                                                \
4789               (data.flags & SCF_TRIE_RESTUDY)               \
4790               && ! restudied++                              \
4791         ) {                                                 \
4792             dOsomething;                                    \
4793             goto reStudy;                                   \
4794         }                                                   \
4795     } STMT_END
4796 #else
4797 #define CHECK_RESTUDY_GOTO_butfirst
4798 #endif        
4799
4800 /*
4801  * pregcomp - compile a regular expression into internal code
4802  *
4803  * Decides which engine's compiler to call based on the hint currently in
4804  * scope
4805  */
4806
4807 #ifndef PERL_IN_XSUB_RE 
4808
4809 /* return the currently in-scope regex engine (or the default if none)  */
4810
4811 regexp_engine const *
4812 Perl_current_re_engine(pTHX)
4813 {
4814     dVAR;
4815
4816     if (IN_PERL_COMPILETIME) {
4817         HV * const table = GvHV(PL_hintgv);
4818         SV **ptr;
4819
4820         if (!table)
4821             return &PL_core_reg_engine;
4822         ptr = hv_fetchs(table, "regcomp", FALSE);
4823         if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
4824             return &PL_core_reg_engine;
4825         return INT2PTR(regexp_engine*,SvIV(*ptr));
4826     }
4827     else {
4828         SV *ptr;
4829         if (!PL_curcop->cop_hints_hash)
4830             return &PL_core_reg_engine;
4831         ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
4832         if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
4833             return &PL_core_reg_engine;
4834         return INT2PTR(regexp_engine*,SvIV(ptr));
4835     }
4836 }
4837
4838
4839 REGEXP *
4840 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
4841 {
4842     dVAR;
4843     regexp_engine const *eng = current_re_engine();
4844     GET_RE_DEBUG_FLAGS_DECL;
4845
4846     PERL_ARGS_ASSERT_PREGCOMP;
4847
4848     /* Dispatch a request to compile a regexp to correct regexp engine. */
4849     DEBUG_COMPILE_r({
4850         PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
4851                         PTR2UV(eng));
4852     });
4853     return CALLREGCOMP_ENG(eng, pattern, flags);
4854 }
4855 #endif
4856
4857 /* public(ish) entry point for the perl core's own regex compiling code.
4858  * It's actually a wrapper for Perl_re_op_compile that only takes an SV
4859  * pattern rather than a list of OPs, and uses the internal engine rather
4860  * than the current one */
4861
4862 REGEXP *
4863 Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
4864 {
4865     SV *pat = pattern; /* defeat constness! */
4866     PERL_ARGS_ASSERT_RE_COMPILE;
4867     return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
4868 #ifdef PERL_IN_XSUB_RE
4869                                 &my_reg_engine,
4870 #else
4871                                 &PL_core_reg_engine,
4872 #endif
4873                                 NULL, NULL, rx_flags, 0);
4874 }
4875
4876
4877 /* upgrade pattern pat_p of length plen_p to UTF8, and if there are code
4878  * blocks, recalculate the indices. Update pat_p and plen_p in-place to
4879  * point to the realloced string and length.
4880  *
4881  * This is essentially a copy of Perl_bytes_to_utf8() with the code index
4882  * stuff added */
4883
4884 static void
4885 S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state,
4886                     char **pat_p, STRLEN *plen_p, int num_code_blocks)
4887 {
4888     U8 *const src = (U8*)*pat_p;
4889     U8 *dst;
4890     int n=0;
4891     STRLEN s = 0, d = 0;
4892     bool do_end = 0;
4893     GET_RE_DEBUG_FLAGS_DECL;
4894
4895     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
4896         "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
4897
4898     Newx(dst, *plen_p * 2 + 1, U8);
4899
4900     while (s < *plen_p) {
4901         const UV uv = NATIVE_TO_ASCII(src[s]);
4902         if (UNI_IS_INVARIANT(uv))
4903             dst[d]   = (U8)UTF_TO_NATIVE(uv);
4904         else {
4905             dst[d++] = (U8)UTF8_EIGHT_BIT_HI(uv);
4906             dst[d]   = (U8)UTF8_EIGHT_BIT_LO(uv);
4907         }
4908         if (n < num_code_blocks) {
4909             if (!do_end && pRExC_state->code_blocks[n].start == s) {
4910                 pRExC_state->code_blocks[n].start = d;
4911                 assert(dst[d] == '(');
4912                 do_end = 1;
4913             }
4914             else if (do_end && pRExC_state->code_blocks[n].end == s) {
4915                 pRExC_state->code_blocks[n].end = d;
4916                 assert(dst[d] == ')');
4917                 do_end = 0;
4918                 n++;
4919             }
4920         }
4921         s++;
4922         d++;
4923     }
4924     dst[d] = '\0';
4925     *plen_p = d;
4926     *pat_p = (char*) dst;
4927     SAVEFREEPV(*pat_p);
4928     RExC_orig_utf8 = RExC_utf8 = 1;
4929 }
4930
4931
4932
4933 /* S_concat_pat(): concatenate a list of args to the pattern string pat,
4934  * while recording any code block indices, and handling overloading,
4935  * nested qr// objects etc.  If pat is null, it will allocate a new
4936  * string, or just return the first arg, if there's only one.
4937  *
4938  * Returns the malloced/updated pat.
4939  * patternp and pat_count is the array of SVs to be concatted;
4940  * oplist is the optional list of ops that generated the SVs;
4941  * recompile_p is a pointer to a boolean that will be set if
4942  *   the regex will need to be recompiled.
4943  * delim, if non-null is an SV that will be inserted between each element
4944  */
4945
4946 static SV*
4947 S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
4948                 SV *pat, SV ** const patternp, int pat_count,
4949                 OP *oplist, bool *recompile_p, SV *delim)
4950 {
4951     SV **svp;
4952     int n = 0;
4953     bool use_delim = FALSE;
4954     bool alloced = FALSE;
4955
4956     /* if we know we have at least two args, create an empty string,
4957      * then concatenate args to that. For no args, return an empty string */
4958     if (!pat && pat_count != 1) {
4959         pat = newSVpvn("", 0);
4960         SAVEFREESV(pat);
4961         alloced = TRUE;
4962     }
4963
4964     for (svp = patternp; svp < patternp + pat_count; svp++) {
4965         SV *sv;
4966         SV *rx  = NULL;
4967         STRLEN orig_patlen = 0;
4968         bool code = 0;
4969         SV *msv = use_delim ? delim : *svp;
4970
4971         /* if we've got a delimiter, we go round the loop twice for each
4972          * svp slot (except the last), using the delimiter the second
4973          * time round */
4974         if (use_delim) {
4975             svp--;
4976             use_delim = FALSE;
4977         }
4978         else if (delim)
4979             use_delim = TRUE;
4980
4981         if (SvTYPE(msv) == SVt_PVAV) {
4982             /* we've encountered an interpolated array within
4983              * the pattern, e.g. /...@a..../. Expand the list of elements,
4984              * then recursively append elements.
4985              * The code in this block is based on S_pushav() */
4986
4987             AV *const av = (AV*)msv;
4988             const I32 maxarg = AvFILL(av) + 1;
4989             SV **array;
4990
4991             if (oplist) {
4992                 assert(oplist->op_type == OP_PADAV
4993                     || oplist->op_type == OP_RV2AV); 
4994                 oplist = oplist->op_sibling;;
4995             }
4996
4997             if (SvRMAGICAL(av)) {
4998                 U32 i;
4999
5000                 Newx(array, maxarg, SV*);
5001                 SAVEFREEPV(array);
5002                 for (i=0; i < (U32)maxarg; i++) {
5003                     SV ** const svp = av_fetch(av, i, FALSE);
5004                     array[i] = svp ? *svp : &PL_sv_undef;
5005                 }
5006             }
5007             else
5008                 array = AvARRAY(av);
5009
5010             pat = S_concat_pat(aTHX_ pRExC_state, pat,
5011                                 array, maxarg, NULL, recompile_p,
5012                                 /* $" */
5013                                 GvSV((gv_fetchpvs("\"", GV_ADDMULTI, SVt_PV))));
5014
5015             continue;
5016         }
5017
5018
5019         /* we make the assumption here that each op in the list of
5020          * op_siblings maps to one SV pushed onto the stack,
5021          * except for code blocks, with have both an OP_NULL and
5022          * and OP_CONST.
5023          * This allows us to match up the list of SVs against the
5024          * list of OPs to find the next code block.
5025          *
5026          * Note that       PUSHMARK PADSV PADSV ..
5027          * is optimised to
5028          *                 PADRANGE PADSV  PADSV  ..
5029          * so the alignment still works. */
5030
5031         if (oplist) {
5032             if (oplist->op_type == OP_NULL
5033                 && (oplist->op_flags & OPf_SPECIAL))
5034             {
5035                 assert(n < pRExC_state->num_code_blocks);
5036                 pRExC_state->code_blocks[n].start = pat ? SvCUR(pat) : 0;
5037                 pRExC_state->code_blocks[n].block = oplist;
5038                 pRExC_state->code_blocks[n].src_regex = NULL;
5039                 n++;
5040                 code = 1;
5041                 oplist = oplist->op_sibling; /* skip CONST */
5042                 assert(oplist);
5043             }
5044             oplist = oplist->op_sibling;;
5045         }
5046
5047         /* apply magic and QR overloading to arg */
5048
5049         SvGETMAGIC(msv);
5050         if (SvROK(msv) && SvAMAGIC(msv)) {
5051             SV *sv = AMG_CALLunary(msv, regexp_amg);
5052             if (sv) {
5053                 if (SvROK(sv))
5054                     sv = SvRV(sv);
5055                 if (SvTYPE(sv) != SVt_REGEXP)
5056                     Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
5057                 msv = sv;
5058             }
5059         }
5060
5061         /* try concatenation overload ... */
5062         if (pat && (SvAMAGIC(pat) || SvAMAGIC(msv)) &&
5063                 (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
5064         {
5065             sv_setsv(pat, sv);
5066             /* overloading involved: all bets are off over literal
5067              * code. Pretend we haven't seen it */
5068             pRExC_state->num_code_blocks -= n;
5069             n = 0;
5070         }
5071         else  {
5072             /* ... or failing that, try "" overload */
5073             while (SvAMAGIC(msv)
5074                     && (sv = AMG_CALLunary(msv, string_amg))
5075                     && sv != msv
5076                     &&  !(   SvROK(msv)
5077                           && SvROK(sv)
5078                           && SvRV(msv) == SvRV(sv))
5079             ) {
5080                 msv = sv;
5081                 SvGETMAGIC(msv);
5082             }
5083             if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
5084                 msv = SvRV(msv);
5085
5086             if (pat) {
5087                 /* this is a partially unrolled
5088                  *     sv_catsv_nomg(pat, msv);
5089                  * that allows us to adjust code block indices if
5090                  * needed */
5091                 STRLEN dlen;
5092                 char *dst = SvPV_force_nomg(pat, dlen);
5093                 orig_patlen = dlen;
5094                 if (SvUTF8(msv) && !SvUTF8(pat)) {
5095                     S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &dst, &dlen, n);
5096                     sv_setpvn(pat, dst, dlen);
5097                     SvUTF8_on(pat);
5098                 }
5099                 sv_catsv_nomg(pat, msv);
5100                 rx = msv;
5101             }
5102             else
5103                 pat = msv;
5104
5105             if (code)
5106                 pRExC_state->code_blocks[n-1].end = SvCUR(pat)-1;
5107         }
5108
5109         /* extract any code blocks within any embedded qr//'s */
5110         if (rx && SvTYPE(rx) == SVt_REGEXP
5111             && RX_ENGINE((REGEXP*)rx)->op_comp)
5112         {
5113
5114             RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
5115             if (ri->num_code_blocks) {
5116                 int i;
5117                 /* the presence of an embedded qr// with code means
5118                  * we should always recompile: the text of the
5119                  * qr// may not have changed, but it may be a
5120                  * different closure than last time */
5121                 *recompile_p = 1;
5122                 Renew(pRExC_state->code_blocks,
5123                     pRExC_state->num_code_blocks + ri->num_code_blocks,
5124                     struct reg_code_block);
5125                 pRExC_state->num_code_blocks += ri->num_code_blocks;
5126
5127                 for (i=0; i < ri->num_code_blocks; i++) {
5128                     struct reg_code_block *src, *dst;
5129                     STRLEN offset =  orig_patlen
5130                         + ReANY((REGEXP *)rx)->pre_prefix;
5131                     assert(n < pRExC_state->num_code_blocks);
5132                     src = &ri->code_blocks[i];
5133                     dst = &pRExC_state->code_blocks[n];
5134                     dst->start      = src->start + offset;
5135                     dst->end        = src->end   + offset;
5136                     dst->block      = src->block;
5137                     dst->src_regex  = (REGEXP*) SvREFCNT_inc( (SV*)
5138                                             src->src_regex
5139                                                 ? src->src_regex
5140                                                 : (REGEXP*)rx);
5141                     n++;
5142                 }
5143             }
5144         }
5145     }
5146     /* avoid calling magic multiple times on a single element e.g. =~ $qr */
5147     if (alloced)
5148         SvSETMAGIC(pat);
5149
5150     return pat;
5151 }
5152
5153
5154
5155 /* see if there are any run-time code blocks in the pattern.
5156  * False positives are allowed */
5157
5158 static bool
5159 S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
5160                     char *pat, STRLEN plen)
5161 {
5162     int n = 0;
5163     STRLEN s;
5164
5165     for (s = 0; s < plen; s++) {
5166         if (n < pRExC_state->num_code_blocks
5167             && s == pRExC_state->code_blocks[n].start)
5168         {
5169             s = pRExC_state->code_blocks[n].end;
5170             n++;
5171             continue;
5172         }
5173         /* TODO ideally should handle [..], (#..), /#.../x to reduce false
5174          * positives here */
5175         if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' &&
5176             (pat[s+2] == '{'
5177                 || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{'))
5178         )
5179             return 1;
5180     }
5181     return 0;
5182 }
5183
5184 /* Handle run-time code blocks. We will already have compiled any direct
5185  * or indirect literal code blocks. Now, take the pattern 'pat' and make a
5186  * copy of it, but with any literal code blocks blanked out and
5187  * appropriate chars escaped; then feed it into
5188  *
5189  *    eval "qr'modified_pattern'"
5190  *
5191  * For example,
5192  *
5193  *       a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
5194  *
5195  * becomes
5196  *
5197  *    qr'a\\bc_______________________def\'ghi\\\\jkl(?{"this is runtime"})mno'
5198  *
5199  * After eval_sv()-ing that, grab any new code blocks from the returned qr
5200  * and merge them with any code blocks of the original regexp.
5201  *
5202  * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
5203  * instead, just save the qr and return FALSE; this tells our caller that
5204  * the original pattern needs upgrading to utf8.
5205  */
5206
5207 static bool
5208 S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
5209     char *pat, STRLEN plen)
5210 {
5211     SV *qr;
5212
5213     GET_RE_DEBUG_FLAGS_DECL;
5214
5215     if (pRExC_state->runtime_code_qr) {
5216         /* this is the second time we've been called; this should
5217          * only happen if the main pattern got upgraded to utf8
5218          * during compilation; re-use the qr we compiled first time
5219          * round (which should be utf8 too)
5220          */
5221         qr = pRExC_state->runtime_code_qr;
5222         pRExC_state->runtime_code_qr = NULL;
5223         assert(RExC_utf8 && SvUTF8(qr));
5224     }
5225     else {
5226         int n = 0;
5227         STRLEN s;
5228         char *p, *newpat;
5229         int newlen = plen + 6; /* allow for "qr''x\0" extra chars */
5230         SV *sv, *qr_ref;
5231         dSP;
5232
5233         /* determine how many extra chars we need for ' and \ escaping */
5234         for (s = 0; s < plen; s++) {
5235             if (pat[s] == '\'' || pat[s] == '\\')
5236                 newlen++;
5237         }
5238
5239         Newx(newpat, newlen, char);
5240         p = newpat;
5241         *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
5242
5243         for (s = 0; s < plen; s++) {
5244             if (n < pRExC_state->num_code_blocks
5245                 && s == pRExC_state->code_blocks[n].start)
5246             {
5247                 /* blank out literal code block */
5248                 assert(pat[s] == '(');
5249                 while (s <= pRExC_state->code_blocks[n].end) {
5250                     *p++ = '_';
5251                     s++;
5252                 }
5253                 s--;
5254                 n++;
5255                 continue;
5256             }
5257             if (pat[s] == '\'' || pat[s] == '\\')
5258                 *p++ = '\\';
5259             *p++ = pat[s];
5260         }
5261         *p++ = '\'';
5262         if (pRExC_state->pm_flags & RXf_PMf_EXTENDED)
5263             *p++ = 'x';
5264         *p++ = '\0';
5265         DEBUG_COMPILE_r({
5266             PerlIO_printf(Perl_debug_log,
5267                 "%sre-parsing pattern for runtime code:%s %s\n",
5268                 PL_colors[4],PL_colors[5],newpat);
5269         });
5270
5271         sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
5272         Safefree(newpat);
5273
5274         ENTER;
5275         SAVETMPS;
5276         save_re_context();
5277         PUSHSTACKi(PERLSI_REQUIRE);
5278         /* G_RE_REPARSING causes the toker to collapse \\ into \ when
5279          * parsing qr''; normally only q'' does this. It also alters
5280          * hints handling */
5281         eval_sv(sv, G_SCALAR|G_RE_REPARSING);
5282         SvREFCNT_dec_NN(sv);
5283         SPAGAIN;
5284         qr_ref = POPs;
5285         PUTBACK;
5286         {
5287             SV * const errsv = ERRSV;
5288             if (SvTRUE_NN(errsv))
5289             {
5290                 Safefree(pRExC_state->code_blocks);
5291                 /* use croak_sv ? */
5292                 Perl_croak_nocontext("%s", SvPV_nolen_const(errsv));
5293             }
5294         }
5295         assert(SvROK(qr_ref));
5296         qr = SvRV(qr_ref);
5297         assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
5298         /* the leaving below frees the tmp qr_ref.
5299          * Give qr a life of its own */
5300         SvREFCNT_inc(qr);
5301         POPSTACK;
5302         FREETMPS;
5303         LEAVE;
5304
5305     }
5306
5307     if (!RExC_utf8 && SvUTF8(qr)) {
5308         /* first time through; the pattern got upgraded; save the
5309          * qr for the next time through */
5310         assert(!pRExC_state->runtime_code_qr);
5311         pRExC_state->runtime_code_qr = qr;
5312         return 0;
5313     }
5314
5315
5316     /* extract any code blocks within the returned qr//  */
5317
5318
5319     /* merge the main (r1) and run-time (r2) code blocks into one */
5320     {
5321         RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
5322         struct reg_code_block *new_block, *dst;
5323         RExC_state_t * const r1 = pRExC_state; /* convenient alias */
5324         int i1 = 0, i2 = 0;
5325
5326         if (!r2->num_code_blocks) /* we guessed wrong */
5327         {
5328             SvREFCNT_dec_NN(qr);
5329             return 1;
5330         }
5331
5332         Newx(new_block,
5333             r1->num_code_blocks + r2->num_code_blocks,
5334             struct reg_code_block);
5335         dst = new_block;
5336
5337         while (    i1 < r1->num_code_blocks
5338                 || i2 < r2->num_code_blocks)
5339         {
5340             struct reg_code_block *src;
5341             bool is_qr = 0;
5342
5343             if (i1 == r1->num_code_blocks) {
5344                 src = &r2->code_blocks[i2++];
5345                 is_qr = 1;
5346             }
5347             else if (i2 == r2->num_code_blocks)
5348                 src = &r1->code_blocks[i1++];
5349             else if (  r1->code_blocks[i1].start
5350                      < r2->code_blocks[i2].start)
5351             {
5352                 src = &r1->code_blocks[i1++];
5353                 assert(src->end < r2->code_blocks[i2].start);
5354             }
5355             else {
5356                 assert(  r1->code_blocks[i1].start
5357                        > r2->code_blocks[i2].start);
5358                 src = &r2->code_blocks[i2++];
5359                 is_qr = 1;
5360                 assert(src->end < r1->code_blocks[i1].start);
5361             }
5362
5363             assert(pat[src->start] == '(');
5364             assert(pat[src->end]   == ')');
5365             dst->start      = src->start;
5366             dst->end        = src->end;
5367             dst->block      = src->block;
5368             dst->src_regex  = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
5369                                     : src->src_regex;
5370             dst++;
5371         }
5372         r1->num_code_blocks += r2->num_code_blocks;
5373         Safefree(r1->code_blocks);
5374         r1->code_blocks = new_block;
5375     }
5376
5377     SvREFCNT_dec_NN(qr);
5378     return 1;
5379 }
5380
5381
5382 STATIC bool
5383 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)
5384 {
5385     /* This is the common code for setting up the floating and fixed length
5386      * string data extracted from Perl_re_op_compile() below.  Returns a boolean
5387      * as to whether succeeded or not */
5388
5389     I32 t,ml;
5390
5391     if (! (longest_length
5392            || (eol /* Can't have SEOL and MULTI */
5393                && (! meol || (RExC_flags & RXf_PMf_MULTILINE)))
5394           )
5395             /* See comments for join_exact for why REG_SEEN_EXACTF_SHARP_S */
5396         || (RExC_seen & REG_SEEN_EXACTF_SHARP_S))
5397     {
5398         return FALSE;
5399     }
5400
5401     /* copy the information about the longest from the reg_scan_data
5402         over to the program. */
5403     if (SvUTF8(sv_longest)) {
5404         *rx_utf8 = sv_longest;
5405         *rx_substr = NULL;
5406     } else {
5407         *rx_substr = sv_longest;
5408         *rx_utf8 = NULL;
5409     }
5410     /* end_shift is how many chars that must be matched that
5411         follow this item. We calculate it ahead of time as once the
5412         lookbehind offset is added in we lose the ability to correctly
5413         calculate it.*/
5414     ml = minlen ? *(minlen) : (I32)longest_length;
5415     *rx_end_shift = ml - offset
5416         - longest_length + (SvTAIL(sv_longest) != 0)
5417         + lookbehind;
5418
5419     t = (eol/* Can't have SEOL and MULTI */
5420          && (! meol || (RExC_flags & RXf_PMf_MULTILINE)));
5421     fbm_compile(sv_longest, t ? FBMcf_TAIL : 0);
5422
5423     return TRUE;
5424 }
5425
5426 /*
5427  * Perl_re_op_compile - the perl internal RE engine's function to compile a
5428  * regular expression into internal code.
5429  * The pattern may be passed either as:
5430  *    a list of SVs (patternp plus pat_count)
5431  *    a list of OPs (expr)
5432  * If both are passed, the SV list is used, but the OP list indicates
5433  * which SVs are actually pre-compiled code blocks
5434  *
5435  * The SVs in the list have magic and qr overloading applied to them (and
5436  * the list may be modified in-place with replacement SVs in the latter
5437  * case).
5438  *
5439  * If the pattern hasn't changed from old_re, then old_re will be
5440  * returned.
5441  *
5442  * eng is the current engine. If that engine has an op_comp method, then
5443  * handle directly (i.e. we assume that op_comp was us); otherwise, just
5444  * do the initial concatenation of arguments and pass on to the external
5445  * engine.
5446  *
5447  * If is_bare_re is not null, set it to a boolean indicating whether the
5448  * arg list reduced (after overloading) to a single bare regex which has
5449  * been returned (i.e. /$qr/).
5450  *
5451  * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
5452  *
5453  * pm_flags contains the PMf_* flags, typically based on those from the
5454  * pm_flags field of the related PMOP. Currently we're only interested in
5455  * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL.
5456  *
5457  * We can't allocate space until we know how big the compiled form will be,
5458  * but we can't compile it (and thus know how big it is) until we've got a
5459  * place to put the code.  So we cheat:  we compile it twice, once with code
5460  * generation turned off and size counting turned on, and once "for real".
5461  * This also means that we don't allocate space until we are sure that the
5462  * thing really will compile successfully, and we never have to move the
5463  * code and thus invalidate pointers into it.  (Note that it has to be in
5464  * one piece because free() must be able to free it all.) [NB: not true in perl]
5465  *
5466  * Beware that the optimization-preparation code in here knows about some
5467  * of the structure of the compiled regexp.  [I'll say.]
5468  */
5469
5470 REGEXP *
5471 Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
5472                     OP *expr, const regexp_engine* eng, REGEXP *old_re,
5473                      bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags)
5474 {
5475     dVAR;
5476     REGEXP *rx;
5477     struct regexp *r;
5478     regexp_internal *ri;
5479     STRLEN plen;
5480     char *exp;
5481     regnode *scan;
5482     I32 flags;
5483     I32 minlen = 0;
5484     U32 rx_flags;
5485     SV *pat;
5486     SV *code_blocksv = NULL;
5487     SV** new_patternp = patternp;
5488
5489     /* these are all flags - maybe they should be turned
5490      * into a single int with different bit masks */
5491     I32 sawlookahead = 0;
5492     I32 sawplus = 0;
5493     I32 sawopen = 0;
5494     regex_charset initial_charset = get_regex_charset(orig_rx_flags);
5495     bool recompile = 0;
5496     bool runtime_code = 0;
5497     scan_data_t data;
5498     RExC_state_t RExC_state;
5499     RExC_state_t * const pRExC_state = &RExC_state;
5500 #ifdef TRIE_STUDY_OPT    
5501     int restudied = 0;
5502     RExC_state_t copyRExC_state;
5503 #endif    
5504     GET_RE_DEBUG_FLAGS_DECL;
5505
5506     PERL_ARGS_ASSERT_RE_OP_COMPILE;
5507
5508     DEBUG_r(if (!PL_colorset) reginitcolors());
5509
5510 #ifndef PERL_IN_XSUB_RE
5511     /* Initialize these here instead of as-needed, as is quick and avoids
5512      * having to test them each time otherwise */
5513     if (! PL_AboveLatin1) {
5514         PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
5515         PL_ASCII = _new_invlist_C_array(ASCII_invlist);
5516         PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
5517
5518         PL_L1Posix_ptrs[_CC_ALPHANUMERIC]
5519                                 = _new_invlist_C_array(L1PosixAlnum_invlist);
5520         PL_Posix_ptrs[_CC_ALPHANUMERIC]
5521                                 = _new_invlist_C_array(PosixAlnum_invlist);
5522
5523         PL_L1Posix_ptrs[_CC_ALPHA]
5524                                 = _new_invlist_C_array(L1PosixAlpha_invlist);
5525         PL_Posix_ptrs[_CC_ALPHA] = _new_invlist_C_array(PosixAlpha_invlist);
5526
5527         PL_Posix_ptrs[_CC_BLANK] = _new_invlist_C_array(PosixBlank_invlist);
5528         PL_XPosix_ptrs[_CC_BLANK] = _new_invlist_C_array(XPosixBlank_invlist);
5529
5530         /* Cased is the same as Alpha in the ASCII range */
5531         PL_L1Posix_ptrs[_CC_CASED] =  _new_invlist_C_array(L1Cased_invlist);
5532         PL_Posix_ptrs[_CC_CASED] =  _new_invlist_C_array(PosixAlpha_invlist);
5533
5534         PL_Posix_ptrs[_CC_CNTRL] = _new_invlist_C_array(PosixCntrl_invlist);
5535         PL_XPosix_ptrs[_CC_CNTRL] = _new_invlist_C_array(XPosixCntrl_invlist);
5536
5537         PL_Posix_ptrs[_CC_DIGIT] = _new_invlist_C_array(PosixDigit_invlist);
5538         PL_L1Posix_ptrs[_CC_DIGIT] = _new_invlist_C_array(PosixDigit_invlist);
5539
5540         PL_L1Posix_ptrs[_CC_GRAPH] = _new_invlist_C_array(L1PosixGraph_invlist);
5541         PL_Posix_ptrs[_CC_GRAPH] = _new_invlist_C_array(PosixGraph_invlist);
5542
5543         PL_L1Posix_ptrs[_CC_LOWER] = _new_invlist_C_array(L1PosixLower_invlist);
5544         PL_Posix_ptrs[_CC_LOWER] = _new_invlist_C_array(PosixLower_invlist);
5545
5546         PL_L1Posix_ptrs[_CC_PRINT] = _new_invlist_C_array(L1PosixPrint_invlist);
5547         PL_Posix_ptrs[_CC_PRINT] = _new_invlist_C_array(PosixPrint_invlist);
5548
5549         PL_L1Posix_ptrs[_CC_PUNCT] = _new_invlist_C_array(L1PosixPunct_invlist);
5550         PL_Posix_ptrs[_CC_PUNCT] = _new_invlist_C_array(PosixPunct_invlist);
5551
5552         PL_Posix_ptrs[_CC_SPACE] = _new_invlist_C_array(PerlSpace_invlist);
5553         PL_XPosix_ptrs[_CC_SPACE] = _new_invlist_C_array(XPerlSpace_invlist);
5554         PL_Posix_ptrs[_CC_PSXSPC] = _new_invlist_C_array(PosixSpace_invlist);
5555         PL_XPosix_ptrs[_CC_PSXSPC] = _new_invlist_C_array(XPosixSpace_invlist);
5556
5557         PL_L1Posix_ptrs[_CC_UPPER] = _new_invlist_C_array(L1PosixUpper_invlist);
5558         PL_Posix_ptrs[_CC_UPPER] = _new_invlist_C_array(PosixUpper_invlist);
5559
5560         PL_XPosix_ptrs[_CC_VERTSPACE] = _new_invlist_C_array(VertSpace_invlist);
5561
5562         PL_Posix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(PosixWord_invlist);
5563         PL_L1Posix_ptrs[_CC_WORDCHAR]
5564                                 = _new_invlist_C_array(L1PosixWord_invlist);
5565
5566         PL_Posix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(PosixXDigit_invlist);
5567         PL_XPosix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(XPosixXDigit_invlist);
5568
5569         PL_HasMultiCharFold = _new_invlist_C_array(_Perl_Multi_Char_Folds_invlist);
5570     }
5571 #endif
5572
5573     pRExC_state->code_blocks = NULL;
5574     pRExC_state->num_code_blocks = 0;
5575
5576     if (is_bare_re)
5577         *is_bare_re = FALSE;
5578
5579     if (expr && (expr->op_type == OP_LIST ||
5580                 (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
5581         /* allocate code_blocks if needed */
5582         OP *o;
5583         int ncode = 0;
5584
5585         for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling)
5586             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
5587                 ncode++; /* count of DO blocks */
5588         if (ncode) {
5589             pRExC_state->num_code_blocks = ncode;
5590             Newx(pRExC_state->code_blocks, ncode, struct reg_code_block);
5591         }
5592     }
5593
5594     if (!pat_count) {
5595         /* compile-time pattern with just OP_CONSTs and DO blocks */
5596
5597         int n;
5598         OP *o;
5599
5600         /* find how many CONSTs there are */
5601         assert(expr);
5602         n = 0;
5603         if (expr->op_type == OP_CONST)
5604             n = 1;
5605         else
5606             for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
5607                 if (o->op_type == OP_CONST)
5608                     n++;
5609             }
5610
5611         /* fake up an SV array */
5612
5613         assert(!new_patternp);
5614         Newx(new_patternp, n, SV*);
5615         SAVEFREEPV(new_patternp);
5616         pat_count = n;
5617
5618         n = 0;
5619         if (expr->op_type == OP_CONST)
5620             new_patternp[n] = cSVOPx_sv(expr);
5621         else
5622             for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
5623                 if (o->op_type == OP_CONST)
5624                     new_patternp[n++] = cSVOPo_sv;
5625             }
5626
5627     }
5628
5629     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
5630         "Assembling pattern from %d elements%s\n", pat_count,
5631             orig_rx_flags & RXf_SPLIT ? " for split" : ""));
5632
5633     /* set expr to the first arg op */
5634
5635     if (pRExC_state->num_code_blocks
5636          && expr->op_type != OP_CONST)
5637     {
5638             expr = cLISTOPx(expr)->op_first;
5639             assert(   expr->op_type == OP_PUSHMARK
5640                    || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK)
5641                    || expr->op_type == OP_PADRANGE);
5642             expr = expr->op_sibling;
5643     }
5644
5645     pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count,
5646                         expr, &recompile, NULL);
5647
5648     /* handle bare (possibly after overloading) regex: foo =~ $re */
5649     {
5650         SV *re = pat;
5651         if (SvROK(re))
5652             re = SvRV(re);
5653         if (SvTYPE(re) == SVt_REGEXP) {
5654             if (is_bare_re)
5655                 *is_bare_re = TRUE;
5656             SvREFCNT_inc(re);
5657             Safefree(pRExC_state->code_blocks);
5658             DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
5659                 "Precompiled pattern%s\n",
5660                     orig_rx_flags & RXf_SPLIT ? " for split" : ""));
5661
5662             return (REGEXP*)re;
5663         }
5664     }
5665
5666     exp = SvPV_nomg(pat, plen);
5667
5668     if (!eng->op_comp) {
5669         if ((SvUTF8(pat) && IN_BYTES)
5670                 || SvGMAGICAL(pat) || SvAMAGIC(pat))
5671         {
5672             /* make a temporary copy; either to convert to bytes,
5673              * or to avoid repeating get-magic / overloaded stringify */
5674             pat = newSVpvn_flags(exp, plen, SVs_TEMP |
5675                                         (IN_BYTES ? 0 : SvUTF8(pat)));
5676         }
5677         Safefree(pRExC_state->code_blocks);
5678         return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
5679     }
5680
5681     /* ignore the utf8ness if the pattern is 0 length */
5682     RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
5683     RExC_uni_semantics = 0;
5684     RExC_contains_locale = 0;
5685     pRExC_state->runtime_code_qr = NULL;
5686
5687     DEBUG_COMPILE_r({
5688             SV *dsv= sv_newmortal();
5689             RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, 60);
5690             PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
5691                           PL_colors[4],PL_colors[5],s);
5692         });
5693
5694   redo_first_pass:
5695     /* we jump here if we upgrade the pattern to utf8 and have to
5696      * recompile */
5697
5698     if ((pm_flags & PMf_USE_RE_EVAL)
5699                 /* this second condition covers the non-regex literal case,
5700                  * i.e.  $foo =~ '(?{})'. */
5701                 || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
5702     )
5703         runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen);
5704
5705     /* return old regex if pattern hasn't changed */
5706     /* XXX: note in the below we have to check the flags as well as the pattern.
5707      *
5708      * Things get a touch tricky as we have to compare the utf8 flag independently
5709      * from the compile flags.
5710      */
5711
5712     if (   old_re
5713         && !recompile
5714         && !!RX_UTF8(old_re) == !!RExC_utf8
5715         && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) )
5716         && RX_PRECOMP(old_re)
5717         && RX_PRELEN(old_re) == plen
5718         && memEQ(RX_PRECOMP(old_re), exp, plen)
5719         && !runtime_code /* with runtime code, always recompile */ )
5720     {
5721         Safefree(pRExC_state->code_blocks);
5722         return old_re;
5723     }
5724
5725     rx_flags = orig_rx_flags;
5726
5727     if (initial_charset == REGEX_LOCALE_CHARSET) {
5728         RExC_contains_locale = 1;
5729     }
5730     else if (RExC_utf8 && initial_charset == REGEX_DEPENDS_CHARSET) {
5731
5732         /* Set to use unicode semantics if the pattern is in utf8 and has the
5733          * 'depends' charset specified, as it means unicode when utf8  */
5734         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
5735     }
5736
5737     RExC_precomp = exp;
5738     RExC_flags = rx_flags;
5739     RExC_pm_flags = pm_flags;
5740
5741     if (runtime_code) {
5742         if (TAINTING_get && TAINT_get)
5743             Perl_croak(aTHX_ "Eval-group in insecure regular expression");
5744
5745         if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
5746             /* whoops, we have a non-utf8 pattern, whilst run-time code
5747              * got compiled as utf8. Try again with a utf8 pattern */
5748             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
5749                                     pRExC_state->num_code_blocks);
5750             goto redo_first_pass;
5751         }
5752     }
5753     assert(!pRExC_state->runtime_code_qr);
5754
5755     RExC_sawback = 0;
5756
5757     RExC_seen = 0;
5758     RExC_in_lookbehind = 0;
5759     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
5760     RExC_extralen = 0;
5761     RExC_override_recoding = 0;
5762     RExC_in_multi_char_class = 0;
5763
5764     /* First pass: determine size, legality. */
5765     RExC_parse = exp;
5766     RExC_start = exp;
5767     RExC_end = exp + plen;
5768     RExC_naughty = 0;
5769     RExC_npar = 1;
5770     RExC_nestroot = 0;
5771     RExC_size = 0L;
5772     RExC_emit = &PL_regdummy;
5773     RExC_whilem_seen = 0;
5774     RExC_open_parens = NULL;
5775     RExC_close_parens = NULL;
5776     RExC_opend = NULL;
5777     RExC_paren_names = NULL;
5778 #ifdef DEBUGGING
5779     RExC_paren_name_list = NULL;
5780 #endif
5781     RExC_recurse = NULL;
5782     RExC_recurse_count = 0;
5783     pRExC_state->code_index = 0;
5784
5785 #if 0 /* REGC() is (currently) a NOP at the first pass.
5786        * Clever compilers notice this and complain. --jhi */
5787     REGC((U8)REG_MAGIC, (char*)RExC_emit);
5788 #endif
5789     DEBUG_PARSE_r(
5790         PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n");
5791         RExC_lastnum=0;
5792         RExC_lastparse=NULL;
5793     );
5794     /* reg may croak on us, not giving us a chance to free
5795        pRExC_state->code_blocks.  We cannot SAVEFREEPV it now, as we may
5796        need it to survive as long as the regexp (qr/(?{})/).
5797        We must check that code_blocksv is not already set, because we may
5798        have jumped back to restart the sizing pass. */
5799     if (pRExC_state->code_blocks && !code_blocksv) {
5800         code_blocksv = newSV_type(SVt_PV);
5801         SAVEFREESV(code_blocksv);
5802         SvPV_set(code_blocksv, (char *)pRExC_state->code_blocks);
5803         SvLEN_set(code_blocksv, 1); /*sufficient to make sv_clear free it*/
5804     }
5805     if (reg(pRExC_state, 0, &flags,1) == NULL) {
5806         /* It's possible to write a regexp in ascii that represents Unicode
5807         codepoints outside of the byte range, such as via \x{100}. If we
5808         detect such a sequence we have to convert the entire pattern to utf8
5809         and then recompile, as our sizing calculation will have been based
5810         on 1 byte == 1 character, but we will need to use utf8 to encode
5811         at least some part of the pattern, and therefore must convert the whole
5812         thing.
5813         -- dmq */
5814         if (flags & RESTART_UTF8) {
5815             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
5816                                     pRExC_state->num_code_blocks);
5817             goto redo_first_pass;
5818         }
5819         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for sizing pass, flags=%#X", flags);
5820     }
5821     if (code_blocksv)
5822         SvLEN_set(code_blocksv,0); /* no you can't have it, sv_clear */
5823
5824     DEBUG_PARSE_r({
5825         PerlIO_printf(Perl_debug_log, 
5826             "Required size %"IVdf" nodes\n"
5827             "Starting second pass (creation)\n", 
5828             (IV)RExC_size);
5829         RExC_lastnum=0; 
5830         RExC_lastparse=NULL; 
5831     });
5832
5833     /* The first pass could have found things that force Unicode semantics */
5834     if ((RExC_utf8 || RExC_uni_semantics)
5835          && get_regex_charset(rx_flags) == REGEX_DEPENDS_CHARSET)
5836     {
5837         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
5838     }
5839
5840     /* Small enough for pointer-storage convention?
5841        If extralen==0, this means that we will not need long jumps. */
5842     if (RExC_size >= 0x10000L && RExC_extralen)
5843         RExC_size += RExC_extralen;
5844     else
5845         RExC_extralen = 0;
5846     if (RExC_whilem_seen > 15)
5847         RExC_whilem_seen = 15;
5848
5849     /* Allocate space and zero-initialize. Note, the two step process 
5850        of zeroing when in debug mode, thus anything assigned has to 
5851        happen after that */
5852     rx = (REGEXP*) newSV_type(SVt_REGEXP);
5853     r = ReANY(rx);
5854     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
5855          char, regexp_internal);
5856     if ( r == NULL || ri == NULL )
5857         FAIL("Regexp out of space");
5858 #ifdef DEBUGGING
5859     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
5860     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char);
5861 #else 
5862     /* bulk initialize base fields with 0. */
5863     Zero(ri, sizeof(regexp_internal), char);        
5864 #endif
5865
5866     /* non-zero initialization begins here */
5867     RXi_SET( r, ri );
5868     r->engine= eng;
5869     r->extflags = rx_flags;
5870     RXp_COMPFLAGS(r) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK;
5871
5872     if (pm_flags & PMf_IS_QR) {
5873         ri->code_blocks = pRExC_state->code_blocks;
5874         ri->num_code_blocks = pRExC_state->num_code_blocks;
5875     }
5876     else
5877     {
5878         int n;
5879         for (n = 0; n < pRExC_state->num_code_blocks; n++)
5880             if (pRExC_state->code_blocks[n].src_regex)
5881                 SAVEFREESV(pRExC_state->code_blocks[n].src_regex);
5882         SAVEFREEPV(pRExC_state->code_blocks);
5883     }
5884
5885     {
5886         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
5887         bool has_charset = (get_regex_charset(r->extflags) != REGEX_DEPENDS_CHARSET);
5888
5889         /* The caret is output if there are any defaults: if not all the STD
5890          * flags are set, or if no character set specifier is needed */
5891         bool has_default =
5892                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
5893                     || ! has_charset);
5894         bool has_runon = ((RExC_seen & REG_SEEN_RUN_ON_COMMENT)==REG_SEEN_RUN_ON_COMMENT);
5895         U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD)
5896                             >> RXf_PMf_STD_PMMOD_SHIFT);
5897         const char *fptr = STD_PAT_MODS;        /*"msix"*/
5898         char *p;
5899         /* Allocate for the worst case, which is all the std flags are turned
5900          * on.  If more precision is desired, we could do a population count of
5901          * the flags set.  This could be done with a small lookup table, or by
5902          * shifting, masking and adding, or even, when available, assembly
5903          * language for a machine-language population count.
5904          * We never output a minus, as all those are defaults, so are
5905          * covered by the caret */
5906         const STRLEN wraplen = plen + has_p + has_runon
5907             + has_default       /* If needs a caret */
5908
5909                 /* If needs a character set specifier */
5910             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
5911             + (sizeof(STD_PAT_MODS) - 1)
5912             + (sizeof("(?:)") - 1);
5913
5914         Newx(p, wraplen + 1, char); /* +1 for the ending NUL */
5915         r->xpv_len_u.xpvlenu_pv = p;
5916         if (RExC_utf8)
5917             SvFLAGS(rx) |= SVf_UTF8;
5918         *p++='('; *p++='?';
5919
5920         /* If a default, cover it using the caret */
5921         if (has_default) {
5922             *p++= DEFAULT_PAT_MOD;
5923         }
5924         if (has_charset) {
5925             STRLEN len;
5926             const char* const name = get_regex_charset_name(r->extflags, &len);
5927             Copy(name, p, len, char);
5928             p += len;
5929         }
5930         if (has_p)
5931             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
5932         {
5933             char ch;
5934             while((ch = *fptr++)) {
5935                 if(reganch & 1)
5936                     *p++ = ch;
5937                 reganch >>= 1;
5938             }
5939         }
5940
5941         *p++ = ':';
5942         Copy(RExC_precomp, p, plen, char);
5943         assert ((RX_WRAPPED(rx) - p) < 16);
5944         r->pre_prefix = p - RX_WRAPPED(rx);
5945         p += plen;
5946         if (has_runon)
5947             *p++ = '\n';
5948         *p++ = ')';
5949         *p = 0;
5950         SvCUR_set(rx, p - RX_WRAPPED(rx));
5951     }
5952
5953     r->intflags = 0;
5954     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
5955     
5956     if (RExC_seen & REG_SEEN_RECURSE) {
5957         Newxz(RExC_open_parens, RExC_npar,regnode *);
5958         SAVEFREEPV(RExC_open_parens);
5959         Newxz(RExC_close_parens,RExC_npar,regnode *);
5960         SAVEFREEPV(RExC_close_parens);
5961     }
5962
5963     /* Useful during FAIL. */
5964 #ifdef RE_TRACK_PATTERN_OFFSETS
5965     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
5966     DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
5967                           "%s %"UVuf" bytes for offset annotations.\n",
5968                           ri->u.offsets ? "Got" : "Couldn't get",
5969                           (UV)((2*RExC_size+1) * sizeof(U32))));
5970 #endif
5971     SetProgLen(ri,RExC_size);
5972     RExC_rx_sv = rx;
5973     RExC_rx = r;
5974     RExC_rxi = ri;
5975
5976     /* Second pass: emit code. */
5977     RExC_flags = rx_flags;      /* don't let top level (?i) bleed */
5978     RExC_pm_flags = pm_flags;
5979     RExC_parse = exp;
5980     RExC_end = exp + plen;
5981     RExC_naughty = 0;
5982     RExC_npar = 1;
5983     RExC_emit_start = ri->program;
5984     RExC_emit = ri->program;
5985     RExC_emit_bound = ri->program + RExC_size + 1;
5986     pRExC_state->code_index = 0;
5987
5988     REGC((U8)REG_MAGIC, (char*) RExC_emit++);
5989     if (reg(pRExC_state, 0, &flags,1) == NULL) {
5990         ReREFCNT_dec(rx);   
5991         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for generation pass, flags=%#X", flags);
5992     }
5993     /* XXXX To minimize changes to RE engine we always allocate
5994        3-units-long substrs field. */
5995     Newx(r->substrs, 1, struct reg_substr_data);
5996     if (RExC_recurse_count) {
5997         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
5998         SAVEFREEPV(RExC_recurse);
5999     }
6000
6001 reStudy:
6002     r->minlen = minlen = sawlookahead = sawplus = sawopen = 0;
6003     Zero(r->substrs, 1, struct reg_substr_data);
6004
6005 #ifdef TRIE_STUDY_OPT
6006     if (!restudied) {
6007         StructCopy(&zero_scan_data, &data, scan_data_t);
6008         copyRExC_state = RExC_state;
6009     } else {
6010         U32 seen=RExC_seen;
6011         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
6012         
6013         RExC_state = copyRExC_state;
6014         if (seen & REG_TOP_LEVEL_BRANCHES) 
6015             RExC_seen |= REG_TOP_LEVEL_BRANCHES;
6016         else
6017             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES;
6018         StructCopy(&zero_scan_data, &data, scan_data_t);
6019     }
6020 #else
6021     StructCopy(&zero_scan_data, &data, scan_data_t);
6022 #endif    
6023
6024     /* Dig out information for optimizations. */
6025     r->extflags = RExC_flags; /* was pm_op */
6026     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
6027  
6028     if (UTF)
6029         SvUTF8_on(rx);  /* Unicode in it? */
6030     ri->regstclass = NULL;
6031     if (RExC_naughty >= 10)     /* Probably an expensive pattern. */
6032         r->intflags |= PREGf_NAUGHTY;
6033     scan = ri->program + 1;             /* First BRANCH. */
6034
6035     /* testing for BRANCH here tells us whether there is "must appear"
6036        data in the pattern. If there is then we can use it for optimisations */
6037     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /*  Only one top-level choice. */
6038         I32 fake;
6039         STRLEN longest_float_length, longest_fixed_length;
6040         struct regnode_charclass_class ch_class; /* pointed to by data */
6041         int stclass_flag;
6042         I32 last_close = 0; /* pointed to by data */
6043         regnode *first= scan;
6044         regnode *first_next= regnext(first);
6045         /*
6046          * Skip introductions and multiplicators >= 1
6047          * so that we can extract the 'meat' of the pattern that must 
6048          * match in the large if() sequence following.
6049          * NOTE that EXACT is NOT covered here, as it is normally
6050          * picked up by the optimiser separately. 
6051          *
6052          * This is unfortunate as the optimiser isnt handling lookahead
6053          * properly currently.
6054          *
6055          */
6056         while ((OP(first) == OPEN && (sawopen = 1)) ||
6057                /* An OR of *one* alternative - should not happen now. */
6058             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
6059             /* for now we can't handle lookbehind IFMATCH*/
6060             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
6061             (OP(first) == PLUS) ||
6062             (OP(first) == MINMOD) ||
6063                /* An {n,m} with n>0 */
6064             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
6065             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
6066         {
6067                 /* 
6068                  * the only op that could be a regnode is PLUS, all the rest
6069                  * will be regnode_1 or regnode_2.
6070                  *
6071                  */
6072                 if (OP(first) == PLUS)
6073                     sawplus = 1;
6074                 else
6075                     first += regarglen[OP(first)];
6076
6077                 first = NEXTOPER(first);
6078                 first_next= regnext(first);
6079         }
6080
6081         /* Starting-point info. */
6082       again:
6083         DEBUG_PEEP("first:",first,0);
6084         /* Ignore EXACT as we deal with it later. */
6085         if (PL_regkind[OP(first)] == EXACT) {
6086             if (OP(first) == EXACT)
6087                 NOOP;   /* Empty, get anchored substr later. */
6088             else
6089                 ri->regstclass = first;
6090         }
6091 #ifdef TRIE_STCLASS
6092         else if (PL_regkind[OP(first)] == TRIE &&
6093                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0) 
6094         {
6095             regnode *trie_op;
6096             /* this can happen only on restudy */
6097             if ( OP(first) == TRIE ) {
6098                 struct regnode_1 *trieop = (struct regnode_1 *)
6099                     PerlMemShared_calloc(1, sizeof(struct regnode_1));
6100                 StructCopy(first,trieop,struct regnode_1);
6101                 trie_op=(regnode *)trieop;
6102             } else {
6103                 struct regnode_charclass *trieop = (struct regnode_charclass *)
6104                     PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
6105                 StructCopy(first,trieop,struct regnode_charclass);
6106                 trie_op=(regnode *)trieop;
6107             }
6108             OP(trie_op)+=2;
6109             make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
6110             ri->regstclass = trie_op;
6111         }
6112 #endif
6113         else if (REGNODE_SIMPLE(OP(first)))
6114             ri->regstclass = first;
6115         else if (PL_regkind[OP(first)] == BOUND ||
6116                  PL_regkind[OP(first)] == NBOUND)
6117             ri->regstclass = first;
6118         else if (PL_regkind[OP(first)] == BOL) {
6119             r->extflags |= (OP(first) == MBOL
6120                            ? RXf_ANCH_MBOL
6121                            : (OP(first) == SBOL
6122                               ? RXf_ANCH_SBOL
6123                               : RXf_ANCH_BOL));
6124             first = NEXTOPER(first);
6125             goto again;
6126         }
6127         else if (OP(first) == GPOS) {
6128             r->extflags |= RXf_ANCH_GPOS;
6129             first = NEXTOPER(first);
6130             goto again;
6131         }
6132         else if ((!sawopen || !RExC_sawback) &&
6133             (OP(first) == STAR &&
6134             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
6135             !(r->extflags & RXf_ANCH) && !pRExC_state->num_code_blocks)
6136         {
6137             /* turn .* into ^.* with an implied $*=1 */
6138             const int type =
6139                 (OP(NEXTOPER(first)) == REG_ANY)
6140                     ? RXf_ANCH_MBOL
6141                     : RXf_ANCH_SBOL;
6142             r->extflags |= type;
6143             r->intflags |= PREGf_IMPLICIT;
6144             first = NEXTOPER(first);
6145             goto again;
6146         }
6147         if (sawplus && !sawlookahead && (!sawopen || !RExC_sawback)
6148             && !pRExC_state->num_code_blocks) /* May examine pos and $& */
6149             /* x+ must match at the 1st pos of run of x's */
6150             r->intflags |= PREGf_SKIP;
6151
6152         /* Scan is after the zeroth branch, first is atomic matcher. */
6153 #ifdef TRIE_STUDY_OPT
6154         DEBUG_PARSE_r(
6155             if (!restudied)
6156                 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
6157                               (IV)(first - scan + 1))
6158         );
6159 #else
6160         DEBUG_PARSE_r(
6161             PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
6162                 (IV)(first - scan + 1))
6163         );
6164 #endif
6165
6166
6167         /*
6168         * If there's something expensive in the r.e., find the
6169         * longest literal string that must appear and make it the
6170         * regmust.  Resolve ties in favor of later strings, since
6171         * the regstart check works with the beginning of the r.e.
6172         * and avoiding duplication strengthens checking.  Not a
6173         * strong reason, but sufficient in the absence of others.
6174         * [Now we resolve ties in favor of the earlier string if
6175         * it happens that c_offset_min has been invalidated, since the
6176         * earlier string may buy us something the later one won't.]
6177         */
6178
6179         data.longest_fixed = newSVpvs("");
6180         data.longest_float = newSVpvs("");
6181         data.last_found = newSVpvs("");
6182         data.longest = &(data.longest_fixed);
6183         ENTER_with_name("study_chunk");
6184         SAVEFREESV(data.longest_fixed);
6185         SAVEFREESV(data.longest_float);
6186         SAVEFREESV(data.last_found);
6187         first = scan;
6188         if (!ri->regstclass) {
6189             cl_init(pRExC_state, &ch_class);
6190             data.start_class = &ch_class;
6191             stclass_flag = SCF_DO_STCLASS_AND;
6192         } else                          /* XXXX Check for BOUND? */
6193             stclass_flag = 0;
6194         data.last_closep = &last_close;
6195         
6196         minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */
6197             &data, -1, NULL, NULL,
6198             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
6199
6200
6201         CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
6202
6203
6204         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
6205              && data.last_start_min == 0 && data.last_end > 0
6206              && !RExC_seen_zerolen
6207              && !(RExC_seen & REG_SEEN_VERBARG)
6208              && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
6209             r->extflags |= RXf_CHECK_ALL;
6210         scan_commit(pRExC_state, &data,&minlen,0);
6211
6212         longest_float_length = CHR_SVLEN(data.longest_float);
6213
6214         if (! ((SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
6215                    && data.offset_fixed == data.offset_float_min
6216                    && SvCUR(data.longest_fixed) == SvCUR(data.longest_float)))
6217             && S_setup_longest (aTHX_ pRExC_state,
6218                                     data.longest_float,
6219                                     &(r->float_utf8),
6220                                     &(r->float_substr),
6221                                     &(r->float_end_shift),
6222                                     data.lookbehind_float,
6223                                     data.offset_float_min,
6224                                     data.minlen_float,
6225                                     longest_float_length,
6226                                     cBOOL(data.flags & SF_FL_BEFORE_EOL),
6227                                     cBOOL(data.flags & SF_FL_BEFORE_MEOL)))
6228         {
6229             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
6230             r->float_max_offset = data.offset_float_max;
6231             if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
6232                 r->float_max_offset -= data.lookbehind_float;
6233             SvREFCNT_inc_simple_void_NN(data.longest_float);
6234         }
6235         else {
6236             r->float_substr = r->float_utf8 = NULL;
6237             longest_float_length = 0;
6238         }
6239
6240         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
6241
6242         if (S_setup_longest (aTHX_ pRExC_state,
6243                                 data.longest_fixed,
6244                                 &(r->anchored_utf8),
6245                                 &(r->anchored_substr),
6246                                 &(r->anchored_end_shift),
6247                                 data.lookbehind_fixed,
6248                                 data.offset_fixed,
6249                                 data.minlen_fixed,
6250                                 longest_fixed_length,
6251                                 cBOOL(data.flags & SF_FIX_BEFORE_EOL),
6252                                 cBOOL(data.flags & SF_FIX_BEFORE_MEOL)))
6253         {
6254             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
6255             SvREFCNT_inc_simple_void_NN(data.longest_fixed);
6256         }
6257         else {
6258             r->anchored_substr = r->anchored_utf8 = NULL;
6259             longest_fixed_length = 0;
6260         }
6261         LEAVE_with_name("study_chunk");
6262
6263         if (ri->regstclass
6264             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
6265             ri->regstclass = NULL;
6266
6267         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
6268             && stclass_flag
6269             && ! TEST_SSC_EOS(data.start_class)
6270             && !cl_is_anything(data.start_class))
6271         {
6272             const U32 n = add_data(pRExC_state, 1, "f");
6273             OP(data.start_class) = ANYOF_SYNTHETIC;
6274
6275             Newx(RExC_rxi->data->data[n], 1,
6276                 struct regnode_charclass_class);
6277             StructCopy(data.start_class,
6278                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
6279                        struct regnode_charclass_class);
6280             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
6281             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
6282             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
6283                       regprop(r, sv, (regnode*)data.start_class);
6284                       PerlIO_printf(Perl_debug_log,
6285                                     "synthetic stclass \"%s\".\n",
6286                                     SvPVX_const(sv));});
6287         }
6288
6289         /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
6290         if (longest_fixed_length > longest_float_length) {
6291             r->check_end_shift = r->anchored_end_shift;
6292             r->check_substr = r->anchored_substr;
6293             r->check_utf8 = r->anchored_utf8;
6294             r->check_offset_min = r->check_offset_max = r->anchored_offset;
6295             if (r->extflags & RXf_ANCH_SINGLE)
6296                 r->extflags |= RXf_NOSCAN;
6297         }
6298         else {
6299             r->check_end_shift = r->float_end_shift;
6300             r->check_substr = r->float_substr;
6301             r->check_utf8 = r->float_utf8;
6302             r->check_offset_min = r->float_min_offset;
6303             r->check_offset_max = r->float_max_offset;
6304         }
6305         /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
6306            This should be changed ASAP!  */
6307         if ((r->check_substr || r->check_utf8) && !(r->extflags & RXf_ANCH_GPOS)) {
6308             r->extflags |= RXf_USE_INTUIT;
6309             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
6310                 r->extflags |= RXf_INTUIT_TAIL;
6311         }
6312         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
6313         if ( (STRLEN)minlen < longest_float_length )
6314             minlen= longest_float_length;
6315         if ( (STRLEN)minlen < longest_fixed_length )
6316             minlen= longest_fixed_length;     
6317         */
6318     }
6319     else {
6320         /* Several toplevels. Best we can is to set minlen. */
6321         I32 fake;
6322         struct regnode_charclass_class ch_class;
6323         I32 last_close = 0;
6324
6325         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
6326
6327         scan = ri->program + 1;
6328         cl_init(pRExC_state, &ch_class);
6329         data.start_class = &ch_class;
6330         data.last_closep = &last_close;
6331
6332         
6333         minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
6334             &data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
6335         
6336         CHECK_RESTUDY_GOTO_butfirst(NOOP);
6337
6338         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
6339                 = r->float_substr = r->float_utf8 = NULL;
6340
6341         if (! TEST_SSC_EOS(data.start_class)
6342             && !cl_is_anything(data.start_class))
6343         {
6344             const U32 n = add_data(pRExC_state, 1, "f");
6345             OP(data.start_class) = ANYOF_SYNTHETIC;
6346
6347             Newx(RExC_rxi->data->data[n], 1,
6348                 struct regnode_charclass_class);
6349             StructCopy(data.start_class,
6350                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
6351                        struct regnode_charclass_class);
6352             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
6353             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
6354             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
6355                       regprop(r, sv, (regnode*)data.start_class);
6356                       PerlIO_printf(Perl_debug_log,
6357                                     "synthetic stclass \"%s\".\n",
6358                                     SvPVX_const(sv));});
6359         }
6360     }
6361
6362     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
6363        the "real" pattern. */
6364     DEBUG_OPTIMISE_r({
6365         PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n",
6366                       (IV)minlen, (IV)r->minlen);
6367     });
6368     r->minlenret = minlen;
6369     if (r->minlen < minlen) 
6370         r->minlen = minlen;
6371     
6372     if (RExC_seen & REG_SEEN_GPOS)
6373         r->extflags |= RXf_GPOS_SEEN;
6374     if (RExC_seen & REG_SEEN_LOOKBEHIND)
6375         r->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the lookbehind */
6376     if (pRExC_state->num_code_blocks)
6377         r->extflags |= RXf_EVAL_SEEN;
6378     if (RExC_seen & REG_SEEN_CANY)
6379         r->extflags |= RXf_CANY_SEEN;
6380     if (RExC_seen & REG_SEEN_VERBARG)
6381     {
6382         r->intflags |= PREGf_VERBARG_SEEN;
6383         r->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */
6384     }
6385     if (RExC_seen & REG_SEEN_CUTGROUP)
6386         r->intflags |= PREGf_CUTGROUP_SEEN;
6387     if (pm_flags & PMf_USE_RE_EVAL)
6388         r->intflags |= PREGf_USE_RE_EVAL;
6389     if (RExC_paren_names)
6390         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
6391     else
6392         RXp_PAREN_NAMES(r) = NULL;
6393
6394     {
6395         regnode *first = ri->program + 1;
6396         U8 fop = OP(first);
6397         regnode *next = NEXTOPER(first);
6398         U8 nop = OP(next);
6399
6400         if (PL_regkind[fop] == NOTHING && nop == END)
6401             r->extflags |= RXf_NULL;
6402         else if (PL_regkind[fop] == BOL && nop == END)
6403             r->extflags |= RXf_START_ONLY;
6404         else if (fop == PLUS && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE && OP(regnext(first)) == END)
6405             r->extflags |= RXf_WHITE;
6406         else if ( r->extflags & RXf_SPLIT && fop == EXACT && STR_LEN(first) == 1 && *(STRING(first)) == ' ' && OP(regnext(first)) == END )
6407             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
6408
6409     }
6410 #ifdef DEBUGGING
6411     if (RExC_paren_names) {
6412         ri->name_list_idx = add_data( pRExC_state, 1, "a" );
6413         ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list);
6414     } else
6415 #endif
6416         ri->name_list_idx = 0;
6417
6418     if (RExC_recurse_count) {
6419         for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
6420             const regnode *scan = RExC_recurse[RExC_recurse_count-1];
6421             ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
6422         }
6423     }
6424     Newxz(r->offs, RExC_npar, regexp_paren_pair);
6425     /* assume we don't need to swap parens around before we match */
6426
6427     DEBUG_DUMP_r({
6428         PerlIO_printf(Perl_debug_log,"Final program:\n");
6429         regdump(r);
6430     });
6431 #ifdef RE_TRACK_PATTERN_OFFSETS
6432     DEBUG_OFFSETS_r(if (ri->u.offsets) {
6433         const U32 len = ri->u.offsets[0];
6434         U32 i;
6435         GET_RE_DEBUG_FLAGS_DECL;
6436         PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
6437         for (i = 1; i <= len; i++) {
6438             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
6439                 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
6440                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
6441             }
6442         PerlIO_printf(Perl_debug_log, "\n");
6443     });
6444 #endif
6445
6446 #ifdef USE_ITHREADS
6447     /* under ithreads the ?pat? PMf_USED flag on the pmop is simulated
6448      * by setting the regexp SV to readonly-only instead. If the
6449      * pattern's been recompiled, the USEDness should remain. */
6450     if (old_re && SvREADONLY(old_re))
6451         SvREADONLY_on(rx);
6452 #endif
6453     return rx;
6454 }
6455
6456
6457 SV*
6458 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
6459                     const U32 flags)
6460 {
6461     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
6462
6463     PERL_UNUSED_ARG(value);
6464
6465     if (flags & RXapif_FETCH) {
6466         return reg_named_buff_fetch(rx, key, flags);
6467     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
6468         Perl_croak_no_modify();
6469         return NULL;
6470     } else if (flags & RXapif_EXISTS) {
6471         return reg_named_buff_exists(rx, key, flags)
6472             ? &PL_sv_yes
6473             : &PL_sv_no;
6474     } else if (flags & RXapif_REGNAMES) {
6475         return reg_named_buff_all(rx, flags);
6476     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
6477         return reg_named_buff_scalar(rx, flags);
6478     } else {
6479         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
6480         return NULL;
6481     }
6482 }
6483
6484 SV*
6485 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
6486                          const U32 flags)
6487 {
6488     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
6489     PERL_UNUSED_ARG(lastkey);
6490
6491     if (flags & RXapif_FIRSTKEY)
6492         return reg_named_buff_firstkey(rx, flags);
6493     else if (flags & RXapif_NEXTKEY)
6494         return reg_named_buff_nextkey(rx, flags);
6495     else {
6496         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter", (int)flags);
6497         return NULL;
6498     }
6499 }
6500
6501 SV*
6502 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
6503                           const U32 flags)
6504 {
6505     AV *retarray = NULL;
6506     SV *ret;
6507     struct regexp *const rx = ReANY(r);
6508
6509     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
6510
6511     if (flags & RXapif_ALL)
6512         retarray=newAV();
6513
6514     if (rx && RXp_PAREN_NAMES(rx)) {
6515         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
6516         if (he_str) {
6517             IV i;
6518             SV* sv_dat=HeVAL(he_str);
6519             I32 *nums=(I32*)SvPVX(sv_dat);
6520             for ( i=0; i<SvIVX(sv_dat); i++ ) {
6521                 if ((I32)(rx->nparens) >= nums[i]
6522                     && rx->offs[nums[i]].start != -1
6523                     && rx->offs[nums[i]].end != -1)
6524                 {
6525                     ret = newSVpvs("");
6526                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
6527                     if (!retarray)
6528                         return ret;
6529                 } else {
6530                     if (retarray)
6531                         ret = newSVsv(&PL_sv_undef);
6532                 }
6533                 if (retarray)
6534                     av_push(retarray, ret);
6535             }
6536             if (retarray)
6537                 return newRV_noinc(MUTABLE_SV(retarray));
6538         }
6539     }
6540     return NULL;
6541 }
6542
6543 bool
6544 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
6545                            const U32 flags)
6546 {
6547     struct regexp *const rx = ReANY(r);
6548
6549     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
6550
6551     if (rx && RXp_PAREN_NAMES(rx)) {
6552         if (flags & RXapif_ALL) {
6553             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
6554         } else {
6555             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
6556             if (sv) {
6557                 SvREFCNT_dec_NN(sv);
6558                 return TRUE;
6559             } else {
6560                 return FALSE;
6561             }
6562         }
6563     } else {
6564         return FALSE;
6565     }
6566 }
6567
6568 SV*
6569 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
6570 {
6571     struct regexp *const rx = ReANY(r);
6572
6573     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
6574
6575     if ( rx && RXp_PAREN_NAMES(rx) ) {
6576         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
6577
6578         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
6579     } else {
6580         return FALSE;
6581     }
6582 }
6583
6584 SV*
6585 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
6586 {
6587     struct regexp *const rx = ReANY(r);
6588     GET_RE_DEBUG_FLAGS_DECL;
6589
6590     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
6591
6592     if (rx && RXp_PAREN_NAMES(rx)) {
6593         HV *hv = RXp_PAREN_NAMES(rx);
6594         HE *temphe;
6595         while ( (temphe = hv_iternext_flags(hv,0)) ) {
6596             IV i;
6597             IV parno = 0;
6598             SV* sv_dat = HeVAL(temphe);
6599             I32 *nums = (I32*)SvPVX(sv_dat);
6600             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
6601                 if ((I32)(rx->lastparen) >= nums[i] &&
6602                     rx->offs[nums[i]].start != -1 &&
6603                     rx->offs[nums[i]].end != -1)
6604                 {
6605                     parno = nums[i];
6606                     break;
6607                 }
6608             }
6609             if (parno || flags & RXapif_ALL) {
6610                 return newSVhek(HeKEY_hek(temphe));
6611             }
6612         }
6613     }
6614     return NULL;
6615 }
6616
6617 SV*
6618 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
6619 {
6620     SV *ret;
6621     AV *av;
6622     I32 length;
6623     struct regexp *const rx = ReANY(r);
6624
6625     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
6626
6627     if (rx && RXp_PAREN_NAMES(rx)) {
6628         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
6629             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
6630         } else if (flags & RXapif_ONE) {
6631             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
6632             av = MUTABLE_AV(SvRV(ret));
6633             length = av_len(av);
6634             SvREFCNT_dec_NN(ret);
6635             return newSViv(length + 1);
6636         } else {
6637             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", (int)flags);
6638             return NULL;
6639         }
6640     }
6641     return &PL_sv_undef;
6642 }
6643
6644 SV*
6645 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
6646 {
6647     struct regexp *const rx = ReANY(r);
6648     AV *av = newAV();
6649
6650     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
6651
6652     if (rx && RXp_PAREN_NAMES(rx)) {
6653         HV *hv= RXp_PAREN_NAMES(rx);
6654         HE *temphe;
6655         (void)hv_iterinit(hv);
6656         while ( (temphe = hv_iternext_flags(hv,0)) ) {
6657             IV i;
6658             IV parno = 0;
6659             SV* sv_dat = HeVAL(temphe);
6660             I32 *nums = (I32*)SvPVX(sv_dat);
6661             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
6662                 if ((I32)(rx->lastparen) >= nums[i] &&
6663                     rx->offs[nums[i]].start != -1 &&
6664                     rx->offs[nums[i]].end != -1)
6665                 {
6666                     parno = nums[i];
6667                     break;
6668                 }
6669             }
6670             if (parno || flags & RXapif_ALL) {
6671                 av_push(av, newSVhek(HeKEY_hek(temphe)));
6672             }
6673         }
6674     }
6675
6676     return newRV_noinc(MUTABLE_SV(av));
6677 }
6678
6679 void
6680 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
6681                              SV * const sv)
6682 {
6683     struct regexp *const rx = ReANY(r);
6684     char *s = NULL;
6685     I32 i = 0;
6686     I32 s1, t1;
6687     I32 n = paren;
6688
6689     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
6690         
6691     if (      n == RX_BUFF_IDX_CARET_PREMATCH
6692            || n == RX_BUFF_IDX_CARET_FULLMATCH
6693            || n == RX_BUFF_IDX_CARET_POSTMATCH
6694        )
6695     {
6696         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
6697         if (!keepcopy) {
6698             /* on something like
6699              *    $r = qr/.../;
6700              *    /$qr/p;
6701              * the KEEPCOPY is set on the PMOP rather than the regex */
6702             if (PL_curpm && r == PM_GETRE(PL_curpm))
6703                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
6704         }
6705         if (!keepcopy)
6706             goto ret_undef;
6707     }
6708
6709     if (!rx->subbeg)
6710         goto ret_undef;
6711
6712     if (n == RX_BUFF_IDX_CARET_FULLMATCH)
6713         /* no need to distinguish between them any more */
6714         n = RX_BUFF_IDX_FULLMATCH;
6715
6716     if ((n == RX_BUFF_IDX_PREMATCH || n == RX_BUFF_IDX_CARET_PREMATCH)
6717         && rx->offs[0].start != -1)
6718     {
6719         /* $`, ${^PREMATCH} */
6720         i = rx->offs[0].start;
6721         s = rx->subbeg;
6722     }
6723     else 
6724     if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
6725         && rx->offs[0].end != -1)
6726     {
6727         /* $', ${^POSTMATCH} */
6728         s = rx->subbeg - rx->suboffset + rx->offs[0].end;
6729         i = rx->sublen + rx->suboffset - rx->offs[0].end;
6730     } 
6731     else
6732     if ( 0 <= n && n <= (I32)rx->nparens &&
6733         (s1 = rx->offs[n].start) != -1 &&
6734         (t1 = rx->offs[n].end) != -1)
6735     {
6736         /* $&, ${^MATCH},  $1 ... */
6737         i = t1 - s1;
6738         s = rx->subbeg + s1 - rx->suboffset;
6739     } else {
6740         goto ret_undef;
6741     }          
6742
6743     assert(s >= rx->subbeg);
6744     assert(rx->sublen >= (s - rx->subbeg) + i );
6745     if (i >= 0) {
6746 #if NO_TAINT_SUPPORT
6747         sv_setpvn(sv, s, i);
6748 #else
6749         const int oldtainted = TAINT_get;
6750         TAINT_NOT;
6751         sv_setpvn(sv, s, i);
6752         TAINT_set(oldtainted);
6753 #endif
6754         if ( (rx->extflags & RXf_CANY_SEEN)
6755             ? (RXp_MATCH_UTF8(rx)
6756                         && (!i || is_utf8_string((U8*)s, i)))
6757             : (RXp_MATCH_UTF8(rx)) )
6758         {
6759             SvUTF8_on(sv);
6760         }
6761         else
6762             SvUTF8_off(sv);
6763         if (TAINTING_get) {
6764             if (RXp_MATCH_TAINTED(rx)) {
6765                 if (SvTYPE(sv) >= SVt_PVMG) {
6766                     MAGIC* const mg = SvMAGIC(sv);
6767                     MAGIC* mgt;
6768                     TAINT;
6769                     SvMAGIC_set(sv, mg->mg_moremagic);
6770                     SvTAINT(sv);
6771                     if ((mgt = SvMAGIC(sv))) {
6772                         mg->mg_moremagic = mgt;
6773                         SvMAGIC_set(sv, mg);
6774                     }
6775                 } else {
6776                     TAINT;
6777                     SvTAINT(sv);
6778                 }
6779             } else 
6780                 SvTAINTED_off(sv);
6781         }
6782     } else {
6783       ret_undef:
6784         sv_setsv(sv,&PL_sv_undef);
6785         return;
6786     }
6787 }
6788
6789 void
6790 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
6791                                                          SV const * const value)
6792 {
6793     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
6794
6795     PERL_UNUSED_ARG(rx);
6796     PERL_UNUSED_ARG(paren);
6797     PERL_UNUSED_ARG(value);
6798
6799     if (!PL_localizing)
6800         Perl_croak_no_modify();
6801 }
6802
6803 I32
6804 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
6805                               const I32 paren)
6806 {
6807     struct regexp *const rx = ReANY(r);
6808     I32 i;
6809     I32 s1, t1;
6810
6811     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
6812
6813     if (   paren == RX_BUFF_IDX_CARET_PREMATCH
6814         || paren == RX_BUFF_IDX_CARET_FULLMATCH
6815         || paren == RX_BUFF_IDX_CARET_POSTMATCH
6816     )
6817     {
6818         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
6819         if (!keepcopy) {
6820             /* on something like
6821              *    $r = qr/.../;
6822              *    /$qr/p;
6823              * the KEEPCOPY is set on the PMOP rather than the regex */
6824             if (PL_curpm && r == PM_GETRE(PL_curpm))
6825                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
6826         }
6827         if (!keepcopy)
6828             goto warn_undef;
6829     }
6830
6831     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
6832     switch (paren) {
6833       case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */
6834       case RX_BUFF_IDX_PREMATCH:       /* $` */
6835         if (rx->offs[0].start != -1) {
6836                         i = rx->offs[0].start;
6837                         if (i > 0) {
6838                                 s1 = 0;
6839                                 t1 = i;
6840                                 goto getlen;
6841                         }
6842             }
6843         return 0;
6844
6845       case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */
6846       case RX_BUFF_IDX_POSTMATCH:       /* $' */
6847             if (rx->offs[0].end != -1) {
6848                         i = rx->sublen - rx->offs[0].end;
6849                         if (i > 0) {
6850                                 s1 = rx->offs[0].end;
6851                                 t1 = rx->sublen;
6852                                 goto getlen;
6853                         }
6854             }
6855         return 0;
6856
6857       default: /* $& / ${^MATCH}, $1, $2, ... */
6858             if (paren <= (I32)rx->nparens &&
6859             (s1 = rx->offs[paren].start) != -1 &&
6860             (t1 = rx->offs[paren].end) != -1)
6861             {
6862             i = t1 - s1;
6863             goto getlen;
6864         } else {
6865           warn_undef:
6866             if (ckWARN(WARN_UNINITIALIZED))
6867                 report_uninit((const SV *)sv);
6868             return 0;
6869         }
6870     }
6871   getlen:
6872     if (i > 0 && RXp_MATCH_UTF8(rx)) {
6873         const char * const s = rx->subbeg - rx->suboffset + s1;
6874         const U8 *ep;
6875         STRLEN el;
6876
6877         i = t1 - s1;
6878         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
6879                         i = el;
6880     }
6881     return i;
6882 }
6883
6884 SV*
6885 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
6886 {
6887     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
6888         PERL_UNUSED_ARG(rx);
6889         if (0)
6890             return NULL;
6891         else
6892             return newSVpvs("Regexp");
6893 }
6894
6895 /* Scans the name of a named buffer from the pattern.
6896  * If flags is REG_RSN_RETURN_NULL returns null.
6897  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
6898  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
6899  * to the parsed name as looked up in the RExC_paren_names hash.
6900  * If there is an error throws a vFAIL().. type exception.
6901  */
6902
6903 #define REG_RSN_RETURN_NULL    0
6904 #define REG_RSN_RETURN_NAME    1
6905 #define REG_RSN_RETURN_DATA    2
6906
6907 STATIC SV*
6908 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
6909 {
6910     char *name_start = RExC_parse;
6911
6912     PERL_ARGS_ASSERT_REG_SCAN_NAME;
6913
6914     if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
6915          /* skip IDFIRST by using do...while */
6916         if (UTF)
6917             do {
6918                 RExC_parse += UTF8SKIP(RExC_parse);
6919             } while (isWORDCHAR_utf8((U8*)RExC_parse));
6920         else
6921             do {
6922                 RExC_parse++;
6923             } while (isWORDCHAR(*RExC_parse));
6924     } else {
6925         RExC_parse++; /* so the <- from the vFAIL is after the offending character */
6926         vFAIL("Group name must start with a non-digit word character");
6927     }
6928     if ( flags ) {
6929         SV* sv_name
6930             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
6931                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
6932         if ( flags == REG_RSN_RETURN_NAME)
6933             return sv_name;
6934         else if (flags==REG_RSN_RETURN_DATA) {
6935             HE *he_str = NULL;
6936             SV *sv_dat = NULL;
6937             if ( ! sv_name )      /* should not happen*/
6938                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
6939             if (RExC_paren_names)
6940                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
6941             if ( he_str )
6942                 sv_dat = HeVAL(he_str);
6943             if ( ! sv_dat )
6944                 vFAIL("Reference to nonexistent named group");
6945             return sv_dat;
6946         }
6947         else {
6948             Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
6949                        (unsigned long) flags);
6950         }
6951         assert(0); /* NOT REACHED */
6952     }
6953     return NULL;
6954 }
6955
6956 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
6957     int rem=(int)(RExC_end - RExC_parse);                       \
6958     int cut;                                                    \
6959     int num;                                                    \
6960     int iscut=0;                                                \
6961     if (rem>10) {                                               \
6962         rem=10;                                                 \
6963         iscut=1;                                                \
6964     }                                                           \
6965     cut=10-rem;                                                 \
6966     if (RExC_lastparse!=RExC_parse)                             \
6967         PerlIO_printf(Perl_debug_log," >%.*s%-*s",              \
6968             rem, RExC_parse,                                    \
6969             cut + 4,                                            \
6970             iscut ? "..." : "<"                                 \
6971         );                                                      \
6972     else                                                        \
6973         PerlIO_printf(Perl_debug_log,"%16s","");                \
6974                                                                 \
6975     if (SIZE_ONLY)                                              \
6976        num = RExC_size + 1;                                     \
6977     else                                                        \
6978        num=REG_NODE_NUM(RExC_emit);                             \
6979     if (RExC_lastnum!=num)                                      \
6980        PerlIO_printf(Perl_debug_log,"|%4d",num);                \
6981     else                                                        \
6982        PerlIO_printf(Perl_debug_log,"|%4s","");                 \
6983     PerlIO_printf(Perl_debug_log,"|%*s%-4s",                    \
6984         (int)((depth*2)), "",                                   \
6985         (funcname)                                              \
6986     );                                                          \
6987     RExC_lastnum=num;                                           \
6988     RExC_lastparse=RExC_parse;                                  \
6989 })
6990
6991
6992
6993 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
6994     DEBUG_PARSE_MSG((funcname));                            \
6995     PerlIO_printf(Perl_debug_log,"%4s","\n");               \
6996 })
6997 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({           \
6998     DEBUG_PARSE_MSG((funcname));                            \
6999     PerlIO_printf(Perl_debug_log,fmt "\n",args);               \
7000 })
7001
7002 /* This section of code defines the inversion list object and its methods.  The
7003  * interfaces are highly subject to change, so as much as possible is static to
7004  * this file.  An inversion list is here implemented as a malloc'd C UV array
7005  * with some added info that is placed as UVs at the beginning in a header
7006  * portion.  An inversion list for Unicode is an array of code points, sorted
7007  * by ordinal number.  The zeroth element is the first code point in the list.
7008  * The 1th element is the first element beyond that not in the list.  In other
7009  * words, the first range is
7010  *  invlist[0]..(invlist[1]-1)
7011  * The other ranges follow.  Thus every element whose index is divisible by two
7012  * marks the beginning of a range that is in the list, and every element not
7013  * divisible by two marks the beginning of a range not in the list.  A single
7014  * element inversion list that contains the single code point N generally
7015  * consists of two elements
7016  *  invlist[0] == N
7017  *  invlist[1] == N+1
7018  * (The exception is when N is the highest representable value on the
7019  * machine, in which case the list containing just it would be a single
7020  * element, itself.  By extension, if the last range in the list extends to
7021  * infinity, then the first element of that range will be in the inversion list
7022  * at a position that is divisible by two, and is the final element in the
7023  * list.)
7024  * Taking the complement (inverting) an inversion list is quite simple, if the
7025  * first element is 0, remove it; otherwise add a 0 element at the beginning.
7026  * This implementation reserves an element at the beginning of each inversion
7027  * list to contain 0 when the list contains 0, and contains 1 otherwise.  The
7028  * actual beginning of the list is either that element if 0, or the next one if
7029  * 1.
7030  *
7031  * More about inversion lists can be found in "Unicode Demystified"
7032  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
7033  * More will be coming when functionality is added later.
7034  *
7035  * The inversion list data structure is currently implemented as an SV pointing
7036  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
7037  * array of UV whose memory management is automatically handled by the existing
7038  * facilities for SV's.
7039  *
7040  * Some of the methods should always be private to the implementation, and some
7041  * should eventually be made public */
7042
7043 /* The header definitions are in F<inline_invlist.c> */
7044 #define TO_INTERNAL_SIZE(x) (((x) + HEADER_LENGTH) * sizeof(UV))
7045 #define FROM_INTERNAL_SIZE(x) (((x)/ sizeof(UV)) - HEADER_LENGTH)
7046
7047 #define INVLIST_INITIAL_LEN 10
7048
7049 PERL_STATIC_INLINE UV*
7050 S__invlist_array_init(pTHX_ SV* const invlist, const bool will_have_0)
7051 {
7052     /* Returns a pointer to the first element in the inversion list's array.
7053      * This is called upon initialization of an inversion list.  Where the
7054      * array begins depends on whether the list has the code point U+0000
7055      * in it or not.  The other parameter tells it whether the code that
7056      * follows this call is about to put a 0 in the inversion list or not.
7057      * The first element is either the element with 0, if 0, or the next one,
7058      * if 1 */
7059
7060     UV* zero = get_invlist_zero_addr(invlist);
7061
7062     PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
7063
7064     /* Must be empty */
7065     assert(! *_get_invlist_len_addr(invlist));
7066
7067     /* 1^1 = 0; 1^0 = 1 */
7068     *zero = 1 ^ will_have_0;
7069     return zero + *zero;
7070 }
7071
7072 PERL_STATIC_INLINE UV*
7073 S_invlist_array(pTHX_ SV* const invlist)
7074 {
7075     /* Returns the pointer to the inversion list's array.  Every time the
7076      * length changes, this needs to be called in case malloc or realloc moved
7077      * it */
7078
7079     PERL_ARGS_ASSERT_INVLIST_ARRAY;
7080
7081     /* Must not be empty.  If these fail, you probably didn't check for <len>
7082      * being non-zero before trying to get the array */
7083     assert(*_get_invlist_len_addr(invlist));
7084     assert(*get_invlist_zero_addr(invlist) == 0
7085            || *get_invlist_zero_addr(invlist) == 1);
7086
7087     /* The array begins either at the element reserved for zero if the
7088      * list contains 0 (that element will be set to 0), or otherwise the next
7089      * element (in which case the reserved element will be set to 1). */
7090     return (UV *) (get_invlist_zero_addr(invlist)
7091                    + *get_invlist_zero_addr(invlist));
7092 }
7093
7094 PERL_STATIC_INLINE void
7095 S_invlist_set_len(pTHX_ SV* const invlist, const UV len)
7096 {
7097     /* Sets the current number of elements stored in the inversion list */
7098
7099     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
7100
7101     *_get_invlist_len_addr(invlist) = len;
7102
7103     assert(len <= SvLEN(invlist));
7104
7105     SvCUR_set(invlist, TO_INTERNAL_SIZE(len));
7106     /* If the list contains U+0000, that element is part of the header,
7107      * and should not be counted as part of the array.  It will contain
7108      * 0 in that case, and 1 otherwise.  So we could flop 0=>1, 1=>0 and
7109      * subtract:
7110      *  SvCUR_set(invlist,
7111      *            TO_INTERNAL_SIZE(len
7112      *                             - (*get_invlist_zero_addr(inv_list) ^ 1)));
7113      * But, this is only valid if len is not 0.  The consequences of not doing
7114      * this is that the memory allocation code may think that 1 more UV is
7115      * being used than actually is, and so might do an unnecessary grow.  That
7116      * seems worth not bothering to make this the precise amount.
7117      *
7118      * Note that when inverting, SvCUR shouldn't change */
7119 }
7120
7121 PERL_STATIC_INLINE IV*
7122 S_get_invlist_previous_index_addr(pTHX_ SV* invlist)
7123 {
7124     /* Return the address of the UV that is reserved to hold the cached index
7125      * */
7126
7127     PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR;
7128
7129     return (IV *) (SvPVX(invlist) + (INVLIST_PREVIOUS_INDEX_OFFSET * sizeof (UV)));
7130 }
7131
7132 PERL_STATIC_INLINE IV
7133 S_invlist_previous_index(pTHX_ SV* const invlist)
7134 {
7135     /* Returns cached index of previous search */
7136
7137     PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX;
7138
7139     return *get_invlist_previous_index_addr(invlist);
7140 }
7141
7142 PERL_STATIC_INLINE void
7143 S_invlist_set_previous_index(pTHX_ SV* const invlist, const IV index)
7144 {
7145     /* Caches <index> for later retrieval */
7146
7147     PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX;
7148
7149     assert(index == 0 || index < (int) _invlist_len(invlist));
7150
7151     *get_invlist_previous_index_addr(invlist) = index;
7152 }
7153
7154 PERL_STATIC_INLINE UV
7155 S_invlist_max(pTHX_ SV* const invlist)
7156 {
7157     /* Returns the maximum number of elements storable in the inversion list's
7158      * array, without having to realloc() */
7159
7160     PERL_ARGS_ASSERT_INVLIST_MAX;
7161
7162     return SvLEN(invlist) == 0  /* This happens under _new_invlist_C_array */
7163            ? _invlist_len(invlist)
7164            : FROM_INTERNAL_SIZE(SvLEN(invlist));
7165 }
7166
7167 PERL_STATIC_INLINE UV*
7168 S_get_invlist_zero_addr(pTHX_ SV* invlist)
7169 {
7170     /* Return the address of the UV that is reserved to hold 0 if the inversion
7171      * list contains 0.  This has to be the last element of the heading, as the
7172      * list proper starts with either it if 0, or the next element if not.
7173      * (But we force it to contain either 0 or 1) */
7174
7175     PERL_ARGS_ASSERT_GET_INVLIST_ZERO_ADDR;
7176
7177     return (UV *) (SvPVX(invlist) + (INVLIST_ZERO_OFFSET * sizeof (UV)));
7178 }
7179
7180 #ifndef PERL_IN_XSUB_RE
7181 SV*
7182 Perl__new_invlist(pTHX_ IV initial_size)
7183 {
7184
7185     /* Return a pointer to a newly constructed inversion list, with enough
7186      * space to store 'initial_size' elements.  If that number is negative, a
7187      * system default is used instead */
7188
7189     SV* new_list;
7190
7191     if (initial_size < 0) {
7192         initial_size = INVLIST_INITIAL_LEN;
7193     }
7194
7195     /* Allocate the initial space */
7196     new_list = newSV(TO_INTERNAL_SIZE(initial_size));
7197     invlist_set_len(new_list, 0);
7198
7199     /* Force iterinit() to be used to get iteration to work */
7200     *get_invlist_iter_addr(new_list) = UV_MAX;
7201
7202     /* This should force a segfault if a method doesn't initialize this
7203      * properly */
7204     *get_invlist_zero_addr(new_list) = UV_MAX;
7205
7206     *get_invlist_previous_index_addr(new_list) = 0;
7207     *get_invlist_version_id_addr(new_list) = INVLIST_VERSION_ID;
7208 #if HEADER_LENGTH != 5
7209 #   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
7210 #endif
7211
7212     return new_list;
7213 }
7214 #endif
7215
7216 STATIC SV*
7217 S__new_invlist_C_array(pTHX_ UV* list)
7218 {
7219     /* Return a pointer to a newly constructed inversion list, initialized to
7220      * point to <list>, which has to be in the exact correct inversion list
7221      * form, including internal fields.  Thus this is a dangerous routine that
7222      * should not be used in the wrong hands */
7223
7224     SV* invlist = newSV_type(SVt_PV);
7225
7226     PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
7227
7228     SvPV_set(invlist, (char *) list);
7229     SvLEN_set(invlist, 0);  /* Means we own the contents, and the system
7230                                shouldn't touch it */
7231     SvCUR_set(invlist, TO_INTERNAL_SIZE(_invlist_len(invlist)));
7232
7233     if (*get_invlist_version_id_addr(invlist) != INVLIST_VERSION_ID) {
7234         Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
7235     }
7236
7237     /* Initialize the iteration pointer.
7238      * XXX This could be done at compile time in charclass_invlists.h, but I
7239      * (khw) am not confident that the suffixes for specifying the C constant
7240      * UV_MAX are portable, e.g.  'ull' on a 32 bit machine that is configured
7241      * to use 64 bits; might need a Configure probe */
7242     invlist_iterfinish(invlist);
7243
7244     return invlist;
7245 }
7246
7247 STATIC void
7248 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
7249 {
7250     /* Grow the maximum size of an inversion list */
7251
7252     PERL_ARGS_ASSERT_INVLIST_EXTEND;
7253
7254     SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max));
7255 }
7256
7257 PERL_STATIC_INLINE void
7258 S_invlist_trim(pTHX_ SV* const invlist)
7259 {
7260     PERL_ARGS_ASSERT_INVLIST_TRIM;
7261
7262     /* Change the length of the inversion list to how many entries it currently
7263      * has */
7264
7265     SvPV_shrink_to_cur((SV *) invlist);
7266 }
7267
7268 #define _invlist_union_complement_2nd(a, b, output) _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
7269
7270 STATIC void
7271 S__append_range_to_invlist(pTHX_ SV* const invlist, const UV start, const UV end)
7272 {
7273    /* Subject to change or removal.  Append the range from 'start' to 'end' at
7274     * the end of the inversion list.  The range must be above any existing
7275     * ones. */
7276
7277     UV* array;
7278     UV max = invlist_max(invlist);
7279     UV len = _invlist_len(invlist);
7280
7281     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
7282
7283     if (len == 0) { /* Empty lists must be initialized */
7284         array = _invlist_array_init(invlist, start == 0);
7285     }
7286     else {
7287         /* Here, the existing list is non-empty. The current max entry in the
7288          * list is generally the first value not in the set, except when the
7289          * set extends to the end of permissible values, in which case it is
7290          * the first entry in that final set, and so this call is an attempt to
7291          * append out-of-order */
7292
7293         UV final_element = len - 1;
7294         array = invlist_array(invlist);
7295         if (array[final_element] > start
7296             || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
7297         {
7298             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",
7299                        array[final_element], start,
7300                        ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
7301         }
7302
7303         /* Here, it is a legal append.  If the new range begins with the first
7304          * value not in the set, it is extending the set, so the new first
7305          * value not in the set is one greater than the newly extended range.
7306          * */
7307         if (array[final_element] == start) {
7308             if (end != UV_MAX) {
7309                 array[final_element] = end + 1;
7310             }
7311             else {
7312                 /* But if the end is the maximum representable on the machine,
7313                  * just let the range that this would extend to have no end */
7314                 invlist_set_len(invlist, len - 1);
7315             }
7316             return;
7317         }
7318     }
7319
7320     /* Here the new range doesn't extend any existing set.  Add it */
7321
7322     len += 2;   /* Includes an element each for the start and end of range */
7323
7324     /* If overflows the existing space, extend, which may cause the array to be
7325      * moved */
7326     if (max < len) {
7327         invlist_extend(invlist, len);
7328         invlist_set_len(invlist, len);  /* Have to set len here to avoid assert
7329                                            failure in invlist_array() */
7330         array = invlist_array(invlist);
7331     }
7332     else {
7333         invlist_set_len(invlist, len);
7334     }
7335
7336     /* The next item on the list starts the range, the one after that is
7337      * one past the new range.  */
7338     array[len - 2] = start;
7339     if (end != UV_MAX) {
7340         array[len - 1] = end + 1;
7341     }
7342     else {
7343         /* But if the end is the maximum representable on the machine, just let
7344          * the range have no end */
7345         invlist_set_len(invlist, len - 1);
7346     }
7347 }
7348
7349 #ifndef PERL_IN_XSUB_RE
7350
7351 IV
7352 Perl__invlist_search(pTHX_ SV* const invlist, const UV cp)
7353 {
7354     /* Searches the inversion list for the entry that contains the input code
7355      * point <cp>.  If <cp> is not in the list, -1 is returned.  Otherwise, the
7356      * return value is the index into the list's array of the range that
7357      * contains <cp> */
7358
7359     IV low = 0;
7360     IV mid;
7361     IV high = _invlist_len(invlist);
7362     const IV highest_element = high - 1;
7363     const UV* array;
7364
7365     PERL_ARGS_ASSERT__INVLIST_SEARCH;
7366
7367     /* If list is empty, return failure. */
7368     if (high == 0) {
7369         return -1;
7370     }
7371
7372     /* (We can't get the array unless we know the list is non-empty) */
7373     array = invlist_array(invlist);
7374
7375     mid = invlist_previous_index(invlist);
7376     assert(mid >=0 && mid <= highest_element);
7377
7378     /* <mid> contains the cache of the result of the previous call to this
7379      * function (0 the first time).  See if this call is for the same result,
7380      * or if it is for mid-1.  This is under the theory that calls to this
7381      * function will often be for related code points that are near each other.
7382      * And benchmarks show that caching gives better results.  We also test
7383      * here if the code point is within the bounds of the list.  These tests
7384      * replace others that would have had to be made anyway to make sure that
7385      * the array bounds were not exceeded, and these give us extra information
7386      * at the same time */
7387     if (cp >= array[mid]) {
7388         if (cp >= array[highest_element]) {
7389             return highest_element;
7390         }
7391
7392         /* Here, array[mid] <= cp < array[highest_element].  This means that
7393          * the final element is not the answer, so can exclude it; it also
7394          * means that <mid> is not the final element, so can refer to 'mid + 1'
7395          * safely */
7396         if (cp < array[mid + 1]) {
7397             return mid;
7398         }
7399         high--;
7400         low = mid + 1;
7401     }
7402     else { /* cp < aray[mid] */
7403         if (cp < array[0]) { /* Fail if outside the array */
7404             return -1;
7405         }
7406         high = mid;
7407         if (cp >= array[mid - 1]) {
7408             goto found_entry;
7409         }
7410     }
7411
7412     /* Binary search.  What we are looking for is <i> such that
7413      *  array[i] <= cp < array[i+1]
7414      * The loop below converges on the i+1.  Note that there may not be an
7415      * (i+1)th element in the array, and things work nonetheless */
7416     while (low < high) {
7417         mid = (low + high) / 2;
7418         assert(mid <= highest_element);
7419         if (array[mid] <= cp) { /* cp >= array[mid] */
7420             low = mid + 1;
7421
7422             /* We could do this extra test to exit the loop early.
7423             if (cp < array[low]) {
7424                 return mid;
7425             }
7426             */
7427         }
7428         else { /* cp < array[mid] */
7429             high = mid;
7430         }
7431     }
7432
7433   found_entry:
7434     high--;
7435     invlist_set_previous_index(invlist, high);
7436     return high;
7437 }
7438
7439 void
7440 Perl__invlist_populate_swatch(pTHX_ SV* const invlist, const UV start, const UV end, U8* swatch)
7441 {
7442     /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
7443      * but is used when the swash has an inversion list.  This makes this much
7444      * faster, as it uses a binary search instead of a linear one.  This is
7445      * intimately tied to that function, and perhaps should be in utf8.c,
7446      * except it is intimately tied to inversion lists as well.  It assumes
7447      * that <swatch> is all 0's on input */
7448
7449     UV current = start;
7450     const IV len = _invlist_len(invlist);
7451     IV i;
7452     const UV * array;
7453
7454     PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
7455
7456     if (len == 0) { /* Empty inversion list */
7457         return;
7458     }
7459
7460     array = invlist_array(invlist);
7461
7462     /* Find which element it is */
7463     i = _invlist_search(invlist, start);
7464
7465     /* We populate from <start> to <end> */
7466     while (current < end) {
7467         UV upper;
7468
7469         /* The inversion list gives the results for every possible code point
7470          * after the first one in the list.  Only those ranges whose index is
7471          * even are ones that the inversion list matches.  For the odd ones,
7472          * and if the initial code point is not in the list, we have to skip
7473          * forward to the next element */
7474         if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
7475             i++;
7476             if (i >= len) { /* Finished if beyond the end of the array */
7477                 return;
7478             }
7479             current = array[i];
7480             if (current >= end) {   /* Finished if beyond the end of what we
7481                                        are populating */
7482                 if (LIKELY(end < UV_MAX)) {
7483                     return;
7484                 }
7485
7486                 /* We get here when the upper bound is the maximum
7487                  * representable on the machine, and we are looking for just
7488                  * that code point.  Have to special case it */
7489                 i = len;
7490                 goto join_end_of_list;
7491             }
7492         }
7493         assert(current >= start);
7494
7495         /* The current range ends one below the next one, except don't go past
7496          * <end> */
7497         i++;
7498         upper = (i < len && array[i] < end) ? array[i] : end;
7499
7500         /* Here we are in a range that matches.  Populate a bit in the 3-bit U8
7501          * for each code point in it */
7502         for (; current < upper; current++) {
7503             const STRLEN offset = (STRLEN)(current - start);
7504             swatch[offset >> 3] |= 1 << (offset & 7);
7505         }
7506
7507     join_end_of_list:
7508
7509         /* Quit if at the end of the list */
7510         if (i >= len) {
7511
7512             /* But first, have to deal with the highest possible code point on
7513              * the platform.  The previous code assumes that <end> is one
7514              * beyond where we want to populate, but that is impossible at the
7515              * platform's infinity, so have to handle it specially */
7516             if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
7517             {
7518                 const STRLEN offset = (STRLEN)(end - start);
7519                 swatch[offset >> 3] |= 1 << (offset & 7);
7520             }
7521             return;
7522         }
7523
7524         /* Advance to the next range, which will be for code points not in the
7525          * inversion list */
7526         current = array[i];
7527     }
7528
7529     return;
7530 }
7531
7532 void
7533 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** output)
7534 {
7535     /* Take the union of two inversion lists and point <output> to it.  *output
7536      * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
7537      * the reference count to that list will be decremented.  The first list,
7538      * <a>, may be NULL, in which case a copy of the second list is returned.
7539      * If <complement_b> is TRUE, the union is taken of the complement
7540      * (inversion) of <b> instead of b itself.
7541      *
7542      * The basis for this comes from "Unicode Demystified" Chapter 13 by
7543      * Richard Gillam, published by Addison-Wesley, and explained at some
7544      * length there.  The preface says to incorporate its examples into your
7545      * code at your own risk.
7546      *
7547      * The algorithm is like a merge sort.
7548      *
7549      * XXX A potential performance improvement is to keep track as we go along
7550      * if only one of the inputs contributes to the result, meaning the other
7551      * is a subset of that one.  In that case, we can skip the final copy and
7552      * return the larger of the input lists, but then outside code might need
7553      * to keep track of whether to free the input list or not */
7554
7555     UV* array_a;    /* a's array */
7556     UV* array_b;
7557     UV len_a;       /* length of a's array */
7558     UV len_b;
7559
7560     SV* u;                      /* the resulting union */
7561     UV* array_u;
7562     UV len_u;
7563
7564     UV i_a = 0;             /* current index into a's array */
7565     UV i_b = 0;
7566     UV i_u = 0;
7567
7568     /* running count, as explained in the algorithm source book; items are
7569      * stopped accumulating and are output when the count changes to/from 0.
7570      * The count is incremented when we start a range that's in the set, and
7571      * decremented when we start a range that's not in the set.  So its range
7572      * is 0 to 2.  Only when the count is zero is something not in the set.
7573      */
7574     UV count = 0;
7575
7576     PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
7577     assert(a != b);
7578
7579     /* If either one is empty, the union is the other one */
7580     if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
7581         if (*output == a) {
7582             if (a != NULL) {
7583                 SvREFCNT_dec_NN(a);
7584             }
7585         }
7586         if (*output != b) {
7587             *output = invlist_clone(b);
7588             if (complement_b) {
7589                 _invlist_invert(*output);
7590             }
7591         } /* else *output already = b; */
7592         return;
7593     }
7594     else if ((len_b = _invlist_len(b)) == 0) {
7595         if (*output == b) {
7596             SvREFCNT_dec_NN(b);
7597         }
7598
7599         /* The complement of an empty list is a list that has everything in it,
7600          * so the union with <a> includes everything too */
7601         if (complement_b) {
7602             if (a == *output) {
7603                 SvREFCNT_dec_NN(a);
7604             }
7605             *output = _new_invlist(1);
7606             _append_range_to_invlist(*output, 0, UV_MAX);
7607         }
7608         else if (*output != a) {
7609             *output = invlist_clone(a);
7610         }
7611         /* else *output already = a; */
7612         return;
7613     }
7614
7615     /* Here both lists exist and are non-empty */
7616     array_a = invlist_array(a);
7617     array_b = invlist_array(b);
7618
7619     /* If are to take the union of 'a' with the complement of b, set it
7620      * up so are looking at b's complement. */
7621     if (complement_b) {
7622
7623         /* To complement, we invert: if the first element is 0, remove it.  To
7624          * do this, we just pretend the array starts one later, and clear the
7625          * flag as we don't have to do anything else later */
7626         if (array_b[0] == 0) {
7627             array_b++;
7628             len_b--;
7629             complement_b = FALSE;
7630         }
7631         else {
7632
7633             /* But if the first element is not zero, we unshift a 0 before the
7634              * array.  The data structure reserves a space for that 0 (which
7635              * should be a '1' right now), so physical shifting is unneeded,
7636              * but temporarily change that element to 0.  Before exiting the
7637              * routine, we must restore the element to '1' */
7638             array_b--;
7639             len_b++;
7640             array_b[0] = 0;
7641         }
7642     }
7643
7644     /* Size the union for the worst case: that the sets are completely
7645      * disjoint */
7646     u = _new_invlist(len_a + len_b);
7647
7648     /* Will contain U+0000 if either component does */
7649     array_u = _invlist_array_init(u, (len_a > 0 && array_a[0] == 0)
7650                                       || (len_b > 0 && array_b[0] == 0));
7651
7652     /* Go through each list item by item, stopping when exhausted one of
7653      * them */
7654     while (i_a < len_a && i_b < len_b) {
7655         UV cp;      /* The element to potentially add to the union's array */
7656         bool cp_in_set;   /* is it in the the input list's set or not */
7657
7658         /* We need to take one or the other of the two inputs for the union.
7659          * Since we are merging two sorted lists, we take the smaller of the
7660          * next items.  In case of a tie, we take the one that is in its set
7661          * first.  If we took one not in the set first, it would decrement the
7662          * count, possibly to 0 which would cause it to be output as ending the
7663          * range, and the next time through we would take the same number, and
7664          * output it again as beginning the next range.  By doing it the
7665          * opposite way, there is no possibility that the count will be
7666          * momentarily decremented to 0, and thus the two adjoining ranges will
7667          * be seamlessly merged.  (In a tie and both are in the set or both not
7668          * in the set, it doesn't matter which we take first.) */
7669         if (array_a[i_a] < array_b[i_b]
7670             || (array_a[i_a] == array_b[i_b]
7671                 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
7672         {
7673             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
7674             cp= array_a[i_a++];
7675         }
7676         else {
7677             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
7678             cp = array_b[i_b++];
7679         }
7680
7681         /* Here, have chosen which of the two inputs to look at.  Only output
7682          * if the running count changes to/from 0, which marks the
7683          * beginning/end of a range in that's in the set */
7684         if (cp_in_set) {
7685             if (count == 0) {
7686                 array_u[i_u++] = cp;
7687             }
7688             count++;
7689         }
7690         else {
7691             count--;
7692             if (count == 0) {
7693                 array_u[i_u++] = cp;
7694             }
7695         }
7696     }
7697
7698     /* Here, we are finished going through at least one of the lists, which
7699      * means there is something remaining in at most one.  We check if the list
7700      * that hasn't been exhausted is positioned such that we are in the middle
7701      * of a range in its set or not.  (i_a and i_b point to the element beyond
7702      * the one we care about.) If in the set, we decrement 'count'; if 0, there
7703      * is potentially more to output.
7704      * There are four cases:
7705      *  1) Both weren't in their sets, count is 0, and remains 0.  What's left
7706      *     in the union is entirely from the non-exhausted set.
7707      *  2) Both were in their sets, count is 2.  Nothing further should
7708      *     be output, as everything that remains will be in the exhausted
7709      *     list's set, hence in the union; decrementing to 1 but not 0 insures
7710      *     that
7711      *  3) the exhausted was in its set, non-exhausted isn't, count is 1.
7712      *     Nothing further should be output because the union includes
7713      *     everything from the exhausted set.  Not decrementing ensures that.
7714      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1;
7715      *     decrementing to 0 insures that we look at the remainder of the
7716      *     non-exhausted set */
7717     if ((i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
7718         || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
7719     {
7720         count--;
7721     }
7722
7723     /* The final length is what we've output so far, plus what else is about to
7724      * be output.  (If 'count' is non-zero, then the input list we exhausted
7725      * has everything remaining up to the machine's limit in its set, and hence
7726      * in the union, so there will be no further output. */
7727     len_u = i_u;
7728     if (count == 0) {
7729         /* At most one of the subexpressions will be non-zero */
7730         len_u += (len_a - i_a) + (len_b - i_b);
7731     }
7732
7733     /* Set result to final length, which can change the pointer to array_u, so
7734      * re-find it */
7735     if (len_u != _invlist_len(u)) {
7736         invlist_set_len(u, len_u);
7737         invlist_trim(u);
7738         array_u = invlist_array(u);
7739     }
7740
7741     /* When 'count' is 0, the list that was exhausted (if one was shorter than
7742      * the other) ended with everything above it not in its set.  That means
7743      * that the remaining part of the union is precisely the same as the
7744      * non-exhausted list, so can just copy it unchanged.  (If both list were
7745      * exhausted at the same time, then the operations below will be both 0.)
7746      */
7747     if (count == 0) {
7748         IV copy_count; /* At most one will have a non-zero copy count */
7749         if ((copy_count = len_a - i_a) > 0) {
7750             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
7751         }
7752         else if ((copy_count = len_b - i_b) > 0) {
7753             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
7754         }
7755     }
7756
7757     /* If we've changed b, restore it */
7758     if (complement_b) {
7759         array_b[0] = 1;
7760     }
7761
7762     /*  We may be removing a reference to one of the inputs */
7763     if (a == *output || b == *output) {
7764         assert(! invlist_is_iterating(*output));
7765         SvREFCNT_dec_NN(*output);
7766     }
7767
7768     *output = u;
7769     return;
7770 }
7771
7772 void
7773 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** i)
7774 {
7775     /* Take the intersection of two inversion lists and point <i> to it.  *i
7776      * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
7777      * the reference count to that list will be decremented.
7778      * If <complement_b> is TRUE, the result will be the intersection of <a>
7779      * and the complement (or inversion) of <b> instead of <b> directly.
7780      *
7781      * The basis for this comes from "Unicode Demystified" Chapter 13 by
7782      * Richard Gillam, published by Addison-Wesley, and explained at some
7783      * length there.  The preface says to incorporate its examples into your
7784      * code at your own risk.  In fact, it had bugs
7785      *
7786      * The algorithm is like a merge sort, and is essentially the same as the
7787      * union above
7788      */
7789
7790     UV* array_a;                /* a's array */
7791     UV* array_b;
7792     UV len_a;   /* length of a's array */
7793     UV len_b;
7794
7795     SV* r;                   /* the resulting intersection */
7796     UV* array_r;
7797     UV len_r;
7798
7799     UV i_a = 0;             /* current index into a's array */
7800     UV i_b = 0;
7801     UV i_r = 0;
7802
7803     /* running count, as explained in the algorithm source book; items are
7804      * stopped accumulating and are output when the count changes to/from 2.
7805      * The count is incremented when we start a range that's in the set, and
7806      * decremented when we start a range that's not in the set.  So its range
7807      * is 0 to 2.  Only when the count is 2 is something in the intersection.
7808      */
7809     UV count = 0;
7810
7811     PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
7812     assert(a != b);
7813
7814     /* Special case if either one is empty */
7815     len_a = _invlist_len(a);
7816     if ((len_a == 0) || ((len_b = _invlist_len(b)) == 0)) {
7817
7818         if (len_a != 0 && complement_b) {
7819
7820             /* Here, 'a' is not empty, therefore from the above 'if', 'b' must
7821              * be empty.  Here, also we are using 'b's complement, which hence
7822              * must be every possible code point.  Thus the intersection is
7823              * simply 'a'. */
7824             if (*i != a) {
7825                 *i = invlist_clone(a);
7826
7827                 if (*i == b) {
7828                     SvREFCNT_dec_NN(b);
7829                 }
7830             }
7831             /* else *i is already 'a' */
7832             return;
7833         }
7834
7835         /* Here, 'a' or 'b' is empty and not using the complement of 'b'.  The
7836          * intersection must be empty */
7837         if (*i == a) {
7838             SvREFCNT_dec_NN(a);
7839         }
7840         else if (*i == b) {
7841             SvREFCNT_dec_NN(b);
7842         }
7843         *i = _new_invlist(0);
7844         return;
7845     }
7846
7847     /* Here both lists exist and are non-empty */
7848     array_a = invlist_array(a);
7849     array_b = invlist_array(b);
7850
7851     /* If are to take the intersection of 'a' with the complement of b, set it
7852      * up so are looking at b's complement. */
7853     if (complement_b) {
7854
7855         /* To complement, we invert: if the first element is 0, remove it.  To
7856          * do this, we just pretend the array starts one later, and clear the
7857          * flag as we don't have to do anything else later */
7858         if (array_b[0] == 0) {
7859             array_b++;
7860             len_b--;
7861             complement_b = FALSE;
7862         }
7863         else {
7864
7865             /* But if the first element is not zero, we unshift a 0 before the
7866              * array.  The data structure reserves a space for that 0 (which
7867              * should be a '1' right now), so physical shifting is unneeded,
7868              * but temporarily change that element to 0.  Before exiting the
7869              * routine, we must restore the element to '1' */
7870             array_b--;
7871             len_b++;
7872             array_b[0] = 0;
7873         }
7874     }
7875
7876     /* Size the intersection for the worst case: that the intersection ends up
7877      * fragmenting everything to be completely disjoint */
7878     r= _new_invlist(len_a + len_b);
7879
7880     /* Will contain U+0000 iff both components do */
7881     array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
7882                                      && len_b > 0 && array_b[0] == 0);
7883
7884     /* Go through each list item by item, stopping when exhausted one of
7885      * them */
7886     while (i_a < len_a && i_b < len_b) {
7887         UV cp;      /* The element to potentially add to the intersection's
7888                        array */
7889         bool cp_in_set; /* Is it in the input list's set or not */
7890
7891         /* We need to take one or the other of the two inputs for the
7892          * intersection.  Since we are merging two sorted lists, we take the
7893          * smaller of the next items.  In case of a tie, we take the one that
7894          * is not in its set first (a difference from the union algorithm).  If
7895          * we took one in the set first, it would increment the count, possibly
7896          * to 2 which would cause it to be output as starting a range in the
7897          * intersection, and the next time through we would take that same
7898          * number, and output it again as ending the set.  By doing it the
7899          * opposite of this, there is no possibility that the count will be
7900          * momentarily incremented to 2.  (In a tie and both are in the set or
7901          * both not in the set, it doesn't matter which we take first.) */
7902         if (array_a[i_a] < array_b[i_b]
7903             || (array_a[i_a] == array_b[i_b]
7904                 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
7905         {
7906             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
7907             cp= array_a[i_a++];
7908         }
7909         else {
7910             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
7911             cp= array_b[i_b++];
7912         }
7913
7914         /* Here, have chosen which of the two inputs to look at.  Only output
7915          * if the running count changes to/from 2, which marks the
7916          * beginning/end of a range that's in the intersection */
7917         if (cp_in_set) {
7918             count++;
7919             if (count == 2) {
7920                 array_r[i_r++] = cp;
7921             }
7922         }
7923         else {
7924             if (count == 2) {
7925                 array_r[i_r++] = cp;
7926             }
7927             count--;
7928         }
7929     }
7930
7931     /* Here, we are finished going through at least one of the lists, which
7932      * means there is something remaining in at most one.  We check if the list
7933      * that has been exhausted is positioned such that we are in the middle
7934      * of a range in its set or not.  (i_a and i_b point to elements 1 beyond
7935      * the ones we care about.)  There are four cases:
7936      *  1) Both weren't in their sets, count is 0, and remains 0.  There's
7937      *     nothing left in the intersection.
7938      *  2) Both were in their sets, count is 2 and perhaps is incremented to
7939      *     above 2.  What should be output is exactly that which is in the
7940      *     non-exhausted set, as everything it has is also in the intersection
7941      *     set, and everything it doesn't have can't be in the intersection
7942      *  3) The exhausted was in its set, non-exhausted isn't, count is 1, and
7943      *     gets incremented to 2.  Like the previous case, the intersection is
7944      *     everything that remains in the non-exhausted set.
7945      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1, and
7946      *     remains 1.  And the intersection has nothing more. */
7947     if ((i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
7948         || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
7949     {
7950         count++;
7951     }
7952
7953     /* The final length is what we've output so far plus what else is in the
7954      * intersection.  At most one of the subexpressions below will be non-zero */
7955     len_r = i_r;
7956     if (count >= 2) {
7957         len_r += (len_a - i_a) + (len_b - i_b);
7958     }
7959
7960     /* Set result to final length, which can change the pointer to array_r, so
7961      * re-find it */
7962     if (len_r != _invlist_len(r)) {
7963         invlist_set_len(r, len_r);
7964         invlist_trim(r);
7965         array_r = invlist_array(r);
7966     }
7967
7968     /* Finish outputting any remaining */
7969     if (count >= 2) { /* At most one will have a non-zero copy count */
7970         IV copy_count;
7971         if ((copy_count = len_a - i_a) > 0) {
7972             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
7973         }
7974         else if ((copy_count = len_b - i_b) > 0) {
7975             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
7976         }
7977     }
7978
7979     /* If we've changed b, restore it */
7980     if (complement_b) {
7981         array_b[0] = 1;
7982     }
7983
7984     /*  We may be removing a reference to one of the inputs */
7985     if (a == *i || b == *i) {
7986         assert(! invlist_is_iterating(*i));
7987         SvREFCNT_dec_NN(*i);
7988     }
7989
7990     *i = r;
7991     return;
7992 }
7993
7994 SV*
7995 Perl__add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end)
7996 {
7997     /* Add the range from 'start' to 'end' inclusive to the inversion list's
7998      * set.  A pointer to the inversion list is returned.  This may actually be
7999      * a new list, in which case the passed in one has been destroyed.  The
8000      * passed in inversion list can be NULL, in which case a new one is created
8001      * with just the one range in it */
8002
8003     SV* range_invlist;
8004     UV len;
8005
8006     if (invlist == NULL) {
8007         invlist = _new_invlist(2);
8008         len = 0;
8009     }
8010     else {
8011         len = _invlist_len(invlist);
8012     }
8013
8014     /* If comes after the final entry actually in the list, can just append it
8015      * to the end, */
8016     if (len == 0
8017         || (! ELEMENT_RANGE_MATCHES_INVLIST(len - 1)
8018             && start >= invlist_array(invlist)[len - 1]))
8019     {
8020         _append_range_to_invlist(invlist, start, end);
8021         return invlist;
8022     }
8023
8024     /* Here, can't just append things, create and return a new inversion list
8025      * which is the union of this range and the existing inversion list */
8026     range_invlist = _new_invlist(2);
8027     _append_range_to_invlist(range_invlist, start, end);
8028
8029     _invlist_union(invlist, range_invlist, &invlist);
8030
8031     /* The temporary can be freed */
8032     SvREFCNT_dec_NN(range_invlist);
8033
8034     return invlist;
8035 }
8036
8037 #endif
8038
8039 PERL_STATIC_INLINE SV*
8040 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
8041     return _add_range_to_invlist(invlist, cp, cp);
8042 }
8043
8044 #ifndef PERL_IN_XSUB_RE
8045 void
8046 Perl__invlist_invert(pTHX_ SV* const invlist)
8047 {
8048     /* Complement the input inversion list.  This adds a 0 if the list didn't
8049      * have a zero; removes it otherwise.  As described above, the data
8050      * structure is set up so that this is very efficient */
8051
8052     UV* len_pos = _get_invlist_len_addr(invlist);
8053
8054     PERL_ARGS_ASSERT__INVLIST_INVERT;
8055
8056     assert(! invlist_is_iterating(invlist));
8057
8058     /* The inverse of matching nothing is matching everything */
8059     if (*len_pos == 0) {
8060         _append_range_to_invlist(invlist, 0, UV_MAX);
8061         return;
8062     }
8063
8064     /* The exclusive or complents 0 to 1; and 1 to 0.  If the result is 1, the
8065      * zero element was a 0, so it is being removed, so the length decrements
8066      * by 1; and vice-versa.  SvCUR is unaffected */
8067     if (*get_invlist_zero_addr(invlist) ^= 1) {
8068         (*len_pos)--;
8069     }
8070     else {
8071         (*len_pos)++;
8072     }
8073 }
8074
8075 void
8076 Perl__invlist_invert_prop(pTHX_ SV* const invlist)
8077 {
8078     /* Complement the input inversion list (which must be a Unicode property,
8079      * all of which don't match above the Unicode maximum code point.)  And
8080      * Perl has chosen to not have the inversion match above that either.  This
8081      * adds a 0x110000 if the list didn't end with it, and removes it if it did
8082      */
8083
8084     UV len;
8085     UV* array;
8086
8087     PERL_ARGS_ASSERT__INVLIST_INVERT_PROP;
8088
8089     _invlist_invert(invlist);
8090
8091     len = _invlist_len(invlist);
8092
8093     if (len != 0) { /* If empty do nothing */
8094         array = invlist_array(invlist);
8095         if (array[len - 1] != PERL_UNICODE_MAX + 1) {
8096             /* Add 0x110000.  First, grow if necessary */
8097             len++;
8098             if (invlist_max(invlist) < len) {
8099                 invlist_extend(invlist, len);
8100                 array = invlist_array(invlist);
8101             }
8102             invlist_set_len(invlist, len);
8103             array[len - 1] = PERL_UNICODE_MAX + 1;
8104         }
8105         else {  /* Remove the 0x110000 */
8106             invlist_set_len(invlist, len - 1);
8107         }
8108     }
8109
8110     return;
8111 }
8112 #endif
8113
8114 PERL_STATIC_INLINE SV*
8115 S_invlist_clone(pTHX_ SV* const invlist)
8116 {
8117
8118     /* Return a new inversion list that is a copy of the input one, which is
8119      * unchanged */
8120
8121     /* Need to allocate extra space to accommodate Perl's addition of a
8122      * trailing NUL to SvPV's, since it thinks they are always strings */
8123     SV* new_invlist = _new_invlist(_invlist_len(invlist) + 1);
8124     STRLEN length = SvCUR(invlist);
8125
8126     PERL_ARGS_ASSERT_INVLIST_CLONE;
8127
8128     SvCUR_set(new_invlist, length); /* This isn't done automatically */
8129     Copy(SvPVX(invlist), SvPVX(new_invlist), length, char);
8130
8131     return new_invlist;
8132 }
8133
8134 PERL_STATIC_INLINE UV*
8135 S_get_invlist_iter_addr(pTHX_ SV* invlist)
8136 {
8137     /* Return the address of the UV that contains the current iteration
8138      * position */
8139
8140     PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
8141
8142     return (UV *) (SvPVX(invlist) + (INVLIST_ITER_OFFSET * sizeof (UV)));
8143 }
8144
8145 PERL_STATIC_INLINE UV*
8146 S_get_invlist_version_id_addr(pTHX_ SV* invlist)
8147 {
8148     /* Return the address of the UV that contains the version id. */
8149
8150     PERL_ARGS_ASSERT_GET_INVLIST_VERSION_ID_ADDR;
8151
8152     return (UV *) (SvPVX(invlist) + (INVLIST_VERSION_ID_OFFSET * sizeof (UV)));
8153 }
8154
8155 PERL_STATIC_INLINE void
8156 S_invlist_iterinit(pTHX_ SV* invlist)   /* Initialize iterator for invlist */
8157 {
8158     PERL_ARGS_ASSERT_INVLIST_ITERINIT;
8159
8160     *get_invlist_iter_addr(invlist) = 0;
8161 }
8162
8163 PERL_STATIC_INLINE void
8164 S_invlist_iterfinish(pTHX_ SV* invlist)
8165 {
8166     /* Terminate iterator for invlist.  This is to catch development errors.
8167      * Any iteration that is interrupted before completed should call this
8168      * function.  Functions that add code points anywhere else but to the end
8169      * of an inversion list assert that they are not in the middle of an
8170      * iteration.  If they were, the addition would make the iteration
8171      * problematical: if the iteration hadn't reached the place where things
8172      * were being added, it would be ok */
8173
8174     PERL_ARGS_ASSERT_INVLIST_ITERFINISH;
8175
8176     *get_invlist_iter_addr(invlist) = UV_MAX;
8177 }
8178
8179 STATIC bool
8180 S_invlist_iternext(pTHX_ SV* invlist, UV* start, UV* end)
8181 {
8182     /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
8183      * This call sets in <*start> and <*end>, the next range in <invlist>.
8184      * Returns <TRUE> if successful and the next call will return the next
8185      * range; <FALSE> if was already at the end of the list.  If the latter,
8186      * <*start> and <*end> are unchanged, and the next call to this function
8187      * will start over at the beginning of the list */
8188
8189     UV* pos = get_invlist_iter_addr(invlist);
8190     UV len = _invlist_len(invlist);
8191     UV *array;
8192
8193     PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
8194
8195     if (*pos >= len) {
8196         *pos = UV_MAX;  /* Force iterinit() to be required next time */
8197         return FALSE;
8198     }
8199
8200     array = invlist_array(invlist);
8201
8202     *start = array[(*pos)++];
8203
8204     if (*pos >= len) {
8205         *end = UV_MAX;
8206     }
8207     else {
8208         *end = array[(*pos)++] - 1;
8209     }
8210
8211     return TRUE;
8212 }
8213
8214 PERL_STATIC_INLINE bool
8215 S_invlist_is_iterating(pTHX_ SV* const invlist)
8216 {
8217     PERL_ARGS_ASSERT_INVLIST_IS_ITERATING;
8218
8219     return *(get_invlist_iter_addr(invlist)) < UV_MAX;
8220 }
8221
8222 PERL_STATIC_INLINE UV
8223 S_invlist_highest(pTHX_ SV* const invlist)
8224 {
8225     /* Returns the highest code point that matches an inversion list.  This API
8226      * has an ambiguity, as it returns 0 under either the highest is actually
8227      * 0, or if the list is empty.  If this distinction matters to you, check
8228      * for emptiness before calling this function */
8229
8230     UV len = _invlist_len(invlist);
8231     UV *array;
8232
8233     PERL_ARGS_ASSERT_INVLIST_HIGHEST;
8234
8235     if (len == 0) {
8236         return 0;
8237     }
8238
8239     array = invlist_array(invlist);
8240
8241     /* The last element in the array in the inversion list always starts a
8242      * range that goes to infinity.  That range may be for code points that are
8243      * matched in the inversion list, or it may be for ones that aren't
8244      * matched.  In the latter case, the highest code point in the set is one
8245      * less than the beginning of this range; otherwise it is the final element
8246      * of this range: infinity */
8247     return (ELEMENT_RANGE_MATCHES_INVLIST(len - 1))
8248            ? UV_MAX
8249            : array[len - 1] - 1;
8250 }
8251
8252 #ifndef PERL_IN_XSUB_RE
8253 SV *
8254 Perl__invlist_contents(pTHX_ SV* const invlist)
8255 {
8256     /* Get the contents of an inversion list into a string SV so that they can
8257      * be printed out.  It uses the format traditionally done for debug tracing
8258      */
8259
8260     UV start, end;
8261     SV* output = newSVpvs("\n");
8262
8263     PERL_ARGS_ASSERT__INVLIST_CONTENTS;
8264
8265     assert(! invlist_is_iterating(invlist));
8266
8267     invlist_iterinit(invlist);
8268     while (invlist_iternext(invlist, &start, &end)) {
8269         if (end == UV_MAX) {
8270             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\tINFINITY\n", start);
8271         }
8272         else if (end != start) {
8273             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\t%04"UVXf"\n",
8274                     start,       end);
8275         }
8276         else {
8277             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\n", start);
8278         }
8279     }
8280
8281     return output;
8282 }
8283 #endif
8284
8285 #ifdef PERL_ARGS_ASSERT__INVLIST_DUMP
8286 void
8287 Perl__invlist_dump(pTHX_ SV* const invlist, const char * const header)
8288 {
8289     /* Dumps out the ranges in an inversion list.  The string 'header'
8290      * if present is output on a line before the first range */
8291
8292     UV start, end;
8293
8294     PERL_ARGS_ASSERT__INVLIST_DUMP;
8295
8296     if (header && strlen(header)) {
8297         PerlIO_printf(Perl_debug_log, "%s\n", header);
8298     }
8299     if (invlist_is_iterating(invlist)) {
8300         PerlIO_printf(Perl_debug_log, "Can't dump because is in middle of iterating\n");
8301         return;
8302     }
8303
8304     invlist_iterinit(invlist);
8305     while (invlist_iternext(invlist, &start, &end)) {
8306         if (end == UV_MAX) {
8307             PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. INFINITY\n", start);
8308         }
8309         else if (end != start) {
8310             PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. 0x%04"UVXf"\n",
8311                                                  start,         end);
8312         }
8313         else {
8314             PerlIO_printf(Perl_debug_log, "0x%04"UVXf"\n", start);
8315         }
8316     }
8317 }
8318 #endif
8319
8320 #if 0
8321 bool
8322 S__invlistEQ(pTHX_ SV* const a, SV* const b, bool complement_b)
8323 {
8324     /* Return a boolean as to if the two passed in inversion lists are
8325      * identical.  The final argument, if TRUE, says to take the complement of
8326      * the second inversion list before doing the comparison */
8327
8328     UV* array_a = invlist_array(a);
8329     UV* array_b = invlist_array(b);
8330     UV len_a = _invlist_len(a);
8331     UV len_b = _invlist_len(b);
8332
8333     UV i = 0;               /* current index into the arrays */
8334     bool retval = TRUE;     /* Assume are identical until proven otherwise */
8335
8336     PERL_ARGS_ASSERT__INVLISTEQ;
8337
8338     /* If are to compare 'a' with the complement of b, set it
8339      * up so are looking at b's complement. */
8340     if (complement_b) {
8341
8342         /* The complement of nothing is everything, so <a> would have to have
8343          * just one element, starting at zero (ending at infinity) */
8344         if (len_b == 0) {
8345             return (len_a == 1 && array_a[0] == 0);
8346         }
8347         else if (array_b[0] == 0) {
8348
8349             /* Otherwise, to complement, we invert.  Here, the first element is
8350              * 0, just remove it.  To do this, we just pretend the array starts
8351              * one later, and clear the flag as we don't have to do anything
8352              * else later */
8353
8354             array_b++;
8355             len_b--;
8356             complement_b = FALSE;
8357         }
8358         else {
8359
8360             /* But if the first element is not zero, we unshift a 0 before the
8361              * array.  The data structure reserves a space for that 0 (which
8362              * should be a '1' right now), so physical shifting is unneeded,
8363              * but temporarily change that element to 0.  Before exiting the
8364              * routine, we must restore the element to '1' */
8365             array_b--;
8366             len_b++;
8367             array_b[0] = 0;
8368         }
8369     }
8370
8371     /* Make sure that the lengths are the same, as well as the final element
8372      * before looping through the remainder.  (Thus we test the length, final,
8373      * and first elements right off the bat) */
8374     if (len_a != len_b || array_a[len_a-1] != array_b[len_a-1]) {
8375         retval = FALSE;
8376     }
8377     else for (i = 0; i < len_a - 1; i++) {
8378         if (array_a[i] != array_b[i]) {
8379             retval = FALSE;
8380             break;
8381         }
8382     }
8383
8384     if (complement_b) {
8385         array_b[0] = 1;
8386     }
8387     return retval;
8388 }
8389 #endif
8390
8391 #undef HEADER_LENGTH
8392 #undef INVLIST_INITIAL_LENGTH
8393 #undef TO_INTERNAL_SIZE
8394 #undef FROM_INTERNAL_SIZE
8395 #undef INVLIST_LEN_OFFSET
8396 #undef INVLIST_ZERO_OFFSET
8397 #undef INVLIST_ITER_OFFSET
8398 #undef INVLIST_VERSION_ID
8399 #undef INVLIST_PREVIOUS_INDEX_OFFSET
8400
8401 /* End of inversion list object */
8402
8403 STATIC void
8404 S_parse_lparen_question_flags(pTHX_ struct RExC_state_t *pRExC_state)
8405 {
8406     /* This parses the flags that are in either the '(?foo)' or '(?foo:bar)'
8407      * constructs, and updates RExC_flags with them.  On input, RExC_parse
8408      * should point to the first flag; it is updated on output to point to the
8409      * final ')' or ':'.  There needs to be at least one flag, or this will
8410      * abort */
8411
8412     /* for (?g), (?gc), and (?o) warnings; warning
8413        about (?c) will warn about (?g) -- japhy    */
8414
8415 #define WASTED_O  0x01
8416 #define WASTED_G  0x02
8417 #define WASTED_C  0x04
8418 #define WASTED_GC (0x02|0x04)
8419     I32 wastedflags = 0x00;
8420     U32 posflags = 0, negflags = 0;
8421     U32 *flagsp = &posflags;
8422     char has_charset_modifier = '\0';
8423     regex_charset cs;
8424     bool has_use_defaults = FALSE;
8425     const char* const seqstart = RExC_parse - 1; /* Point to the '?' */
8426
8427     PERL_ARGS_ASSERT_PARSE_LPAREN_QUESTION_FLAGS;
8428
8429     /* '^' as an initial flag sets certain defaults */
8430     if (UCHARAT(RExC_parse) == '^') {
8431         RExC_parse++;
8432         has_use_defaults = TRUE;
8433         STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
8434         set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
8435                                         ? REGEX_UNICODE_CHARSET
8436                                         : REGEX_DEPENDS_CHARSET);
8437     }
8438
8439     cs = get_regex_charset(RExC_flags);
8440     if (cs == REGEX_DEPENDS_CHARSET
8441         && (RExC_utf8 || RExC_uni_semantics))
8442     {
8443         cs = REGEX_UNICODE_CHARSET;
8444     }
8445
8446     while (*RExC_parse) {
8447         /* && strchr("iogcmsx", *RExC_parse) */
8448         /* (?g), (?gc) and (?o) are useless here
8449            and must be globally applied -- japhy */
8450         switch (*RExC_parse) {
8451
8452             /* Code for the imsx flags */
8453             CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
8454
8455             case LOCALE_PAT_MOD:
8456                 if (has_charset_modifier) {
8457                     goto excess_modifier;
8458                 }
8459                 else if (flagsp == &negflags) {
8460                     goto neg_modifier;
8461                 }
8462                 cs = REGEX_LOCALE_CHARSET;
8463                 has_charset_modifier = LOCALE_PAT_MOD;
8464                 RExC_contains_locale = 1;
8465                 break;
8466             case UNICODE_PAT_MOD:
8467                 if (has_charset_modifier) {
8468                     goto excess_modifier;
8469                 }
8470                 else if (flagsp == &negflags) {
8471                     goto neg_modifier;
8472                 }
8473                 cs = REGEX_UNICODE_CHARSET;
8474                 has_charset_modifier = UNICODE_PAT_MOD;
8475                 break;
8476             case ASCII_RESTRICT_PAT_MOD:
8477                 if (flagsp == &negflags) {
8478                     goto neg_modifier;
8479                 }
8480                 if (has_charset_modifier) {
8481                     if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
8482                         goto excess_modifier;
8483                     }
8484                     /* Doubled modifier implies more restricted */
8485                     cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
8486                 }
8487                 else {
8488                     cs = REGEX_ASCII_RESTRICTED_CHARSET;
8489                 }
8490                 has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
8491                 break;
8492             case DEPENDS_PAT_MOD:
8493                 if (has_use_defaults) {
8494                     goto fail_modifiers;
8495                 }
8496                 else if (flagsp == &negflags) {
8497                     goto neg_modifier;
8498                 }
8499                 else if (has_charset_modifier) {
8500                     goto excess_modifier;
8501                 }
8502
8503                 /* The dual charset means unicode semantics if the
8504                  * pattern (or target, not known until runtime) are
8505                  * utf8, or something in the pattern indicates unicode
8506                  * semantics */
8507                 cs = (RExC_utf8 || RExC_uni_semantics)
8508                      ? REGEX_UNICODE_CHARSET
8509                      : REGEX_DEPENDS_CHARSET;
8510                 has_charset_modifier = DEPENDS_PAT_MOD;
8511                 break;
8512             excess_modifier:
8513                 RExC_parse++;
8514                 if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
8515                     vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
8516                 }
8517                 else if (has_charset_modifier == *(RExC_parse - 1)) {
8518                     vFAIL2("Regexp modifier \"%c\" may not appear twice", *(RExC_parse - 1));
8519                 }
8520                 else {
8521                     vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
8522                 }
8523                 /*NOTREACHED*/
8524             neg_modifier:
8525                 RExC_parse++;
8526                 vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", *(RExC_parse - 1));
8527                 /*NOTREACHED*/
8528             case ONCE_PAT_MOD: /* 'o' */
8529             case GLOBAL_PAT_MOD: /* 'g' */
8530                 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
8531                     const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
8532                     if (! (wastedflags & wflagbit) ) {
8533                         wastedflags |= wflagbit;
8534                         vWARN5(
8535                             RExC_parse + 1,
8536                             "Useless (%s%c) - %suse /%c modifier",
8537                             flagsp == &negflags ? "?-" : "?",
8538                             *RExC_parse,
8539                             flagsp == &negflags ? "don't " : "",
8540                             *RExC_parse
8541                         );
8542                     }
8543                 }
8544                 break;
8545
8546             case CONTINUE_PAT_MOD: /* 'c' */
8547                 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
8548                     if (! (wastedflags & WASTED_C) ) {
8549                         wastedflags |= WASTED_GC;
8550                         vWARN3(
8551                             RExC_parse + 1,
8552                             "Useless (%sc) - %suse /gc modifier",
8553                             flagsp == &negflags ? "?-" : "?",
8554                             flagsp == &negflags ? "don't " : ""
8555                         );
8556                     }
8557                 }
8558                 break;
8559             case KEEPCOPY_PAT_MOD: /* 'p' */
8560                 if (flagsp == &negflags) {
8561                     if (SIZE_ONLY)
8562                         ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
8563                 } else {
8564                     *flagsp |= RXf_PMf_KEEPCOPY;
8565                 }
8566                 break;
8567             case '-':
8568                 /* A flag is a default iff it is following a minus, so
8569                  * if there is a minus, it means will be trying to
8570                  * re-specify a default which is an error */
8571                 if (has_use_defaults || flagsp == &negflags) {
8572                     goto fail_modifiers;
8573                 }
8574                 flagsp = &negflags;
8575                 wastedflags = 0;  /* reset so (?g-c) warns twice */
8576                 break;
8577             case ':':
8578             case ')':
8579                 RExC_flags |= posflags;
8580                 RExC_flags &= ~negflags;
8581                 set_regex_charset(&RExC_flags, cs);
8582                 return;
8583                 /*NOTREACHED*/
8584             default:
8585             fail_modifiers:
8586                 RExC_parse++;
8587                 vFAIL3("Sequence (%.*s...) not recognized",
8588                        RExC_parse-seqstart, seqstart);
8589                 /*NOTREACHED*/
8590         }
8591
8592         ++RExC_parse;
8593     }
8594 }
8595
8596 /*
8597  - reg - regular expression, i.e. main body or parenthesized thing
8598  *
8599  * Caller must absorb opening parenthesis.
8600  *
8601  * Combining parenthesis handling with the base level of regular expression
8602  * is a trifle forced, but the need to tie the tails of the branches to what
8603  * follows makes it hard to avoid.
8604  */
8605 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
8606 #ifdef DEBUGGING
8607 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
8608 #else
8609 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
8610 #endif
8611
8612 /* Returns NULL, setting *flagp to TRYAGAIN at the end of (?) that only sets
8613    flags. Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan
8614    needs to be restarted.
8615    Otherwise would only return NULL if regbranch() returns NULL, which
8616    cannot happen.  */
8617 STATIC regnode *
8618 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
8619     /* paren: Parenthesized? 0=top; 1,2=inside '(': changed to letter.
8620      * 2 is like 1, but indicates that nextchar() has been called to advance
8621      * RExC_parse beyond the '('.  Things like '(?' are indivisible tokens, and
8622      * this flag alerts us to the need to check for that */
8623 {
8624     dVAR;
8625     regnode *ret;               /* Will be the head of the group. */
8626     regnode *br;
8627     regnode *lastbr;
8628     regnode *ender = NULL;
8629     I32 parno = 0;
8630     I32 flags;
8631     U32 oregflags = RExC_flags;
8632     bool have_branch = 0;
8633     bool is_open = 0;
8634     I32 freeze_paren = 0;
8635     I32 after_freeze = 0;
8636
8637     char * parse_start = RExC_parse; /* MJD */
8638     char * const oregcomp_parse = RExC_parse;
8639
8640     GET_RE_DEBUG_FLAGS_DECL;
8641
8642     PERL_ARGS_ASSERT_REG;
8643     DEBUG_PARSE("reg ");
8644
8645     *flagp = 0;                         /* Tentatively. */
8646
8647
8648     /* Make an OPEN node, if parenthesized. */
8649     if (paren) {
8650
8651         /* Under /x, space and comments can be gobbled up between the '(' and
8652          * here (if paren ==2).  The forms '(*VERB' and '(?...' disallow such
8653          * intervening space, as the sequence is a token, and a token should be
8654          * indivisible */
8655         bool has_intervening_patws = paren == 2 && *(RExC_parse - 1) != '(';
8656
8657         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
8658             char *start_verb = RExC_parse;
8659             STRLEN verb_len = 0;
8660             char *start_arg = NULL;
8661             unsigned char op = 0;
8662             int argok = 1;
8663             int internal_argval = 0; /* internal_argval is only useful if !argok */
8664
8665             if (has_intervening_patws && SIZE_ONLY) {
8666                 ckWARNregdep(RExC_parse + 1, "In '(*VERB...)', splitting the initial '(*' is deprecated");
8667             }
8668             while ( *RExC_parse && *RExC_parse != ')' ) {
8669                 if ( *RExC_parse == ':' ) {
8670                     start_arg = RExC_parse + 1;
8671                     break;
8672                 }
8673                 RExC_parse++;
8674             }
8675             ++start_verb;
8676             verb_len = RExC_parse - start_verb;
8677             if ( start_arg ) {
8678                 RExC_parse++;
8679                 while ( *RExC_parse && *RExC_parse != ')' ) 
8680                     RExC_parse++;
8681                 if ( *RExC_parse != ')' ) 
8682                     vFAIL("Unterminated verb pattern argument");
8683                 if ( RExC_parse == start_arg )
8684                     start_arg = NULL;
8685             } else {
8686                 if ( *RExC_parse != ')' )
8687                     vFAIL("Unterminated verb pattern");
8688             }
8689             
8690             switch ( *start_verb ) {
8691             case 'A':  /* (*ACCEPT) */
8692                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
8693                     op = ACCEPT;
8694                     internal_argval = RExC_nestroot;
8695                 }
8696                 break;
8697             case 'C':  /* (*COMMIT) */
8698                 if ( memEQs(start_verb,verb_len,"COMMIT") )
8699                     op = COMMIT;
8700                 break;
8701             case 'F':  /* (*FAIL) */
8702                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
8703                     op = OPFAIL;
8704                     argok = 0;
8705                 }
8706                 break;
8707             case ':':  /* (*:NAME) */
8708             case 'M':  /* (*MARK:NAME) */
8709                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
8710                     op = MARKPOINT;
8711                     argok = -1;
8712                 }
8713                 break;
8714             case 'P':  /* (*PRUNE) */
8715                 if ( memEQs(start_verb,verb_len,"PRUNE") )
8716                     op = PRUNE;
8717                 break;
8718             case 'S':   /* (*SKIP) */  
8719                 if ( memEQs(start_verb,verb_len,"SKIP") ) 
8720                     op = SKIP;
8721                 break;
8722             case 'T':  /* (*THEN) */
8723                 /* [19:06] <TimToady> :: is then */
8724                 if ( memEQs(start_verb,verb_len,"THEN") ) {
8725                     op = CUTGROUP;
8726                     RExC_seen |= REG_SEEN_CUTGROUP;
8727                 }
8728                 break;
8729             }
8730             if ( ! op ) {
8731                 RExC_parse++;
8732                 vFAIL3("Unknown verb pattern '%.*s'",
8733                     verb_len, start_verb);
8734             }
8735             if ( argok ) {
8736                 if ( start_arg && internal_argval ) {
8737                     vFAIL3("Verb pattern '%.*s' may not have an argument",
8738                         verb_len, start_verb); 
8739                 } else if ( argok < 0 && !start_arg ) {
8740                     vFAIL3("Verb pattern '%.*s' has a mandatory argument",
8741                         verb_len, start_verb);    
8742                 } else {
8743                     ret = reganode(pRExC_state, op, internal_argval);
8744                     if ( ! internal_argval && ! SIZE_ONLY ) {
8745                         if (start_arg) {
8746                             SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
8747                             ARG(ret) = add_data( pRExC_state, 1, "S" );
8748                             RExC_rxi->data->data[ARG(ret)]=(void*)sv;
8749                             ret->flags = 0;
8750                         } else {
8751                             ret->flags = 1; 
8752                         }
8753                     }               
8754                 }
8755                 if (!internal_argval)
8756                     RExC_seen |= REG_SEEN_VERBARG;
8757             } else if ( start_arg ) {
8758                 vFAIL3("Verb pattern '%.*s' may not have an argument",
8759                         verb_len, start_verb);    
8760             } else {
8761                 ret = reg_node(pRExC_state, op);
8762             }
8763             nextchar(pRExC_state);
8764             return ret;
8765         } else 
8766         if (*RExC_parse == '?') { /* (?...) */
8767             bool is_logical = 0;
8768             const char * const seqstart = RExC_parse;
8769             if (has_intervening_patws && SIZE_ONLY) {
8770                 ckWARNregdep(RExC_parse + 1, "In '(?...)', splitting the initial '(?' is deprecated");
8771             }
8772
8773             RExC_parse++;
8774             paren = *RExC_parse++;
8775             ret = NULL;                 /* For look-ahead/behind. */
8776             switch (paren) {
8777
8778             case 'P':   /* (?P...) variants for those used to PCRE/Python */
8779                 paren = *RExC_parse++;
8780                 if ( paren == '<')         /* (?P<...>) named capture */
8781                     goto named_capture;
8782                 else if (paren == '>') {   /* (?P>name) named recursion */
8783                     goto named_recursion;
8784                 }
8785                 else if (paren == '=') {   /* (?P=...)  named backref */
8786                     /* this pretty much dupes the code for \k<NAME> in regatom(), if
8787                        you change this make sure you change that */
8788                     char* name_start = RExC_parse;
8789                     U32 num = 0;
8790                     SV *sv_dat = reg_scan_name(pRExC_state,
8791                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8792                     if (RExC_parse == name_start || *RExC_parse != ')')
8793                         vFAIL2("Sequence %.3s... not terminated",parse_start);
8794
8795                     if (!SIZE_ONLY) {
8796                         num = add_data( pRExC_state, 1, "S" );
8797                         RExC_rxi->data->data[num]=(void*)sv_dat;
8798                         SvREFCNT_inc_simple_void(sv_dat);
8799                     }
8800                     RExC_sawback = 1;
8801                     ret = reganode(pRExC_state,
8802                                    ((! FOLD)
8803                                      ? NREF
8804                                      : (ASCII_FOLD_RESTRICTED)
8805                                        ? NREFFA
8806                                        : (AT_LEAST_UNI_SEMANTICS)
8807                                          ? NREFFU
8808                                          : (LOC)
8809                                            ? NREFFL
8810                                            : NREFF),
8811                                     num);
8812                     *flagp |= HASWIDTH;
8813
8814                     Set_Node_Offset(ret, parse_start+1);
8815                     Set_Node_Cur_Length(ret); /* MJD */
8816
8817                     nextchar(pRExC_state);
8818                     return ret;
8819                 }
8820                 RExC_parse++;
8821                 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8822                 /*NOTREACHED*/
8823             case '<':           /* (?<...) */
8824                 if (*RExC_parse == '!')
8825                     paren = ',';
8826                 else if (*RExC_parse != '=') 
8827               named_capture:
8828                 {               /* (?<...>) */
8829                     char *name_start;
8830                     SV *svname;
8831                     paren= '>';
8832             case '\'':          /* (?'...') */
8833                     name_start= RExC_parse;
8834                     svname = reg_scan_name(pRExC_state,
8835                         SIZE_ONLY ?  /* reverse test from the others */
8836                         REG_RSN_RETURN_NAME : 
8837                         REG_RSN_RETURN_NULL);
8838                     if (RExC_parse == name_start) {
8839                         RExC_parse++;
8840                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8841                         /*NOTREACHED*/
8842                     }
8843                     if (*RExC_parse != paren)
8844                         vFAIL2("Sequence (?%c... not terminated",
8845                             paren=='>' ? '<' : paren);
8846                     if (SIZE_ONLY) {
8847                         HE *he_str;
8848                         SV *sv_dat = NULL;
8849                         if (!svname) /* shouldn't happen */
8850                             Perl_croak(aTHX_
8851                                 "panic: reg_scan_name returned NULL");
8852                         if (!RExC_paren_names) {
8853                             RExC_paren_names= newHV();
8854                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
8855 #ifdef DEBUGGING
8856                             RExC_paren_name_list= newAV();
8857                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
8858 #endif
8859                         }
8860                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
8861                         if ( he_str )
8862                             sv_dat = HeVAL(he_str);
8863                         if ( ! sv_dat ) {
8864                             /* croak baby croak */
8865                             Perl_croak(aTHX_
8866                                 "panic: paren_name hash element allocation failed");
8867                         } else if ( SvPOK(sv_dat) ) {
8868                             /* (?|...) can mean we have dupes so scan to check
8869                                its already been stored. Maybe a flag indicating
8870                                we are inside such a construct would be useful,
8871                                but the arrays are likely to be quite small, so
8872                                for now we punt -- dmq */
8873                             IV count = SvIV(sv_dat);
8874                             I32 *pv = (I32*)SvPVX(sv_dat);
8875                             IV i;
8876                             for ( i = 0 ; i < count ; i++ ) {
8877                                 if ( pv[i] == RExC_npar ) {
8878                                     count = 0;
8879                                     break;
8880                                 }
8881                             }
8882                             if ( count ) {
8883                                 pv = (I32*)SvGROW(sv_dat, SvCUR(sv_dat) + sizeof(I32)+1);
8884                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
8885                                 pv[count] = RExC_npar;
8886                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
8887                             }
8888                         } else {
8889                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
8890                             sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
8891                             SvIOK_on(sv_dat);
8892                             SvIV_set(sv_dat, 1);
8893                         }
8894 #ifdef DEBUGGING
8895                         /* Yes this does cause a memory leak in debugging Perls */
8896                         if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
8897                             SvREFCNT_dec_NN(svname);
8898 #endif
8899
8900                         /*sv_dump(sv_dat);*/
8901                     }
8902                     nextchar(pRExC_state);
8903                     paren = 1;
8904                     goto capturing_parens;
8905                 }
8906                 RExC_seen |= REG_SEEN_LOOKBEHIND;
8907                 RExC_in_lookbehind++;
8908                 RExC_parse++;
8909             case '=':           /* (?=...) */
8910                 RExC_seen_zerolen++;
8911                 break;
8912             case '!':           /* (?!...) */
8913                 RExC_seen_zerolen++;
8914                 if (*RExC_parse == ')') {
8915                     ret=reg_node(pRExC_state, OPFAIL);
8916                     nextchar(pRExC_state);
8917                     return ret;
8918                 }
8919                 break;
8920             case '|':           /* (?|...) */
8921                 /* branch reset, behave like a (?:...) except that
8922                    buffers in alternations share the same numbers */
8923                 paren = ':'; 
8924                 after_freeze = freeze_paren = RExC_npar;
8925                 break;
8926             case ':':           /* (?:...) */
8927             case '>':           /* (?>...) */
8928                 break;
8929             case '$':           /* (?$...) */
8930             case '@':           /* (?@...) */
8931                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
8932                 break;
8933             case '#':           /* (?#...) */
8934                 /* XXX As soon as we disallow separating the '?' and '*' (by
8935                  * spaces or (?#...) comment), it is believed that this case
8936                  * will be unreachable and can be removed.  See
8937                  * [perl #117327] */
8938                 while (*RExC_parse && *RExC_parse != ')')
8939                     RExC_parse++;
8940                 if (*RExC_parse != ')')
8941                     FAIL("Sequence (?#... not terminated");
8942                 nextchar(pRExC_state);
8943                 *flagp = TRYAGAIN;
8944                 return NULL;
8945             case '0' :           /* (?0) */
8946             case 'R' :           /* (?R) */
8947                 if (*RExC_parse != ')')
8948                     FAIL("Sequence (?R) not terminated");
8949                 ret = reg_node(pRExC_state, GOSTART);
8950                 *flagp |= POSTPONED;
8951                 nextchar(pRExC_state);
8952                 return ret;
8953                 /*notreached*/
8954             { /* named and numeric backreferences */
8955                 I32 num;
8956             case '&':            /* (?&NAME) */
8957                 parse_start = RExC_parse - 1;
8958               named_recursion:
8959                 {
8960                     SV *sv_dat = reg_scan_name(pRExC_state,
8961                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8962                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
8963                 }
8964                 goto gen_recurse_regop;
8965                 assert(0); /* NOT REACHED */
8966             case '+':
8967                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
8968                     RExC_parse++;
8969                     vFAIL("Illegal pattern");
8970                 }
8971                 goto parse_recursion;
8972                 /* NOT REACHED*/
8973             case '-': /* (?-1) */
8974                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
8975                     RExC_parse--; /* rewind to let it be handled later */
8976                     goto parse_flags;
8977                 } 
8978                 /*FALLTHROUGH */
8979             case '1': case '2': case '3': case '4': /* (?1) */
8980             case '5': case '6': case '7': case '8': case '9':
8981                 RExC_parse--;
8982               parse_recursion:
8983                 num = atoi(RExC_parse);
8984                 parse_start = RExC_parse - 1; /* MJD */
8985                 if (*RExC_parse == '-')
8986                     RExC_parse++;
8987                 while (isDIGIT(*RExC_parse))
8988                         RExC_parse++;
8989                 if (*RExC_parse!=')') 
8990                     vFAIL("Expecting close bracket");
8991
8992               gen_recurse_regop:
8993                 if ( paren == '-' ) {
8994                     /*
8995                     Diagram of capture buffer numbering.
8996                     Top line is the normal capture buffer numbers
8997                     Bottom line is the negative indexing as from
8998                     the X (the (?-2))
8999
9000                     +   1 2    3 4 5 X          6 7
9001                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
9002                     -   5 4    3 2 1 X          x x
9003
9004                     */
9005                     num = RExC_npar + num;
9006                     if (num < 1)  {
9007                         RExC_parse++;
9008                         vFAIL("Reference to nonexistent group");
9009                     }
9010                 } else if ( paren == '+' ) {
9011                     num = RExC_npar + num - 1;
9012                 }
9013
9014                 ret = reganode(pRExC_state, GOSUB, num);
9015                 if (!SIZE_ONLY) {
9016                     if (num > (I32)RExC_rx->nparens) {
9017                         RExC_parse++;
9018                         vFAIL("Reference to nonexistent group");
9019                     }
9020                     ARG2L_SET( ret, RExC_recurse_count++);
9021                     RExC_emit++;
9022                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
9023                         "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
9024                 } else {
9025                     RExC_size++;
9026                 }
9027                 RExC_seen |= REG_SEEN_RECURSE;
9028                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
9029                 Set_Node_Offset(ret, parse_start); /* MJD */
9030
9031                 *flagp |= POSTPONED;
9032                 nextchar(pRExC_state);
9033                 return ret;
9034             } /* named and numeric backreferences */
9035             assert(0); /* NOT REACHED */
9036
9037             case '?':           /* (??...) */
9038                 is_logical = 1;
9039                 if (*RExC_parse != '{') {
9040                     RExC_parse++;
9041                     vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
9042                     /*NOTREACHED*/
9043                 }
9044                 *flagp |= POSTPONED;
9045                 paren = *RExC_parse++;
9046                 /* FALL THROUGH */
9047             case '{':           /* (?{...}) */
9048             {
9049                 U32 n = 0;
9050                 struct reg_code_block *cb;
9051
9052                 RExC_seen_zerolen++;
9053
9054                 if (   !pRExC_state->num_code_blocks
9055                     || pRExC_state->code_index >= pRExC_state->num_code_blocks
9056                     || pRExC_state->code_blocks[pRExC_state->code_index].start
9057                         != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
9058                             - RExC_start)
9059                 ) {
9060                     if (RExC_pm_flags & PMf_USE_RE_EVAL)
9061                         FAIL("panic: Sequence (?{...}): no code block found\n");
9062                     FAIL("Eval-group not allowed at runtime, use re 'eval'");
9063                 }
9064                 /* this is a pre-compiled code block (?{...}) */
9065                 cb = &pRExC_state->code_blocks[pRExC_state->code_index];
9066                 RExC_parse = RExC_start + cb->end;
9067                 if (!SIZE_ONLY) {
9068                     OP *o = cb->block;
9069                     if (cb->src_regex) {
9070                         n = add_data(pRExC_state, 2, "rl");
9071                         RExC_rxi->data->data[n] =
9072                             (void*)SvREFCNT_inc((SV*)cb->src_regex);
9073                         RExC_rxi->data->data[n+1] = (void*)o;
9074                     }
9075                     else {
9076                         n = add_data(pRExC_state, 1,
9077                                (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l");
9078                         RExC_rxi->data->data[n] = (void*)o;
9079                     }
9080                 }
9081                 pRExC_state->code_index++;
9082                 nextchar(pRExC_state);
9083
9084                 if (is_logical) {
9085                     regnode *eval;
9086                     ret = reg_node(pRExC_state, LOGICAL);
9087                     eval = reganode(pRExC_state, EVAL, n);
9088                     if (!SIZE_ONLY) {
9089                         ret->flags = 2;
9090                         /* for later propagation into (??{}) return value */
9091                         eval->flags = (U8) (RExC_flags & RXf_PMf_COMPILETIME);
9092                     }
9093                     REGTAIL(pRExC_state, ret, eval);
9094                     /* deal with the length of this later - MJD */
9095                     return ret;
9096                 }
9097                 ret = reganode(pRExC_state, EVAL, n);
9098                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
9099                 Set_Node_Offset(ret, parse_start);
9100                 return ret;
9101             }
9102             case '(':           /* (?(?{...})...) and (?(?=...)...) */
9103             {
9104                 int is_define= 0;
9105                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
9106                     if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
9107                         || RExC_parse[1] == '<'
9108                         || RExC_parse[1] == '{') { /* Lookahead or eval. */
9109                         I32 flag;
9110                         regnode *tail;
9111
9112                         ret = reg_node(pRExC_state, LOGICAL);
9113                         if (!SIZE_ONLY)
9114                             ret->flags = 1;
9115                         
9116                         tail = reg(pRExC_state, 1, &flag, depth+1);
9117                         if (flag & RESTART_UTF8) {
9118                             *flagp = RESTART_UTF8;
9119                             return NULL;
9120                         }
9121                         REGTAIL(pRExC_state, ret, tail);
9122                         goto insert_if;
9123                     }
9124                 }
9125                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
9126                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
9127                 {
9128                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
9129                     char *name_start= RExC_parse++;
9130                     U32 num = 0;
9131                     SV *sv_dat=reg_scan_name(pRExC_state,
9132                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
9133                     if (RExC_parse == name_start || *RExC_parse != ch)
9134                         vFAIL2("Sequence (?(%c... not terminated",
9135                             (ch == '>' ? '<' : ch));
9136                     RExC_parse++;
9137                     if (!SIZE_ONLY) {
9138                         num = add_data( pRExC_state, 1, "S" );
9139                         RExC_rxi->data->data[num]=(void*)sv_dat;
9140                         SvREFCNT_inc_simple_void(sv_dat);
9141                     }
9142                     ret = reganode(pRExC_state,NGROUPP,num);
9143                     goto insert_if_check_paren;
9144                 }
9145                 else if (RExC_parse[0] == 'D' &&
9146                          RExC_parse[1] == 'E' &&
9147                          RExC_parse[2] == 'F' &&
9148                          RExC_parse[3] == 'I' &&
9149                          RExC_parse[4] == 'N' &&
9150                          RExC_parse[5] == 'E')
9151                 {
9152                     ret = reganode(pRExC_state,DEFINEP,0);
9153                     RExC_parse +=6 ;
9154                     is_define = 1;
9155                     goto insert_if_check_paren;
9156                 }
9157                 else if (RExC_parse[0] == 'R') {
9158                     RExC_parse++;
9159                     parno = 0;
9160                     if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
9161                         parno = atoi(RExC_parse++);
9162                         while (isDIGIT(*RExC_parse))
9163                             RExC_parse++;
9164                     } else if (RExC_parse[0] == '&') {
9165                         SV *sv_dat;
9166                         RExC_parse++;
9167                         sv_dat = reg_scan_name(pRExC_state,
9168                             SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
9169                         parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
9170                     }
9171                     ret = reganode(pRExC_state,INSUBP,parno); 
9172                     goto insert_if_check_paren;
9173                 }
9174                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
9175                     /* (?(1)...) */
9176                     char c;
9177                     parno = atoi(RExC_parse++);
9178
9179                     while (isDIGIT(*RExC_parse))
9180                         RExC_parse++;
9181                     ret = reganode(pRExC_state, GROUPP, parno);
9182
9183                  insert_if_check_paren:
9184                     if ((c = *nextchar(pRExC_state)) != ')')
9185                         vFAIL("Switch condition not recognized");
9186                   insert_if:
9187                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
9188                     br = regbranch(pRExC_state, &flags, 1,depth+1);
9189                     if (br == NULL) {
9190                         if (flags & RESTART_UTF8) {
9191                             *flagp = RESTART_UTF8;
9192                             return NULL;
9193                         }
9194                         FAIL2("panic: regbranch returned NULL, flags=%#X",
9195                               flags);
9196                     } else
9197                         REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
9198                     c = *nextchar(pRExC_state);
9199                     if (flags&HASWIDTH)
9200                         *flagp |= HASWIDTH;
9201                     if (c == '|') {
9202                         if (is_define) 
9203                             vFAIL("(?(DEFINE)....) does not allow branches");
9204                         lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
9205                         if (!regbranch(pRExC_state, &flags, 1,depth+1)) {
9206                             if (flags & RESTART_UTF8) {
9207                                 *flagp = RESTART_UTF8;
9208                                 return NULL;
9209                             }
9210                             FAIL2("panic: regbranch returned NULL, flags=%#X",
9211                                   flags);
9212                         }
9213                         REGTAIL(pRExC_state, ret, lastbr);
9214                         if (flags&HASWIDTH)
9215                             *flagp |= HASWIDTH;
9216                         c = *nextchar(pRExC_state);
9217                     }
9218                     else
9219                         lastbr = NULL;
9220                     if (c != ')')
9221                         vFAIL("Switch (?(condition)... contains too many branches");
9222                     ender = reg_node(pRExC_state, TAIL);
9223                     REGTAIL(pRExC_state, br, ender);
9224                     if (lastbr) {
9225                         REGTAIL(pRExC_state, lastbr, ender);
9226                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
9227                     }
9228                     else
9229                         REGTAIL(pRExC_state, ret, ender);
9230                     RExC_size++; /* XXX WHY do we need this?!!
9231                                     For large programs it seems to be required
9232                                     but I can't figure out why. -- dmq*/
9233                     return ret;
9234                 }
9235                 else {
9236                     vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
9237                 }
9238             }
9239             case '[':           /* (?[ ... ]) */
9240                 return handle_regex_sets(pRExC_state, NULL, flagp, depth,
9241                                          oregcomp_parse);
9242             case 0:
9243                 RExC_parse--; /* for vFAIL to print correctly */
9244                 vFAIL("Sequence (? incomplete");
9245                 break;
9246             default: /* e.g., (?i) */
9247                 --RExC_parse;
9248               parse_flags:
9249                 parse_lparen_question_flags(pRExC_state);
9250                 if (UCHARAT(RExC_parse) != ':') {
9251                     nextchar(pRExC_state);
9252                     *flagp = TRYAGAIN;
9253                     return NULL;
9254                 }
9255                 paren = ':';
9256                 nextchar(pRExC_state);
9257                 ret = NULL;
9258                 goto parse_rest;
9259             } /* end switch */
9260         }
9261         else {                  /* (...) */
9262           capturing_parens:
9263             parno = RExC_npar;
9264             RExC_npar++;
9265             
9266             ret = reganode(pRExC_state, OPEN, parno);
9267             if (!SIZE_ONLY ){
9268                 if (!RExC_nestroot) 
9269                     RExC_nestroot = parno;
9270                 if (RExC_seen & REG_SEEN_RECURSE
9271                     && !RExC_open_parens[parno-1])
9272                 {
9273                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
9274                         "Setting open paren #%"IVdf" to %d\n", 
9275                         (IV)parno, REG_NODE_NUM(ret)));
9276                     RExC_open_parens[parno-1]= ret;
9277                 }
9278             }
9279             Set_Node_Length(ret, 1); /* MJD */
9280             Set_Node_Offset(ret, RExC_parse); /* MJD */
9281             is_open = 1;
9282         }
9283     }
9284     else                        /* ! paren */
9285         ret = NULL;
9286    
9287    parse_rest:
9288     /* Pick up the branches, linking them together. */
9289     parse_start = RExC_parse;   /* MJD */
9290     br = regbranch(pRExC_state, &flags, 1,depth+1);
9291
9292     /*     branch_len = (paren != 0); */
9293
9294     if (br == NULL) {
9295         if (flags & RESTART_UTF8) {
9296             *flagp = RESTART_UTF8;
9297             return NULL;
9298         }
9299         FAIL2("panic: regbranch returned NULL, flags=%#X", flags);
9300     }
9301     if (*RExC_parse == '|') {
9302         if (!SIZE_ONLY && RExC_extralen) {
9303             reginsert(pRExC_state, BRANCHJ, br, depth+1);
9304         }
9305         else {                  /* MJD */
9306             reginsert(pRExC_state, BRANCH, br, depth+1);
9307             Set_Node_Length(br, paren != 0);
9308             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
9309         }
9310         have_branch = 1;
9311         if (SIZE_ONLY)
9312             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
9313     }
9314     else if (paren == ':') {
9315         *flagp |= flags&SIMPLE;
9316     }
9317     if (is_open) {                              /* Starts with OPEN. */
9318         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
9319     }
9320     else if (paren != '?')              /* Not Conditional */
9321         ret = br;
9322     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
9323     lastbr = br;
9324     while (*RExC_parse == '|') {
9325         if (!SIZE_ONLY && RExC_extralen) {
9326             ender = reganode(pRExC_state, LONGJMP,0);
9327             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
9328         }
9329         if (SIZE_ONLY)
9330             RExC_extralen += 2;         /* Account for LONGJMP. */
9331         nextchar(pRExC_state);
9332         if (freeze_paren) {
9333             if (RExC_npar > after_freeze)
9334                 after_freeze = RExC_npar;
9335             RExC_npar = freeze_paren;       
9336         }
9337         br = regbranch(pRExC_state, &flags, 0, depth+1);
9338
9339         if (br == NULL) {
9340             if (flags & RESTART_UTF8) {
9341                 *flagp = RESTART_UTF8;
9342                 return NULL;
9343             }
9344             FAIL2("panic: regbranch returned NULL, flags=%#X", flags);
9345         }
9346         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
9347         lastbr = br;
9348         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
9349     }
9350
9351     if (have_branch || paren != ':') {
9352         /* Make a closing node, and hook it on the end. */
9353         switch (paren) {
9354         case ':':
9355             ender = reg_node(pRExC_state, TAIL);
9356             break;
9357         case 1: case 2:
9358             ender = reganode(pRExC_state, CLOSE, parno);
9359             if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
9360                 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
9361                         "Setting close paren #%"IVdf" to %d\n", 
9362                         (IV)parno, REG_NODE_NUM(ender)));
9363                 RExC_close_parens[parno-1]= ender;
9364                 if (RExC_nestroot == parno) 
9365                     RExC_nestroot = 0;
9366             }       
9367             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
9368             Set_Node_Length(ender,1); /* MJD */
9369             break;
9370         case '<':
9371         case ',':
9372         case '=':
9373         case '!':
9374             *flagp &= ~HASWIDTH;
9375             /* FALL THROUGH */
9376         case '>':
9377             ender = reg_node(pRExC_state, SUCCEED);
9378             break;
9379         case 0:
9380             ender = reg_node(pRExC_state, END);
9381             if (!SIZE_ONLY) {
9382                 assert(!RExC_opend); /* there can only be one! */
9383                 RExC_opend = ender;
9384             }
9385             break;
9386         }
9387         DEBUG_PARSE_r(if (!SIZE_ONLY) {
9388             SV * const mysv_val1=sv_newmortal();
9389             SV * const mysv_val2=sv_newmortal();
9390             DEBUG_PARSE_MSG("lsbr");
9391             regprop(RExC_rx, mysv_val1, lastbr);
9392             regprop(RExC_rx, mysv_val2, ender);
9393             PerlIO_printf(Perl_debug_log, "~ tying lastbr %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
9394                           SvPV_nolen_const(mysv_val1),
9395                           (IV)REG_NODE_NUM(lastbr),
9396                           SvPV_nolen_const(mysv_val2),
9397                           (IV)REG_NODE_NUM(ender),
9398                           (IV)(ender - lastbr)
9399             );
9400         });
9401         REGTAIL(pRExC_state, lastbr, ender);
9402
9403         if (have_branch && !SIZE_ONLY) {
9404             char is_nothing= 1;
9405             if (depth==1)
9406                 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
9407
9408             /* Hook the tails of the branches to the closing node. */
9409             for (br = ret; br; br = regnext(br)) {
9410                 const U8 op = PL_regkind[OP(br)];
9411                 if (op == BRANCH) {
9412                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
9413                     if (OP(NEXTOPER(br)) != NOTHING || regnext(NEXTOPER(br)) != ender)
9414                         is_nothing= 0;
9415                 }
9416                 else if (op == BRANCHJ) {
9417                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
9418                     /* for now we always disable this optimisation * /
9419                     if (OP(NEXTOPER(NEXTOPER(br))) != NOTHING || regnext(NEXTOPER(NEXTOPER(br))) != ender)
9420                     */
9421                         is_nothing= 0;
9422                 }
9423             }
9424             if (is_nothing) {
9425                 br= PL_regkind[OP(ret)] != BRANCH ? regnext(ret) : ret;
9426                 DEBUG_PARSE_r(if (!SIZE_ONLY) {
9427                     SV * const mysv_val1=sv_newmortal();
9428                     SV * const mysv_val2=sv_newmortal();
9429                     DEBUG_PARSE_MSG("NADA");
9430                     regprop(RExC_rx, mysv_val1, ret);
9431                     regprop(RExC_rx, mysv_val2, ender);
9432                     PerlIO_printf(Perl_debug_log, "~ converting ret %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
9433                                   SvPV_nolen_const(mysv_val1),
9434                                   (IV)REG_NODE_NUM(ret),
9435                                   SvPV_nolen_const(mysv_val2),
9436                                   (IV)REG_NODE_NUM(ender),
9437                                   (IV)(ender - ret)
9438                     );
9439                 });
9440                 OP(br)= NOTHING;
9441                 if (OP(ender) == TAIL) {
9442                     NEXT_OFF(br)= 0;
9443                     RExC_emit= br + 1;
9444                 } else {
9445                     regnode *opt;
9446                     for ( opt= br + 1; opt < ender ; opt++ )
9447                         OP(opt)= OPTIMIZED;
9448                     NEXT_OFF(br)= ender - br;
9449                 }
9450             }
9451         }
9452     }
9453
9454     {
9455         const char *p;
9456         static const char parens[] = "=!<,>";
9457
9458         if (paren && (p = strchr(parens, paren))) {
9459             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
9460             int flag = (p - parens) > 1;
9461
9462             if (paren == '>')
9463                 node = SUSPEND, flag = 0;
9464             reginsert(pRExC_state, node,ret, depth+1);
9465             Set_Node_Cur_Length(ret);
9466             Set_Node_Offset(ret, parse_start + 1);
9467             ret->flags = flag;
9468             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
9469         }
9470     }
9471
9472     /* Check for proper termination. */
9473     if (paren) {
9474         /* restore original flags, but keep (?p) */
9475         RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY);
9476         if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
9477             RExC_parse = oregcomp_parse;
9478             vFAIL("Unmatched (");
9479         }
9480     }
9481     else if (!paren && RExC_parse < RExC_end) {
9482         if (*RExC_parse == ')') {
9483             RExC_parse++;
9484             vFAIL("Unmatched )");
9485         }
9486         else
9487             FAIL("Junk on end of regexp");      /* "Can't happen". */
9488         assert(0); /* NOTREACHED */
9489     }
9490
9491     if (RExC_in_lookbehind) {
9492         RExC_in_lookbehind--;
9493     }
9494     if (after_freeze > RExC_npar)
9495         RExC_npar = after_freeze;
9496     return(ret);
9497 }
9498
9499 /*
9500  - regbranch - one alternative of an | operator
9501  *
9502  * Implements the concatenation operator.
9503  *
9504  * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
9505  * restarted.
9506  */
9507 STATIC regnode *
9508 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
9509 {
9510     dVAR;
9511     regnode *ret;
9512     regnode *chain = NULL;
9513     regnode *latest;
9514     I32 flags = 0, c = 0;
9515     GET_RE_DEBUG_FLAGS_DECL;
9516
9517     PERL_ARGS_ASSERT_REGBRANCH;
9518
9519     DEBUG_PARSE("brnc");
9520
9521     if (first)
9522         ret = NULL;
9523     else {
9524         if (!SIZE_ONLY && RExC_extralen)
9525             ret = reganode(pRExC_state, BRANCHJ,0);
9526         else {
9527             ret = reg_node(pRExC_state, BRANCH);
9528             Set_Node_Length(ret, 1);
9529         }
9530     }
9531
9532     if (!first && SIZE_ONLY)
9533         RExC_extralen += 1;                     /* BRANCHJ */
9534
9535     *flagp = WORST;                     /* Tentatively. */
9536
9537     RExC_parse--;
9538     nextchar(pRExC_state);
9539     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
9540         flags &= ~TRYAGAIN;
9541         latest = regpiece(pRExC_state, &flags,depth+1);
9542         if (latest == NULL) {
9543             if (flags & TRYAGAIN)
9544                 continue;
9545             if (flags & RESTART_UTF8) {
9546                 *flagp = RESTART_UTF8;
9547                 return NULL;
9548             }
9549             FAIL2("panic: regpiece returned NULL, flags=%#X", flags);
9550         }
9551         else if (ret == NULL)
9552             ret = latest;
9553         *flagp |= flags&(HASWIDTH|POSTPONED);
9554         if (chain == NULL)      /* First piece. */
9555             *flagp |= flags&SPSTART;
9556         else {
9557             RExC_naughty++;
9558             REGTAIL(pRExC_state, chain, latest);
9559         }
9560         chain = latest;
9561         c++;
9562     }
9563     if (chain == NULL) {        /* Loop ran zero times. */
9564         chain = reg_node(pRExC_state, NOTHING);
9565         if (ret == NULL)
9566             ret = chain;
9567     }
9568     if (c == 1) {
9569         *flagp |= flags&SIMPLE;
9570     }
9571
9572     return ret;
9573 }
9574
9575 /*
9576  - regpiece - something followed by possible [*+?]
9577  *
9578  * Note that the branching code sequences used for ? and the general cases
9579  * of * and + are somewhat optimized:  they use the same NOTHING node as
9580  * both the endmarker for their branch list and the body of the last branch.
9581  * It might seem that this node could be dispensed with entirely, but the
9582  * endmarker role is not redundant.
9583  *
9584  * Returns NULL, setting *flagp to TRYAGAIN if regatom() returns NULL with
9585  * TRYAGAIN.
9586  * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
9587  * restarted.
9588  */
9589 STATIC regnode *
9590 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
9591 {
9592     dVAR;
9593     regnode *ret;
9594     char op;
9595     char *next;
9596     I32 flags;
9597     const char * const origparse = RExC_parse;
9598     I32 min;
9599     I32 max = REG_INFTY;
9600 #ifdef RE_TRACK_PATTERN_OFFSETS
9601     char *parse_start;
9602 #endif
9603     const char *maxpos = NULL;
9604
9605     /* Save the original in case we change the emitted regop to a FAIL. */
9606     regnode * const orig_emit = RExC_emit;
9607
9608     GET_RE_DEBUG_FLAGS_DECL;
9609
9610     PERL_ARGS_ASSERT_REGPIECE;
9611
9612     DEBUG_PARSE("piec");
9613
9614     ret = regatom(pRExC_state, &flags,depth+1);
9615     if (ret == NULL) {
9616         if (flags & (TRYAGAIN|RESTART_UTF8))
9617             *flagp |= flags & (TRYAGAIN|RESTART_UTF8);
9618         else
9619             FAIL2("panic: regatom returned NULL, flags=%#X", flags);
9620         return(NULL);
9621     }
9622
9623     op = *RExC_parse;
9624
9625     if (op == '{' && regcurly(RExC_parse, FALSE)) {
9626         maxpos = NULL;
9627 #ifdef RE_TRACK_PATTERN_OFFSETS
9628         parse_start = RExC_parse; /* MJD */
9629 #endif
9630         next = RExC_parse + 1;
9631         while (isDIGIT(*next) || *next == ',') {
9632             if (*next == ',') {
9633                 if (maxpos)
9634                     break;
9635                 else
9636                     maxpos = next;
9637             }
9638             next++;
9639         }
9640         if (*next == '}') {             /* got one */
9641             if (!maxpos)
9642                 maxpos = next;
9643             RExC_parse++;
9644             min = atoi(RExC_parse);
9645             if (*maxpos == ',')
9646                 maxpos++;
9647             else
9648                 maxpos = RExC_parse;
9649             max = atoi(maxpos);
9650             if (!max && *maxpos != '0')
9651                 max = REG_INFTY;                /* meaning "infinity" */
9652             else if (max >= REG_INFTY)
9653                 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
9654             RExC_parse = next;
9655             nextchar(pRExC_state);
9656             if (max < min) {    /* If can't match, warn and optimize to fail
9657                                    unconditionally */
9658                 if (SIZE_ONLY) {
9659                     ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
9660
9661                     /* We can't back off the size because we have to reserve
9662                      * enough space for all the things we are about to throw
9663                      * away, but we can shrink it by the ammount we are about
9664                      * to re-use here */
9665                     RExC_size = PREVOPER(RExC_size) - regarglen[(U8)OPFAIL];
9666                 }
9667                 else {
9668                     RExC_emit = orig_emit;
9669                 }
9670                 ret = reg_node(pRExC_state, OPFAIL);
9671                 return ret;
9672             }
9673
9674         do_curly:
9675             if ((flags&SIMPLE)) {
9676                 RExC_naughty += 2 + RExC_naughty / 2;
9677                 reginsert(pRExC_state, CURLY, ret, depth+1);
9678                 Set_Node_Offset(ret, parse_start+1); /* MJD */
9679                 Set_Node_Cur_Length(ret);
9680             }
9681             else {
9682                 regnode * const w = reg_node(pRExC_state, WHILEM);
9683
9684                 w->flags = 0;
9685                 REGTAIL(pRExC_state, ret, w);
9686                 if (!SIZE_ONLY && RExC_extralen) {
9687                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
9688                     reginsert(pRExC_state, NOTHING,ret, depth+1);
9689                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
9690                 }
9691                 reginsert(pRExC_state, CURLYX,ret, depth+1);
9692                                 /* MJD hk */
9693                 Set_Node_Offset(ret, parse_start+1);
9694                 Set_Node_Length(ret,
9695                                 op == '{' ? (RExC_parse - parse_start) : 1);
9696
9697                 if (!SIZE_ONLY && RExC_extralen)
9698                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
9699                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
9700                 if (SIZE_ONLY)
9701                     RExC_whilem_seen++, RExC_extralen += 3;
9702                 RExC_naughty += 4 + RExC_naughty;       /* compound interest */
9703             }
9704             ret->flags = 0;
9705
9706             if (min > 0)
9707                 *flagp = WORST;
9708             if (max > 0)
9709                 *flagp |= HASWIDTH;
9710             if (!SIZE_ONLY) {
9711                 ARG1_SET(ret, (U16)min);
9712                 ARG2_SET(ret, (U16)max);
9713             }
9714
9715             goto nest_check;
9716         }
9717     }
9718
9719     if (!ISMULT1(op)) {
9720         *flagp = flags;
9721         return(ret);
9722     }
9723
9724 #if 0                           /* Now runtime fix should be reliable. */
9725
9726     /* if this is reinstated, don't forget to put this back into perldiag:
9727
9728             =item Regexp *+ operand could be empty at {#} in regex m/%s/
9729
9730            (F) The part of the regexp subject to either the * or + quantifier
9731            could match an empty string. The {#} shows in the regular
9732            expression about where the problem was discovered.
9733
9734     */
9735
9736     if (!(flags&HASWIDTH) && op != '?')
9737       vFAIL("Regexp *+ operand could be empty");
9738 #endif
9739
9740 #ifdef RE_TRACK_PATTERN_OFFSETS
9741     parse_start = RExC_parse;
9742 #endif
9743     nextchar(pRExC_state);
9744
9745     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
9746
9747     if (op == '*' && (flags&SIMPLE)) {
9748         reginsert(pRExC_state, STAR, ret, depth+1);
9749         ret->flags = 0;
9750         RExC_naughty += 4;
9751     }
9752     else if (op == '*') {
9753         min = 0;
9754         goto do_curly;
9755     }
9756     else if (op == '+' && (flags&SIMPLE)) {
9757         reginsert(pRExC_state, PLUS, ret, depth+1);
9758         ret->flags = 0;
9759         RExC_naughty += 3;
9760     }
9761     else if (op == '+') {
9762         min = 1;
9763         goto do_curly;
9764     }
9765     else if (op == '?') {
9766         min = 0; max = 1;
9767         goto do_curly;
9768     }
9769   nest_check:
9770     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
9771         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
9772         ckWARN3reg(RExC_parse,
9773                    "%.*s matches null string many times",
9774                    (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
9775                    origparse);
9776         (void)ReREFCNT_inc(RExC_rx_sv);
9777     }
9778
9779     if (RExC_parse < RExC_end && *RExC_parse == '?') {
9780         nextchar(pRExC_state);
9781         reginsert(pRExC_state, MINMOD, ret, depth+1);
9782         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
9783     }
9784 #ifndef REG_ALLOW_MINMOD_SUSPEND
9785     else
9786 #endif
9787     if (RExC_parse < RExC_end && *RExC_parse == '+') {
9788         regnode *ender;
9789         nextchar(pRExC_state);
9790         ender = reg_node(pRExC_state, SUCCEED);
9791         REGTAIL(pRExC_state, ret, ender);
9792         reginsert(pRExC_state, SUSPEND, ret, depth+1);
9793         ret->flags = 0;
9794         ender = reg_node(pRExC_state, TAIL);
9795         REGTAIL(pRExC_state, ret, ender);
9796         /*ret= ender;*/
9797     }
9798
9799     if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
9800         RExC_parse++;
9801         vFAIL("Nested quantifiers");
9802     }
9803
9804     return(ret);
9805 }
9806
9807 STATIC bool
9808 S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, UV *valuep, I32 *flagp, U32 depth, bool in_char_class,
9809         const bool strict   /* Apply stricter parsing rules? */
9810     )
9811 {
9812    
9813  /* This is expected to be called by a parser routine that has recognized '\N'
9814    and needs to handle the rest. RExC_parse is expected to point at the first
9815    char following the N at the time of the call.  On successful return,
9816    RExC_parse has been updated to point to just after the sequence identified
9817    by this routine, and <*flagp> has been updated.
9818
9819    The \N may be inside (indicated by the boolean <in_char_class>) or outside a
9820    character class.
9821
9822    \N may begin either a named sequence, or if outside a character class, mean
9823    to match a non-newline.  For non single-quoted regexes, the tokenizer has
9824    attempted to decide which, and in the case of a named sequence, converted it
9825    into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...},
9826    where c1... are the characters in the sequence.  For single-quoted regexes,
9827    the tokenizer passes the \N sequence through unchanged; this code will not
9828    attempt to determine this nor expand those, instead raising a syntax error.
9829    The net effect is that if the beginning of the passed-in pattern isn't '{U+'
9830    or there is no '}', it signals that this \N occurrence means to match a
9831    non-newline.
9832
9833    Only the \N{U+...} form should occur in a character class, for the same
9834    reason that '.' inside a character class means to just match a period: it
9835    just doesn't make sense.
9836
9837    The function raises an error (via vFAIL), and doesn't return for various
9838    syntax errors.  Otherwise it returns TRUE and sets <node_p> or <valuep> on
9839    success; it returns FALSE otherwise. Returns FALSE, setting *flagp to
9840    RESTART_UTF8 if the sizing scan needs to be restarted. Such a restart is
9841    only possible if node_p is non-NULL.
9842
9843
9844    If <valuep> is non-null, it means the caller can accept an input sequence
9845    consisting of a just a single code point; <*valuep> is set to that value
9846    if the input is such.
9847
9848    If <node_p> is non-null it signifies that the caller can accept any other
9849    legal sequence (i.e., one that isn't just a single code point).  <*node_p>
9850    is set as follows:
9851     1) \N means not-a-NL: points to a newly created REG_ANY node;
9852     2) \N{}:              points to a new NOTHING node;
9853     3) otherwise:         points to a new EXACT node containing the resolved
9854                           string.
9855    Note that FALSE is returned for single code point sequences if <valuep> is
9856    null.
9857  */
9858
9859     char * endbrace;    /* '}' following the name */
9860     char* p;
9861     char *endchar;      /* Points to '.' or '}' ending cur char in the input
9862                            stream */
9863     bool has_multiple_chars; /* true if the input stream contains a sequence of
9864                                 more than one character */
9865
9866     GET_RE_DEBUG_FLAGS_DECL;
9867  
9868     PERL_ARGS_ASSERT_GROK_BSLASH_N;
9869
9870     GET_RE_DEBUG_FLAGS;
9871
9872     assert(cBOOL(node_p) ^ cBOOL(valuep));  /* Exactly one should be set */
9873
9874     /* The [^\n] meaning of \N ignores spaces and comments under the /x
9875      * modifier.  The other meaning does not */
9876     p = (RExC_flags & RXf_PMf_EXTENDED)
9877         ? regwhite( pRExC_state, RExC_parse )
9878         : RExC_parse;
9879
9880     /* Disambiguate between \N meaning a named character versus \N meaning
9881      * [^\n].  The former is assumed when it can't be the latter. */
9882     if (*p != '{' || regcurly(p, FALSE)) {
9883         RExC_parse = p;
9884         if (! node_p) {
9885             /* no bare \N in a charclass */
9886             if (in_char_class) {
9887                 vFAIL("\\N in a character class must be a named character: \\N{...}");
9888             }
9889             return FALSE;
9890         }
9891         nextchar(pRExC_state);
9892         *node_p = reg_node(pRExC_state, REG_ANY);
9893         *flagp |= HASWIDTH|SIMPLE;
9894         RExC_naughty++;
9895         RExC_parse--;
9896         Set_Node_Length(*node_p, 1); /* MJD */
9897         return TRUE;
9898     }
9899
9900     /* Here, we have decided it should be a named character or sequence */
9901
9902     /* The test above made sure that the next real character is a '{', but
9903      * under the /x modifier, it could be separated by space (or a comment and
9904      * \n) and this is not allowed (for consistency with \x{...} and the
9905      * tokenizer handling of \N{NAME}). */
9906     if (*RExC_parse != '{') {
9907         vFAIL("Missing braces on \\N{}");
9908     }
9909
9910     RExC_parse++;       /* Skip past the '{' */
9911
9912     if (! (endbrace = strchr(RExC_parse, '}')) /* no trailing brace */
9913         || ! (endbrace == RExC_parse            /* nothing between the {} */
9914               || (endbrace - RExC_parse >= 2    /* U+ (bad hex is checked below */
9915                   && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg) */
9916     {
9917         if (endbrace) RExC_parse = endbrace;    /* position msg's '<--HERE' */
9918         vFAIL("\\N{NAME} must be resolved by the lexer");
9919     }
9920
9921     if (endbrace == RExC_parse) {   /* empty: \N{} */
9922         bool ret = TRUE;
9923         if (node_p) {
9924             *node_p = reg_node(pRExC_state,NOTHING);
9925         }
9926         else if (in_char_class) {
9927             if (SIZE_ONLY && in_char_class) {
9928                 if (strict) {
9929                     RExC_parse++;   /* Position after the "}" */
9930                     vFAIL("Zero length \\N{}");
9931                 }
9932                 else {
9933                     ckWARNreg(RExC_parse,
9934                               "Ignoring zero length \\N{} in character class");
9935                 }
9936             }
9937             ret = FALSE;
9938         }
9939         else {
9940             return FALSE;
9941         }
9942         nextchar(pRExC_state);
9943         return ret;
9944     }
9945
9946     RExC_uni_semantics = 1; /* Unicode named chars imply Unicode semantics */
9947     RExC_parse += 2;    /* Skip past the 'U+' */
9948
9949     endchar = RExC_parse + strcspn(RExC_parse, ".}");
9950
9951     /* Code points are separated by dots.  If none, there is only one code
9952      * point, and is terminated by the brace */
9953     has_multiple_chars = (endchar < endbrace);
9954
9955     if (valuep && (! has_multiple_chars || in_char_class)) {
9956         /* We only pay attention to the first char of
9957         multichar strings being returned in char classes. I kinda wonder
9958         if this makes sense as it does change the behaviour
9959         from earlier versions, OTOH that behaviour was broken
9960         as well. XXX Solution is to recharacterize as
9961         [rest-of-class]|multi1|multi2... */
9962
9963         STRLEN length_of_hex = (STRLEN)(endchar - RExC_parse);
9964         I32 grok_hex_flags = PERL_SCAN_ALLOW_UNDERSCORES
9965             | PERL_SCAN_DISALLOW_PREFIX
9966             | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
9967
9968         *valuep = grok_hex(RExC_parse, &length_of_hex, &grok_hex_flags, NULL);
9969
9970         /* The tokenizer should have guaranteed validity, but it's possible to
9971          * bypass it by using single quoting, so check */
9972         if (length_of_hex == 0
9973             || length_of_hex != (STRLEN)(endchar - RExC_parse) )
9974         {
9975             RExC_parse += length_of_hex;        /* Includes all the valid */
9976             RExC_parse += (RExC_orig_utf8)      /* point to after 1st invalid */
9977                             ? UTF8SKIP(RExC_parse)
9978                             : 1;
9979             /* Guard against malformed utf8 */
9980             if (RExC_parse >= endchar) {
9981                 RExC_parse = endchar;
9982             }
9983             vFAIL("Invalid hexadecimal number in \\N{U+...}");
9984         }
9985
9986         if (in_char_class && has_multiple_chars) {
9987             if (strict) {
9988                 RExC_parse = endbrace;
9989                 vFAIL("\\N{} in character class restricted to one character");
9990             }
9991             else {
9992                 ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
9993             }
9994         }
9995
9996         RExC_parse = endbrace + 1;
9997     }
9998     else if (! node_p || ! has_multiple_chars) {
9999
10000         /* Here, the input is legal, but not according to the caller's
10001          * options.  We fail without advancing the parse, so that the
10002          * caller can try again */
10003         RExC_parse = p;
10004         return FALSE;
10005     }
10006     else {
10007
10008         /* What is done here is to convert this to a sub-pattern of the form
10009          * (?:\x{char1}\x{char2}...)
10010          * and then call reg recursively.  That way, it retains its atomicness,
10011          * while not having to worry about special handling that some code
10012          * points may have.  toke.c has converted the original Unicode values
10013          * to native, so that we can just pass on the hex values unchanged.  We
10014          * do have to set a flag to keep recoding from happening in the
10015          * recursion */
10016
10017         SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP);
10018         STRLEN len;
10019         char *orig_end = RExC_end;
10020         I32 flags;
10021
10022         while (RExC_parse < endbrace) {
10023
10024             /* Convert to notation the rest of the code understands */
10025             sv_catpv(substitute_parse, "\\x{");
10026             sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
10027             sv_catpv(substitute_parse, "}");
10028
10029             /* Point to the beginning of the next character in the sequence. */
10030             RExC_parse = endchar + 1;
10031             endchar = RExC_parse + strcspn(RExC_parse, ".}");
10032         }
10033         sv_catpv(substitute_parse, ")");
10034
10035         RExC_parse = SvPV(substitute_parse, len);
10036
10037         /* Don't allow empty number */
10038         if (len < 8) {
10039             vFAIL("Invalid hexadecimal number in \\N{U+...}");
10040         }
10041         RExC_end = RExC_parse + len;
10042
10043         /* The values are Unicode, and therefore not subject to recoding */
10044         RExC_override_recoding = 1;
10045
10046         if (!(*node_p = reg(pRExC_state, 1, &flags, depth+1))) {
10047             if (flags & RESTART_UTF8) {
10048                 *flagp = RESTART_UTF8;
10049                 return FALSE;
10050             }
10051             FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#X",
10052                   flags);
10053         } 
10054         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
10055
10056         RExC_parse = endbrace;
10057         RExC_end = orig_end;
10058         RExC_override_recoding = 0;
10059
10060         nextchar(pRExC_state);
10061     }
10062
10063     return TRUE;
10064 }
10065
10066
10067 /*
10068  * reg_recode
10069  *
10070  * It returns the code point in utf8 for the value in *encp.
10071  *    value: a code value in the source encoding
10072  *    encp:  a pointer to an Encode object
10073  *
10074  * If the result from Encode is not a single character,
10075  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
10076  */
10077 STATIC UV
10078 S_reg_recode(pTHX_ const char value, SV **encp)
10079 {
10080     STRLEN numlen = 1;
10081     SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP);
10082     const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
10083     const STRLEN newlen = SvCUR(sv);
10084     UV uv = UNICODE_REPLACEMENT;
10085
10086     PERL_ARGS_ASSERT_REG_RECODE;
10087
10088     if (newlen)
10089         uv = SvUTF8(sv)
10090              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
10091              : *(U8*)s;
10092
10093     if (!newlen || numlen != newlen) {
10094         uv = UNICODE_REPLACEMENT;
10095         *encp = NULL;
10096     }
10097     return uv;
10098 }
10099
10100 PERL_STATIC_INLINE U8
10101 S_compute_EXACTish(pTHX_ RExC_state_t *pRExC_state)
10102 {
10103     U8 op;
10104
10105     PERL_ARGS_ASSERT_COMPUTE_EXACTISH;
10106
10107     if (! FOLD) {
10108         return EXACT;
10109     }
10110
10111     op = get_regex_charset(RExC_flags);
10112     if (op >= REGEX_ASCII_RESTRICTED_CHARSET) {
10113         op--; /* /a is same as /u, and map /aa's offset to what /a's would have
10114                  been, so there is no hole */
10115     }
10116
10117     return op + EXACTF;
10118 }
10119
10120 PERL_STATIC_INLINE void
10121 S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state, regnode *node, I32* flagp, STRLEN len, UV code_point)
10122 {
10123     /* This knows the details about sizing an EXACTish node, setting flags for
10124      * it (by setting <*flagp>, and potentially populating it with a single
10125      * character.
10126      *
10127      * If <len> (the length in bytes) is non-zero, this function assumes that
10128      * the node has already been populated, and just does the sizing.  In this
10129      * case <code_point> should be the final code point that has already been
10130      * placed into the node.  This value will be ignored except that under some
10131      * circumstances <*flagp> is set based on it.
10132      *
10133      * If <len> is zero, the function assumes that the node is to contain only
10134      * the single character given by <code_point> and calculates what <len>
10135      * should be.  In pass 1, it sizes the node appropriately.  In pass 2, it
10136      * additionally will populate the node's STRING with <code_point>, if <len>
10137      * is 0.  In both cases <*flagp> is appropriately set
10138      *
10139      * It knows that under FOLD, the Latin Sharp S and UTF characters above
10140      * 255, must be folded (the former only when the rules indicate it can
10141      * match 'ss') */
10142
10143     bool len_passed_in = cBOOL(len != 0);
10144     U8 character[UTF8_MAXBYTES_CASE+1];
10145
10146     PERL_ARGS_ASSERT_ALLOC_MAYBE_POPULATE_EXACT;
10147
10148     if (! len_passed_in) {
10149         if (UTF) {
10150             if (FOLD && (! LOC || code_point > 255)) {
10151                 _to_uni_fold_flags(NATIVE_TO_UNI(code_point),
10152                                    character,
10153                                    &len,
10154                                    FOLD_FLAGS_FULL | ((LOC)
10155                                                      ? FOLD_FLAGS_LOCALE
10156                                                      : (ASCII_FOLD_RESTRICTED)
10157                                                        ? FOLD_FLAGS_NOMIX_ASCII
10158                                                        : 0));
10159             }
10160             else {
10161                 uvchr_to_utf8( character, code_point);
10162                 len = UTF8SKIP(character);
10163             }
10164         }
10165         else if (! FOLD
10166                  || code_point != LATIN_SMALL_LETTER_SHARP_S
10167                  || ASCII_FOLD_RESTRICTED
10168                  || ! AT_LEAST_UNI_SEMANTICS)
10169         {
10170             *character = (U8) code_point;
10171             len = 1;
10172         }
10173         else {
10174             *character = 's';
10175             *(character + 1) = 's';
10176             len = 2;
10177         }
10178     }
10179
10180     if (SIZE_ONLY) {
10181         RExC_size += STR_SZ(len);
10182     }
10183     else {
10184         RExC_emit += STR_SZ(len);
10185         STR_LEN(node) = len;
10186         if (! len_passed_in) {
10187             Copy((char *) character, STRING(node), len, char);
10188         }
10189     }
10190
10191     *flagp |= HASWIDTH;
10192
10193     /* A single character node is SIMPLE, except for the special-cased SHARP S
10194      * under /di. */
10195     if ((len == 1 || (UTF && len == UNISKIP(code_point)))
10196         && (code_point != LATIN_SMALL_LETTER_SHARP_S
10197             || ! FOLD || ! DEPENDS_SEMANTICS))
10198     {
10199         *flagp |= SIMPLE;
10200     }
10201 }
10202
10203 /*
10204  - regatom - the lowest level
10205
10206    Try to identify anything special at the start of the pattern. If there
10207    is, then handle it as required. This may involve generating a single regop,
10208    such as for an assertion; or it may involve recursing, such as to
10209    handle a () structure.
10210
10211    If the string doesn't start with something special then we gobble up
10212    as much literal text as we can.
10213
10214    Once we have been able to handle whatever type of thing started the
10215    sequence, we return.
10216
10217    Note: we have to be careful with escapes, as they can be both literal
10218    and special, and in the case of \10 and friends, context determines which.
10219
10220    A summary of the code structure is:
10221
10222    switch (first_byte) {
10223         cases for each special:
10224             handle this special;
10225             break;
10226         case '\\':
10227             switch (2nd byte) {
10228                 cases for each unambiguous special:
10229                     handle this special;
10230                     break;
10231                 cases for each ambigous special/literal:
10232                     disambiguate;
10233                     if (special)  handle here
10234                     else goto defchar;
10235                 default: // unambiguously literal:
10236                     goto defchar;
10237             }
10238         default:  // is a literal char
10239             // FALL THROUGH
10240         defchar:
10241             create EXACTish node for literal;
10242             while (more input and node isn't full) {
10243                 switch (input_byte) {
10244                    cases for each special;
10245                        make sure parse pointer is set so that the next call to
10246                            regatom will see this special first
10247                        goto loopdone; // EXACTish node terminated by prev. char
10248                    default:
10249                        append char to EXACTISH node;
10250                 }
10251                 get next input byte;
10252             }
10253         loopdone:
10254    }
10255    return the generated node;
10256
10257    Specifically there are two separate switches for handling
10258    escape sequences, with the one for handling literal escapes requiring
10259    a dummy entry for all of the special escapes that are actually handled
10260    by the other.
10261
10262    Returns NULL, setting *flagp to TRYAGAIN if reg() returns NULL with
10263    TRYAGAIN.  
10264    Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
10265    restarted.
10266    Otherwise does not return NULL.
10267 */
10268
10269 STATIC regnode *
10270 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
10271 {
10272     dVAR;
10273     regnode *ret = NULL;
10274     I32 flags = 0;
10275     char *parse_start = RExC_parse;
10276     U8 op;
10277     int invert = 0;
10278
10279     GET_RE_DEBUG_FLAGS_DECL;
10280
10281     *flagp = WORST;             /* Tentatively. */
10282
10283     DEBUG_PARSE("atom");
10284
10285     PERL_ARGS_ASSERT_REGATOM;
10286
10287 tryagain:
10288     switch ((U8)*RExC_parse) {
10289     case '^':
10290         RExC_seen_zerolen++;
10291         nextchar(pRExC_state);
10292         if (RExC_flags & RXf_PMf_MULTILINE)
10293             ret = reg_node(pRExC_state, MBOL);
10294         else if (RExC_flags & RXf_PMf_SINGLELINE)
10295             ret = reg_node(pRExC_state, SBOL);
10296         else
10297             ret = reg_node(pRExC_state, BOL);
10298         Set_Node_Length(ret, 1); /* MJD */
10299         break;
10300     case '$':
10301         nextchar(pRExC_state);
10302         if (*RExC_parse)
10303             RExC_seen_zerolen++;
10304         if (RExC_flags & RXf_PMf_MULTILINE)
10305             ret = reg_node(pRExC_state, MEOL);
10306         else if (RExC_flags & RXf_PMf_SINGLELINE)
10307             ret = reg_node(pRExC_state, SEOL);
10308         else
10309             ret = reg_node(pRExC_state, EOL);
10310         Set_Node_Length(ret, 1); /* MJD */
10311         break;
10312     case '.':
10313         nextchar(pRExC_state);
10314         if (RExC_flags & RXf_PMf_SINGLELINE)
10315             ret = reg_node(pRExC_state, SANY);
10316         else
10317             ret = reg_node(pRExC_state, REG_ANY);
10318         *flagp |= HASWIDTH|SIMPLE;
10319         RExC_naughty++;
10320         Set_Node_Length(ret, 1); /* MJD */
10321         break;
10322     case '[':
10323     {
10324         char * const oregcomp_parse = ++RExC_parse;
10325         ret = regclass(pRExC_state, flagp,depth+1,
10326                        FALSE, /* means parse the whole char class */
10327                        TRUE, /* allow multi-char folds */
10328                        FALSE, /* don't silence non-portable warnings. */
10329                        NULL);
10330         if (*RExC_parse != ']') {
10331             RExC_parse = oregcomp_parse;
10332             vFAIL("Unmatched [");
10333         }
10334         if (ret == NULL) {
10335             if (*flagp & RESTART_UTF8)
10336                 return NULL;
10337             FAIL2("panic: regclass returned NULL to regatom, flags=%#X",
10338                   *flagp);
10339         }
10340         nextchar(pRExC_state);
10341         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
10342         break;
10343     }
10344     case '(':
10345         nextchar(pRExC_state);
10346         ret = reg(pRExC_state, 2, &flags,depth+1);
10347         if (ret == NULL) {
10348                 if (flags & TRYAGAIN) {
10349                     if (RExC_parse == RExC_end) {
10350                          /* Make parent create an empty node if needed. */
10351                         *flagp |= TRYAGAIN;
10352                         return(NULL);
10353                     }
10354                     goto tryagain;
10355                 }
10356                 if (flags & RESTART_UTF8) {
10357                     *flagp = RESTART_UTF8;
10358                     return NULL;
10359                 }
10360                 FAIL2("panic: reg returned NULL to regatom, flags=%#X", flags);
10361         }
10362         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
10363         break;
10364     case '|':
10365     case ')':
10366         if (flags & TRYAGAIN) {
10367             *flagp |= TRYAGAIN;
10368             return NULL;
10369         }
10370         vFAIL("Internal urp");
10371                                 /* Supposed to be caught earlier. */
10372         break;
10373     case '{':
10374         if (!regcurly(RExC_parse, FALSE)) {
10375             RExC_parse++;
10376             goto defchar;
10377         }
10378         /* FALL THROUGH */
10379     case '?':
10380     case '+':
10381     case '*':
10382         RExC_parse++;
10383         vFAIL("Quantifier follows nothing");
10384         break;
10385     case '\\':
10386         /* Special Escapes
10387
10388            This switch handles escape sequences that resolve to some kind
10389            of special regop and not to literal text. Escape sequnces that
10390            resolve to literal text are handled below in the switch marked
10391            "Literal Escapes".
10392
10393            Every entry in this switch *must* have a corresponding entry
10394            in the literal escape switch. However, the opposite is not
10395            required, as the default for this switch is to jump to the
10396            literal text handling code.
10397         */
10398         switch ((U8)*++RExC_parse) {
10399             U8 arg;
10400         /* Special Escapes */
10401         case 'A':
10402             RExC_seen_zerolen++;
10403             ret = reg_node(pRExC_state, SBOL);
10404             *flagp |= SIMPLE;
10405             goto finish_meta_pat;
10406         case 'G':
10407             ret = reg_node(pRExC_state, GPOS);
10408             RExC_seen |= REG_SEEN_GPOS;
10409             *flagp |= SIMPLE;
10410             goto finish_meta_pat;
10411         case 'K':
10412             RExC_seen_zerolen++;
10413             ret = reg_node(pRExC_state, KEEPS);
10414             *flagp |= SIMPLE;
10415             /* XXX:dmq : disabling in-place substitution seems to
10416              * be necessary here to avoid cases of memory corruption, as
10417              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
10418              */
10419             RExC_seen |= REG_SEEN_LOOKBEHIND;
10420             goto finish_meta_pat;
10421         case 'Z':
10422             ret = reg_node(pRExC_state, SEOL);
10423             *flagp |= SIMPLE;
10424             RExC_seen_zerolen++;                /* Do not optimize RE away */
10425             goto finish_meta_pat;
10426         case 'z':
10427             ret = reg_node(pRExC_state, EOS);
10428             *flagp |= SIMPLE;
10429             RExC_seen_zerolen++;                /* Do not optimize RE away */
10430             goto finish_meta_pat;
10431         case 'C':
10432             ret = reg_node(pRExC_state, CANY);
10433             RExC_seen |= REG_SEEN_CANY;
10434             *flagp |= HASWIDTH|SIMPLE;
10435             goto finish_meta_pat;
10436         case 'X':
10437             ret = reg_node(pRExC_state, CLUMP);
10438             *flagp |= HASWIDTH;
10439             goto finish_meta_pat;
10440
10441         case 'W':
10442             invert = 1;
10443             /* FALLTHROUGH */
10444         case 'w':
10445             arg = ANYOF_WORDCHAR;
10446             goto join_posix;
10447
10448         case 'b':
10449             RExC_seen_zerolen++;
10450             RExC_seen |= REG_SEEN_LOOKBEHIND;
10451             op = BOUND + get_regex_charset(RExC_flags);
10452             if (op > BOUNDA) {  /* /aa is same as /a */
10453                 op = BOUNDA;
10454             }
10455             ret = reg_node(pRExC_state, op);
10456             FLAGS(ret) = get_regex_charset(RExC_flags);
10457             *flagp |= SIMPLE;
10458             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
10459                 ckWARNdep(RExC_parse, "\"\\b{\" is deprecated; use \"\\b\\{\" or \"\\b[{]\" instead");
10460             }
10461             goto finish_meta_pat;
10462         case 'B':
10463             RExC_seen_zerolen++;
10464             RExC_seen |= REG_SEEN_LOOKBEHIND;
10465             op = NBOUND + get_regex_charset(RExC_flags);
10466             if (op > NBOUNDA) { /* /aa is same as /a */
10467                 op = NBOUNDA;
10468             }
10469             ret = reg_node(pRExC_state, op);
10470             FLAGS(ret) = get_regex_charset(RExC_flags);
10471             *flagp |= SIMPLE;
10472             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
10473                 ckWARNdep(RExC_parse, "\"\\B{\" is deprecated; use \"\\B\\{\" or \"\\B[{]\" instead");
10474             }
10475             goto finish_meta_pat;
10476
10477         case 'D':
10478             invert = 1;
10479             /* FALLTHROUGH */
10480         case 'd':
10481             arg = ANYOF_DIGIT;
10482             goto join_posix;
10483
10484         case 'R':
10485             ret = reg_node(pRExC_state, LNBREAK);
10486             *flagp |= HASWIDTH|SIMPLE;
10487             goto finish_meta_pat;
10488
10489         case 'H':
10490             invert = 1;
10491             /* FALLTHROUGH */
10492         case 'h':
10493             arg = ANYOF_BLANK;
10494             op = POSIXU;
10495             goto join_posix_op_known;
10496
10497         case 'V':
10498             invert = 1;
10499             /* FALLTHROUGH */
10500         case 'v':
10501             arg = ANYOF_VERTWS;
10502             op = POSIXU;
10503             goto join_posix_op_known;
10504
10505         case 'S':
10506             invert = 1;
10507             /* FALLTHROUGH */
10508         case 's':
10509             arg = ANYOF_SPACE;
10510
10511         join_posix:
10512
10513             op = POSIXD + get_regex_charset(RExC_flags);
10514             if (op > POSIXA) {  /* /aa is same as /a */
10515                 op = POSIXA;
10516             }
10517
10518         join_posix_op_known:
10519
10520             if (invert) {
10521                 op += NPOSIXD - POSIXD;
10522             }
10523
10524             ret = reg_node(pRExC_state, op);
10525             if (! SIZE_ONLY) {
10526                 FLAGS(ret) = namedclass_to_classnum(arg);
10527             }
10528
10529             *flagp |= HASWIDTH|SIMPLE;
10530             /* FALL THROUGH */
10531
10532          finish_meta_pat:           
10533             nextchar(pRExC_state);
10534             Set_Node_Length(ret, 2); /* MJD */
10535             break;          
10536         case 'p':
10537         case 'P':
10538             {
10539 #ifdef DEBUGGING
10540                 char* parse_start = RExC_parse - 2;
10541 #endif
10542
10543                 RExC_parse--;
10544
10545                 ret = regclass(pRExC_state, flagp,depth+1,
10546                                TRUE, /* means just parse this element */
10547                                FALSE, /* don't allow multi-char folds */
10548                                FALSE, /* don't silence non-portable warnings.
10549                                          It would be a bug if these returned
10550                                          non-portables */
10551                                NULL);
10552                 /* regclass() can only return RESTART_UTF8 if multi-char folds
10553                    are allowed.  */
10554                 if (!ret)
10555                     FAIL2("panic: regclass returned NULL to regatom, flags=%#X",
10556                           *flagp);
10557
10558                 RExC_parse--;
10559
10560                 Set_Node_Offset(ret, parse_start + 2);
10561                 Set_Node_Cur_Length(ret);
10562                 nextchar(pRExC_state);
10563             }
10564             break;
10565         case 'N': 
10566             /* Handle \N and \N{NAME} with multiple code points here and not
10567              * below because it can be multicharacter. join_exact() will join
10568              * them up later on.  Also this makes sure that things like
10569              * /\N{BLAH}+/ and \N{BLAH} being multi char Just Happen. dmq.
10570              * The options to the grok function call causes it to fail if the
10571              * sequence is just a single code point.  We then go treat it as
10572              * just another character in the current EXACT node, and hence it
10573              * gets uniform treatment with all the other characters.  The
10574              * special treatment for quantifiers is not needed for such single
10575              * character sequences */
10576             ++RExC_parse;
10577             if (! grok_bslash_N(pRExC_state, &ret, NULL, flagp, depth, FALSE,
10578                                 FALSE /* not strict */ )) {
10579                 if (*flagp & RESTART_UTF8)
10580                     return NULL;
10581                 RExC_parse--;
10582                 goto defchar;
10583             }
10584             break;
10585         case 'k':    /* Handle \k<NAME> and \k'NAME' */
10586         parse_named_seq:
10587         {   
10588             char ch= RExC_parse[1];         
10589             if (ch != '<' && ch != '\'' && ch != '{') {
10590                 RExC_parse++;
10591                 vFAIL2("Sequence %.2s... not terminated",parse_start);
10592             } else {
10593                 /* this pretty much dupes the code for (?P=...) in reg(), if
10594                    you change this make sure you change that */
10595                 char* name_start = (RExC_parse += 2);
10596                 U32 num = 0;
10597                 SV *sv_dat = reg_scan_name(pRExC_state,
10598                     SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
10599                 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
10600                 if (RExC_parse == name_start || *RExC_parse != ch)
10601                     vFAIL2("Sequence %.3s... not terminated",parse_start);
10602
10603                 if (!SIZE_ONLY) {
10604                     num = add_data( pRExC_state, 1, "S" );
10605                     RExC_rxi->data->data[num]=(void*)sv_dat;
10606                     SvREFCNT_inc_simple_void(sv_dat);
10607                 }
10608
10609                 RExC_sawback = 1;
10610                 ret = reganode(pRExC_state,
10611                                ((! FOLD)
10612                                  ? NREF
10613                                  : (ASCII_FOLD_RESTRICTED)
10614                                    ? NREFFA
10615                                    : (AT_LEAST_UNI_SEMANTICS)
10616                                      ? NREFFU
10617                                      : (LOC)
10618                                        ? NREFFL
10619                                        : NREFF),
10620                                 num);
10621                 *flagp |= HASWIDTH;
10622
10623                 /* override incorrect value set in reganode MJD */
10624                 Set_Node_Offset(ret, parse_start+1);
10625                 Set_Node_Cur_Length(ret); /* MJD */
10626                 nextchar(pRExC_state);
10627
10628             }
10629             break;
10630         }
10631         case 'g': 
10632         case '1': case '2': case '3': case '4':
10633         case '5': case '6': case '7': case '8': case '9':
10634             {
10635                 I32 num;
10636                 bool isg = *RExC_parse == 'g';
10637                 bool isrel = 0; 
10638                 bool hasbrace = 0;
10639                 if (isg) {
10640                     RExC_parse++;
10641                     if (*RExC_parse == '{') {
10642                         RExC_parse++;
10643                         hasbrace = 1;
10644                     }
10645                     if (*RExC_parse == '-') {
10646                         RExC_parse++;
10647                         isrel = 1;
10648                     }
10649                     if (hasbrace && !isDIGIT(*RExC_parse)) {
10650                         if (isrel) RExC_parse--;
10651                         RExC_parse -= 2;                            
10652                         goto parse_named_seq;
10653                 }   }
10654                 num = atoi(RExC_parse);
10655                 if (isg && num == 0)
10656                     vFAIL("Reference to invalid group 0");
10657                 if (isrel) {
10658                     num = RExC_npar - num;
10659                     if (num < 1)
10660                         vFAIL("Reference to nonexistent or unclosed group");
10661                 }
10662                 if (!isg && num > 9 && num >= RExC_npar)
10663                     /* Probably a character specified in octal, e.g. \35 */
10664                     goto defchar;
10665                 else {
10666                     char * const parse_start = RExC_parse - 1; /* MJD */
10667                     while (isDIGIT(*RExC_parse))
10668                         RExC_parse++;
10669                     if (parse_start == RExC_parse - 1) 
10670                         vFAIL("Unterminated \\g... pattern");
10671                     if (hasbrace) {
10672                         if (*RExC_parse != '}') 
10673                             vFAIL("Unterminated \\g{...} pattern");
10674                         RExC_parse++;
10675                     }    
10676                     if (!SIZE_ONLY) {
10677                         if (num > (I32)RExC_rx->nparens)
10678                             vFAIL("Reference to nonexistent group");
10679                     }
10680                     RExC_sawback = 1;
10681                     ret = reganode(pRExC_state,
10682                                    ((! FOLD)
10683                                      ? REF
10684                                      : (ASCII_FOLD_RESTRICTED)
10685                                        ? REFFA
10686                                        : (AT_LEAST_UNI_SEMANTICS)
10687                                          ? REFFU
10688                                          : (LOC)
10689                                            ? REFFL
10690                                            : REFF),
10691                                     num);
10692                     *flagp |= HASWIDTH;
10693
10694                     /* override incorrect value set in reganode MJD */
10695                     Set_Node_Offset(ret, parse_start+1);
10696                     Set_Node_Cur_Length(ret); /* MJD */
10697                     RExC_parse--;
10698                     nextchar(pRExC_state);
10699                 }
10700             }
10701             break;
10702         case '\0':
10703             if (RExC_parse >= RExC_end)
10704                 FAIL("Trailing \\");
10705             /* FALL THROUGH */
10706         default:
10707             /* Do not generate "unrecognized" warnings here, we fall
10708                back into the quick-grab loop below */
10709             parse_start--;
10710             goto defchar;
10711         }
10712         break;
10713
10714     case '#':
10715         if (RExC_flags & RXf_PMf_EXTENDED) {
10716             if ( reg_skipcomment( pRExC_state ) )
10717                 goto tryagain;
10718         }
10719         /* FALL THROUGH */
10720
10721     default:
10722
10723             parse_start = RExC_parse - 1;
10724
10725             RExC_parse++;
10726
10727         defchar: {
10728             STRLEN len = 0;
10729             UV ender;
10730             char *p;
10731             char *s;
10732 #define MAX_NODE_STRING_SIZE 127
10733             char foldbuf[MAX_NODE_STRING_SIZE+UTF8_MAXBYTES_CASE];
10734             char *s0;
10735             U8 upper_parse = MAX_NODE_STRING_SIZE;
10736             STRLEN foldlen;
10737             U8 node_type;
10738             bool next_is_quantifier;
10739             char * oldp = NULL;
10740
10741             /* If a folding node contains only code points that don't
10742              * participate in folds, it can be changed into an EXACT node,
10743              * which allows the optimizer more things to look for */
10744             bool maybe_exact;
10745
10746             ender = 0;
10747             node_type = compute_EXACTish(pRExC_state);
10748             ret = reg_node(pRExC_state, node_type);
10749
10750             /* In pass1, folded, we use a temporary buffer instead of the
10751              * actual node, as the node doesn't exist yet */
10752             s = (SIZE_ONLY && FOLD) ? foldbuf : STRING(ret);
10753
10754             s0 = s;
10755
10756         reparse:
10757
10758             /* We do the EXACTFish to EXACT node only if folding, and not if in
10759              * locale, as whether a character folds or not isn't known until
10760              * runtime */
10761             maybe_exact = FOLD && ! LOC;
10762
10763             /* XXX The node can hold up to 255 bytes, yet this only goes to
10764              * 127.  I (khw) do not know why.  Keeping it somewhat less than
10765              * 255 allows us to not have to worry about overflow due to
10766              * converting to utf8 and fold expansion, but that value is
10767              * 255-UTF8_MAXBYTES_CASE.  join_exact() may join adjacent nodes
10768              * split up by this limit into a single one using the real max of
10769              * 255.  Even at 127, this breaks under rare circumstances.  If
10770              * folding, we do not want to split a node at a character that is a
10771              * non-final in a multi-char fold, as an input string could just
10772              * happen to want to match across the node boundary.  The join
10773              * would solve that problem if the join actually happens.  But a
10774              * series of more than two nodes in a row each of 127 would cause
10775              * the first join to succeed to get to 254, but then there wouldn't
10776              * be room for the next one, which could at be one of those split
10777              * multi-char folds.  I don't know of any fool-proof solution.  One
10778              * could back off to end with only a code point that isn't such a
10779              * non-final, but it is possible for there not to be any in the
10780              * entire node. */
10781             for (p = RExC_parse - 1;
10782                  len < upper_parse && p < RExC_end;
10783                  len++)
10784             {
10785                 oldp = p;
10786
10787                 if (RExC_flags & RXf_PMf_EXTENDED)
10788                     p = regwhite( pRExC_state, p );
10789                 switch ((U8)*p) {
10790                 case '^':
10791                 case '$':
10792                 case '.':
10793                 case '[':
10794                 case '(':
10795                 case ')':
10796                 case '|':
10797                     goto loopdone;
10798                 case '\\':
10799                     /* Literal Escapes Switch
10800
10801                        This switch is meant to handle escape sequences that
10802                        resolve to a literal character.
10803
10804                        Every escape sequence that represents something
10805                        else, like an assertion or a char class, is handled
10806                        in the switch marked 'Special Escapes' above in this
10807                        routine, but also has an entry here as anything that
10808                        isn't explicitly mentioned here will be treated as
10809                        an unescaped equivalent literal.
10810                     */
10811
10812                     switch ((U8)*++p) {
10813                     /* These are all the special escapes. */
10814                     case 'A':             /* Start assertion */
10815                     case 'b': case 'B':   /* Word-boundary assertion*/
10816                     case 'C':             /* Single char !DANGEROUS! */
10817                     case 'd': case 'D':   /* digit class */
10818                     case 'g': case 'G':   /* generic-backref, pos assertion */
10819                     case 'h': case 'H':   /* HORIZWS */
10820                     case 'k': case 'K':   /* named backref, keep marker */
10821                     case 'p': case 'P':   /* Unicode property */
10822                               case 'R':   /* LNBREAK */
10823                     case 's': case 'S':   /* space class */
10824                     case 'v': case 'V':   /* VERTWS */
10825                     case 'w': case 'W':   /* word class */
10826                     case 'X':             /* eXtended Unicode "combining character sequence" */
10827                     case 'z': case 'Z':   /* End of line/string assertion */
10828                         --p;
10829                         goto loopdone;
10830
10831                     /* Anything after here is an escape that resolves to a
10832                        literal. (Except digits, which may or may not)
10833                      */
10834                     case 'n':
10835                         ender = '\n';
10836                         p++;
10837                         break;
10838                     case 'N': /* Handle a single-code point named character. */
10839                         /* The options cause it to fail if a multiple code
10840                          * point sequence.  Handle those in the switch() above
10841                          * */
10842                         RExC_parse = p + 1;
10843                         if (! grok_bslash_N(pRExC_state, NULL, &ender,
10844                                             flagp, depth, FALSE,
10845                                             FALSE /* not strict */ ))
10846                         {
10847                             if (*flagp & RESTART_UTF8)
10848                                 FAIL("panic: grok_bslash_N set RESTART_UTF8");
10849                             RExC_parse = p = oldp;
10850                             goto loopdone;
10851                         }
10852                         p = RExC_parse;
10853                         if (ender > 0xff) {
10854                             REQUIRE_UTF8;
10855                         }
10856                         break;
10857                     case 'r':
10858                         ender = '\r';
10859                         p++;
10860                         break;
10861                     case 't':
10862                         ender = '\t';
10863                         p++;
10864                         break;
10865                     case 'f':
10866                         ender = '\f';
10867                         p++;
10868                         break;
10869                     case 'e':
10870                           ender = ASCII_TO_NATIVE('\033');
10871                         p++;
10872                         break;
10873                     case 'a':
10874                           ender = ASCII_TO_NATIVE('\007');
10875                         p++;
10876                         break;
10877                     case 'o':
10878                         {
10879                             UV result;
10880                             const char* error_msg;
10881
10882                             bool valid = grok_bslash_o(&p,
10883                                                        &result,
10884                                                        &error_msg,
10885                                                        TRUE, /* out warnings */
10886                                                        FALSE, /* not strict */
10887                                                        TRUE, /* Output warnings
10888                                                                 for non-
10889                                                                 portables */
10890                                                        UTF);
10891                             if (! valid) {
10892                                 RExC_parse = p; /* going to die anyway; point
10893                                                    to exact spot of failure */
10894                                 vFAIL(error_msg);
10895                             }
10896                             ender = result;
10897                             if (PL_encoding && ender < 0x100) {
10898                                 goto recode_encoding;
10899                             }
10900                             if (ender > 0xff) {
10901                                 REQUIRE_UTF8;
10902                             }
10903                             break;
10904                         }
10905                     case 'x':
10906                         {
10907                             UV result = UV_MAX; /* initialize to erroneous
10908                                                    value */
10909                             const char* error_msg;
10910
10911                             bool valid = grok_bslash_x(&p,
10912                                                        &result,
10913                                                        &error_msg,
10914                                                        TRUE, /* out warnings */
10915                                                        FALSE, /* not strict */
10916                                                        TRUE, /* Output warnings
10917                                                                 for non-
10918                                                                 portables */
10919                                                        UTF);
10920                             if (! valid) {
10921                                 RExC_parse = p; /* going to die anyway; point
10922                                                    to exact spot of failure */
10923                                 vFAIL(error_msg);
10924                             }
10925                             ender = result;
10926
10927                             if (PL_encoding && ender < 0x100) {
10928                                 goto recode_encoding;
10929                             }
10930                             if (ender > 0xff) {
10931                                 REQUIRE_UTF8;
10932                             }
10933                             break;
10934                         }
10935                     case 'c':
10936                         p++;
10937                         ender = grok_bslash_c(*p++, UTF, SIZE_ONLY);
10938                         break;
10939                     case '0': case '1': case '2': case '3':case '4':
10940                     case '5': case '6': case '7':
10941                         if (*p == '0' ||
10942                             (isDIGIT(p[1]) && atoi(p) >= RExC_npar))
10943                         {
10944                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
10945                             STRLEN numlen = 3;
10946                             ender = grok_oct(p, &numlen, &flags, NULL);
10947                             if (ender > 0xff) {
10948                                 REQUIRE_UTF8;
10949                             }
10950                             p += numlen;
10951                             if (SIZE_ONLY   /* like \08, \178 */
10952                                 && numlen < 3
10953                                 && p < RExC_end
10954                                 && isDIGIT(*p) && ckWARN(WARN_REGEXP))
10955                             {
10956                                 reg_warn_non_literal_string(
10957                                          p + 1,
10958                                          form_short_octal_warning(p, numlen));
10959                             }
10960                         }
10961                         else {  /* Not to be treated as an octal constant, go
10962                                    find backref */
10963                             --p;
10964                             goto loopdone;
10965                         }
10966                         if (PL_encoding && ender < 0x100)
10967                             goto recode_encoding;
10968                         break;
10969                     case '8': case '9': /* These are illegal unless backrefs */
10970                         if (atoi(p) <= RExC_npar) {
10971                             --p;   /* backup to backslash; handle as backref */
10972                             goto loopdone;
10973                         }
10974                         goto unrecognized;
10975                     recode_encoding:
10976                         if (! RExC_override_recoding) {
10977                             SV* enc = PL_encoding;
10978                             ender = reg_recode((const char)(U8)ender, &enc);
10979                             if (!enc && SIZE_ONLY)
10980                                 ckWARNreg(p, "Invalid escape in the specified encoding");
10981                             REQUIRE_UTF8;
10982                         }
10983                         break;
10984                     case '\0':
10985                         if (p >= RExC_end)
10986                             FAIL("Trailing \\");
10987                         /* FALL THROUGH */
10988                     default:
10989                     unrecognized:
10990                         if (!SIZE_ONLY&& isALPHANUMERIC(*p)) {
10991                             /* Include any { following the alpha to emphasize
10992                              * that it could be part of an escape at some point
10993                              * in the future */
10994                             int len = (isALPHA(*p) && *(p + 1) == '{') ? 2 : 1;
10995                             ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
10996                         }
10997                         goto normal_default;
10998                     } /* End of switch on '\' */
10999                     break;
11000                 default:    /* A literal character */
11001
11002                     if (! SIZE_ONLY
11003                         && RExC_flags & RXf_PMf_EXTENDED
11004                         && ckWARN(WARN_DEPRECATED)
11005                         && is_PATWS_non_low(p, UTF))
11006                     {
11007                         vWARN_dep(p + ((UTF) ? UTF8SKIP(p) : 1),
11008                                 "Escape literal pattern white space under /x");
11009                     }
11010
11011                   normal_default:
11012                     if (UTF8_IS_START(*p) && UTF) {
11013                         STRLEN numlen;
11014                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
11015                                                &numlen, UTF8_ALLOW_DEFAULT);
11016                         p += numlen;
11017                     }
11018                     else
11019                         ender = (U8) *p++;
11020                     break;
11021                 } /* End of switch on the literal */
11022
11023                 /* Here, have looked at the literal character and <ender>
11024                  * contains its ordinal, <p> points to the character after it
11025                  */
11026
11027                 if ( RExC_flags & RXf_PMf_EXTENDED)
11028                     p = regwhite( pRExC_state, p );
11029
11030                 /* If the next thing is a quantifier, it applies to this
11031                  * character only, which means that this character has to be in
11032                  * its own node and can't just be appended to the string in an
11033                  * existing node, so if there are already other characters in
11034                  * the node, close the node with just them, and set up to do
11035                  * this character again next time through, when it will be the
11036                  * only thing in its new node */
11037                 if ((next_is_quantifier = (p < RExC_end && ISMULT2(p))) && len)
11038                 {
11039                     p = oldp;
11040                     goto loopdone;
11041                 }
11042
11043                 if (FOLD) {
11044                     if (UTF
11045                             /* See comments for join_exact() as to why we fold
11046                              * this non-UTF at compile time */
11047                         || (node_type == EXACTFU
11048                             && ender == LATIN_SMALL_LETTER_SHARP_S))
11049                     {
11050
11051
11052                         /* Prime the casefolded buffer.  Locale rules, which
11053                          * apply only to code points < 256, aren't known until
11054                          * execution, so for them, just output the original
11055                          * character using utf8.  If we start to fold non-UTF
11056                          * patterns, be sure to update join_exact() */
11057                         if (LOC && ender < 256) {
11058                             if (UNI_IS_INVARIANT(ender)) {
11059                                 *s = (U8) ender;
11060                                 foldlen = 1;
11061                             } else {
11062                                 *s = UTF8_TWO_BYTE_HI(ender);
11063                                 *(s + 1) = UTF8_TWO_BYTE_LO(ender);
11064                                 foldlen = 2;
11065                             }
11066                         }
11067                         else {
11068                             UV folded = _to_uni_fold_flags(
11069                                            ender,
11070                                            (U8 *) s,
11071                                            &foldlen,
11072                                            FOLD_FLAGS_FULL
11073                                            | ((LOC) ?  FOLD_FLAGS_LOCALE
11074                                                     : (ASCII_FOLD_RESTRICTED)
11075                                                       ? FOLD_FLAGS_NOMIX_ASCII
11076                                                       : 0)
11077                                             );
11078
11079                             /* If this node only contains non-folding code
11080                              * points so far, see if this new one is also
11081                              * non-folding */
11082                             if (maybe_exact) {
11083                                 if (folded != ender) {
11084                                     maybe_exact = FALSE;
11085                                 }
11086                                 else {
11087                                     /* Here the fold is the original; we have
11088                                      * to check further to see if anything
11089                                      * folds to it */
11090                                     if (! PL_utf8_foldable) {
11091                                         SV* swash = swash_init("utf8",
11092                                                            "_Perl_Any_Folds",
11093                                                            &PL_sv_undef, 1, 0);
11094                                         PL_utf8_foldable =
11095                                                     _get_swash_invlist(swash);
11096                                         SvREFCNT_dec_NN(swash);
11097                                     }
11098                                     if (_invlist_contains_cp(PL_utf8_foldable,
11099                                                              ender))
11100                                     {
11101                                         maybe_exact = FALSE;
11102                                     }
11103                                 }
11104                             }
11105                             ender = folded;
11106                         }
11107                         s += foldlen;
11108
11109                         /* The loop increments <len> each time, as all but this
11110                          * path (and the one just below for UTF) through it add
11111                          * a single byte to the EXACTish node.  But this one
11112                          * has changed len to be the correct final value, so
11113                          * subtract one to cancel out the increment that
11114                          * follows */
11115                         len += foldlen - 1;
11116                     }
11117                     else {
11118                         *(s++) = (char) ender;
11119                         maybe_exact &= ! IS_IN_SOME_FOLD_L1(ender);
11120                     }
11121                 }
11122                 else if (UTF) {
11123                     const STRLEN unilen = reguni(pRExC_state, ender, s);
11124                     if (unilen > 0) {
11125                        s   += unilen;
11126                        len += unilen;
11127                     }
11128
11129                     /* See comment just above for - 1 */
11130                     len--;
11131                 }
11132                 else {
11133                     REGC((char)ender, s++);
11134                 }
11135
11136                 if (next_is_quantifier) {
11137
11138                     /* Here, the next input is a quantifier, and to get here,
11139                      * the current character is the only one in the node.
11140                      * Also, here <len> doesn't include the final byte for this
11141                      * character */
11142                     len++;
11143                     goto loopdone;
11144                 }
11145
11146             } /* End of loop through literal characters */
11147
11148             /* Here we have either exhausted the input or ran out of room in
11149              * the node.  (If we encountered a character that can't be in the
11150              * node, transfer is made directly to <loopdone>, and so we
11151              * wouldn't have fallen off the end of the loop.)  In the latter
11152              * case, we artificially have to split the node into two, because
11153              * we just don't have enough space to hold everything.  This
11154              * creates a problem if the final character participates in a
11155              * multi-character fold in the non-final position, as a match that
11156              * should have occurred won't, due to the way nodes are matched,
11157              * and our artificial boundary.  So back off until we find a non-
11158              * problematic character -- one that isn't at the beginning or
11159              * middle of such a fold.  (Either it doesn't participate in any
11160              * folds, or appears only in the final position of all the folds it
11161              * does participate in.)  A better solution with far fewer false
11162              * positives, and that would fill the nodes more completely, would
11163              * be to actually have available all the multi-character folds to
11164              * test against, and to back-off only far enough to be sure that
11165              * this node isn't ending with a partial one.  <upper_parse> is set
11166              * further below (if we need to reparse the node) to include just
11167              * up through that final non-problematic character that this code
11168              * identifies, so when it is set to less than the full node, we can
11169              * skip the rest of this */
11170             if (FOLD && p < RExC_end && upper_parse == MAX_NODE_STRING_SIZE) {
11171
11172                 const STRLEN full_len = len;
11173
11174                 assert(len >= MAX_NODE_STRING_SIZE);
11175
11176                 /* Here, <s> points to the final byte of the final character.
11177                  * Look backwards through the string until find a non-
11178                  * problematic character */
11179
11180                 if (! UTF) {
11181
11182                     /* These two have no multi-char folds to non-UTF characters
11183                      */
11184                     if (ASCII_FOLD_RESTRICTED || LOC) {
11185                         goto loopdone;
11186                     }
11187
11188                     while (--s >= s0 && IS_NON_FINAL_FOLD(*s)) { }
11189                     len = s - s0 + 1;
11190                 }
11191                 else {
11192                     if (!  PL_NonL1NonFinalFold) {
11193                         PL_NonL1NonFinalFold = _new_invlist_C_array(
11194                                         NonL1_Perl_Non_Final_Folds_invlist);
11195                     }
11196
11197                     /* Point to the first byte of the final character */
11198                     s = (char *) utf8_hop((U8 *) s, -1);
11199
11200                     while (s >= s0) {   /* Search backwards until find
11201                                            non-problematic char */
11202                         if (UTF8_IS_INVARIANT(*s)) {
11203
11204                             /* There are no ascii characters that participate
11205                              * in multi-char folds under /aa.  In EBCDIC, the
11206                              * non-ascii invariants are all control characters,
11207                              * so don't ever participate in any folds. */
11208                             if (ASCII_FOLD_RESTRICTED
11209                                 || ! IS_NON_FINAL_FOLD(*s))
11210                             {
11211                                 break;
11212                             }
11213                         }
11214                         else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
11215
11216                             /* No Latin1 characters participate in multi-char
11217                              * folds under /l */
11218                             if (LOC
11219                                 || ! IS_NON_FINAL_FOLD(TWO_BYTE_UTF8_TO_UNI(
11220                                                                 *s, *(s+1))))
11221                             {
11222                                 break;
11223                             }
11224                         }
11225                         else if (! _invlist_contains_cp(
11226                                         PL_NonL1NonFinalFold,
11227                                         valid_utf8_to_uvchr((U8 *) s, NULL)))
11228                         {
11229                             break;
11230                         }
11231
11232                         /* Here, the current character is problematic in that
11233                          * it does occur in the non-final position of some
11234                          * fold, so try the character before it, but have to
11235                          * special case the very first byte in the string, so
11236                          * we don't read outside the string */
11237                         s = (s == s0) ? s -1 : (char *) utf8_hop((U8 *) s, -1);
11238                     } /* End of loop backwards through the string */
11239
11240                     /* If there were only problematic characters in the string,
11241                      * <s> will point to before s0, in which case the length
11242                      * should be 0, otherwise include the length of the
11243                      * non-problematic character just found */
11244                     len = (s < s0) ? 0 : s - s0 + UTF8SKIP(s);
11245                 }
11246
11247                 /* Here, have found the final character, if any, that is
11248                  * non-problematic as far as ending the node without splitting
11249                  * it across a potential multi-char fold.  <len> contains the
11250                  * number of bytes in the node up-to and including that
11251                  * character, or is 0 if there is no such character, meaning
11252                  * the whole node contains only problematic characters.  In
11253                  * this case, give up and just take the node as-is.  We can't
11254                  * do any better */
11255                 if (len == 0) {
11256                     len = full_len;
11257                 } else {
11258
11259                     /* Here, the node does contain some characters that aren't
11260                      * problematic.  If one such is the final character in the
11261                      * node, we are done */
11262                     if (len == full_len) {
11263                         goto loopdone;
11264                     }
11265                     else if (len + ((UTF) ? UTF8SKIP(s) : 1) == full_len) {
11266
11267                         /* If the final character is problematic, but the
11268                          * penultimate is not, back-off that last character to
11269                          * later start a new node with it */
11270                         p = oldp;
11271                         goto loopdone;
11272                     }
11273
11274                     /* Here, the final non-problematic character is earlier
11275                      * in the input than the penultimate character.  What we do
11276                      * is reparse from the beginning, going up only as far as
11277                      * this final ok one, thus guaranteeing that the node ends
11278                      * in an acceptable character.  The reason we reparse is
11279                      * that we know how far in the character is, but we don't
11280                      * know how to correlate its position with the input parse.
11281                      * An alternate implementation would be to build that
11282                      * correlation as we go along during the original parse,
11283                      * but that would entail extra work for every node, whereas
11284                      * this code gets executed only when the string is too
11285                      * large for the node, and the final two characters are
11286                      * problematic, an infrequent occurrence.  Yet another
11287                      * possible strategy would be to save the tail of the
11288                      * string, and the next time regatom is called, initialize
11289                      * with that.  The problem with this is that unless you
11290                      * back off one more character, you won't be guaranteed
11291                      * regatom will get called again, unless regbranch,
11292                      * regpiece ... are also changed.  If you do back off that
11293                      * extra character, so that there is input guaranteed to
11294                      * force calling regatom, you can't handle the case where
11295                      * just the first character in the node is acceptable.  I
11296                      * (khw) decided to try this method which doesn't have that
11297                      * pitfall; if performance issues are found, we can do a
11298                      * combination of the current approach plus that one */
11299                     upper_parse = len;
11300                     len = 0;
11301                     s = s0;
11302                     goto reparse;
11303                 }
11304             }   /* End of verifying node ends with an appropriate char */
11305
11306         loopdone:   /* Jumped to when encounters something that shouldn't be in
11307                        the node */
11308
11309             /* If 'maybe_exact' is still set here, means there are no
11310              * code points in the node that participate in folds */
11311             if (FOLD && maybe_exact) {
11312                 OP(ret) = EXACT;
11313             }
11314
11315             /* I (khw) don't know if you can get here with zero length, but the
11316              * old code handled this situation by creating a zero-length EXACT
11317              * node.  Might as well be NOTHING instead */
11318             if (len == 0) {
11319                 OP(ret) = NOTHING;
11320             }
11321             else{
11322                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, len, ender);
11323             }
11324
11325             RExC_parse = p - 1;
11326             Set_Node_Cur_Length(ret); /* MJD */
11327             nextchar(pRExC_state);
11328             {
11329                 /* len is STRLEN which is unsigned, need to copy to signed */
11330                 IV iv = len;
11331                 if (iv < 0)
11332                     vFAIL("Internal disaster");
11333             }
11334
11335         } /* End of label 'defchar:' */
11336         break;
11337     } /* End of giant switch on input character */
11338
11339     return(ret);
11340 }
11341
11342 STATIC char *
11343 S_regwhite( RExC_state_t *pRExC_state, char *p )
11344 {
11345     const char *e = RExC_end;
11346
11347     PERL_ARGS_ASSERT_REGWHITE;
11348
11349     while (p < e) {
11350         if (isSPACE(*p))
11351             ++p;
11352         else if (*p == '#') {
11353             bool ended = 0;
11354             do {
11355                 if (*p++ == '\n') {
11356                     ended = 1;
11357                     break;
11358                 }
11359             } while (p < e);
11360             if (!ended)
11361                 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
11362         }
11363         else
11364             break;
11365     }
11366     return p;
11367 }
11368
11369 STATIC char *
11370 S_regpatws( RExC_state_t *pRExC_state, char *p , const bool recognize_comment )
11371 {
11372     /* Returns the next non-pattern-white space, non-comment character (the
11373      * latter only if 'recognize_comment is true) in the string p, which is
11374      * ended by RExC_end.  If there is no line break ending a comment,
11375      * RExC_seen has added the REG_SEEN_RUN_ON_COMMENT flag; */
11376     const char *e = RExC_end;
11377
11378     PERL_ARGS_ASSERT_REGPATWS;
11379
11380     while (p < e) {
11381         STRLEN len;
11382         if ((len = is_PATWS_safe(p, e, UTF))) {
11383             p += len;
11384         }
11385         else if (recognize_comment && *p == '#') {
11386             bool ended = 0;
11387             do {
11388                 p++;
11389                 if (is_LNBREAK_safe(p, e, UTF)) {
11390                     ended = 1;
11391                     break;
11392                 }
11393             } while (p < e);
11394             if (!ended)
11395                 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
11396         }
11397         else
11398             break;
11399     }
11400     return p;
11401 }
11402
11403 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
11404    Character classes ([:foo:]) can also be negated ([:^foo:]).
11405    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
11406    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
11407    but trigger failures because they are currently unimplemented. */
11408
11409 #define POSIXCC_DONE(c)   ((c) == ':')
11410 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
11411 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
11412
11413 PERL_STATIC_INLINE I32
11414 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value, const bool strict)
11415 {
11416     dVAR;
11417     I32 namedclass = OOB_NAMEDCLASS;
11418
11419     PERL_ARGS_ASSERT_REGPPOSIXCC;
11420
11421     if (value == '[' && RExC_parse + 1 < RExC_end &&
11422         /* I smell either [: or [= or [. -- POSIX has been here, right? */
11423         POSIXCC(UCHARAT(RExC_parse)))
11424     {
11425         const char c = UCHARAT(RExC_parse);
11426         char* const s = RExC_parse++;
11427
11428         while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
11429             RExC_parse++;
11430         if (RExC_parse == RExC_end) {
11431             if (strict) {
11432
11433                 /* Try to give a better location for the error (than the end of
11434                  * the string) by looking for the matching ']' */
11435                 RExC_parse = s;
11436                 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
11437                     RExC_parse++;
11438                 }
11439                 vFAIL2("Unmatched '%c' in POSIX class", c);
11440             }
11441             /* Grandfather lone [:, [=, [. */
11442             RExC_parse = s;
11443         }
11444         else {
11445             const char* const t = RExC_parse++; /* skip over the c */
11446             assert(*t == c);
11447
11448             if (UCHARAT(RExC_parse) == ']') {
11449                 const char *posixcc = s + 1;
11450                 RExC_parse++; /* skip over the ending ] */
11451
11452                 if (*s == ':') {
11453                     const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
11454                     const I32 skip = t - posixcc;
11455
11456                     /* Initially switch on the length of the name.  */
11457                     switch (skip) {
11458                     case 4:
11459                         if (memEQ(posixcc, "word", 4)) /* this is not POSIX,
11460                                                           this is the Perl \w
11461                                                         */
11462                             namedclass = ANYOF_WORDCHAR;
11463                         break;
11464                     case 5:
11465                         /* Names all of length 5.  */
11466                         /* alnum alpha ascii blank cntrl digit graph lower
11467                            print punct space upper  */
11468                         /* Offset 4 gives the best switch position.  */
11469                         switch (posixcc[4]) {
11470                         case 'a':
11471                             if (memEQ(posixcc, "alph", 4)) /* alpha */
11472                                 namedclass = ANYOF_ALPHA;
11473                             break;
11474                         case 'e':
11475                             if (memEQ(posixcc, "spac", 4)) /* space */
11476                                 namedclass = ANYOF_PSXSPC;
11477                             break;
11478                         case 'h':
11479                             if (memEQ(posixcc, "grap", 4)) /* graph */
11480                                 namedclass = ANYOF_GRAPH;
11481                             break;
11482                         case 'i':
11483                             if (memEQ(posixcc, "asci", 4)) /* ascii */
11484                                 namedclass = ANYOF_ASCII;
11485                             break;
11486                         case 'k':
11487                             if (memEQ(posixcc, "blan", 4)) /* blank */
11488                                 namedclass = ANYOF_BLANK;
11489                             break;
11490                         case 'l':
11491                             if (memEQ(posixcc, "cntr", 4)) /* cntrl */
11492                                 namedclass = ANYOF_CNTRL;
11493                             break;
11494                         case 'm':
11495                             if (memEQ(posixcc, "alnu", 4)) /* alnum */
11496                                 namedclass = ANYOF_ALPHANUMERIC;
11497                             break;
11498                         case 'r':
11499                             if (memEQ(posixcc, "lowe", 4)) /* lower */
11500                                 namedclass = (FOLD) ? ANYOF_CASED : ANYOF_LOWER;
11501                             else if (memEQ(posixcc, "uppe", 4)) /* upper */
11502                                 namedclass = (FOLD) ? ANYOF_CASED : ANYOF_UPPER;
11503                             break;
11504                         case 't':
11505                             if (memEQ(posixcc, "digi", 4)) /* digit */
11506                                 namedclass = ANYOF_DIGIT;
11507                             else if (memEQ(posixcc, "prin", 4)) /* print */
11508                                 namedclass = ANYOF_PRINT;
11509                             else if (memEQ(posixcc, "punc", 4)) /* punct */
11510                                 namedclass = ANYOF_PUNCT;
11511                             break;
11512                         }
11513                         break;
11514                     case 6:
11515                         if (memEQ(posixcc, "xdigit", 6))
11516                             namedclass = ANYOF_XDIGIT;
11517                         break;
11518                     }
11519
11520                     if (namedclass == OOB_NAMEDCLASS)
11521                         Simple_vFAIL3("POSIX class [:%.*s:] unknown",
11522                                       t - s - 1, s + 1);
11523
11524                     /* The #defines are structured so each complement is +1 to
11525                      * the normal one */
11526                     if (complement) {
11527                         namedclass++;
11528                     }
11529                     assert (posixcc[skip] == ':');
11530                     assert (posixcc[skip+1] == ']');
11531                 } else if (!SIZE_ONLY) {
11532                     /* [[=foo=]] and [[.foo.]] are still future. */
11533
11534                     /* adjust RExC_parse so the warning shows after
11535                        the class closes */
11536                     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
11537                         RExC_parse++;
11538                     vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
11539                 }
11540             } else {
11541                 /* Maternal grandfather:
11542                  * "[:" ending in ":" but not in ":]" */
11543                 if (strict) {
11544                     vFAIL("Unmatched '[' in POSIX class");
11545                 }
11546
11547                 /* Grandfather lone [:, [=, [. */
11548                 RExC_parse = s;
11549             }
11550         }
11551     }
11552
11553     return namedclass;
11554 }
11555
11556 STATIC bool
11557 S_could_it_be_a_POSIX_class(pTHX_ RExC_state_t *pRExC_state)
11558 {
11559     /* This applies some heuristics at the current parse position (which should
11560      * be at a '[') to see if what follows might be intended to be a [:posix:]
11561      * class.  It returns true if it really is a posix class, of course, but it
11562      * also can return true if it thinks that what was intended was a posix
11563      * class that didn't quite make it.
11564      *
11565      * It will return true for
11566      *      [:alphanumerics:
11567      *      [:alphanumerics]  (as long as the ] isn't followed immediately by a
11568      *                         ')' indicating the end of the (?[
11569      *      [:any garbage including %^&$ punctuation:]
11570      *
11571      * This is designed to be called only from S_handle_regex_sets; it could be
11572      * easily adapted to be called from the spot at the beginning of regclass()
11573      * that checks to see in a normal bracketed class if the surrounding []
11574      * have been omitted ([:word:] instead of [[:word:]]).  But doing so would
11575      * change long-standing behavior, so I (khw) didn't do that */
11576     char* p = RExC_parse + 1;
11577     char first_char = *p;
11578
11579     PERL_ARGS_ASSERT_COULD_IT_BE_A_POSIX_CLASS;
11580
11581     assert(*(p - 1) == '[');
11582
11583     if (! POSIXCC(first_char)) {
11584         return FALSE;
11585     }
11586
11587     p++;
11588     while (p < RExC_end && isWORDCHAR(*p)) p++;
11589
11590     if (p >= RExC_end) {
11591         return FALSE;
11592     }
11593
11594     if (p - RExC_parse > 2    /* Got at least 1 word character */
11595         && (*p == first_char
11596             || (*p == ']' && p + 1 < RExC_end && *(p + 1) != ')')))
11597     {
11598         return TRUE;
11599     }
11600
11601     p = (char *) memchr(RExC_parse, ']', RExC_end - RExC_parse);
11602
11603     return (p
11604             && p - RExC_parse > 2 /* [:] evaluates to colon;
11605                                       [::] is a bad posix class. */
11606             && first_char == *(p - 1));
11607 }
11608
11609 STATIC regnode *
11610 S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist, I32 *flagp, U32 depth,
11611                    char * const oregcomp_parse)
11612 {
11613     /* Handle the (?[...]) construct to do set operations */
11614
11615     U8 curchar;
11616     UV start, end;      /* End points of code point ranges */
11617     SV* result_string;
11618     char *save_end, *save_parse;
11619     SV* final;
11620     STRLEN len;
11621     regnode* node;
11622     AV* stack;
11623     const bool save_fold = FOLD;
11624
11625     GET_RE_DEBUG_FLAGS_DECL;
11626
11627     PERL_ARGS_ASSERT_HANDLE_REGEX_SETS;
11628
11629     if (LOC) {
11630         vFAIL("(?[...]) not valid in locale");
11631     }
11632     RExC_uni_semantics = 1;
11633
11634     /* This will return only an ANYOF regnode, or (unlikely) something smaller
11635      * (such as EXACT).  Thus we can skip most everything if just sizing.  We
11636      * call regclass to handle '[]' so as to not have to reinvent its parsing
11637      * rules here (throwing away the size it computes each time).  And, we exit
11638      * upon an unescaped ']' that isn't one ending a regclass.  To do both
11639      * these things, we need to realize that something preceded by a backslash
11640      * is escaped, so we have to keep track of backslashes */
11641     if (SIZE_ONLY) {
11642
11643         Perl_ck_warner_d(aTHX_
11644             packWARN(WARN_EXPERIMENTAL__REGEX_SETS),
11645             "The regex_sets feature is experimental" REPORT_LOCATION,
11646             (int) (RExC_parse - RExC_precomp) , RExC_precomp, RExC_parse);
11647
11648         while (RExC_parse < RExC_end) {
11649             SV* current = NULL;
11650             RExC_parse = regpatws(pRExC_state, RExC_parse,
11651                                 TRUE); /* means recognize comments */
11652             switch (*RExC_parse) {
11653                 default:
11654                     break;
11655                 case '\\':
11656                     /* Skip the next byte (which could cause us to end up in
11657                      * the middle of a UTF-8 character, but since none of those
11658                      * are confusable with anything we currently handle in this
11659                      * switch (invariants all), it's safe.  We'll just hit the
11660                      * default: case next time and keep on incrementing until
11661                      * we find one of the invariants we do handle. */
11662                     RExC_parse++;
11663                     break;
11664                 case '[':
11665                 {
11666                     /* If this looks like it is a [:posix:] class, leave the
11667                      * parse pointer at the '[' to fool regclass() into
11668                      * thinking it is part of a '[[:posix:]]'.  That function
11669                      * will use strict checking to force a syntax error if it
11670                      * doesn't work out to a legitimate class */
11671                     bool is_posix_class
11672                                     = could_it_be_a_POSIX_class(pRExC_state);
11673                     if (! is_posix_class) {
11674                         RExC_parse++;
11675                     }
11676
11677                     /* regclass() can only return RESTART_UTF8 if multi-char
11678                        folds are allowed.  */
11679                     if (!regclass(pRExC_state, flagp,depth+1,
11680                                   is_posix_class, /* parse the whole char
11681                                                      class only if not a
11682                                                      posix class */
11683                                   FALSE, /* don't allow multi-char folds */
11684                                   TRUE, /* silence non-portable warnings. */
11685                                   &current))
11686                         FAIL2("panic: regclass returned NULL to handle_sets, flags=%#X",
11687                               *flagp);
11688
11689                     /* function call leaves parse pointing to the ']', except
11690                      * if we faked it */
11691                     if (is_posix_class) {
11692                         RExC_parse--;
11693                     }
11694
11695                     SvREFCNT_dec(current);   /* In case it returned something */
11696                     break;
11697                 }
11698
11699                 case ']':
11700                     RExC_parse++;
11701                     if (RExC_parse < RExC_end
11702                         && *RExC_parse == ')')
11703                     {
11704                         node = reganode(pRExC_state, ANYOF, 0);
11705                         RExC_size += ANYOF_SKIP;
11706                         nextchar(pRExC_state);
11707                         Set_Node_Length(node,
11708                                 RExC_parse - oregcomp_parse + 1); /* MJD */
11709                         return node;
11710                     }
11711                     goto no_close;
11712             }
11713             RExC_parse++;
11714         }
11715
11716         no_close:
11717         FAIL("Syntax error in (?[...])");
11718     }
11719
11720     /* Pass 2 only after this.  Everything in this construct is a
11721      * metacharacter.  Operands begin with either a '\' (for an escape
11722      * sequence), or a '[' for a bracketed character class.  Any other
11723      * character should be an operator, or parenthesis for grouping.  Both
11724      * types of operands are handled by calling regclass() to parse them.  It
11725      * is called with a parameter to indicate to return the computed inversion
11726      * list.  The parsing here is implemented via a stack.  Each entry on the
11727      * stack is a single character representing one of the operators, or the
11728      * '('; or else a pointer to an operand inversion list. */
11729
11730 #define IS_OPERAND(a)  (! SvIOK(a))
11731
11732     /* The stack starts empty.  It is a syntax error if the first thing parsed
11733      * is a binary operator; everything else is pushed on the stack.  When an
11734      * operand is parsed, the top of the stack is examined.  If it is a binary
11735      * operator, the item before it should be an operand, and both are replaced
11736      * by the result of doing that operation on the new operand and the one on
11737      * the stack.   Thus a sequence of binary operands is reduced to a single
11738      * one before the next one is parsed.
11739      *
11740      * A unary operator may immediately follow a binary in the input, for
11741      * example
11742      *      [a] + ! [b]
11743      * When an operand is parsed and the top of the stack is a unary operator,
11744      * the operation is performed, and then the stack is rechecked to see if
11745      * this new operand is part of a binary operation; if so, it is handled as
11746      * above.
11747      *
11748      * A '(' is simply pushed on the stack; it is valid only if the stack is
11749      * empty, or the top element of the stack is an operator or another '('
11750      * (for which the parenthesized expression will become an operand).  By the
11751      * time the corresponding ')' is parsed everything in between should have
11752      * been parsed and evaluated to a single operand (or else is a syntax
11753      * error), and is handled as a regular operand */
11754
11755     sv_2mortal((SV *)(stack = newAV()));
11756
11757     while (RExC_parse < RExC_end) {
11758         I32 top_index = av_tindex(stack);
11759         SV** top_ptr;
11760         SV* current = NULL;
11761
11762         /* Skip white space */
11763         RExC_parse = regpatws(pRExC_state, RExC_parse,
11764                                 TRUE); /* means recognize comments */
11765         if (RExC_parse >= RExC_end) {
11766             Perl_croak(aTHX_ "panic: Read past end of '(?[ ])'");
11767         }
11768         if ((curchar = UCHARAT(RExC_parse)) == ']') {
11769             break;
11770         }
11771
11772         switch (curchar) {
11773
11774             case '?':
11775                 if (av_tindex(stack) >= 0   /* This makes sure that we can
11776                                                safely subtract 1 from
11777                                                RExC_parse in the next clause.
11778                                                If we have something on the
11779                                                stack, we have parsed something
11780                                              */
11781                     && UCHARAT(RExC_parse - 1) == '('
11782                     && RExC_parse < RExC_end)
11783                 {
11784                     /* If is a '(?', could be an embedded '(?flags:(?[...])'.
11785                      * This happens when we have some thing like
11786                      *
11787                      *   my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
11788                      *   ...
11789                      *   qr/(?[ \p{Digit} & $thai_or_lao ])/;
11790                      *
11791                      * Here we would be handling the interpolated
11792                      * '$thai_or_lao'.  We handle this by a recursive call to
11793                      * ourselves which returns the inversion list the
11794                      * interpolated expression evaluates to.  We use the flags
11795                      * from the interpolated pattern. */
11796                     U32 save_flags = RExC_flags;
11797                     const char * const save_parse = ++RExC_parse;
11798
11799                     parse_lparen_question_flags(pRExC_state);
11800
11801                     if (RExC_parse == save_parse  /* Makes sure there was at
11802                                                      least one flag (or this
11803                                                      embedding wasn't compiled)
11804                                                    */
11805                         || RExC_parse >= RExC_end - 4
11806                         || UCHARAT(RExC_parse) != ':'
11807                         || UCHARAT(++RExC_parse) != '('
11808                         || UCHARAT(++RExC_parse) != '?'
11809                         || UCHARAT(++RExC_parse) != '[')
11810                     {
11811
11812                         /* In combination with the above, this moves the
11813                          * pointer to the point just after the first erroneous
11814                          * character (or if there are no flags, to where they
11815                          * should have been) */
11816                         if (RExC_parse >= RExC_end - 4) {
11817                             RExC_parse = RExC_end;
11818                         }
11819                         else if (RExC_parse != save_parse) {
11820                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
11821                         }
11822                         vFAIL("Expecting '(?flags:(?[...'");
11823                     }
11824                     RExC_parse++;
11825                     (void) handle_regex_sets(pRExC_state, &current, flagp,
11826                                                     depth+1, oregcomp_parse);
11827
11828                     /* Here, 'current' contains the embedded expression's
11829                      * inversion list, and RExC_parse points to the trailing
11830                      * ']'; the next character should be the ')' which will be
11831                      * paired with the '(' that has been put on the stack, so
11832                      * the whole embedded expression reduces to '(operand)' */
11833                     RExC_parse++;
11834
11835                     RExC_flags = save_flags;
11836                     goto handle_operand;
11837                 }
11838                 /* FALL THROUGH */
11839
11840             default:
11841                 RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
11842                 vFAIL("Unexpected character");
11843
11844             case '\\':
11845                 /* regclass() can only return RESTART_UTF8 if multi-char
11846                    folds are allowed.  */
11847                 if (!regclass(pRExC_state, flagp,depth+1,
11848                               TRUE, /* means parse just the next thing */
11849                               FALSE, /* don't allow multi-char folds */
11850                               FALSE, /* don't silence non-portable warnings.  */
11851                               &current))
11852                     FAIL2("panic: regclass returned NULL to handle_sets, flags=%#X",
11853                           *flagp);
11854                 /* regclass() will return with parsing just the \ sequence,
11855                  * leaving the parse pointer at the next thing to parse */
11856                 RExC_parse--;
11857                 goto handle_operand;
11858
11859             case '[':   /* Is a bracketed character class */
11860             {
11861                 bool is_posix_class = could_it_be_a_POSIX_class(pRExC_state);
11862
11863                 if (! is_posix_class) {
11864                     RExC_parse++;
11865                 }
11866
11867                 /* regclass() can only return RESTART_UTF8 if multi-char
11868                    folds are allowed.  */
11869                 if(!regclass(pRExC_state, flagp,depth+1,
11870                              is_posix_class, /* parse the whole char class
11871                                                 only if not a posix class */
11872                              FALSE, /* don't allow multi-char folds */
11873                              FALSE, /* don't silence non-portable warnings.  */
11874                              &current))
11875                     FAIL2("panic: regclass returned NULL to handle_sets, flags=%#X",
11876                           *flagp);
11877                 /* function call leaves parse pointing to the ']', except if we
11878                  * faked it */
11879                 if (is_posix_class) {
11880                     RExC_parse--;
11881                 }
11882
11883                 goto handle_operand;
11884             }
11885
11886             case '&':
11887             case '|':
11888             case '+':
11889             case '-':
11890             case '^':
11891                 if (top_index < 0
11892                     || ( ! (top_ptr = av_fetch(stack, top_index, FALSE)))
11893                     || ! IS_OPERAND(*top_ptr))
11894                 {
11895                     RExC_parse++;
11896                     vFAIL2("Unexpected binary operator '%c' with no preceding operand", curchar);
11897                 }
11898                 av_push(stack, newSVuv(curchar));
11899                 break;
11900
11901             case '!':
11902                 av_push(stack, newSVuv(curchar));
11903                 break;
11904
11905             case '(':
11906                 if (top_index >= 0) {
11907                     top_ptr = av_fetch(stack, top_index, FALSE);
11908                     assert(top_ptr);
11909                     if (IS_OPERAND(*top_ptr)) {
11910                         RExC_parse++;
11911                         vFAIL("Unexpected '(' with no preceding operator");
11912                     }
11913                 }
11914                 av_push(stack, newSVuv(curchar));
11915                 break;
11916
11917             case ')':
11918             {
11919                 SV* lparen;
11920                 if (top_index < 1
11921                     || ! (current = av_pop(stack))
11922                     || ! IS_OPERAND(current)
11923                     || ! (lparen = av_pop(stack))
11924                     || IS_OPERAND(lparen)
11925                     || SvUV(lparen) != '(')
11926                 {
11927                     SvREFCNT_dec(current);
11928                     RExC_parse++;
11929                     vFAIL("Unexpected ')'");
11930                 }
11931                 top_index -= 2;
11932                 SvREFCNT_dec_NN(lparen);
11933
11934                 /* FALL THROUGH */
11935             }
11936
11937               handle_operand:
11938
11939                 /* Here, we have an operand to process, in 'current' */
11940
11941                 if (top_index < 0) {    /* Just push if stack is empty */
11942                     av_push(stack, current);
11943                 }
11944                 else {
11945                     SV* top = av_pop(stack);
11946                     SV *prev = NULL;
11947                     char current_operator;
11948
11949                     if (IS_OPERAND(top)) {
11950                         SvREFCNT_dec_NN(top);
11951                         SvREFCNT_dec_NN(current);
11952                         vFAIL("Operand with no preceding operator");
11953                     }
11954                     current_operator = (char) SvUV(top);
11955                     switch (current_operator) {
11956                         case '(':   /* Push the '(' back on followed by the new
11957                                        operand */
11958                             av_push(stack, top);
11959                             av_push(stack, current);
11960                             SvREFCNT_inc(top);  /* Counters the '_dec' done
11961                                                    just after the 'break', so
11962                                                    it doesn't get wrongly freed
11963                                                  */
11964                             break;
11965
11966                         case '!':
11967                             _invlist_invert(current);
11968
11969                             /* Unlike binary operators, the top of the stack,
11970                              * now that this unary one has been popped off, may
11971                              * legally be an operator, and we now have operand
11972                              * for it. */
11973                             top_index--;
11974                             SvREFCNT_dec_NN(top);
11975                             goto handle_operand;
11976
11977                         case '&':
11978                             prev = av_pop(stack);
11979                             _invlist_intersection(prev,
11980                                                    current,
11981                                                    &current);
11982                             av_push(stack, current);
11983                             break;
11984
11985                         case '|':
11986                         case '+':
11987                             prev = av_pop(stack);
11988                             _invlist_union(prev, current, &current);
11989                             av_push(stack, current);
11990                             break;
11991
11992                         case '-':
11993                             prev = av_pop(stack);;
11994                             _invlist_subtract(prev, current, &current);
11995                             av_push(stack, current);
11996                             break;
11997
11998                         case '^':   /* The union minus the intersection */
11999                         {
12000                             SV* i = NULL;
12001                             SV* u = NULL;
12002                             SV* element;
12003
12004                             prev = av_pop(stack);
12005                             _invlist_union(prev, current, &u);
12006                             _invlist_intersection(prev, current, &i);
12007                             /* _invlist_subtract will overwrite current
12008                                 without freeing what it already contains */
12009                             element = current;
12010                             _invlist_subtract(u, i, &current);
12011                             av_push(stack, current);
12012                             SvREFCNT_dec_NN(i);
12013                             SvREFCNT_dec_NN(u);
12014                             SvREFCNT_dec_NN(element);
12015                             break;
12016                         }
12017
12018                         default:
12019                             Perl_croak(aTHX_ "panic: Unexpected item on '(?[ ])' stack");
12020                 }
12021                 SvREFCNT_dec_NN(top);
12022                 SvREFCNT_dec(prev);
12023             }
12024         }
12025
12026         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
12027     }
12028
12029     if (av_tindex(stack) < 0   /* Was empty */
12030         || ((final = av_pop(stack)) == NULL)
12031         || ! IS_OPERAND(final)
12032         || av_tindex(stack) >= 0)  /* More left on stack */
12033     {
12034         vFAIL("Incomplete expression within '(?[ ])'");
12035     }
12036
12037     /* Here, 'final' is the resultant inversion list from evaluating the
12038      * expression.  Return it if so requested */
12039     if (return_invlist) {
12040         *return_invlist = final;
12041         return END;
12042     }
12043
12044     /* Otherwise generate a resultant node, based on 'final'.  regclass() is
12045      * expecting a string of ranges and individual code points */
12046     invlist_iterinit(final);
12047     result_string = newSVpvs("");
12048     while (invlist_iternext(final, &start, &end)) {
12049         if (start == end) {
12050             Perl_sv_catpvf(aTHX_ result_string, "\\x{%"UVXf"}", start);
12051         }
12052         else {
12053             Perl_sv_catpvf(aTHX_ result_string, "\\x{%"UVXf"}-\\x{%"UVXf"}",
12054                                                      start,          end);
12055         }
12056     }
12057
12058     save_parse = RExC_parse;
12059     RExC_parse = SvPV(result_string, len);
12060     save_end = RExC_end;
12061     RExC_end = RExC_parse + len;
12062
12063     /* We turn off folding around the call, as the class we have constructed
12064      * already has all folding taken into consideration, and we don't want
12065      * regclass() to add to that */
12066     RExC_flags &= ~RXf_PMf_FOLD;
12067     /* regclass() can only return RESTART_UTF8 if multi-char folds are allowed.
12068      */
12069     node = regclass(pRExC_state, flagp,depth+1,
12070                     FALSE, /* means parse the whole char class */
12071                     FALSE, /* don't allow multi-char folds */
12072                     TRUE, /* silence non-portable warnings.  The above may very
12073                              well have generated non-portable code points, but
12074                              they're valid on this machine */
12075                     NULL);
12076     if (!node)
12077         FAIL2("panic: regclass returned NULL to handle_sets, flags=%#"UVxf,
12078                     PTR2UV(flagp));
12079     if (save_fold) {
12080         RExC_flags |= RXf_PMf_FOLD;
12081     }
12082     RExC_parse = save_parse + 1;
12083     RExC_end = save_end;
12084     SvREFCNT_dec_NN(final);
12085     SvREFCNT_dec_NN(result_string);
12086
12087     nextchar(pRExC_state);
12088     Set_Node_Length(node, RExC_parse - oregcomp_parse + 1); /* MJD */
12089     return node;
12090 }
12091 #undef IS_OPERAND
12092
12093 /* The names of properties whose definitions are not known at compile time are
12094  * stored in this SV, after a constant heading.  So if the length has been
12095  * changed since initialization, then there is a run-time definition. */
12096 #define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION (SvCUR(listsv) != initial_listsv_len)
12097
12098 STATIC regnode *
12099 S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
12100                  const bool stop_at_1,  /* Just parse the next thing, don't
12101                                            look for a full character class */
12102                  bool allow_multi_folds,
12103                  const bool silence_non_portable,   /* Don't output warnings
12104                                                        about too large
12105                                                        characters */
12106                  SV** ret_invlist)  /* Return an inversion list, not a node */
12107 {
12108     /* parse a bracketed class specification.  Most of these will produce an
12109      * ANYOF node; but something like [a] will produce an EXACT node; [aA], an
12110      * EXACTFish node; [[:ascii:]], a POSIXA node; etc.  It is more complex
12111      * under /i with multi-character folds: it will be rewritten following the
12112      * paradigm of this example, where the <multi-fold>s are characters which
12113      * fold to multiple character sequences:
12114      *      /[abc\x{multi-fold1}def\x{multi-fold2}ghi]/i
12115      * gets effectively rewritten as:
12116      *      /(?:\x{multi-fold1}|\x{multi-fold2}|[abcdefghi]/i
12117      * reg() gets called (recursively) on the rewritten version, and this
12118      * function will return what it constructs.  (Actually the <multi-fold>s
12119      * aren't physically removed from the [abcdefghi], it's just that they are
12120      * ignored in the recursion by means of a flag:
12121      * <RExC_in_multi_char_class>.)
12122      *
12123      * ANYOF nodes contain a bit map for the first 256 characters, with the
12124      * corresponding bit set if that character is in the list.  For characters
12125      * above 255, a range list or swash is used.  There are extra bits for \w,
12126      * etc. in locale ANYOFs, as what these match is not determinable at
12127      * compile time
12128      *
12129      * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs
12130      * to be restarted.  This can only happen if ret_invlist is non-NULL.
12131      */
12132
12133     dVAR;
12134     UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE;
12135     IV range = 0;
12136     UV value = OOB_UNICODE, save_value = OOB_UNICODE;
12137     regnode *ret;
12138     STRLEN numlen;
12139     IV namedclass = OOB_NAMEDCLASS;
12140     char *rangebegin = NULL;
12141     bool need_class = 0;
12142     SV *listsv = NULL;
12143     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
12144                                       than just initialized.  */
12145     SV* properties = NULL;    /* Code points that match \p{} \P{} */
12146     SV* posixes = NULL;     /* Code points that match classes like, [:word:],
12147                                extended beyond the Latin1 range */
12148     UV element_count = 0;   /* Number of distinct elements in the class.
12149                                Optimizations may be possible if this is tiny */
12150     AV * multi_char_matches = NULL; /* Code points that fold to more than one
12151                                        character; used under /i */
12152     UV n;
12153     char * stop_ptr = RExC_end;    /* where to stop parsing */
12154     const bool skip_white = cBOOL(ret_invlist); /* ignore unescaped white
12155                                                    space? */
12156     const bool strict = cBOOL(ret_invlist); /* Apply strict parsing rules? */
12157
12158     /* Unicode properties are stored in a swash; this holds the current one
12159      * being parsed.  If this swash is the only above-latin1 component of the
12160      * character class, an optimization is to pass it directly on to the
12161      * execution engine.  Otherwise, it is set to NULL to indicate that there
12162      * are other things in the class that have to be dealt with at execution
12163      * time */
12164     SV* swash = NULL;           /* Code points that match \p{} \P{} */
12165
12166     /* Set if a component of this character class is user-defined; just passed
12167      * on to the engine */
12168     bool has_user_defined_property = FALSE;
12169
12170     /* inversion list of code points this node matches only when the target
12171      * string is in UTF-8.  (Because is under /d) */
12172     SV* depends_list = NULL;
12173
12174     /* inversion list of code points this node matches.  For much of the
12175      * function, it includes only those that match regardless of the utf8ness
12176      * of the target string */
12177     SV* cp_list = NULL;
12178
12179 #ifdef EBCDIC
12180     /* In a range, counts how many 0-2 of the ends of it came from literals,
12181      * not escapes.  Thus we can tell if 'A' was input vs \x{C1} */
12182     UV literal_endpoint = 0;
12183 #endif
12184     bool invert = FALSE;    /* Is this class to be complemented */
12185
12186     /* Is there any thing like \W or [:^digit:] that matches above the legal
12187      * Unicode range? */
12188     bool runtime_posix_matches_above_Unicode = FALSE;
12189
12190     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
12191         case we need to change the emitted regop to an EXACT. */
12192     const char * orig_parse = RExC_parse;
12193     const I32 orig_size = RExC_size;
12194     GET_RE_DEBUG_FLAGS_DECL;
12195
12196     PERL_ARGS_ASSERT_REGCLASS;
12197 #ifndef DEBUGGING
12198     PERL_UNUSED_ARG(depth);
12199 #endif
12200
12201     DEBUG_PARSE("clas");
12202
12203     /* Assume we are going to generate an ANYOF node. */
12204     ret = reganode(pRExC_state, ANYOF, 0);
12205
12206     if (SIZE_ONLY) {
12207         RExC_size += ANYOF_SKIP;
12208         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
12209     }
12210     else {
12211         ANYOF_FLAGS(ret) = 0;
12212
12213         RExC_emit += ANYOF_SKIP;
12214         if (LOC) {
12215             ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
12216         }
12217         listsv = newSVpvs_flags("# comment\n", SVs_TEMP);
12218         initial_listsv_len = SvCUR(listsv);
12219         SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated.  */
12220     }
12221
12222     if (skip_white) {
12223         RExC_parse = regpatws(pRExC_state, RExC_parse,
12224                               FALSE /* means don't recognize comments */);
12225     }
12226
12227     if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
12228         RExC_parse++;
12229         invert = TRUE;
12230         allow_multi_folds = FALSE;
12231         RExC_naughty++;
12232         if (skip_white) {
12233             RExC_parse = regpatws(pRExC_state, RExC_parse,
12234                                   FALSE /* means don't recognize comments */);
12235         }
12236     }
12237
12238     /* Check that they didn't say [:posix:] instead of [[:posix:]] */
12239     if (!SIZE_ONLY && RExC_parse < RExC_end && POSIXCC(UCHARAT(RExC_parse))) {
12240         const char *s = RExC_parse;
12241         const char  c = *s++;
12242
12243         while (isWORDCHAR(*s))
12244             s++;
12245         if (*s && c == *s && s[1] == ']') {
12246             SAVEFREESV(RExC_rx_sv);
12247             ckWARN3reg(s+2,
12248                        "POSIX syntax [%c %c] belongs inside character classes",
12249                        c, c);
12250             (void)ReREFCNT_inc(RExC_rx_sv);
12251         }
12252     }
12253
12254     /* If the caller wants us to just parse a single element, accomplish this
12255      * by faking the loop ending condition */
12256     if (stop_at_1 && RExC_end > RExC_parse) {
12257         stop_ptr = RExC_parse + 1;
12258     }
12259
12260     /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */
12261     if (UCHARAT(RExC_parse) == ']')
12262         goto charclassloop;
12263
12264 parseit:
12265     while (1) {
12266         if  (RExC_parse >= stop_ptr) {
12267             break;
12268         }
12269
12270         if (skip_white) {
12271             RExC_parse = regpatws(pRExC_state, RExC_parse,
12272                                   FALSE /* means don't recognize comments */);
12273         }
12274
12275         if  (UCHARAT(RExC_parse) == ']') {
12276             break;
12277         }
12278
12279     charclassloop:
12280
12281         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
12282         save_value = value;
12283         save_prevvalue = prevvalue;
12284
12285         if (!range) {
12286             rangebegin = RExC_parse;
12287             element_count++;
12288         }
12289         if (UTF) {
12290             value = utf8n_to_uvchr((U8*)RExC_parse,
12291                                    RExC_end - RExC_parse,
12292                                    &numlen, UTF8_ALLOW_DEFAULT);
12293             RExC_parse += numlen;
12294         }
12295         else
12296             value = UCHARAT(RExC_parse++);
12297
12298         if (value == '['
12299             && RExC_parse < RExC_end
12300             && POSIXCC(UCHARAT(RExC_parse)))
12301         {
12302             namedclass = regpposixcc(pRExC_state, value, strict);
12303         }
12304         else if (value == '\\') {
12305             if (UTF) {
12306                 value = utf8n_to_uvchr((U8*)RExC_parse,
12307                                    RExC_end - RExC_parse,
12308                                    &numlen, UTF8_ALLOW_DEFAULT);
12309                 RExC_parse += numlen;
12310             }
12311             else
12312                 value = UCHARAT(RExC_parse++);
12313
12314             /* Some compilers cannot handle switching on 64-bit integer
12315              * values, therefore value cannot be an UV.  Yes, this will
12316              * be a problem later if we want switch on Unicode.
12317              * A similar issue a little bit later when switching on
12318              * namedclass. --jhi */
12319
12320             /* If the \ is escaping white space when white space is being
12321              * skipped, it means that that white space is wanted literally, and
12322              * is already in 'value'.  Otherwise, need to translate the escape
12323              * into what it signifies. */
12324             if (! skip_white || ! is_PATWS_cp(value)) switch ((I32)value) {
12325
12326             case 'w':   namedclass = ANYOF_WORDCHAR;    break;
12327             case 'W':   namedclass = ANYOF_NWORDCHAR;   break;
12328             case 's':   namedclass = ANYOF_SPACE;       break;
12329             case 'S':   namedclass = ANYOF_NSPACE;      break;
12330             case 'd':   namedclass = ANYOF_DIGIT;       break;
12331             case 'D':   namedclass = ANYOF_NDIGIT;      break;
12332             case 'v':   namedclass = ANYOF_VERTWS;      break;
12333             case 'V':   namedclass = ANYOF_NVERTWS;     break;
12334             case 'h':   namedclass = ANYOF_HORIZWS;     break;
12335             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
12336             case 'N':  /* Handle \N{NAME} in class */
12337                 {
12338                     /* We only pay attention to the first char of 
12339                     multichar strings being returned. I kinda wonder
12340                     if this makes sense as it does change the behaviour
12341                     from earlier versions, OTOH that behaviour was broken
12342                     as well. */
12343                     if (! grok_bslash_N(pRExC_state, NULL, &value, flagp, depth,
12344                                       TRUE, /* => charclass */
12345                                       strict))
12346                     {
12347                         if (*flagp & RESTART_UTF8)
12348                             FAIL("panic: grok_bslash_N set RESTART_UTF8");
12349                         goto parseit;
12350                     }
12351                 }
12352                 break;
12353             case 'p':
12354             case 'P':
12355                 {
12356                 char *e;
12357
12358                 /* We will handle any undefined properties ourselves */
12359                 U8 swash_init_flags = _CORE_SWASH_INIT_RETURN_IF_UNDEF;
12360
12361                 if (RExC_parse >= RExC_end)
12362                     vFAIL2("Empty \\%c{}", (U8)value);
12363                 if (*RExC_parse == '{') {
12364                     const U8 c = (U8)value;
12365                     e = strchr(RExC_parse++, '}');
12366                     if (!e)
12367                         vFAIL2("Missing right brace on \\%c{}", c);
12368                     while (isSPACE(UCHARAT(RExC_parse)))
12369                         RExC_parse++;
12370                     if (e == RExC_parse)
12371                         vFAIL2("Empty \\%c{}", c);
12372                     n = e - RExC_parse;
12373                     while (isSPACE(UCHARAT(RExC_parse + n - 1)))
12374                         n--;
12375                 }
12376                 else {
12377                     e = RExC_parse;
12378                     n = 1;
12379                 }
12380                 if (!SIZE_ONLY) {
12381                     SV* invlist;
12382                     char* name;
12383
12384                     if (UCHARAT(RExC_parse) == '^') {
12385                          RExC_parse++;
12386                          n--;
12387                          /* toggle.  (The rhs xor gets the single bit that
12388                           * differs between P and p; the other xor inverts just
12389                           * that bit) */
12390                          value ^= 'P' ^ 'p';
12391
12392                          while (isSPACE(UCHARAT(RExC_parse))) {
12393                               RExC_parse++;
12394                               n--;
12395                          }
12396                     }
12397                     /* Try to get the definition of the property into
12398                      * <invlist>.  If /i is in effect, the effective property
12399                      * will have its name be <__NAME_i>.  The design is
12400                      * discussed in commit
12401                      * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
12402                     Newx(name, n + sizeof("_i__\n"), char);
12403
12404                     sprintf(name, "%s%.*s%s\n",
12405                                     (FOLD) ? "__" : "",
12406                                     (int)n,
12407                                     RExC_parse,
12408                                     (FOLD) ? "_i" : ""
12409                     );
12410
12411                     /* Look up the property name, and get its swash and
12412                      * inversion list, if the property is found  */
12413                     if (swash) {
12414                         SvREFCNT_dec_NN(swash);
12415                     }
12416                     swash = _core_swash_init("utf8", name, &PL_sv_undef,
12417                                              1, /* binary */
12418                                              0, /* not tr/// */
12419                                              NULL, /* No inversion list */
12420                                              &swash_init_flags
12421                                             );
12422                     if (! swash || ! (invlist = _get_swash_invlist(swash))) {
12423                         if (swash) {
12424                             SvREFCNT_dec_NN(swash);
12425                             swash = NULL;
12426                         }
12427
12428                         /* Here didn't find it.  It could be a user-defined
12429                          * property that will be available at run-time.  If we
12430                          * accept only compile-time properties, is an error;
12431                          * otherwise add it to the list for run-time look up */
12432                         if (ret_invlist) {
12433                             RExC_parse = e + 1;
12434                             vFAIL3("Property '%.*s' is unknown", (int) n, name);
12435                         }
12436                         Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s\n",
12437                                         (value == 'p' ? '+' : '!'),
12438                                         name);
12439                         has_user_defined_property = TRUE;
12440
12441                         /* We don't know yet, so have to assume that the
12442                          * property could match something in the Latin1 range,
12443                          * hence something that isn't utf8.  Note that this
12444                          * would cause things in <depends_list> to match
12445                          * inappropriately, except that any \p{}, including
12446                          * this one forces Unicode semantics, which means there
12447                          * is <no depends_list> */
12448                         ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
12449                     }
12450                     else {
12451
12452                         /* Here, did get the swash and its inversion list.  If
12453                          * the swash is from a user-defined property, then this
12454                          * whole character class should be regarded as such */
12455                         has_user_defined_property =
12456                                     (swash_init_flags
12457                                      & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY);
12458
12459                         /* Invert if asking for the complement */
12460                         if (value == 'P') {
12461                             _invlist_union_complement_2nd(properties,
12462                                                           invlist,
12463                                                           &properties);
12464
12465                             /* The swash can't be used as-is, because we've
12466                              * inverted things; delay removing it to here after
12467                              * have copied its invlist above */
12468                             SvREFCNT_dec_NN(swash);
12469                             swash = NULL;
12470                         }
12471                         else {
12472                             _invlist_union(properties, invlist, &properties);
12473                         }
12474                     }
12475                     Safefree(name);
12476                 }
12477                 RExC_parse = e + 1;
12478                 namedclass = ANYOF_UNIPROP;  /* no official name, but it's
12479                                                 named */
12480
12481                 /* \p means they want Unicode semantics */
12482                 RExC_uni_semantics = 1;
12483                 }
12484                 break;
12485             case 'n':   value = '\n';                   break;
12486             case 'r':   value = '\r';                   break;
12487             case 't':   value = '\t';                   break;
12488             case 'f':   value = '\f';                   break;
12489             case 'b':   value = '\b';                   break;
12490             case 'e':   value = ASCII_TO_NATIVE('\033');break;
12491             case 'a':   value = ASCII_TO_NATIVE('\007');break;
12492             case 'o':
12493                 RExC_parse--;   /* function expects to be pointed at the 'o' */
12494                 {
12495                     const char* error_msg;
12496                     bool valid = grok_bslash_o(&RExC_parse,
12497                                                &value,
12498                                                &error_msg,
12499                                                SIZE_ONLY,   /* warnings in pass
12500                                                                1 only */
12501                                                strict,
12502                                                silence_non_portable,
12503                                                UTF);
12504                     if (! valid) {
12505                         vFAIL(error_msg);
12506                     }
12507                 }
12508                 if (PL_encoding && value < 0x100) {
12509                     goto recode_encoding;
12510                 }
12511                 break;
12512             case 'x':
12513                 RExC_parse--;   /* function expects to be pointed at the 'x' */
12514                 {
12515                     const char* error_msg;
12516                     bool valid = grok_bslash_x(&RExC_parse,
12517                                                &value,
12518                                                &error_msg,
12519                                                TRUE, /* Output warnings */
12520                                                strict,
12521                                                silence_non_portable,
12522                                                UTF);
12523                     if (! valid) {
12524                         vFAIL(error_msg);
12525                     }
12526                 }
12527                 if (PL_encoding && value < 0x100)
12528                     goto recode_encoding;
12529                 break;
12530             case 'c':
12531                 value = grok_bslash_c(*RExC_parse++, UTF, SIZE_ONLY);
12532                 break;
12533             case '0': case '1': case '2': case '3': case '4':
12534             case '5': case '6': case '7':
12535                 {
12536                     /* Take 1-3 octal digits */
12537                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
12538                     numlen = (strict) ? 4 : 3;
12539                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
12540                     RExC_parse += numlen;
12541                     if (numlen != 3) {
12542                         if (strict) {
12543                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
12544                             vFAIL("Need exactly 3 octal digits");
12545                         }
12546                         else if (! SIZE_ONLY /* like \08, \178 */
12547                                  && numlen < 3
12548                                  && RExC_parse < RExC_end
12549                                  && isDIGIT(*RExC_parse)
12550                                  && ckWARN(WARN_REGEXP))
12551                         {
12552                             SAVEFREESV(RExC_rx_sv);
12553                             reg_warn_non_literal_string(
12554                                  RExC_parse + 1,
12555                                  form_short_octal_warning(RExC_parse, numlen));
12556                             (void)ReREFCNT_inc(RExC_rx_sv);
12557                         }
12558                     }
12559                     if (PL_encoding && value < 0x100)
12560                         goto recode_encoding;
12561                     break;
12562                 }
12563             recode_encoding:
12564                 if (! RExC_override_recoding) {
12565                     SV* enc = PL_encoding;
12566                     value = reg_recode((const char)(U8)value, &enc);
12567                     if (!enc) {
12568                         if (strict) {
12569                             vFAIL("Invalid escape in the specified encoding");
12570                         }
12571                         else if (SIZE_ONLY) {
12572                             ckWARNreg(RExC_parse,
12573                                   "Invalid escape in the specified encoding");
12574                         }
12575                     }
12576                     break;
12577                 }
12578             default:
12579                 /* Allow \_ to not give an error */
12580                 if (!SIZE_ONLY && isWORDCHAR(value) && value != '_') {
12581                     if (strict) {
12582                         vFAIL2("Unrecognized escape \\%c in character class",
12583                                (int)value);
12584                     }
12585                     else {
12586                         SAVEFREESV(RExC_rx_sv);
12587                         ckWARN2reg(RExC_parse,
12588                             "Unrecognized escape \\%c in character class passed through",
12589                             (int)value);
12590                         (void)ReREFCNT_inc(RExC_rx_sv);
12591                     }
12592                 }
12593                 break;
12594             }   /* End of switch on char following backslash */
12595         } /* end of handling backslash escape sequences */
12596 #ifdef EBCDIC
12597         else
12598             literal_endpoint++;
12599 #endif
12600
12601         /* Here, we have the current token in 'value' */
12602
12603         /* What matches in a locale is not known until runtime.  This includes
12604          * what the Posix classes (like \w, [:space:]) match.  Room must be
12605          * reserved (one time per class) to store such classes, either if Perl
12606          * is compiled so that locale nodes always should have this space, or
12607          * if there is such class info to be stored.  The space will contain a
12608          * bit for each named class that is to be matched against.  This isn't
12609          * needed for \p{} and pseudo-classes, as they are not affected by
12610          * locale, and hence are dealt with separately */
12611         if (LOC
12612             && ! need_class
12613             && (ANYOF_LOCALE == ANYOF_CLASS
12614                 || (namedclass > OOB_NAMEDCLASS && namedclass < ANYOF_MAX)))
12615         {
12616             need_class = 1;
12617             if (SIZE_ONLY) {
12618                 RExC_size += ANYOF_CLASS_SKIP - ANYOF_SKIP;
12619             }
12620             else {
12621                 RExC_emit += ANYOF_CLASS_SKIP - ANYOF_SKIP;
12622                 ANYOF_CLASS_ZERO(ret);
12623             }
12624             ANYOF_FLAGS(ret) |= ANYOF_CLASS;
12625         }
12626
12627         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
12628
12629             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
12630              * literal, as is the character that began the false range, i.e.
12631              * the 'a' in the examples */
12632             if (range) {
12633                 if (!SIZE_ONLY) {
12634                     const int w = (RExC_parse >= rangebegin)
12635                                   ? RExC_parse - rangebegin
12636                                   : 0;
12637                     if (strict) {
12638                         vFAIL4("False [] range \"%*.*s\"", w, w, rangebegin);
12639                     }
12640                     else {
12641                         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
12642                         ckWARN4reg(RExC_parse,
12643                                 "False [] range \"%*.*s\"",
12644                                 w, w, rangebegin);
12645                         (void)ReREFCNT_inc(RExC_rx_sv);
12646                         cp_list = add_cp_to_invlist(cp_list, '-');
12647                         cp_list = add_cp_to_invlist(cp_list, prevvalue);
12648                     }
12649                 }
12650
12651                 range = 0; /* this was not a true range */
12652                 element_count += 2; /* So counts for three values */
12653             }
12654
12655             if (! SIZE_ONLY) {
12656                 U8 classnum = namedclass_to_classnum(namedclass);
12657                 if (namedclass >= ANYOF_MAX) {  /* If a special class */
12658                     if (namedclass != ANYOF_UNIPROP) { /* UNIPROP = \p and \P */
12659
12660                         /* Here, should be \h, \H, \v, or \V.  Neither /d nor
12661                          * /l make a difference in what these match.  There
12662                          * would be problems if these characters had folds
12663                          * other than themselves, as cp_list is subject to
12664                          * folding. */
12665                         if (classnum != _CC_VERTSPACE) {
12666                             assert(   namedclass == ANYOF_HORIZWS
12667                                    || namedclass == ANYOF_NHORIZWS);
12668
12669                             /* It turns out that \h is just a synonym for
12670                              * XPosixBlank */
12671                             classnum = _CC_BLANK;
12672                         }
12673
12674                         _invlist_union_maybe_complement_2nd(
12675                                 cp_list,
12676                                 PL_XPosix_ptrs[classnum],
12677                                 cBOOL(namedclass % 2), /* Complement if odd
12678                                                           (NHORIZWS, NVERTWS)
12679                                                         */
12680                                 &cp_list);
12681                     }
12682                 }
12683                 else if (classnum == _CC_ASCII) {
12684 #ifdef HAS_ISASCII
12685                     if (LOC) {
12686                         ANYOF_CLASS_SET(ret, namedclass);
12687                     }
12688                     else
12689 #endif  /* Not isascii(); just use the hard-coded definition for it */
12690                     {
12691                         _invlist_union_maybe_complement_2nd(
12692                                 posixes,
12693                                 PL_ASCII,
12694                                 cBOOL(namedclass % 2), /* Complement if odd
12695                                                           (NASCII) */
12696                                 &posixes);
12697
12698                         /* The code points 128-255 added above will be
12699                          * subtracted out below under /d, so the flag needs to
12700                          * be set */
12701                         if (namedclass == ANYOF_NASCII && DEPENDS_SEMANTICS) {
12702                             ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL;
12703                         }
12704                     }
12705                 }
12706                 else {  /* Garden variety class */
12707
12708                     /* The ascii range inversion list */
12709                     SV* ascii_source = PL_Posix_ptrs[classnum];
12710
12711                     /* The full Latin1 range inversion list */
12712                     SV* l1_source = PL_L1Posix_ptrs[classnum];
12713
12714                     /* This code is structured into two major clauses.  The
12715                      * first is for classes whose complete definitions may not
12716                      * already be known.  It not, the Latin1 definition
12717                      * (guaranteed to already known) is used plus code is
12718                      * generated to load the rest at run-time (only if needed).
12719                      * If the complete definition is known, it drops down to
12720                      * the second clause, where the complete definition is
12721                      * known */
12722
12723                     if (classnum < _FIRST_NON_SWASH_CC) {
12724
12725                         /* Here, the class has a swash, which may or not
12726                          * already be loaded */
12727
12728                         /* The name of the property to use to match the full
12729                          * eXtended Unicode range swash for this character
12730                          * class */
12731                         const char *Xname = swash_property_names[classnum];
12732
12733                         /* If returning the inversion list, we can't defer
12734                          * getting this until runtime */
12735                         if (ret_invlist && !  PL_utf8_swash_ptrs[classnum]) {
12736                             PL_utf8_swash_ptrs[classnum] =
12737                                 _core_swash_init("utf8", Xname, &PL_sv_undef,
12738                                              1, /* binary */
12739                                              0, /* not tr/// */
12740                                              NULL, /* No inversion list */
12741                                              NULL  /* No flags */
12742                                             );
12743                             assert(PL_utf8_swash_ptrs[classnum]);
12744                         }
12745                         if ( !  PL_utf8_swash_ptrs[classnum]) {
12746                             if (namedclass % 2 == 0) { /* A non-complemented
12747                                                           class */
12748                                 /* If not /a matching, there are code points we
12749                                  * don't know at compile time.  Arrange for the
12750                                  * unknown matches to be loaded at run-time, if
12751                                  * needed */
12752                                 if (! AT_LEAST_ASCII_RESTRICTED) {
12753                                     Perl_sv_catpvf(aTHX_ listsv, "+utf8::%s\n",
12754                                                                  Xname);
12755                                 }
12756                                 if (LOC) {  /* Under locale, set run-time
12757                                                lookup */
12758                                     ANYOF_CLASS_SET(ret, namedclass);
12759                                 }
12760                                 else {
12761                                     /* Add the current class's code points to
12762                                      * the running total */
12763                                     _invlist_union(posixes,
12764                                                    (AT_LEAST_ASCII_RESTRICTED)
12765                                                         ? ascii_source
12766                                                         : l1_source,
12767                                                    &posixes);
12768                                 }
12769                             }
12770                             else {  /* A complemented class */
12771                                 if (AT_LEAST_ASCII_RESTRICTED) {
12772                                     /* Under /a should match everything above
12773                                      * ASCII, plus the complement of the set's
12774                                      * ASCII matches */
12775                                     _invlist_union_complement_2nd(posixes,
12776                                                                   ascii_source,
12777                                                                   &posixes);
12778                                 }
12779                                 else {
12780                                     /* Arrange for the unknown matches to be
12781                                      * loaded at run-time, if needed */
12782                                     Perl_sv_catpvf(aTHX_ listsv, "!utf8::%s\n",
12783                                                                  Xname);
12784                                     runtime_posix_matches_above_Unicode = TRUE;
12785                                     if (LOC) {
12786                                         ANYOF_CLASS_SET(ret, namedclass);
12787                                     }
12788                                     else {
12789
12790                                         /* We want to match everything in
12791                                          * Latin1, except those things that
12792                                          * l1_source matches */
12793                                         SV* scratch_list = NULL;
12794                                         _invlist_subtract(PL_Latin1, l1_source,
12795                                                           &scratch_list);
12796
12797                                         /* Add the list from this class to the
12798                                          * running total */
12799                                         if (! posixes) {
12800                                             posixes = scratch_list;
12801                                         }
12802                                         else {
12803                                             _invlist_union(posixes,
12804                                                            scratch_list,
12805                                                            &posixes);
12806                                             SvREFCNT_dec_NN(scratch_list);
12807                                         }
12808                                         if (DEPENDS_SEMANTICS) {
12809                                             ANYOF_FLAGS(ret)
12810                                                   |= ANYOF_NON_UTF8_LATIN1_ALL;
12811                                         }
12812                                     }
12813                                 }
12814                             }
12815                             goto namedclass_done;
12816                         }
12817
12818                         /* Here, there is a swash loaded for the class.  If no
12819                          * inversion list for it yet, get it */
12820                         if (! PL_XPosix_ptrs[classnum]) {
12821                             PL_XPosix_ptrs[classnum]
12822                              = _swash_to_invlist(PL_utf8_swash_ptrs[classnum]);
12823                         }
12824                     }
12825
12826                     /* Here there is an inversion list already loaded for the
12827                      * entire class */
12828
12829                     if (namedclass % 2 == 0) {  /* A non-complemented class,
12830                                                    like ANYOF_PUNCT */
12831                         if (! LOC) {
12832                             /* For non-locale, just add it to any existing list
12833                              * */
12834                             _invlist_union(posixes,
12835                                            (AT_LEAST_ASCII_RESTRICTED)
12836                                                ? ascii_source
12837                                                : PL_XPosix_ptrs[classnum],
12838                                            &posixes);
12839                         }
12840                         else {  /* Locale */
12841                             SV* scratch_list = NULL;
12842
12843                             /* For above Latin1 code points, we use the full
12844                              * Unicode range */
12845                             _invlist_intersection(PL_AboveLatin1,
12846                                                   PL_XPosix_ptrs[classnum],
12847                                                   &scratch_list);
12848                             /* And set the output to it, adding instead if
12849                              * there already is an output.  Checking if
12850                              * 'posixes' is NULL first saves an extra clone.
12851                              * Its reference count will be decremented at the
12852                              * next union, etc, or if this is the only
12853                              * instance, at the end of the routine */
12854                             if (! posixes) {
12855                                 posixes = scratch_list;
12856                             }
12857                             else {
12858                                 _invlist_union(posixes, scratch_list, &posixes);
12859                                 SvREFCNT_dec_NN(scratch_list);
12860                             }
12861
12862 #ifndef HAS_ISBLANK
12863                             if (namedclass != ANYOF_BLANK) {
12864 #endif
12865                                 /* Set this class in the node for runtime
12866                                  * matching */
12867                                 ANYOF_CLASS_SET(ret, namedclass);
12868 #ifndef HAS_ISBLANK
12869                             }
12870                             else {
12871                                 /* No isblank(), use the hard-coded ASCII-range
12872                                  * blanks, adding them to the running total. */
12873
12874                                 _invlist_union(posixes, ascii_source, &posixes);
12875                             }
12876 #endif
12877                         }
12878                     }
12879                     else {  /* A complemented class, like ANYOF_NPUNCT */
12880                         if (! LOC) {
12881                             _invlist_union_complement_2nd(
12882                                                 posixes,
12883                                                 (AT_LEAST_ASCII_RESTRICTED)
12884                                                     ? ascii_source
12885                                                     : PL_XPosix_ptrs[classnum],
12886                                                 &posixes);
12887                             /* Under /d, everything in the upper half of the
12888                              * Latin1 range matches this complement */
12889                             if (DEPENDS_SEMANTICS) {
12890                                 ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL;
12891                             }
12892                         }
12893                         else {  /* Locale */
12894                             SV* scratch_list = NULL;
12895                             _invlist_subtract(PL_AboveLatin1,
12896                                               PL_XPosix_ptrs[classnum],
12897                                               &scratch_list);
12898                             if (! posixes) {
12899                                 posixes = scratch_list;
12900                             }
12901                             else {
12902                                 _invlist_union(posixes, scratch_list, &posixes);
12903                                 SvREFCNT_dec_NN(scratch_list);
12904                             }
12905 #ifndef HAS_ISBLANK
12906                             if (namedclass != ANYOF_NBLANK) {
12907 #endif
12908                                 ANYOF_CLASS_SET(ret, namedclass);
12909 #ifndef HAS_ISBLANK
12910                             }
12911                             else {
12912                                 /* Get the list of all code points in Latin1
12913                                  * that are not ASCII blanks, and add them to
12914                                  * the running total */
12915                                 _invlist_subtract(PL_Latin1, ascii_source,
12916                                                   &scratch_list);
12917                                 _invlist_union(posixes, scratch_list, &posixes);
12918                                 SvREFCNT_dec_NN(scratch_list);
12919                             }
12920 #endif
12921                         }
12922                     }
12923                 }
12924               namedclass_done:
12925                 continue;   /* Go get next character */
12926             }
12927         } /* end of namedclass \blah */
12928
12929         /* Here, we have a single value.  If 'range' is set, it is the ending
12930          * of a range--check its validity.  Later, we will handle each
12931          * individual code point in the range.  If 'range' isn't set, this
12932          * could be the beginning of a range, so check for that by looking
12933          * ahead to see if the next real character to be processed is the range
12934          * indicator--the minus sign */
12935
12936         if (skip_white) {
12937             RExC_parse = regpatws(pRExC_state, RExC_parse,
12938                                 FALSE /* means don't recognize comments */);
12939         }
12940
12941         if (range) {
12942             if (prevvalue > value) /* b-a */ {
12943                 const int w = RExC_parse - rangebegin;
12944                 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
12945                 range = 0; /* not a valid range */
12946             }
12947         }
12948         else {
12949             prevvalue = value; /* save the beginning of the potential range */
12950             if (! stop_at_1     /* Can't be a range if parsing just one thing */
12951                 && *RExC_parse == '-')
12952             {
12953                 char* next_char_ptr = RExC_parse + 1;
12954                 if (skip_white) {   /* Get the next real char after the '-' */
12955                     next_char_ptr = regpatws(pRExC_state,
12956                                              RExC_parse + 1,
12957                                              FALSE); /* means don't recognize
12958                                                         comments */
12959                 }
12960
12961                 /* If the '-' is at the end of the class (just before the ']',
12962                  * it is a literal minus; otherwise it is a range */
12963                 if (next_char_ptr < RExC_end && *next_char_ptr != ']') {
12964                     RExC_parse = next_char_ptr;
12965
12966                     /* a bad range like \w-, [:word:]- ? */
12967                     if (namedclass > OOB_NAMEDCLASS) {
12968                         if (strict || ckWARN(WARN_REGEXP)) {
12969                             const int w =
12970                                 RExC_parse >= rangebegin ?
12971                                 RExC_parse - rangebegin : 0;
12972                             if (strict) {
12973                                 vFAIL4("False [] range \"%*.*s\"",
12974                                     w, w, rangebegin);
12975                             }
12976                             else {
12977                                 vWARN4(RExC_parse,
12978                                     "False [] range \"%*.*s\"",
12979                                     w, w, rangebegin);
12980                             }
12981                         }
12982                         if (!SIZE_ONLY) {
12983                             cp_list = add_cp_to_invlist(cp_list, '-');
12984                         }
12985                         element_count++;
12986                     } else
12987                         range = 1;      /* yeah, it's a range! */
12988                     continue;   /* but do it the next time */
12989                 }
12990             }
12991         }
12992
12993         /* Here, <prevvalue> is the beginning of the range, if any; or <value>
12994          * if not */
12995
12996         /* non-Latin1 code point implies unicode semantics.  Must be set in
12997          * pass1 so is there for the whole of pass 2 */
12998         if (value > 255) {
12999             RExC_uni_semantics = 1;
13000         }
13001
13002         /* Ready to process either the single value, or the completed range.
13003          * For single-valued non-inverted ranges, we consider the possibility
13004          * of multi-char folds.  (We made a conscious decision to not do this
13005          * for the other cases because it can often lead to non-intuitive
13006          * results.  For example, you have the peculiar case that:
13007          *  "s s" =~ /^[^\xDF]+$/i => Y
13008          *  "ss"  =~ /^[^\xDF]+$/i => N
13009          *
13010          * See [perl #89750] */
13011         if (FOLD && allow_multi_folds && value == prevvalue) {
13012             if (value == LATIN_SMALL_LETTER_SHARP_S
13013                 || (value > 255 && _invlist_contains_cp(PL_HasMultiCharFold,
13014                                                         value)))
13015             {
13016                 /* Here <value> is indeed a multi-char fold.  Get what it is */
13017
13018                 U8 foldbuf[UTF8_MAXBYTES_CASE];
13019                 STRLEN foldlen;
13020
13021                 UV folded = _to_uni_fold_flags(
13022                                 value,
13023                                 foldbuf,
13024                                 &foldlen,
13025                                 FOLD_FLAGS_FULL
13026                                 | ((LOC) ?  FOLD_FLAGS_LOCALE
13027                                             : (ASCII_FOLD_RESTRICTED)
13028                                               ? FOLD_FLAGS_NOMIX_ASCII
13029                                               : 0)
13030                                 );
13031
13032                 /* Here, <folded> should be the first character of the
13033                  * multi-char fold of <value>, with <foldbuf> containing the
13034                  * whole thing.  But, if this fold is not allowed (because of
13035                  * the flags), <fold> will be the same as <value>, and should
13036                  * be processed like any other character, so skip the special
13037                  * handling */
13038                 if (folded != value) {
13039
13040                     /* Skip if we are recursed, currently parsing the class
13041                      * again.  Otherwise add this character to the list of
13042                      * multi-char folds. */
13043                     if (! RExC_in_multi_char_class) {
13044                         AV** this_array_ptr;
13045                         AV* this_array;
13046                         STRLEN cp_count = utf8_length(foldbuf,
13047                                                       foldbuf + foldlen);
13048                         SV* multi_fold = sv_2mortal(newSVpvn("", 0));
13049
13050                         Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%"UVXf"}", value);
13051
13052
13053                         if (! multi_char_matches) {
13054                             multi_char_matches = newAV();
13055                         }
13056
13057                         /* <multi_char_matches> is actually an array of arrays.
13058                          * There will be one or two top-level elements: [2],
13059                          * and/or [3].  The [2] element is an array, each
13060                          * element thereof is a character which folds to two
13061                          * characters; likewise for [3].  (Unicode guarantees a
13062                          * maximum of 3 characters in any fold.)  When we
13063                          * rewrite the character class below, we will do so
13064                          * such that the longest folds are written first, so
13065                          * that it prefers the longest matching strings first.
13066                          * This is done even if it turns out that any
13067                          * quantifier is non-greedy, out of programmer
13068                          * laziness.  Tom Christiansen has agreed that this is
13069                          * ok.  This makes the test for the ligature 'ffi' come
13070                          * before the test for 'ff' */
13071                         if (av_exists(multi_char_matches, cp_count)) {
13072                             this_array_ptr = (AV**) av_fetch(multi_char_matches,
13073                                                              cp_count, FALSE);
13074                             this_array = *this_array_ptr;
13075                         }
13076                         else {
13077                             this_array = newAV();
13078                             av_store(multi_char_matches, cp_count,
13079                                      (SV*) this_array);
13080                         }
13081                         av_push(this_array, multi_fold);
13082                     }
13083
13084                     /* This element should not be processed further in this
13085                      * class */
13086                     element_count--;
13087                     value = save_value;
13088                     prevvalue = save_prevvalue;
13089                     continue;
13090                 }
13091             }
13092         }
13093
13094         /* Deal with this element of the class */
13095         if (! SIZE_ONLY) {
13096 #ifndef EBCDIC
13097             cp_list = _add_range_to_invlist(cp_list, prevvalue, value);
13098 #else
13099             SV* this_range = _new_invlist(1);
13100             _append_range_to_invlist(this_range, prevvalue, value);
13101
13102             /* In EBCDIC, the ranges 'A-Z' and 'a-z' are each not contiguous.
13103              * If this range was specified using something like 'i-j', we want
13104              * to include only the 'i' and the 'j', and not anything in
13105              * between, so exclude non-ASCII, non-alphabetics from it.
13106              * However, if the range was specified with something like
13107              * [\x89-\x91] or [\x89-j], all code points within it should be
13108              * included.  literal_endpoint==2 means both ends of the range used
13109              * a literal character, not \x{foo} */
13110             if (literal_endpoint == 2
13111                 && (prevvalue >= 'a' && value <= 'z')
13112                     || (prevvalue >= 'A' && value <= 'Z'))
13113             {
13114                 _invlist_intersection(this_range, PL_Posix_ptrs[_CC_ALPHA],
13115                                       &this_range);
13116             }
13117             _invlist_union(cp_list, this_range, &cp_list);
13118             literal_endpoint = 0;
13119 #endif
13120         }
13121
13122         range = 0; /* this range (if it was one) is done now */
13123     } /* End of loop through all the text within the brackets */
13124
13125     /* If anything in the class expands to more than one character, we have to
13126      * deal with them by building up a substitute parse string, and recursively
13127      * calling reg() on it, instead of proceeding */
13128     if (multi_char_matches) {
13129         SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
13130         I32 cp_count;
13131         STRLEN len;
13132         char *save_end = RExC_end;
13133         char *save_parse = RExC_parse;
13134         bool first_time = TRUE;     /* First multi-char occurrence doesn't get
13135                                        a "|" */
13136         I32 reg_flags;
13137
13138         assert(! invert);
13139 #if 0   /* Have decided not to deal with multi-char folds in inverted classes,
13140            because too confusing */
13141         if (invert) {
13142             sv_catpv(substitute_parse, "(?:");
13143         }
13144 #endif
13145
13146         /* Look at the longest folds first */
13147         for (cp_count = av_len(multi_char_matches); cp_count > 0; cp_count--) {
13148
13149             if (av_exists(multi_char_matches, cp_count)) {
13150                 AV** this_array_ptr;
13151                 SV* this_sequence;
13152
13153                 this_array_ptr = (AV**) av_fetch(multi_char_matches,
13154                                                  cp_count, FALSE);
13155                 while ((this_sequence = av_pop(*this_array_ptr)) !=
13156                                                                 &PL_sv_undef)
13157                 {
13158                     if (! first_time) {
13159                         sv_catpv(substitute_parse, "|");
13160                     }
13161                     first_time = FALSE;
13162
13163                     sv_catpv(substitute_parse, SvPVX(this_sequence));
13164                 }
13165             }
13166         }
13167
13168         /* If the character class contains anything else besides these
13169          * multi-character folds, have to include it in recursive parsing */
13170         if (element_count) {
13171             sv_catpv(substitute_parse, "|[");
13172             sv_catpvn(substitute_parse, orig_parse, RExC_parse - orig_parse);
13173             sv_catpv(substitute_parse, "]");
13174         }
13175
13176         sv_catpv(substitute_parse, ")");
13177 #if 0
13178         if (invert) {
13179             /* This is a way to get the parse to skip forward a whole named
13180              * sequence instead of matching the 2nd character when it fails the
13181              * first */
13182             sv_catpv(substitute_parse, "(*THEN)(*SKIP)(*FAIL)|.)");
13183         }
13184 #endif
13185
13186         RExC_parse = SvPV(substitute_parse, len);
13187         RExC_end = RExC_parse + len;
13188         RExC_in_multi_char_class = 1;
13189         RExC_emit = (regnode *)orig_emit;
13190
13191         ret = reg(pRExC_state, 1, &reg_flags, depth+1);
13192
13193         *flagp |= reg_flags&(HASWIDTH|SIMPLE|SPSTART|POSTPONED|RESTART_UTF8);
13194
13195         RExC_parse = save_parse;
13196         RExC_end = save_end;
13197         RExC_in_multi_char_class = 0;
13198         SvREFCNT_dec_NN(multi_char_matches);
13199         return ret;
13200     }
13201
13202     /* If the character class contains only a single element, it may be
13203      * optimizable into another node type which is smaller and runs faster.
13204      * Check if this is the case for this class */
13205     if (element_count == 1 && ! ret_invlist) {
13206         U8 op = END;
13207         U8 arg = 0;
13208
13209         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class, like \w or
13210                                               [:digit:] or \p{foo} */
13211
13212             /* All named classes are mapped into POSIXish nodes, with its FLAG
13213              * argument giving which class it is */
13214             switch ((I32)namedclass) {
13215                 case ANYOF_UNIPROP:
13216                     break;
13217
13218                 /* These don't depend on the charset modifiers.  They always
13219                  * match under /u rules */
13220                 case ANYOF_NHORIZWS:
13221                 case ANYOF_HORIZWS:
13222                     namedclass = ANYOF_BLANK + namedclass - ANYOF_HORIZWS;
13223                     /* FALLTHROUGH */
13224
13225                 case ANYOF_NVERTWS:
13226                 case ANYOF_VERTWS:
13227                     op = POSIXU;
13228                     goto join_posix;
13229
13230                 /* The actual POSIXish node for all the rest depends on the
13231                  * charset modifier.  The ones in the first set depend only on
13232                  * ASCII or, if available on this platform, locale */
13233                 case ANYOF_ASCII:
13234                 case ANYOF_NASCII:
13235 #ifdef HAS_ISASCII
13236                     op = (LOC) ? POSIXL : POSIXA;
13237 #else
13238                     op = POSIXA;
13239 #endif
13240                     goto join_posix;
13241
13242                 case ANYOF_NCASED:
13243                 case ANYOF_LOWER:
13244                 case ANYOF_NLOWER:
13245                 case ANYOF_UPPER:
13246                 case ANYOF_NUPPER:
13247                     /* under /a could be alpha */
13248                     if (FOLD) {
13249                         if (ASCII_RESTRICTED) {
13250                             namedclass = ANYOF_ALPHA + (namedclass % 2);
13251                         }
13252                         else if (! LOC) {
13253                             break;
13254                         }
13255                     }
13256                     /* FALLTHROUGH */
13257
13258                 /* The rest have more possibilities depending on the charset.
13259                  * We take advantage of the enum ordering of the charset
13260                  * modifiers to get the exact node type, */
13261                 default:
13262                     op = POSIXD + get_regex_charset(RExC_flags);
13263                     if (op > POSIXA) { /* /aa is same as /a */
13264                         op = POSIXA;
13265                     }
13266 #ifndef HAS_ISBLANK
13267                     if (op == POSIXL
13268                         && (namedclass == ANYOF_BLANK
13269                             || namedclass == ANYOF_NBLANK))
13270                     {
13271                         op = POSIXA;
13272                     }
13273 #endif
13274
13275                 join_posix:
13276                     /* The odd numbered ones are the complements of the
13277                      * next-lower even number one */
13278                     if (namedclass % 2 == 1) {
13279                         invert = ! invert;
13280                         namedclass--;
13281                     }
13282                     arg = namedclass_to_classnum(namedclass);
13283                     break;
13284             }
13285         }
13286         else if (value == prevvalue) {
13287
13288             /* Here, the class consists of just a single code point */
13289
13290             if (invert) {
13291                 if (! LOC && value == '\n') {
13292                     op = REG_ANY; /* Optimize [^\n] */
13293                     *flagp |= HASWIDTH|SIMPLE;
13294                     RExC_naughty++;
13295                 }
13296             }
13297             else if (value < 256 || UTF) {
13298
13299                 /* Optimize a single value into an EXACTish node, but not if it
13300                  * would require converting the pattern to UTF-8. */
13301                 op = compute_EXACTish(pRExC_state);
13302             }
13303         } /* Otherwise is a range */
13304         else if (! LOC) {   /* locale could vary these */
13305             if (prevvalue == '0') {
13306                 if (value == '9') {
13307                     arg = _CC_DIGIT;
13308                     op = POSIXA;
13309                 }
13310             }
13311         }
13312
13313         /* Here, we have changed <op> away from its initial value iff we found
13314          * an optimization */
13315         if (op != END) {
13316
13317             /* Throw away this ANYOF regnode, and emit the calculated one,
13318              * which should correspond to the beginning, not current, state of
13319              * the parse */
13320             const char * cur_parse = RExC_parse;
13321             RExC_parse = (char *)orig_parse;
13322             if ( SIZE_ONLY) {
13323                 if (! LOC) {
13324
13325                     /* To get locale nodes to not use the full ANYOF size would
13326                      * require moving the code above that writes the portions
13327                      * of it that aren't in other nodes to after this point.
13328                      * e.g.  ANYOF_CLASS_SET */
13329                     RExC_size = orig_size;
13330                 }
13331             }
13332             else {
13333                 RExC_emit = (regnode *)orig_emit;
13334                 if (PL_regkind[op] == POSIXD) {
13335                     if (invert) {
13336                         op += NPOSIXD - POSIXD;
13337                     }
13338                 }
13339             }
13340
13341             ret = reg_node(pRExC_state, op);
13342
13343             if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
13344                 if (! SIZE_ONLY) {
13345                     FLAGS(ret) = arg;
13346                 }
13347                 *flagp |= HASWIDTH|SIMPLE;
13348             }
13349             else if (PL_regkind[op] == EXACT) {
13350                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value);
13351             }
13352
13353             RExC_parse = (char *) cur_parse;
13354
13355             SvREFCNT_dec(posixes);
13356             SvREFCNT_dec(cp_list);
13357             return ret;
13358         }
13359     }
13360
13361     if (SIZE_ONLY)
13362         return ret;
13363     /****** !SIZE_ONLY (Pass 2) AFTER HERE *********/
13364
13365     /* If folding, we calculate all characters that could fold to or from the
13366      * ones already on the list */
13367     if (FOLD && cp_list) {
13368         UV start, end;  /* End points of code point ranges */
13369
13370         SV* fold_intersection = NULL;
13371
13372         /* If the highest code point is within Latin1, we can use the
13373          * compiled-in Alphas list, and not have to go out to disk.  This
13374          * yields two false positives, the masculine and feminine ordinal
13375          * indicators, which are weeded out below using the
13376          * IS_IN_SOME_FOLD_L1() macro */
13377         if (invlist_highest(cp_list) < 256) {
13378             _invlist_intersection(PL_L1Posix_ptrs[_CC_ALPHA], cp_list,
13379                                                            &fold_intersection);
13380         }
13381         else {
13382
13383             /* Here, there are non-Latin1 code points, so we will have to go
13384              * fetch the list of all the characters that participate in folds
13385              */
13386             if (! PL_utf8_foldable) {
13387                 SV* swash = swash_init("utf8", "_Perl_Any_Folds",
13388                                        &PL_sv_undef, 1, 0);
13389                 PL_utf8_foldable = _get_swash_invlist(swash);
13390                 SvREFCNT_dec_NN(swash);
13391             }
13392
13393             /* This is a hash that for a particular fold gives all characters
13394              * that are involved in it */
13395             if (! PL_utf8_foldclosures) {
13396
13397                 /* If we were unable to find any folds, then we likely won't be
13398                  * able to find the closures.  So just create an empty list.
13399                  * Folding will effectively be restricted to the non-Unicode
13400                  * rules hard-coded into Perl.  (This case happens legitimately
13401                  * during compilation of Perl itself before the Unicode tables
13402                  * are generated) */
13403                 if (_invlist_len(PL_utf8_foldable) == 0) {
13404                     PL_utf8_foldclosures = newHV();
13405                 }
13406                 else {
13407                     /* If the folds haven't been read in, call a fold function
13408                      * to force that */
13409                     if (! PL_utf8_tofold) {
13410                         U8 dummy[UTF8_MAXBYTES+1];
13411
13412                         /* This string is just a short named one above \xff */
13413                         to_utf8_fold((U8*) HYPHEN_UTF8, dummy, NULL);
13414                         assert(PL_utf8_tofold); /* Verify that worked */
13415                     }
13416                     PL_utf8_foldclosures =
13417                                     _swash_inversion_hash(PL_utf8_tofold);
13418                 }
13419             }
13420
13421             /* Only the characters in this class that participate in folds need
13422              * be checked.  Get the intersection of this class and all the
13423              * possible characters that are foldable.  This can quickly narrow
13424              * down a large class */
13425             _invlist_intersection(PL_utf8_foldable, cp_list,
13426                                   &fold_intersection);
13427         }
13428
13429         /* Now look at the foldable characters in this class individually */
13430         invlist_iterinit(fold_intersection);
13431         while (invlist_iternext(fold_intersection, &start, &end)) {
13432             UV j;
13433
13434             /* Locale folding for Latin1 characters is deferred until runtime */
13435             if (LOC && start < 256) {
13436                 start = 256;
13437             }
13438
13439             /* Look at every character in the range */
13440             for (j = start; j <= end; j++) {
13441
13442                 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
13443                 STRLEN foldlen;
13444                 SV** listp;
13445
13446                 if (j < 256) {
13447
13448                     /* We have the latin1 folding rules hard-coded here so that
13449                      * an innocent-looking character class, like /[ks]/i won't
13450                      * have to go out to disk to find the possible matches.
13451                      * XXX It would be better to generate these via regen, in
13452                      * case a new version of the Unicode standard adds new
13453                      * mappings, though that is not really likely, and may be
13454                      * caught by the default: case of the switch below. */
13455
13456                     if (IS_IN_SOME_FOLD_L1(j)) {
13457
13458                         /* ASCII is always matched; non-ASCII is matched only
13459                          * under Unicode rules */
13460                         if (isASCII(j) || AT_LEAST_UNI_SEMANTICS) {
13461                             cp_list =
13462                                 add_cp_to_invlist(cp_list, PL_fold_latin1[j]);
13463                         }
13464                         else {
13465                             depends_list =
13466                              add_cp_to_invlist(depends_list, PL_fold_latin1[j]);
13467                         }
13468                     }
13469
13470                     if (HAS_NONLATIN1_FOLD_CLOSURE(j)
13471                         && (! isASCII(j) || ! ASCII_FOLD_RESTRICTED))
13472                     {
13473                         /* Certain Latin1 characters have matches outside
13474                          * Latin1.  To get here, <j> is one of those
13475                          * characters.   None of these matches is valid for
13476                          * ASCII characters under /aa, which is why the 'if'
13477                          * just above excludes those.  These matches only
13478                          * happen when the target string is utf8.  The code
13479                          * below adds the single fold closures for <j> to the
13480                          * inversion list. */
13481                         switch (j) {
13482                             case 'k':
13483                             case 'K':
13484                                 cp_list =
13485                                     add_cp_to_invlist(cp_list, KELVIN_SIGN);
13486                                 break;
13487                             case 's':
13488                             case 'S':
13489                                 cp_list = add_cp_to_invlist(cp_list,
13490                                                     LATIN_SMALL_LETTER_LONG_S);
13491                                 break;
13492                             case MICRO_SIGN:
13493                                 cp_list = add_cp_to_invlist(cp_list,
13494                                                     GREEK_CAPITAL_LETTER_MU);
13495                                 cp_list = add_cp_to_invlist(cp_list,
13496                                                     GREEK_SMALL_LETTER_MU);
13497                                 break;
13498                             case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
13499                             case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
13500                                 cp_list =
13501                                     add_cp_to_invlist(cp_list, ANGSTROM_SIGN);
13502                                 break;
13503                             case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
13504                                 cp_list = add_cp_to_invlist(cp_list,
13505                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
13506                                 break;
13507                             case LATIN_SMALL_LETTER_SHARP_S:
13508                                 cp_list = add_cp_to_invlist(cp_list,
13509                                                 LATIN_CAPITAL_LETTER_SHARP_S);
13510                                 break;
13511                             case 'F': case 'f':
13512                             case 'I': case 'i':
13513                             case 'L': case 'l':
13514                             case 'T': case 't':
13515                             case 'A': case 'a':
13516                             case 'H': case 'h':
13517                             case 'J': case 'j':
13518                             case 'N': case 'n':
13519                             case 'W': case 'w':
13520                             case 'Y': case 'y':
13521                                 /* These all are targets of multi-character
13522                                  * folds from code points that require UTF8 to
13523                                  * express, so they can't match unless the
13524                                  * target string is in UTF-8, so no action here
13525                                  * is necessary, as regexec.c properly handles
13526                                  * the general case for UTF-8 matching and
13527                                  * multi-char folds */
13528                                 break;
13529                             default:
13530                                 /* Use deprecated warning to increase the
13531                                  * chances of this being output */
13532                                 ckWARN2regdep(RExC_parse, "Perl folding rules are not up-to-date for 0x%"UVXf"; please use the perlbug utility to report;", j);
13533                                 break;
13534                         }
13535                     }
13536                     continue;
13537                 }
13538
13539                 /* Here is an above Latin1 character.  We don't have the rules
13540                  * hard-coded for it.  First, get its fold.  This is the simple
13541                  * fold, as the multi-character folds have been handled earlier
13542                  * and separated out */
13543                 _to_uni_fold_flags(j, foldbuf, &foldlen,
13544                                                ((LOC)
13545                                                ? FOLD_FLAGS_LOCALE
13546                                                : (ASCII_FOLD_RESTRICTED)
13547                                                   ? FOLD_FLAGS_NOMIX_ASCII
13548                                                   : 0));
13549
13550                 /* Single character fold of above Latin1.  Add everything in
13551                  * its fold closure to the list that this node should match.
13552                  * The fold closures data structure is a hash with the keys
13553                  * being the UTF-8 of every character that is folded to, like
13554                  * 'k', and the values each an array of all code points that
13555                  * fold to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ].
13556                  * Multi-character folds are not included */
13557                 if ((listp = hv_fetch(PL_utf8_foldclosures,
13558                                       (char *) foldbuf, foldlen, FALSE)))
13559                 {
13560                     AV* list = (AV*) *listp;
13561                     IV k;
13562                     for (k = 0; k <= av_len(list); k++) {
13563                         SV** c_p = av_fetch(list, k, FALSE);
13564                         UV c;
13565                         if (c_p == NULL) {
13566                             Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
13567                         }
13568                         c = SvUV(*c_p);
13569
13570                         /* /aa doesn't allow folds between ASCII and non-; /l
13571                          * doesn't allow them between above and below 256 */
13572                         if ((ASCII_FOLD_RESTRICTED
13573                                   && (isASCII(c) != isASCII(j)))
13574                             || (LOC && ((c < 256) != (j < 256))))
13575                         {
13576                             continue;
13577                         }
13578
13579                         /* Folds involving non-ascii Latin1 characters
13580                          * under /d are added to a separate list */
13581                         if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS)
13582                         {
13583                             cp_list = add_cp_to_invlist(cp_list, c);
13584                         }
13585                         else {
13586                           depends_list = add_cp_to_invlist(depends_list, c);
13587                         }
13588                     }
13589                 }
13590             }
13591         }
13592         SvREFCNT_dec_NN(fold_intersection);
13593     }
13594
13595     /* And combine the result (if any) with any inversion list from posix
13596      * classes.  The lists are kept separate up to now because we don't want to
13597      * fold the classes (folding of those is automatically handled by the swash
13598      * fetching code) */
13599     if (posixes) {
13600         if (! DEPENDS_SEMANTICS) {
13601             if (cp_list) {
13602                 _invlist_union(cp_list, posixes, &cp_list);
13603                 SvREFCNT_dec_NN(posixes);
13604             }
13605             else {
13606                 cp_list = posixes;
13607             }
13608         }
13609         else {
13610             /* Under /d, we put into a separate list the Latin1 things that
13611              * match only when the target string is utf8 */
13612             SV* nonascii_but_latin1_properties = NULL;
13613             _invlist_intersection(posixes, PL_Latin1,
13614                                   &nonascii_but_latin1_properties);
13615             _invlist_subtract(nonascii_but_latin1_properties, PL_ASCII,
13616                               &nonascii_but_latin1_properties);
13617             _invlist_subtract(posixes, nonascii_but_latin1_properties,
13618                               &posixes);
13619             if (cp_list) {
13620                 _invlist_union(cp_list, posixes, &cp_list);
13621                 SvREFCNT_dec_NN(posixes);
13622             }
13623             else {
13624                 cp_list = posixes;
13625             }
13626
13627             if (depends_list) {
13628                 _invlist_union(depends_list, nonascii_but_latin1_properties,
13629                                &depends_list);
13630                 SvREFCNT_dec_NN(nonascii_but_latin1_properties);
13631             }
13632             else {
13633                 depends_list = nonascii_but_latin1_properties;
13634             }
13635         }
13636     }
13637
13638     /* And combine the result (if any) with any inversion list from properties.
13639      * The lists are kept separate up to now so that we can distinguish the two
13640      * in regards to matching above-Unicode.  A run-time warning is generated
13641      * if a Unicode property is matched against a non-Unicode code point. But,
13642      * we allow user-defined properties to match anything, without any warning,
13643      * and we also suppress the warning if there is a portion of the character
13644      * class that isn't a Unicode property, and which matches above Unicode, \W
13645      * or [\x{110000}] for example.
13646      * (Note that in this case, unlike the Posix one above, there is no
13647      * <depends_list>, because having a Unicode property forces Unicode
13648      * semantics */
13649     if (properties) {
13650         bool warn_super = ! has_user_defined_property;
13651         if (cp_list) {
13652
13653             /* If it matters to the final outcome, see if a non-property
13654              * component of the class matches above Unicode.  If so, the
13655              * warning gets suppressed.  This is true even if just a single
13656              * such code point is specified, as though not strictly correct if
13657              * another such code point is matched against, the fact that they
13658              * are using above-Unicode code points indicates they should know
13659              * the issues involved */
13660             if (warn_super) {
13661                 bool non_prop_matches_above_Unicode =
13662                             runtime_posix_matches_above_Unicode
13663                             | (invlist_highest(cp_list) > PERL_UNICODE_MAX);
13664                 if (invert) {
13665                     non_prop_matches_above_Unicode =
13666                                             !  non_prop_matches_above_Unicode;
13667                 }
13668                 warn_super = ! non_prop_matches_above_Unicode;
13669             }
13670
13671             _invlist_union(properties, cp_list, &cp_list);
13672             SvREFCNT_dec_NN(properties);
13673         }
13674         else {
13675             cp_list = properties;
13676         }
13677
13678         if (warn_super) {
13679             OP(ret) = ANYOF_WARN_SUPER;
13680         }
13681     }
13682
13683     /* Here, we have calculated what code points should be in the character
13684      * class.
13685      *
13686      * Now we can see about various optimizations.  Fold calculation (which we
13687      * did above) needs to take place before inversion.  Otherwise /[^k]/i
13688      * would invert to include K, which under /i would match k, which it
13689      * shouldn't.  Therefore we can't invert folded locale now, as it won't be
13690      * folded until runtime */
13691
13692     /* Optimize inverted simple patterns (e.g. [^a-z]) when everything is known
13693      * at compile time.  Besides not inverting folded locale now, we can't
13694      * invert if there are things such as \w, which aren't known until runtime
13695      * */
13696     if (invert
13697         && ! (LOC && (FOLD || (ANYOF_FLAGS(ret) & ANYOF_CLASS)))
13698         && ! depends_list
13699         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
13700     {
13701         _invlist_invert(cp_list);
13702
13703         /* Any swash can't be used as-is, because we've inverted things */
13704         if (swash) {
13705             SvREFCNT_dec_NN(swash);
13706             swash = NULL;
13707         }
13708
13709         /* Clear the invert flag since have just done it here */
13710         invert = FALSE;
13711     }
13712
13713     if (ret_invlist) {
13714         *ret_invlist = cp_list;
13715         SvREFCNT_dec(swash);
13716
13717         /* Discard the generated node */
13718         if (SIZE_ONLY) {
13719             RExC_size = orig_size;
13720         }
13721         else {
13722             RExC_emit = orig_emit;
13723         }
13724         return orig_emit;
13725     }
13726
13727     /* If we didn't do folding, it's because some information isn't available
13728      * until runtime; set the run-time fold flag for these.  (We don't have to
13729      * worry about properties folding, as that is taken care of by the swash
13730      * fetching) */
13731     if (FOLD && LOC)
13732     {
13733        ANYOF_FLAGS(ret) |= ANYOF_LOC_FOLD;
13734     }
13735
13736     /* Some character classes are equivalent to other nodes.  Such nodes take
13737      * up less room and generally fewer operations to execute than ANYOF nodes.
13738      * Above, we checked for and optimized into some such equivalents for
13739      * certain common classes that are easy to test.  Getting to this point in
13740      * the code means that the class didn't get optimized there.  Since this
13741      * code is only executed in Pass 2, it is too late to save space--it has
13742      * been allocated in Pass 1, and currently isn't given back.  But turning
13743      * things into an EXACTish node can allow the optimizer to join it to any
13744      * adjacent such nodes.  And if the class is equivalent to things like /./,
13745      * expensive run-time swashes can be avoided.  Now that we have more
13746      * complete information, we can find things necessarily missed by the
13747      * earlier code.  I (khw) am not sure how much to look for here.  It would
13748      * be easy, but perhaps too slow, to check any candidates against all the
13749      * node types they could possibly match using _invlistEQ(). */
13750
13751     if (cp_list
13752         && ! invert
13753         && ! depends_list
13754         && ! (ANYOF_FLAGS(ret) & ANYOF_CLASS)
13755         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
13756     {
13757         UV start, end;
13758         U8 op = END;  /* The optimzation node-type */
13759         const char * cur_parse= RExC_parse;
13760
13761         invlist_iterinit(cp_list);
13762         if (! invlist_iternext(cp_list, &start, &end)) {
13763
13764             /* Here, the list is empty.  This happens, for example, when a
13765              * Unicode property is the only thing in the character class, and
13766              * it doesn't match anything.  (perluniprops.pod notes such
13767              * properties) */
13768             op = OPFAIL;
13769             *flagp |= HASWIDTH|SIMPLE;
13770         }
13771         else if (start == end) {    /* The range is a single code point */
13772             if (! invlist_iternext(cp_list, &start, &end)
13773
13774                     /* Don't do this optimization if it would require changing
13775                      * the pattern to UTF-8 */
13776                 && (start < 256 || UTF))
13777             {
13778                 /* Here, the list contains a single code point.  Can optimize
13779                  * into an EXACT node */
13780
13781                 value = start;
13782
13783                 if (! FOLD) {
13784                     op = EXACT;
13785                 }
13786                 else if (LOC) {
13787
13788                     /* A locale node under folding with one code point can be
13789                      * an EXACTFL, as its fold won't be calculated until
13790                      * runtime */
13791                     op = EXACTFL;
13792                 }
13793                 else {
13794
13795                     /* Here, we are generally folding, but there is only one
13796                      * code point to match.  If we have to, we use an EXACT
13797                      * node, but it would be better for joining with adjacent
13798                      * nodes in the optimization pass if we used the same
13799                      * EXACTFish node that any such are likely to be.  We can
13800                      * do this iff the code point doesn't participate in any
13801                      * folds.  For example, an EXACTF of a colon is the same as
13802                      * an EXACT one, since nothing folds to or from a colon. */
13803                     if (value < 256) {
13804                         if (IS_IN_SOME_FOLD_L1(value)) {
13805                             op = EXACT;
13806                         }
13807                     }
13808                     else {
13809                         if (! PL_utf8_foldable) {
13810                             SV* swash = swash_init("utf8", "_Perl_Any_Folds",
13811                                                 &PL_sv_undef, 1, 0);
13812                             PL_utf8_foldable = _get_swash_invlist(swash);
13813                             SvREFCNT_dec_NN(swash);
13814                         }
13815                         if (_invlist_contains_cp(PL_utf8_foldable, value)) {
13816                             op = EXACT;
13817                         }
13818                     }
13819
13820                     /* If we haven't found the node type, above, it means we
13821                      * can use the prevailing one */
13822                     if (op == END) {
13823                         op = compute_EXACTish(pRExC_state);
13824                     }
13825                 }
13826             }
13827         }
13828         else if (start == 0) {
13829             if (end == UV_MAX) {
13830                 op = SANY;
13831                 *flagp |= HASWIDTH|SIMPLE;
13832                 RExC_naughty++;
13833             }
13834             else if (end == '\n' - 1
13835                     && invlist_iternext(cp_list, &start, &end)
13836                     && start == '\n' + 1 && end == UV_MAX)
13837             {
13838                 op = REG_ANY;
13839                 *flagp |= HASWIDTH|SIMPLE;
13840                 RExC_naughty++;
13841             }
13842         }
13843         invlist_iterfinish(cp_list);
13844
13845         if (op != END) {
13846             RExC_parse = (char *)orig_parse;
13847             RExC_emit = (regnode *)orig_emit;
13848
13849             ret = reg_node(pRExC_state, op);
13850
13851             RExC_parse = (char *)cur_parse;
13852
13853             if (PL_regkind[op] == EXACT) {
13854                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value);
13855             }
13856
13857             SvREFCNT_dec_NN(cp_list);
13858             return ret;
13859         }
13860     }
13861
13862     /* Here, <cp_list> contains all the code points we can determine at
13863      * compile time that match under all conditions.  Go through it, and
13864      * for things that belong in the bitmap, put them there, and delete from
13865      * <cp_list>.  While we are at it, see if everything above 255 is in the
13866      * list, and if so, set a flag to speed up execution */
13867     ANYOF_BITMAP_ZERO(ret);
13868     if (cp_list) {
13869
13870         /* This gets set if we actually need to modify things */
13871         bool change_invlist = FALSE;
13872
13873         UV start, end;
13874
13875         /* Start looking through <cp_list> */
13876         invlist_iterinit(cp_list);
13877         while (invlist_iternext(cp_list, &start, &end)) {
13878             UV high;
13879             int i;
13880
13881             if (end == UV_MAX && start <= 256) {
13882                 ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
13883             }
13884
13885             /* Quit if are above what we should change */
13886             if (start > 255) {
13887                 break;
13888             }
13889
13890             change_invlist = TRUE;
13891
13892             /* Set all the bits in the range, up to the max that we are doing */
13893             high = (end < 255) ? end : 255;
13894             for (i = start; i <= (int) high; i++) {
13895                 if (! ANYOF_BITMAP_TEST(ret, i)) {
13896                     ANYOF_BITMAP_SET(ret, i);
13897                     prevvalue = value;
13898                     value = i;
13899                 }
13900             }
13901         }
13902         invlist_iterfinish(cp_list);
13903
13904         /* Done with loop; remove any code points that are in the bitmap from
13905          * <cp_list> */
13906         if (change_invlist) {
13907             _invlist_subtract(cp_list, PL_Latin1, &cp_list);
13908         }
13909
13910         /* If have completely emptied it, remove it completely */
13911         if (_invlist_len(cp_list) == 0) {
13912             SvREFCNT_dec_NN(cp_list);
13913             cp_list = NULL;
13914         }
13915     }
13916
13917     if (invert) {
13918         ANYOF_FLAGS(ret) |= ANYOF_INVERT;
13919     }
13920
13921     /* Here, the bitmap has been populated with all the Latin1 code points that
13922      * always match.  Can now add to the overall list those that match only
13923      * when the target string is UTF-8 (<depends_list>). */
13924     if (depends_list) {
13925         if (cp_list) {
13926             _invlist_union(cp_list, depends_list, &cp_list);
13927             SvREFCNT_dec_NN(depends_list);
13928         }
13929         else {
13930             cp_list = depends_list;
13931         }
13932     }
13933
13934     /* If there is a swash and more than one element, we can't use the swash in
13935      * the optimization below. */
13936     if (swash && element_count > 1) {
13937         SvREFCNT_dec_NN(swash);
13938         swash = NULL;
13939     }
13940
13941     if (! cp_list
13942         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
13943     {
13944         ARG_SET(ret, ANYOF_NONBITMAP_EMPTY);
13945     }
13946     else {
13947         /* av[0] stores the character class description in its textual form:
13948          *       used later (regexec.c:Perl_regclass_swash()) to initialize the
13949          *       appropriate swash, and is also useful for dumping the regnode.
13950          * av[1] if NULL, is a placeholder to later contain the swash computed
13951          *       from av[0].  But if no further computation need be done, the
13952          *       swash is stored there now.
13953          * av[2] stores the cp_list inversion list for use in addition or
13954          *       instead of av[0]; used only if av[1] is NULL
13955          * av[3] is set if any component of the class is from a user-defined
13956          *       property; used only if av[1] is NULL */
13957         AV * const av = newAV();
13958         SV *rv;
13959
13960         av_store(av, 0, (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
13961                         ? SvREFCNT_inc(listsv) : &PL_sv_undef);
13962         if (swash) {
13963             av_store(av, 1, swash);
13964             SvREFCNT_dec_NN(cp_list);
13965         }
13966         else {
13967             av_store(av, 1, NULL);
13968             if (cp_list) {
13969                 av_store(av, 2, cp_list);
13970                 av_store(av, 3, newSVuv(has_user_defined_property));
13971             }
13972         }
13973
13974         rv = newRV_noinc(MUTABLE_SV(av));
13975         n = add_data(pRExC_state, 1, "s");
13976         RExC_rxi->data->data[n] = (void*)rv;
13977         ARG_SET(ret, n);
13978     }
13979
13980     *flagp |= HASWIDTH|SIMPLE;
13981     return ret;
13982 }
13983 #undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
13984
13985
13986 /* reg_skipcomment()
13987
13988    Absorbs an /x style # comments from the input stream.
13989    Returns true if there is more text remaining in the stream.
13990    Will set the REG_SEEN_RUN_ON_COMMENT flag if the comment
13991    terminates the pattern without including a newline.
13992
13993    Note its the callers responsibility to ensure that we are
13994    actually in /x mode
13995
13996 */
13997
13998 STATIC bool
13999 S_reg_skipcomment(pTHX_ RExC_state_t *pRExC_state)
14000 {
14001     bool ended = 0;
14002
14003     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
14004
14005     while (RExC_parse < RExC_end)
14006         if (*RExC_parse++ == '\n') {
14007             ended = 1;
14008             break;
14009         }
14010     if (!ended) {
14011         /* we ran off the end of the pattern without ending
14012            the comment, so we have to add an \n when wrapping */
14013         RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
14014         return 0;
14015     } else
14016         return 1;
14017 }
14018
14019 /* nextchar()
14020
14021    Advances the parse position, and optionally absorbs
14022    "whitespace" from the inputstream.
14023
14024    Without /x "whitespace" means (?#...) style comments only,
14025    with /x this means (?#...) and # comments and whitespace proper.
14026
14027    Returns the RExC_parse point from BEFORE the scan occurs.
14028
14029    This is the /x friendly way of saying RExC_parse++.
14030 */
14031
14032 STATIC char*
14033 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
14034 {
14035     char* const retval = RExC_parse++;
14036
14037     PERL_ARGS_ASSERT_NEXTCHAR;
14038
14039     for (;;) {
14040         if (RExC_end - RExC_parse >= 3
14041             && *RExC_parse == '('
14042             && RExC_parse[1] == '?'
14043             && RExC_parse[2] == '#')
14044         {
14045             while (*RExC_parse != ')') {
14046                 if (RExC_parse == RExC_end)
14047                     FAIL("Sequence (?#... not terminated");
14048                 RExC_parse++;
14049             }
14050             RExC_parse++;
14051             continue;
14052         }
14053         if (RExC_flags & RXf_PMf_EXTENDED) {
14054             if (isSPACE(*RExC_parse)) {
14055                 RExC_parse++;
14056                 continue;
14057             }
14058             else if (*RExC_parse == '#') {
14059                 if ( reg_skipcomment( pRExC_state ) )
14060                     continue;
14061             }
14062         }
14063         return retval;
14064     }
14065 }
14066
14067 /*
14068 - reg_node - emit a node
14069 */
14070 STATIC regnode *                        /* Location. */
14071 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
14072 {
14073     dVAR;
14074     regnode *ptr;
14075     regnode * const ret = RExC_emit;
14076     GET_RE_DEBUG_FLAGS_DECL;
14077
14078     PERL_ARGS_ASSERT_REG_NODE;
14079
14080     if (SIZE_ONLY) {
14081         SIZE_ALIGN(RExC_size);
14082         RExC_size += 1;
14083         return(ret);
14084     }
14085     if (RExC_emit >= RExC_emit_bound)
14086         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
14087                    op, RExC_emit, RExC_emit_bound);
14088
14089     NODE_ALIGN_FILL(ret);
14090     ptr = ret;
14091     FILL_ADVANCE_NODE(ptr, op);
14092 #ifdef RE_TRACK_PATTERN_OFFSETS
14093     if (RExC_offsets) {         /* MJD */
14094         MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n", 
14095               "reg_node", __LINE__, 
14096               PL_reg_name[op],
14097               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] 
14098                 ? "Overwriting end of array!\n" : "OK",
14099               (UV)(RExC_emit - RExC_emit_start),
14100               (UV)(RExC_parse - RExC_start),
14101               (UV)RExC_offsets[0])); 
14102         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
14103     }
14104 #endif
14105     RExC_emit = ptr;
14106     return(ret);
14107 }
14108
14109 /*
14110 - reganode - emit a node with an argument
14111 */
14112 STATIC regnode *                        /* Location. */
14113 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
14114 {
14115     dVAR;
14116     regnode *ptr;
14117     regnode * const ret = RExC_emit;
14118     GET_RE_DEBUG_FLAGS_DECL;
14119
14120     PERL_ARGS_ASSERT_REGANODE;
14121
14122     if (SIZE_ONLY) {
14123         SIZE_ALIGN(RExC_size);
14124         RExC_size += 2;
14125         /* 
14126            We can't do this:
14127            
14128            assert(2==regarglen[op]+1); 
14129
14130            Anything larger than this has to allocate the extra amount.
14131            If we changed this to be:
14132            
14133            RExC_size += (1 + regarglen[op]);
14134            
14135            then it wouldn't matter. Its not clear what side effect
14136            might come from that so its not done so far.
14137            -- dmq
14138         */
14139         return(ret);
14140     }
14141     if (RExC_emit >= RExC_emit_bound)
14142         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
14143                    op, RExC_emit, RExC_emit_bound);
14144
14145     NODE_ALIGN_FILL(ret);
14146     ptr = ret;
14147     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
14148 #ifdef RE_TRACK_PATTERN_OFFSETS
14149     if (RExC_offsets) {         /* MJD */
14150         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
14151               "reganode",
14152               __LINE__,
14153               PL_reg_name[op],
14154               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? 
14155               "Overwriting end of array!\n" : "OK",
14156               (UV)(RExC_emit - RExC_emit_start),
14157               (UV)(RExC_parse - RExC_start),
14158               (UV)RExC_offsets[0])); 
14159         Set_Cur_Node_Offset;
14160     }
14161 #endif            
14162     RExC_emit = ptr;
14163     return(ret);
14164 }
14165
14166 /*
14167 - reguni - emit (if appropriate) a Unicode character
14168 */
14169 STATIC STRLEN
14170 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
14171 {
14172     dVAR;
14173
14174     PERL_ARGS_ASSERT_REGUNI;
14175
14176     return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
14177 }
14178
14179 /*
14180 - reginsert - insert an operator in front of already-emitted operand
14181 *
14182 * Means relocating the operand.
14183 */
14184 STATIC void
14185 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
14186 {
14187     dVAR;
14188     regnode *src;
14189     regnode *dst;
14190     regnode *place;
14191     const int offset = regarglen[(U8)op];
14192     const int size = NODE_STEP_REGNODE + offset;
14193     GET_RE_DEBUG_FLAGS_DECL;
14194
14195     PERL_ARGS_ASSERT_REGINSERT;
14196     PERL_UNUSED_ARG(depth);
14197 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
14198     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
14199     if (SIZE_ONLY) {
14200         RExC_size += size;
14201         return;
14202     }
14203
14204     src = RExC_emit;
14205     RExC_emit += size;
14206     dst = RExC_emit;
14207     if (RExC_open_parens) {
14208         int paren;
14209         /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
14210         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
14211             if ( RExC_open_parens[paren] >= opnd ) {
14212                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
14213                 RExC_open_parens[paren] += size;
14214             } else {
14215                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
14216             }
14217             if ( RExC_close_parens[paren] >= opnd ) {
14218                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
14219                 RExC_close_parens[paren] += size;
14220             } else {
14221                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
14222             }
14223         }
14224     }
14225
14226     while (src > opnd) {
14227         StructCopy(--src, --dst, regnode);
14228 #ifdef RE_TRACK_PATTERN_OFFSETS
14229         if (RExC_offsets) {     /* MJD 20010112 */
14230             MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
14231                   "reg_insert",
14232                   __LINE__,
14233                   PL_reg_name[op],
14234                   (UV)(dst - RExC_emit_start) > RExC_offsets[0] 
14235                     ? "Overwriting end of array!\n" : "OK",
14236                   (UV)(src - RExC_emit_start),
14237                   (UV)(dst - RExC_emit_start),
14238                   (UV)RExC_offsets[0])); 
14239             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
14240             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
14241         }
14242 #endif
14243     }
14244     
14245
14246     place = opnd;               /* Op node, where operand used to be. */
14247 #ifdef RE_TRACK_PATTERN_OFFSETS
14248     if (RExC_offsets) {         /* MJD */
14249         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
14250               "reginsert",
14251               __LINE__,
14252               PL_reg_name[op],
14253               (UV)(place - RExC_emit_start) > RExC_offsets[0] 
14254               ? "Overwriting end of array!\n" : "OK",
14255               (UV)(place - RExC_emit_start),
14256               (UV)(RExC_parse - RExC_start),
14257               (UV)RExC_offsets[0]));
14258         Set_Node_Offset(place, RExC_parse);
14259         Set_Node_Length(place, 1);
14260     }
14261 #endif    
14262     src = NEXTOPER(place);
14263     FILL_ADVANCE_NODE(place, op);
14264     Zero(src, offset, regnode);
14265 }
14266
14267 /*
14268 - regtail - set the next-pointer at the end of a node chain of p to val.
14269 - SEE ALSO: regtail_study
14270 */
14271 /* TODO: All three parms should be const */
14272 STATIC void
14273 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
14274 {
14275     dVAR;
14276     regnode *scan;
14277     GET_RE_DEBUG_FLAGS_DECL;
14278
14279     PERL_ARGS_ASSERT_REGTAIL;
14280 #ifndef DEBUGGING
14281     PERL_UNUSED_ARG(depth);
14282 #endif
14283
14284     if (SIZE_ONLY)
14285         return;
14286
14287     /* Find last node. */
14288     scan = p;
14289     for (;;) {
14290         regnode * const temp = regnext(scan);
14291         DEBUG_PARSE_r({
14292             SV * const mysv=sv_newmortal();
14293             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
14294             regprop(RExC_rx, mysv, scan);
14295             PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
14296                 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
14297                     (temp == NULL ? "->" : ""),
14298                     (temp == NULL ? PL_reg_name[OP(val)] : "")
14299             );
14300         });
14301         if (temp == NULL)
14302             break;
14303         scan = temp;
14304     }
14305
14306     if (reg_off_by_arg[OP(scan)]) {
14307         ARG_SET(scan, val - scan);
14308     }
14309     else {
14310         NEXT_OFF(scan) = val - scan;
14311     }
14312 }
14313
14314 #ifdef DEBUGGING
14315 /*
14316 - regtail_study - set the next-pointer at the end of a node chain of p to val.
14317 - Look for optimizable sequences at the same time.
14318 - currently only looks for EXACT chains.
14319
14320 This is experimental code. The idea is to use this routine to perform 
14321 in place optimizations on branches and groups as they are constructed,
14322 with the long term intention of removing optimization from study_chunk so
14323 that it is purely analytical.
14324
14325 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
14326 to control which is which.
14327
14328 */
14329 /* TODO: All four parms should be const */
14330
14331 STATIC U8
14332 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
14333 {
14334     dVAR;
14335     regnode *scan;
14336     U8 exact = PSEUDO;
14337 #ifdef EXPERIMENTAL_INPLACESCAN
14338     I32 min = 0;
14339 #endif
14340     GET_RE_DEBUG_FLAGS_DECL;
14341
14342     PERL_ARGS_ASSERT_REGTAIL_STUDY;
14343
14344
14345     if (SIZE_ONLY)
14346         return exact;
14347
14348     /* Find last node. */
14349
14350     scan = p;
14351     for (;;) {
14352         regnode * const temp = regnext(scan);
14353 #ifdef EXPERIMENTAL_INPLACESCAN
14354         if (PL_regkind[OP(scan)] == EXACT) {
14355             bool has_exactf_sharp_s;    /* Unexamined in this routine */
14356             if (join_exact(pRExC_state,scan,&min, &has_exactf_sharp_s, 1,val,depth+1))
14357                 return EXACT;
14358         }
14359 #endif
14360         if ( exact ) {
14361             switch (OP(scan)) {
14362                 case EXACT:
14363                 case EXACTF:
14364                 case EXACTFA:
14365                 case EXACTFU:
14366                 case EXACTFU_SS:
14367                 case EXACTFU_TRICKYFOLD:
14368                 case EXACTFL:
14369                         if( exact == PSEUDO )
14370                             exact= OP(scan);
14371                         else if ( exact != OP(scan) )
14372                             exact= 0;
14373                 case NOTHING:
14374                     break;
14375                 default:
14376                     exact= 0;
14377             }
14378         }
14379         DEBUG_PARSE_r({
14380             SV * const mysv=sv_newmortal();
14381             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
14382             regprop(RExC_rx, mysv, scan);
14383             PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
14384                 SvPV_nolen_const(mysv),
14385                 REG_NODE_NUM(scan),
14386                 PL_reg_name[exact]);
14387         });
14388         if (temp == NULL)
14389             break;
14390         scan = temp;
14391     }
14392     DEBUG_PARSE_r({
14393         SV * const mysv_val=sv_newmortal();
14394         DEBUG_PARSE_MSG("");
14395         regprop(RExC_rx, mysv_val, val);
14396         PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
14397                       SvPV_nolen_const(mysv_val),
14398                       (IV)REG_NODE_NUM(val),
14399                       (IV)(val - scan)
14400         );
14401     });
14402     if (reg_off_by_arg[OP(scan)]) {
14403         ARG_SET(scan, val - scan);
14404     }
14405     else {
14406         NEXT_OFF(scan) = val - scan;
14407     }
14408
14409     return exact;
14410 }
14411 #endif
14412
14413 /*
14414  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
14415  */
14416 #ifdef DEBUGGING
14417 static void 
14418 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
14419 {
14420     int bit;
14421     int set=0;
14422     regex_charset cs;
14423
14424     for (bit=0; bit<32; bit++) {
14425         if (flags & (1<<bit)) {
14426             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
14427                 continue;
14428             }
14429             if (!set++ && lead) 
14430                 PerlIO_printf(Perl_debug_log, "%s",lead);
14431             PerlIO_printf(Perl_debug_log, "%s ",PL_reg_extflags_name[bit]);
14432         }               
14433     }      
14434     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
14435             if (!set++ && lead) {
14436                 PerlIO_printf(Perl_debug_log, "%s",lead);
14437             }
14438             switch (cs) {
14439                 case REGEX_UNICODE_CHARSET:
14440                     PerlIO_printf(Perl_debug_log, "UNICODE");
14441                     break;
14442                 case REGEX_LOCALE_CHARSET:
14443                     PerlIO_printf(Perl_debug_log, "LOCALE");
14444                     break;
14445                 case REGEX_ASCII_RESTRICTED_CHARSET:
14446                     PerlIO_printf(Perl_debug_log, "ASCII-RESTRICTED");
14447                     break;
14448                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
14449                     PerlIO_printf(Perl_debug_log, "ASCII-MORE_RESTRICTED");
14450                     break;
14451                 default:
14452                     PerlIO_printf(Perl_debug_log, "UNKNOWN CHARACTER SET");
14453                     break;
14454             }
14455     }
14456     if (lead)  {
14457         if (set) 
14458             PerlIO_printf(Perl_debug_log, "\n");
14459         else 
14460             PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
14461     }            
14462 }   
14463 #endif
14464
14465 void
14466 Perl_regdump(pTHX_ const regexp *r)
14467 {
14468 #ifdef DEBUGGING
14469     dVAR;
14470     SV * const sv = sv_newmortal();
14471     SV *dsv= sv_newmortal();
14472     RXi_GET_DECL(r,ri);
14473     GET_RE_DEBUG_FLAGS_DECL;
14474
14475     PERL_ARGS_ASSERT_REGDUMP;
14476
14477     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
14478
14479     /* Header fields of interest. */
14480     if (r->anchored_substr) {
14481         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr), 
14482             RE_SV_DUMPLEN(r->anchored_substr), 30);
14483         PerlIO_printf(Perl_debug_log,
14484                       "anchored %s%s at %"IVdf" ",
14485                       s, RE_SV_TAIL(r->anchored_substr),
14486                       (IV)r->anchored_offset);
14487     } else if (r->anchored_utf8) {
14488         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8), 
14489             RE_SV_DUMPLEN(r->anchored_utf8), 30);
14490         PerlIO_printf(Perl_debug_log,
14491                       "anchored utf8 %s%s at %"IVdf" ",
14492                       s, RE_SV_TAIL(r->anchored_utf8),
14493                       (IV)r->anchored_offset);
14494     }                 
14495     if (r->float_substr) {
14496         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr), 
14497             RE_SV_DUMPLEN(r->float_substr), 30);
14498         PerlIO_printf(Perl_debug_log,
14499                       "floating %s%s at %"IVdf"..%"UVuf" ",
14500                       s, RE_SV_TAIL(r->float_substr),
14501                       (IV)r->float_min_offset, (UV)r->float_max_offset);
14502     } else if (r->float_utf8) {
14503         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8), 
14504             RE_SV_DUMPLEN(r->float_utf8), 30);
14505         PerlIO_printf(Perl_debug_log,
14506                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
14507                       s, RE_SV_TAIL(r->float_utf8),
14508                       (IV)r->float_min_offset, (UV)r->float_max_offset);
14509     }
14510     if (r->check_substr || r->check_utf8)
14511         PerlIO_printf(Perl_debug_log,
14512                       (const char *)
14513                       (r->check_substr == r->float_substr
14514                        && r->check_utf8 == r->float_utf8
14515                        ? "(checking floating" : "(checking anchored"));
14516     if (r->extflags & RXf_NOSCAN)
14517         PerlIO_printf(Perl_debug_log, " noscan");
14518     if (r->extflags & RXf_CHECK_ALL)
14519         PerlIO_printf(Perl_debug_log, " isall");
14520     if (r->check_substr || r->check_utf8)
14521         PerlIO_printf(Perl_debug_log, ") ");
14522
14523     if (ri->regstclass) {
14524         regprop(r, sv, ri->regstclass);
14525         PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
14526     }
14527     if (r->extflags & RXf_ANCH) {
14528         PerlIO_printf(Perl_debug_log, "anchored");
14529         if (r->extflags & RXf_ANCH_BOL)
14530             PerlIO_printf(Perl_debug_log, "(BOL)");
14531         if (r->extflags & RXf_ANCH_MBOL)
14532             PerlIO_printf(Perl_debug_log, "(MBOL)");
14533         if (r->extflags & RXf_ANCH_SBOL)
14534             PerlIO_printf(Perl_debug_log, "(SBOL)");
14535         if (r->extflags & RXf_ANCH_GPOS)
14536             PerlIO_printf(Perl_debug_log, "(GPOS)");
14537         PerlIO_putc(Perl_debug_log, ' ');
14538     }
14539     if (r->extflags & RXf_GPOS_SEEN)
14540         PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
14541     if (r->intflags & PREGf_SKIP)
14542         PerlIO_printf(Perl_debug_log, "plus ");
14543     if (r->intflags & PREGf_IMPLICIT)
14544         PerlIO_printf(Perl_debug_log, "implicit ");
14545     PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
14546     if (r->extflags & RXf_EVAL_SEEN)
14547         PerlIO_printf(Perl_debug_log, "with eval ");
14548     PerlIO_printf(Perl_debug_log, "\n");
14549     DEBUG_FLAGS_r(regdump_extflags("r->extflags: ",r->extflags));            
14550 #else
14551     PERL_ARGS_ASSERT_REGDUMP;
14552     PERL_UNUSED_CONTEXT;
14553     PERL_UNUSED_ARG(r);
14554 #endif  /* DEBUGGING */
14555 }
14556
14557 /*
14558 - regprop - printable representation of opcode
14559 */
14560 #define EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags) \
14561 STMT_START { \
14562         if (do_sep) {                           \
14563             Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]); \
14564             if (flags & ANYOF_INVERT)           \
14565                 /*make sure the invert info is in each */ \
14566                 sv_catpvs(sv, "^");             \
14567             do_sep = 0;                         \
14568         }                                       \
14569 } STMT_END
14570
14571 void
14572 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
14573 {
14574 #ifdef DEBUGGING
14575     dVAR;
14576     int k;
14577
14578     /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
14579     static const char * const anyofs[] = {
14580 #if _CC_WORDCHAR != 0 || _CC_DIGIT != 1 || _CC_ALPHA != 2 || _CC_LOWER != 3 \
14581     || _CC_UPPER != 4 || _CC_PUNCT != 5 || _CC_PRINT != 6                   \
14582     || _CC_ALPHANUMERIC != 7 || _CC_GRAPH != 8 || _CC_CASED != 9            \
14583     || _CC_SPACE != 10 || _CC_BLANK != 11 || _CC_XDIGIT != 12               \
14584     || _CC_PSXSPC != 13 || _CC_CNTRL != 14 || _CC_ASCII != 15               \
14585     || _CC_VERTSPACE != 16
14586   #error Need to adjust order of anyofs[]
14587 #endif
14588         "[\\w]",
14589         "[\\W]",
14590         "[\\d]",
14591         "[\\D]",
14592         "[:alpha:]",
14593         "[:^alpha:]",
14594         "[:lower:]",
14595         "[:^lower:]",
14596         "[:upper:]",
14597         "[:^upper:]",
14598         "[:punct:]",
14599         "[:^punct:]",
14600         "[:print:]",
14601         "[:^print:]",
14602         "[:alnum:]",
14603         "[:^alnum:]",
14604         "[:graph:]",
14605         "[:^graph:]",
14606         "[:cased:]",
14607         "[:^cased:]",
14608         "[\\s]",
14609         "[\\S]",
14610         "[:blank:]",
14611         "[:^blank:]",
14612         "[:xdigit:]",
14613         "[:^xdigit:]",
14614         "[:space:]",
14615         "[:^space:]",
14616         "[:cntrl:]",
14617         "[:^cntrl:]",
14618         "[:ascii:]",
14619         "[:^ascii:]",
14620         "[\\v]",
14621         "[\\V]"
14622     };
14623     RXi_GET_DECL(prog,progi);
14624     GET_RE_DEBUG_FLAGS_DECL;
14625     
14626     PERL_ARGS_ASSERT_REGPROP;
14627
14628     sv_setpvs(sv, "");
14629
14630     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
14631         /* It would be nice to FAIL() here, but this may be called from
14632            regexec.c, and it would be hard to supply pRExC_state. */
14633         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
14634     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
14635
14636     k = PL_regkind[OP(o)];
14637
14638     if (k == EXACT) {
14639         sv_catpvs(sv, " ");
14640         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT) 
14641          * is a crude hack but it may be the best for now since 
14642          * we have no flag "this EXACTish node was UTF-8" 
14643          * --jhi */
14644         pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
14645                   PERL_PV_ESCAPE_UNI_DETECT |
14646                   PERL_PV_ESCAPE_NONASCII   |
14647                   PERL_PV_PRETTY_ELLIPSES   |
14648                   PERL_PV_PRETTY_LTGT       |
14649                   PERL_PV_PRETTY_NOCLEAR
14650                   );
14651     } else if (k == TRIE) {
14652         /* print the details of the trie in dumpuntil instead, as
14653          * progi->data isn't available here */
14654         const char op = OP(o);
14655         const U32 n = ARG(o);
14656         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
14657                (reg_ac_data *)progi->data->data[n] :
14658                NULL;
14659         const reg_trie_data * const trie
14660             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
14661         
14662         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
14663         DEBUG_TRIE_COMPILE_r(
14664             Perl_sv_catpvf(aTHX_ sv,
14665                 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
14666                 (UV)trie->startstate,
14667                 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
14668                 (UV)trie->wordcount,
14669                 (UV)trie->minlen,
14670                 (UV)trie->maxlen,
14671                 (UV)TRIE_CHARCOUNT(trie),
14672                 (UV)trie->uniquecharcount
14673             )
14674         );
14675         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
14676             int i;
14677             int rangestart = -1;
14678             U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
14679             sv_catpvs(sv, "[");
14680             for (i = 0; i <= 256; i++) {
14681                 if (i < 256 && BITMAP_TEST(bitmap,i)) {
14682                     if (rangestart == -1)
14683                         rangestart = i;
14684                 } else if (rangestart != -1) {
14685                     if (i <= rangestart + 3)
14686                         for (; rangestart < i; rangestart++)
14687                             put_byte(sv, rangestart);
14688                     else {
14689                         put_byte(sv, rangestart);
14690                         sv_catpvs(sv, "-");
14691                         put_byte(sv, i - 1);
14692                     }
14693                     rangestart = -1;
14694                 }
14695             }
14696             sv_catpvs(sv, "]");
14697         } 
14698          
14699     } else if (k == CURLY) {
14700         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
14701             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
14702         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
14703     }
14704     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
14705         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
14706     else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
14707         Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
14708         if ( RXp_PAREN_NAMES(prog) ) {
14709             if ( k != REF || (OP(o) < NREF)) {
14710                 AV *list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
14711                 SV **name= av_fetch(list, ARG(o), 0 );
14712                 if (name)
14713                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
14714             }       
14715             else {
14716                 AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]);
14717                 SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]);
14718                 I32 *nums=(I32*)SvPVX(sv_dat);
14719                 SV **name= av_fetch(list, nums[0], 0 );
14720                 I32 n;
14721                 if (name) {
14722                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
14723                         Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
14724                                     (n ? "," : ""), (IV)nums[n]);
14725                     }
14726                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
14727                 }
14728             }
14729         }            
14730     } else if (k == GOSUB) 
14731         Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
14732     else if (k == VERB) {
14733         if (!o->flags) 
14734             Perl_sv_catpvf(aTHX_ sv, ":%"SVf, 
14735                            SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
14736     } else if (k == LOGICAL)
14737         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);     /* 2: embedded, otherwise 1 */
14738     else if (k == ANYOF) {
14739         int i, rangestart = -1;
14740         const U8 flags = ANYOF_FLAGS(o);
14741         int do_sep = 0;
14742
14743
14744         if (flags & ANYOF_LOCALE)
14745             sv_catpvs(sv, "{loc}");
14746         if (flags & ANYOF_LOC_FOLD)
14747             sv_catpvs(sv, "{i}");
14748         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
14749         if (flags & ANYOF_INVERT)
14750             sv_catpvs(sv, "^");
14751
14752         /* output what the standard cp 0-255 bitmap matches */
14753         for (i = 0; i <= 256; i++) {
14754             if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
14755                 if (rangestart == -1)
14756                     rangestart = i;
14757             } else if (rangestart != -1) {
14758                 if (i <= rangestart + 3)
14759                     for (; rangestart < i; rangestart++)
14760                         put_byte(sv, rangestart);
14761                 else {
14762                     put_byte(sv, rangestart);
14763                     sv_catpvs(sv, "-");
14764                     put_byte(sv, i - 1);
14765                 }
14766                 do_sep = 1;
14767                 rangestart = -1;
14768             }
14769         }
14770         
14771         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
14772         /* output any special charclass tests (used entirely under use locale) */
14773         if (ANYOF_CLASS_TEST_ANY_SET(o))
14774             for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
14775                 if (ANYOF_CLASS_TEST(o,i)) {
14776                     sv_catpv(sv, anyofs[i]);
14777                     do_sep = 1;
14778                 }
14779         
14780         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
14781         
14782         if (flags & ANYOF_NON_UTF8_LATIN1_ALL) {
14783             sv_catpvs(sv, "{non-utf8-latin1-all}");
14784         }
14785
14786         /* output information about the unicode matching */
14787         if (flags & ANYOF_UNICODE_ALL)
14788             sv_catpvs(sv, "{unicode_all}");
14789         else if (ANYOF_NONBITMAP(o))
14790             sv_catpvs(sv, "{unicode}");
14791         if (flags & ANYOF_NONBITMAP_NON_UTF8)
14792             sv_catpvs(sv, "{outside bitmap}");
14793
14794         if (ANYOF_NONBITMAP(o)) {
14795             SV *lv; /* Set if there is something outside the bit map */
14796             SV * const sw = regclass_swash(prog, o, FALSE, &lv, NULL);
14797             bool byte_output = FALSE;   /* If something in the bitmap has been
14798                                            output */
14799
14800             if (lv && lv != &PL_sv_undef) {
14801                 if (sw) {
14802                     U8 s[UTF8_MAXBYTES_CASE+1];
14803
14804                     for (i = 0; i <= 256; i++) { /* Look at chars in bitmap */
14805                         uvchr_to_utf8(s, i);
14806
14807                         if (i < 256
14808                             && ! ANYOF_BITMAP_TEST(o, i)    /* Don't duplicate
14809                                                                things already
14810                                                                output as part
14811                                                                of the bitmap */
14812                             && swash_fetch(sw, s, TRUE))
14813                         {
14814                             if (rangestart == -1)
14815                                 rangestart = i;
14816                         } else if (rangestart != -1) {
14817                             byte_output = TRUE;
14818                             if (i <= rangestart + 3)
14819                                 for (; rangestart < i; rangestart++) {
14820                                     put_byte(sv, rangestart);
14821                                 }
14822                             else {
14823                                 put_byte(sv, rangestart);
14824                                 sv_catpvs(sv, "-");
14825                                 put_byte(sv, i-1);
14826                             }
14827                             rangestart = -1;
14828                         }
14829                     }
14830                 }
14831
14832                 {
14833                     char *s = savesvpv(lv);
14834                     char * const origs = s;
14835
14836                     while (*s && *s != '\n')
14837                         s++;
14838
14839                     if (*s == '\n') {
14840                         const char * const t = ++s;
14841
14842                         if (byte_output) {
14843                             sv_catpvs(sv, " ");
14844                         }
14845
14846                         while (*s) {
14847                             if (*s == '\n') {
14848
14849                                 /* Truncate very long output */
14850                                 if (s - origs > 256) {
14851                                     Perl_sv_catpvf(aTHX_ sv,
14852                                                    "%.*s...",
14853                                                    (int) (s - origs - 1),
14854                                                    t);
14855                                     goto out_dump;
14856                                 }
14857                                 *s = ' ';
14858                             }
14859                             else if (*s == '\t') {
14860                                 *s = '-';
14861                             }
14862                             s++;
14863                         }
14864                         if (s[-1] == ' ')
14865                             s[-1] = 0;
14866
14867                         sv_catpv(sv, t);
14868                     }
14869
14870                 out_dump:
14871
14872                     Safefree(origs);
14873                 }
14874                 SvREFCNT_dec_NN(lv);
14875             }
14876         }
14877
14878         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
14879     }
14880     else if (k == POSIXD || k == NPOSIXD) {
14881         U8 index = FLAGS(o) * 2;
14882         if (index > (sizeof(anyofs) / sizeof(anyofs[0]))) {
14883             Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
14884         }
14885         else {
14886             sv_catpv(sv, anyofs[index]);
14887         }
14888     }
14889     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
14890         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
14891 #else
14892     PERL_UNUSED_CONTEXT;
14893     PERL_UNUSED_ARG(sv);
14894     PERL_UNUSED_ARG(o);
14895     PERL_UNUSED_ARG(prog);
14896 #endif  /* DEBUGGING */
14897 }
14898
14899 SV *
14900 Perl_re_intuit_string(pTHX_ REGEXP * const r)
14901 {                               /* Assume that RE_INTUIT is set */
14902     dVAR;
14903     struct regexp *const prog = ReANY(r);
14904     GET_RE_DEBUG_FLAGS_DECL;
14905
14906     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
14907     PERL_UNUSED_CONTEXT;
14908
14909     DEBUG_COMPILE_r(
14910         {
14911             const char * const s = SvPV_nolen_const(prog->check_substr
14912                       ? prog->check_substr : prog->check_utf8);
14913
14914             if (!PL_colorset) reginitcolors();
14915             PerlIO_printf(Perl_debug_log,
14916                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
14917                       PL_colors[4],
14918                       prog->check_substr ? "" : "utf8 ",
14919                       PL_colors[5],PL_colors[0],
14920                       s,
14921                       PL_colors[1],
14922                       (strlen(s) > 60 ? "..." : ""));
14923         } );
14924
14925     return prog->check_substr ? prog->check_substr : prog->check_utf8;
14926 }
14927
14928 /* 
14929    pregfree() 
14930    
14931    handles refcounting and freeing the perl core regexp structure. When 
14932    it is necessary to actually free the structure the first thing it 
14933    does is call the 'free' method of the regexp_engine associated to
14934    the regexp, allowing the handling of the void *pprivate; member 
14935    first. (This routine is not overridable by extensions, which is why 
14936    the extensions free is called first.)
14937    
14938    See regdupe and regdupe_internal if you change anything here. 
14939 */
14940 #ifndef PERL_IN_XSUB_RE
14941 void
14942 Perl_pregfree(pTHX_ REGEXP *r)
14943 {
14944     SvREFCNT_dec(r);
14945 }
14946
14947 void
14948 Perl_pregfree2(pTHX_ REGEXP *rx)
14949 {
14950     dVAR;
14951     struct regexp *const r = ReANY(rx);
14952     GET_RE_DEBUG_FLAGS_DECL;
14953
14954     PERL_ARGS_ASSERT_PREGFREE2;
14955
14956     if (r->mother_re) {
14957         ReREFCNT_dec(r->mother_re);
14958     } else {
14959         CALLREGFREE_PVT(rx); /* free the private data */
14960         SvREFCNT_dec(RXp_PAREN_NAMES(r));
14961         Safefree(r->xpv_len_u.xpvlenu_pv);
14962     }        
14963     if (r->substrs) {
14964         SvREFCNT_dec(r->anchored_substr);
14965         SvREFCNT_dec(r->anchored_utf8);
14966         SvREFCNT_dec(r->float_substr);
14967         SvREFCNT_dec(r->float_utf8);
14968         Safefree(r->substrs);
14969     }
14970     RX_MATCH_COPY_FREE(rx);
14971 #ifdef PERL_ANY_COW
14972     SvREFCNT_dec(r->saved_copy);
14973 #endif
14974     Safefree(r->offs);
14975     SvREFCNT_dec(r->qr_anoncv);
14976     rx->sv_u.svu_rx = 0;
14977 }
14978
14979 /*  reg_temp_copy()
14980     
14981     This is a hacky workaround to the structural issue of match results
14982     being stored in the regexp structure which is in turn stored in
14983     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
14984     could be PL_curpm in multiple contexts, and could require multiple
14985     result sets being associated with the pattern simultaneously, such
14986     as when doing a recursive match with (??{$qr})
14987     
14988     The solution is to make a lightweight copy of the regexp structure 
14989     when a qr// is returned from the code executed by (??{$qr}) this
14990     lightweight copy doesn't actually own any of its data except for
14991     the starp/end and the actual regexp structure itself. 
14992     
14993 */    
14994     
14995     
14996 REGEXP *
14997 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
14998 {
14999     struct regexp *ret;
15000     struct regexp *const r = ReANY(rx);
15001     const bool islv = ret_x && SvTYPE(ret_x) == SVt_PVLV;
15002
15003     PERL_ARGS_ASSERT_REG_TEMP_COPY;
15004
15005     if (!ret_x)
15006         ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
15007     else {
15008         SvOK_off((SV *)ret_x);
15009         if (islv) {
15010             /* For PVLVs, SvANY points to the xpvlv body while sv_u points
15011                to the regexp.  (For SVt_REGEXPs, sv_upgrade has already
15012                made both spots point to the same regexp body.) */
15013             REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
15014             assert(!SvPVX(ret_x));
15015             ret_x->sv_u.svu_rx = temp->sv_any;
15016             temp->sv_any = NULL;
15017             SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
15018             SvREFCNT_dec_NN(temp);
15019             /* SvCUR still resides in the xpvlv struct, so the regexp copy-
15020                ing below will not set it. */
15021             SvCUR_set(ret_x, SvCUR(rx));
15022         }
15023     }
15024     /* This ensures that SvTHINKFIRST(sv) is true, and hence that
15025        sv_force_normal(sv) is called.  */
15026     SvFAKE_on(ret_x);
15027     ret = ReANY(ret_x);
15028     
15029     SvFLAGS(ret_x) |= SvUTF8(rx);
15030     /* We share the same string buffer as the original regexp, on which we
15031        hold a reference count, incremented when mother_re is set below.
15032        The string pointer is copied here, being part of the regexp struct.
15033      */
15034     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
15035            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
15036     if (r->offs) {
15037         const I32 npar = r->nparens+1;
15038         Newx(ret->offs, npar, regexp_paren_pair);
15039         Copy(r->offs, ret->offs, npar, regexp_paren_pair);
15040     }
15041     if (r->substrs) {
15042         Newx(ret->substrs, 1, struct reg_substr_data);
15043         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
15044
15045         SvREFCNT_inc_void(ret->anchored_substr);
15046         SvREFCNT_inc_void(ret->anchored_utf8);
15047         SvREFCNT_inc_void(ret->float_substr);
15048         SvREFCNT_inc_void(ret->float_utf8);
15049
15050         /* check_substr and check_utf8, if non-NULL, point to either their
15051            anchored or float namesakes, and don't hold a second reference.  */
15052     }
15053     RX_MATCH_COPIED_off(ret_x);
15054 #ifdef PERL_ANY_COW
15055     ret->saved_copy = NULL;
15056 #endif
15057     ret->mother_re = ReREFCNT_inc(r->mother_re ? r->mother_re : rx);
15058     SvREFCNT_inc_void(ret->qr_anoncv);
15059     
15060     return ret_x;
15061 }
15062 #endif
15063
15064 /* regfree_internal() 
15065
15066    Free the private data in a regexp. This is overloadable by 
15067    extensions. Perl takes care of the regexp structure in pregfree(), 
15068    this covers the *pprivate pointer which technically perl doesn't 
15069    know about, however of course we have to handle the 
15070    regexp_internal structure when no extension is in use. 
15071    
15072    Note this is called before freeing anything in the regexp 
15073    structure. 
15074  */
15075  
15076 void
15077 Perl_regfree_internal(pTHX_ REGEXP * const rx)
15078 {
15079     dVAR;
15080     struct regexp *const r = ReANY(rx);
15081     RXi_GET_DECL(r,ri);
15082     GET_RE_DEBUG_FLAGS_DECL;
15083
15084     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
15085
15086     DEBUG_COMPILE_r({
15087         if (!PL_colorset)
15088             reginitcolors();
15089         {
15090             SV *dsv= sv_newmortal();
15091             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
15092                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
15093             PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n", 
15094                 PL_colors[4],PL_colors[5],s);
15095         }
15096     });
15097 #ifdef RE_TRACK_PATTERN_OFFSETS
15098     if (ri->u.offsets)
15099         Safefree(ri->u.offsets);             /* 20010421 MJD */
15100 #endif
15101     if (ri->code_blocks) {
15102         int n;
15103         for (n = 0; n < ri->num_code_blocks; n++)
15104             SvREFCNT_dec(ri->code_blocks[n].src_regex);
15105         Safefree(ri->code_blocks);
15106     }
15107
15108     if (ri->data) {
15109         int n = ri->data->count;
15110
15111         while (--n >= 0) {
15112           /* If you add a ->what type here, update the comment in regcomp.h */
15113             switch (ri->data->what[n]) {
15114             case 'a':
15115             case 'r':
15116             case 's':
15117             case 'S':
15118             case 'u':
15119                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
15120                 break;
15121             case 'f':
15122                 Safefree(ri->data->data[n]);
15123                 break;
15124             case 'l':
15125             case 'L':
15126                 break;
15127             case 'T':           
15128                 { /* Aho Corasick add-on structure for a trie node.
15129                      Used in stclass optimization only */
15130                     U32 refcount;
15131                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
15132                     OP_REFCNT_LOCK;
15133                     refcount = --aho->refcount;
15134                     OP_REFCNT_UNLOCK;
15135                     if ( !refcount ) {
15136                         PerlMemShared_free(aho->states);
15137                         PerlMemShared_free(aho->fail);
15138                          /* do this last!!!! */
15139                         PerlMemShared_free(ri->data->data[n]);
15140                         PerlMemShared_free(ri->regstclass);
15141                     }
15142                 }
15143                 break;
15144             case 't':
15145                 {
15146                     /* trie structure. */
15147                     U32 refcount;
15148                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
15149                     OP_REFCNT_LOCK;
15150                     refcount = --trie->refcount;
15151                     OP_REFCNT_UNLOCK;
15152                     if ( !refcount ) {
15153                         PerlMemShared_free(trie->charmap);
15154                         PerlMemShared_free(trie->states);
15155                         PerlMemShared_free(trie->trans);
15156                         if (trie->bitmap)
15157                             PerlMemShared_free(trie->bitmap);
15158                         if (trie->jump)
15159                             PerlMemShared_free(trie->jump);
15160                         PerlMemShared_free(trie->wordinfo);
15161                         /* do this last!!!! */
15162                         PerlMemShared_free(ri->data->data[n]);
15163                     }
15164                 }
15165                 break;
15166             default:
15167                 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
15168             }
15169         }
15170         Safefree(ri->data->what);
15171         Safefree(ri->data);
15172     }
15173
15174     Safefree(ri);
15175 }
15176
15177 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
15178 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
15179 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
15180
15181 /* 
15182    re_dup - duplicate a regexp. 
15183    
15184    This routine is expected to clone a given regexp structure. It is only
15185    compiled under USE_ITHREADS.
15186
15187    After all of the core data stored in struct regexp is duplicated
15188    the regexp_engine.dupe method is used to copy any private data
15189    stored in the *pprivate pointer. This allows extensions to handle
15190    any duplication it needs to do.
15191
15192    See pregfree() and regfree_internal() if you change anything here. 
15193 */
15194 #if defined(USE_ITHREADS)
15195 #ifndef PERL_IN_XSUB_RE
15196 void
15197 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
15198 {
15199     dVAR;
15200     I32 npar;
15201     const struct regexp *r = ReANY(sstr);
15202     struct regexp *ret = ReANY(dstr);
15203     
15204     PERL_ARGS_ASSERT_RE_DUP_GUTS;
15205
15206     npar = r->nparens+1;
15207     Newx(ret->offs, npar, regexp_paren_pair);
15208     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
15209
15210     if (ret->substrs) {
15211         /* Do it this way to avoid reading from *r after the StructCopy().
15212            That way, if any of the sv_dup_inc()s dislodge *r from the L1
15213            cache, it doesn't matter.  */
15214         const bool anchored = r->check_substr
15215             ? r->check_substr == r->anchored_substr
15216             : r->check_utf8 == r->anchored_utf8;
15217         Newx(ret->substrs, 1, struct reg_substr_data);
15218         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
15219
15220         ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
15221         ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
15222         ret->float_substr = sv_dup_inc(ret->float_substr, param);
15223         ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
15224
15225         /* check_substr and check_utf8, if non-NULL, point to either their
15226            anchored or float namesakes, and don't hold a second reference.  */
15227
15228         if (ret->check_substr) {
15229             if (anchored) {
15230                 assert(r->check_utf8 == r->anchored_utf8);
15231                 ret->check_substr = ret->anchored_substr;
15232                 ret->check_utf8 = ret->anchored_utf8;
15233             } else {
15234                 assert(r->check_substr == r->float_substr);
15235                 assert(r->check_utf8 == r->float_utf8);
15236                 ret->check_substr = ret->float_substr;
15237                 ret->check_utf8 = ret->float_utf8;
15238             }
15239         } else if (ret->check_utf8) {
15240             if (anchored) {
15241                 ret->check_utf8 = ret->anchored_utf8;
15242             } else {
15243                 ret->check_utf8 = ret->float_utf8;
15244             }
15245         }
15246     }
15247
15248     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
15249     ret->qr_anoncv = MUTABLE_CV(sv_dup_inc((const SV *)ret->qr_anoncv, param));
15250
15251     if (ret->pprivate)
15252         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
15253
15254     if (RX_MATCH_COPIED(dstr))
15255         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
15256     else
15257         ret->subbeg = NULL;
15258 #ifdef PERL_ANY_COW
15259     ret->saved_copy = NULL;
15260 #endif
15261
15262     /* Whether mother_re be set or no, we need to copy the string.  We
15263        cannot refrain from copying it when the storage points directly to
15264        our mother regexp, because that's
15265                1: a buffer in a different thread
15266                2: something we no longer hold a reference on
15267                so we need to copy it locally.  */
15268     RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED(sstr), SvCUR(sstr)+1);
15269     ret->mother_re   = NULL;
15270     ret->gofs = 0;
15271 }
15272 #endif /* PERL_IN_XSUB_RE */
15273
15274 /*
15275    regdupe_internal()
15276    
15277    This is the internal complement to regdupe() which is used to copy
15278    the structure pointed to by the *pprivate pointer in the regexp.
15279    This is the core version of the extension overridable cloning hook.
15280    The regexp structure being duplicated will be copied by perl prior
15281    to this and will be provided as the regexp *r argument, however 
15282    with the /old/ structures pprivate pointer value. Thus this routine
15283    may override any copying normally done by perl.
15284    
15285    It returns a pointer to the new regexp_internal structure.
15286 */
15287
15288 void *
15289 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
15290 {
15291     dVAR;
15292     struct regexp *const r = ReANY(rx);
15293     regexp_internal *reti;
15294     int len;
15295     RXi_GET_DECL(r,ri);
15296
15297     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
15298     
15299     len = ProgLen(ri);
15300     
15301     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), char, regexp_internal);
15302     Copy(ri->program, reti->program, len+1, regnode);
15303
15304     reti->num_code_blocks = ri->num_code_blocks;
15305     if (ri->code_blocks) {
15306         int n;
15307         Newxc(reti->code_blocks, ri->num_code_blocks, struct reg_code_block,
15308                 struct reg_code_block);
15309         Copy(ri->code_blocks, reti->code_blocks, ri->num_code_blocks,
15310                 struct reg_code_block);
15311         for (n = 0; n < ri->num_code_blocks; n++)
15312              reti->code_blocks[n].src_regex = (REGEXP*)
15313                     sv_dup_inc((SV*)(ri->code_blocks[n].src_regex), param);
15314     }
15315     else
15316         reti->code_blocks = NULL;
15317
15318     reti->regstclass = NULL;
15319
15320     if (ri->data) {
15321         struct reg_data *d;
15322         const int count = ri->data->count;
15323         int i;
15324
15325         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
15326                 char, struct reg_data);
15327         Newx(d->what, count, U8);
15328
15329         d->count = count;
15330         for (i = 0; i < count; i++) {
15331             d->what[i] = ri->data->what[i];
15332             switch (d->what[i]) {
15333                 /* see also regcomp.h and regfree_internal() */
15334             case 'a': /* actually an AV, but the dup function is identical.  */
15335             case 'r':
15336             case 's':
15337             case 'S':
15338             case 'u': /* actually an HV, but the dup function is identical.  */
15339                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
15340                 break;
15341             case 'f':
15342                 /* This is cheating. */
15343                 Newx(d->data[i], 1, struct regnode_charclass_class);
15344                 StructCopy(ri->data->data[i], d->data[i],
15345                             struct regnode_charclass_class);
15346                 reti->regstclass = (regnode*)d->data[i];
15347                 break;
15348             case 'T':
15349                 /* Trie stclasses are readonly and can thus be shared
15350                  * without duplication. We free the stclass in pregfree
15351                  * when the corresponding reg_ac_data struct is freed.
15352                  */
15353                 reti->regstclass= ri->regstclass;
15354                 /* Fall through */
15355             case 't':
15356                 OP_REFCNT_LOCK;
15357                 ((reg_trie_data*)ri->data->data[i])->refcount++;
15358                 OP_REFCNT_UNLOCK;
15359                 /* Fall through */
15360             case 'l':
15361             case 'L':
15362                 d->data[i] = ri->data->data[i];
15363                 break;
15364             default:
15365                 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
15366             }
15367         }
15368
15369         reti->data = d;
15370     }
15371     else
15372         reti->data = NULL;
15373
15374     reti->name_list_idx = ri->name_list_idx;
15375
15376 #ifdef RE_TRACK_PATTERN_OFFSETS
15377     if (ri->u.offsets) {
15378         Newx(reti->u.offsets, 2*len+1, U32);
15379         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
15380     }
15381 #else
15382     SetProgLen(reti,len);
15383 #endif
15384
15385     return (void*)reti;
15386 }
15387
15388 #endif    /* USE_ITHREADS */
15389
15390 #ifndef PERL_IN_XSUB_RE
15391
15392 /*
15393  - regnext - dig the "next" pointer out of a node
15394  */
15395 regnode *
15396 Perl_regnext(pTHX_ regnode *p)
15397 {
15398     dVAR;
15399     I32 offset;
15400
15401     if (!p)
15402         return(NULL);
15403
15404     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
15405         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(p), (int)REGNODE_MAX);
15406     }
15407
15408     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
15409     if (offset == 0)
15410         return(NULL);
15411
15412     return(p+offset);
15413 }
15414 #endif
15415
15416 STATIC void
15417 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
15418 {
15419     va_list args;
15420     STRLEN l1 = strlen(pat1);
15421     STRLEN l2 = strlen(pat2);
15422     char buf[512];
15423     SV *msv;
15424     const char *message;
15425
15426     PERL_ARGS_ASSERT_RE_CROAK2;
15427
15428     if (l1 > 510)
15429         l1 = 510;
15430     if (l1 + l2 > 510)
15431         l2 = 510 - l1;
15432     Copy(pat1, buf, l1 , char);
15433     Copy(pat2, buf + l1, l2 , char);
15434     buf[l1 + l2] = '\n';
15435     buf[l1 + l2 + 1] = '\0';
15436 #ifdef I_STDARG
15437     /* ANSI variant takes additional second argument */
15438     va_start(args, pat2);
15439 #else
15440     va_start(args);
15441 #endif
15442     msv = vmess(buf, &args);
15443     va_end(args);
15444     message = SvPV_const(msv,l1);
15445     if (l1 > 512)
15446         l1 = 512;
15447     Copy(message, buf, l1 , char);
15448     buf[l1-1] = '\0';                   /* Overwrite \n */
15449     Perl_croak(aTHX_ "%s", buf);
15450 }
15451
15452 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
15453
15454 #ifndef PERL_IN_XSUB_RE
15455 void
15456 Perl_save_re_context(pTHX)
15457 {
15458     dVAR;
15459
15460     struct re_save_state *state;
15461
15462     SAVEVPTR(PL_curcop);
15463     SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
15464
15465     state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
15466     PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
15467     SSPUSHUV(SAVEt_RE_STATE);
15468
15469     Copy(&PL_reg_state, state, 1, struct re_save_state);
15470
15471     PL_reg_oldsaved = NULL;
15472     PL_reg_oldsavedlen = 0;
15473     PL_reg_oldsavedoffset = 0;
15474     PL_reg_oldsavedcoffset = 0;
15475     PL_reg_maxiter = 0;
15476     PL_reg_leftiter = 0;
15477     PL_reg_poscache = NULL;
15478     PL_reg_poscache_size = 0;
15479 #ifdef PERL_ANY_COW
15480     PL_nrs = NULL;
15481 #endif
15482
15483     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
15484     if (PL_curpm) {
15485         const REGEXP * const rx = PM_GETRE(PL_curpm);
15486         if (rx) {
15487             U32 i;
15488             for (i = 1; i <= RX_NPARENS(rx); i++) {
15489                 char digits[TYPE_CHARS(long)];
15490                 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
15491                 GV *const *const gvp
15492                     = (GV**)hv_fetch(PL_defstash, digits, len, 0);
15493
15494                 if (gvp) {
15495                     GV * const gv = *gvp;
15496                     if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
15497                         save_scalar(gv);
15498                 }
15499             }
15500         }
15501     }
15502 }
15503 #endif
15504
15505 #ifdef DEBUGGING
15506
15507 STATIC void
15508 S_put_byte(pTHX_ SV *sv, int c)
15509 {
15510     PERL_ARGS_ASSERT_PUT_BYTE;
15511
15512     /* Our definition of isPRINT() ignores locales, so only bytes that are
15513        not part of UTF-8 are considered printable. I assume that the same
15514        holds for UTF-EBCDIC.
15515        Also, code point 255 is not printable in either (it's E0 in EBCDIC,
15516        which Wikipedia says:
15517
15518        EO, or Eight Ones, is an 8-bit EBCDIC character code represented as all
15519        ones (binary 1111 1111, hexadecimal FF). It is similar, but not
15520        identical, to the ASCII delete (DEL) or rubout control character. ...
15521        it is typically mapped to hexadecimal code 9F, in order to provide a
15522        unique character mapping in both directions)
15523
15524        So the old condition can be simplified to !isPRINT(c)  */
15525     if (!isPRINT(c)) {
15526         if (c < 256) {
15527             Perl_sv_catpvf(aTHX_ sv, "\\x%02x", c);
15528         }
15529         else {
15530             Perl_sv_catpvf(aTHX_ sv, "\\x{%x}", c);
15531         }
15532     }
15533     else {
15534         const char string = c;
15535         if (c == '-' || c == ']' || c == '\\' || c == '^')
15536             sv_catpvs(sv, "\\");
15537         sv_catpvn(sv, &string, 1);
15538     }
15539 }
15540
15541
15542 #define CLEAR_OPTSTART \
15543     if (optstart) STMT_START { \
15544             DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
15545             optstart=NULL; \
15546     } STMT_END
15547
15548 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
15549
15550 STATIC const regnode *
15551 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
15552             const regnode *last, const regnode *plast, 
15553             SV* sv, I32 indent, U32 depth)
15554 {
15555     dVAR;
15556     U8 op = PSEUDO;     /* Arbitrary non-END op. */
15557     const regnode *next;
15558     const regnode *optstart= NULL;
15559     
15560     RXi_GET_DECL(r,ri);
15561     GET_RE_DEBUG_FLAGS_DECL;
15562
15563     PERL_ARGS_ASSERT_DUMPUNTIL;
15564
15565 #ifdef DEBUG_DUMPUNTIL
15566     PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
15567         last ? last-start : 0,plast ? plast-start : 0);
15568 #endif
15569             
15570     if (plast && plast < last) 
15571         last= plast;
15572
15573     while (PL_regkind[op] != END && (!last || node < last)) {
15574         /* While that wasn't END last time... */
15575         NODE_ALIGN(node);
15576         op = OP(node);
15577         if (op == CLOSE || op == WHILEM)
15578             indent--;
15579         next = regnext((regnode *)node);
15580
15581         /* Where, what. */
15582         if (OP(node) == OPTIMIZED) {
15583             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
15584                 optstart = node;
15585             else
15586                 goto after_print;
15587         } else
15588             CLEAR_OPTSTART;
15589
15590         regprop(r, sv, node);
15591         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
15592                       (int)(2*indent + 1), "", SvPVX_const(sv));
15593         
15594         if (OP(node) != OPTIMIZED) {                  
15595             if (next == NULL)           /* Next ptr. */
15596                 PerlIO_printf(Perl_debug_log, " (0)");
15597             else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
15598                 PerlIO_printf(Perl_debug_log, " (FAIL)");
15599             else 
15600                 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
15601             (void)PerlIO_putc(Perl_debug_log, '\n'); 
15602         }
15603         
15604       after_print:
15605         if (PL_regkind[(U8)op] == BRANCHJ) {
15606             assert(next);
15607             {
15608                 const regnode *nnode = (OP(next) == LONGJMP
15609                                        ? regnext((regnode *)next)
15610                                        : next);
15611                 if (last && nnode > last)
15612                     nnode = last;
15613                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
15614             }
15615         }
15616         else if (PL_regkind[(U8)op] == BRANCH) {
15617             assert(next);
15618             DUMPUNTIL(NEXTOPER(node), next);
15619         }
15620         else if ( PL_regkind[(U8)op]  == TRIE ) {
15621             const regnode *this_trie = node;
15622             const char op = OP(node);
15623             const U32 n = ARG(node);
15624             const reg_ac_data * const ac = op>=AHOCORASICK ?
15625                (reg_ac_data *)ri->data->data[n] :
15626                NULL;
15627             const reg_trie_data * const trie =
15628                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
15629 #ifdef DEBUGGING
15630             AV *const trie_words = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
15631 #endif
15632             const regnode *nextbranch= NULL;
15633             I32 word_idx;
15634             sv_setpvs(sv, "");
15635             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
15636                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
15637
15638                 PerlIO_printf(Perl_debug_log, "%*s%s ",
15639                    (int)(2*(indent+3)), "",
15640                     elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
15641                             PL_colors[0], PL_colors[1],
15642                             (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
15643                             PERL_PV_PRETTY_ELLIPSES    |
15644                             PERL_PV_PRETTY_LTGT
15645                             )
15646                             : "???"
15647                 );
15648                 if (trie->jump) {
15649                     U16 dist= trie->jump[word_idx+1];
15650                     PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
15651                                   (UV)((dist ? this_trie + dist : next) - start));
15652                     if (dist) {
15653                         if (!nextbranch)
15654                             nextbranch= this_trie + trie->jump[0];    
15655                         DUMPUNTIL(this_trie + dist, nextbranch);
15656                     }
15657                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
15658                         nextbranch= regnext((regnode *)nextbranch);
15659                 } else {
15660                     PerlIO_printf(Perl_debug_log, "\n");
15661                 }
15662             }
15663             if (last && next > last)
15664                 node= last;
15665             else
15666                 node= next;
15667         }
15668         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
15669             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
15670                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
15671         }
15672         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
15673             assert(next);
15674             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
15675         }
15676         else if ( op == PLUS || op == STAR) {
15677             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
15678         }
15679         else if (PL_regkind[(U8)op] == ANYOF) {
15680             /* arglen 1 + class block */
15681             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_CLASS)
15682                     ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
15683             node = NEXTOPER(node);
15684         }
15685         else if (PL_regkind[(U8)op] == EXACT) {
15686             /* Literal string, where present. */
15687             node += NODE_SZ_STR(node) - 1;
15688             node = NEXTOPER(node);
15689         }
15690         else {
15691             node = NEXTOPER(node);
15692             node += regarglen[(U8)op];
15693         }
15694         if (op == CURLYX || op == OPEN)
15695             indent++;
15696     }
15697     CLEAR_OPTSTART;
15698 #ifdef DEBUG_DUMPUNTIL    
15699     PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
15700 #endif
15701     return node;
15702 }
15703
15704 #endif  /* DEBUGGING */
15705
15706 /*
15707  * Local variables:
15708  * c-indentation-style: bsd
15709  * c-basic-offset: 4
15710  * indent-tabs-mode: nil
15711  * End:
15712  *
15713  * ex: set ts=8 sts=4 sw=4 et:
15714  */