]> git.vpit.fr Git - perl/modules/re-engine-Hooks.git/blob - src/5017007/regcomp.c
Remove the 5.15 development branch
[perl/modules/re-engine-Hooks.git] / src / 5017007 / 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 "re_defs.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 #ifdef HAS_ISBLANK
95 #   define hasISBLANK 1
96 #else
97 #   define hasISBLANK 0
98 #endif
99
100 #define HAS_NONLATIN1_FOLD_CLOSURE(i) _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
101 #define IS_NON_FINAL_FOLD(c) _IS_NON_FINAL_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
102 #define IS_IN_SOME_FOLD_L1(c) _IS_IN_SOME_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
103
104 #ifdef op
105 #undef op
106 #endif /* op */
107
108 #ifdef MSDOS
109 #  if defined(BUGGY_MSC6)
110  /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
111 #    pragma optimize("a",off)
112  /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
113 #    pragma optimize("w",on )
114 #  endif /* BUGGY_MSC6 */
115 #endif /* MSDOS */
116
117 #ifndef STATIC
118 #define STATIC  static
119 #endif
120
121
122 typedef struct RExC_state_t {
123     U32         flags;                  /* RXf_* are we folding, multilining? */
124     U32         pm_flags;               /* PMf_* stuff from the calling PMOP */
125     char        *precomp;               /* uncompiled string. */
126     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
127     regexp      *rx;                    /* perl core regexp structure */
128     regexp_internal     *rxi;           /* internal data for regexp object pprivate field */        
129     char        *start;                 /* Start of input for compile */
130     char        *end;                   /* End of input for compile */
131     char        *parse;                 /* Input-scan pointer. */
132     I32         whilem_seen;            /* number of WHILEM in this expr */
133     regnode     *emit_start;            /* Start of emitted-code area */
134     regnode     *emit_bound;            /* First regnode outside of the allocated space */
135     regnode     *emit;                  /* Code-emit pointer; &regdummy = don't = compiling */
136     I32         naughty;                /* How bad is this pattern? */
137     I32         sawback;                /* Did we see \1, ...? */
138     U32         seen;
139     I32         size;                   /* Code size. */
140     I32         npar;                   /* Capture buffer count, (OPEN). */
141     I32         cpar;                   /* Capture buffer count, (CLOSE). */
142     I32         nestroot;               /* root parens we are in - used by accept */
143     I32         extralen;
144     I32         seen_zerolen;
145     regnode     **open_parens;          /* pointers to open parens */
146     regnode     **close_parens;         /* pointers to close parens */
147     regnode     *opend;                 /* END node in program */
148     I32         utf8;           /* whether the pattern is utf8 or not */
149     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
150                                 /* XXX use this for future optimisation of case
151                                  * where pattern must be upgraded to utf8. */
152     I32         uni_semantics;  /* If a d charset modifier should use unicode
153                                    rules, even if the pattern is not in
154                                    utf8 */
155     HV          *paren_names;           /* Paren names */
156     
157     regnode     **recurse;              /* Recurse regops */
158     I32         recurse_count;          /* Number of recurse regops */
159     I32         in_lookbehind;
160     I32         contains_locale;
161     I32         override_recoding;
162     I32         in_multi_char_class;
163     struct reg_code_block *code_blocks; /* positions of literal (?{})
164                                             within pattern */
165     int         num_code_blocks;        /* size of code_blocks[] */
166     int         code_index;             /* next code_blocks[] slot */
167 #if ADD_TO_REGEXEC
168     char        *starttry;              /* -Dr: where regtry was called. */
169 #define RExC_starttry   (pRExC_state->starttry)
170 #endif
171     SV          *runtime_code_qr;       /* qr with the runtime code blocks */
172 #ifdef DEBUGGING
173     const char  *lastparse;
174     I32         lastnum;
175     AV          *paren_name_list;       /* idx -> name */
176 #define RExC_lastparse  (pRExC_state->lastparse)
177 #define RExC_lastnum    (pRExC_state->lastnum)
178 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
179 #endif
180 } RExC_state_t;
181
182 #define RExC_flags      (pRExC_state->flags)
183 #define RExC_pm_flags   (pRExC_state->pm_flags)
184 #define RExC_precomp    (pRExC_state->precomp)
185 #define RExC_rx_sv      (pRExC_state->rx_sv)
186 #define RExC_rx         (pRExC_state->rx)
187 #define RExC_rxi        (pRExC_state->rxi)
188 #define RExC_start      (pRExC_state->start)
189 #define RExC_end        (pRExC_state->end)
190 #define RExC_parse      (pRExC_state->parse)
191 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
192 #ifdef RE_TRACK_PATTERN_OFFSETS
193 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the others */
194 #endif
195 #define RExC_emit       (pRExC_state->emit)
196 #define RExC_emit_start (pRExC_state->emit_start)
197 #define RExC_emit_bound (pRExC_state->emit_bound)
198 #define RExC_naughty    (pRExC_state->naughty)
199 #define RExC_sawback    (pRExC_state->sawback)
200 #define RExC_seen       (pRExC_state->seen)
201 #define RExC_size       (pRExC_state->size)
202 #define RExC_npar       (pRExC_state->npar)
203 #define RExC_nestroot   (pRExC_state->nestroot)
204 #define RExC_extralen   (pRExC_state->extralen)
205 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
206 #define RExC_utf8       (pRExC_state->utf8)
207 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
208 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
209 #define RExC_open_parens        (pRExC_state->open_parens)
210 #define RExC_close_parens       (pRExC_state->close_parens)
211 #define RExC_opend      (pRExC_state->opend)
212 #define RExC_paren_names        (pRExC_state->paren_names)
213 #define RExC_recurse    (pRExC_state->recurse)
214 #define RExC_recurse_count      (pRExC_state->recurse_count)
215 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
216 #define RExC_contains_locale    (pRExC_state->contains_locale)
217 #define RExC_override_recoding (pRExC_state->override_recoding)
218 #define RExC_in_multi_char_class (pRExC_state->in_multi_char_class)
219
220
221 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
222 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
223         ((*s) == '{' && regcurly(s)))
224
225 #ifdef SPSTART
226 #undef SPSTART          /* dratted cpp namespace... */
227 #endif
228 /*
229  * Flags to be passed up and down.
230  */
231 #define WORST           0       /* Worst case. */
232 #define HASWIDTH        0x01    /* Known to match non-null strings. */
233
234 /* Simple enough to be STAR/PLUS operand; in an EXACTish node must be a single
235  * character.  (There needs to be a case: in the switch statement in regexec.c
236  * for any node marked SIMPLE.)  Note that this is not the same thing as
237  * REGNODE_SIMPLE */
238 #define SIMPLE          0x02
239 #define SPSTART         0x04    /* Starts with * or + */
240 #define TRYAGAIN        0x08    /* Weeded out a declaration. */
241 #define POSTPONED       0x10    /* (?1),(?&name), (??{...}) or similar */
242
243 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
244
245 /* whether trie related optimizations are enabled */
246 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
247 #define TRIE_STUDY_OPT
248 #define FULL_TRIE_STUDY
249 #define TRIE_STCLASS
250 #endif
251
252
253
254 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
255 #define PBITVAL(paren) (1 << ((paren) & 7))
256 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
257 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
258 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
259
260 /* If not already in utf8, do a longjmp back to the beginning */
261 #define UTF8_LONGJMP 42 /* Choose a value not likely to ever conflict */
262 #define REQUIRE_UTF8    STMT_START {                                       \
263                                      if (! UTF) JMPENV_JUMP(UTF8_LONGJMP); \
264                         } STMT_END
265
266 /* About scan_data_t.
267
268   During optimisation we recurse through the regexp program performing
269   various inplace (keyhole style) optimisations. In addition study_chunk
270   and scan_commit populate this data structure with information about
271   what strings MUST appear in the pattern. We look for the longest 
272   string that must appear at a fixed location, and we look for the
273   longest string that may appear at a floating location. So for instance
274   in the pattern:
275   
276     /FOO[xX]A.*B[xX]BAR/
277     
278   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
279   strings (because they follow a .* construct). study_chunk will identify
280   both FOO and BAR as being the longest fixed and floating strings respectively.
281   
282   The strings can be composites, for instance
283   
284      /(f)(o)(o)/
285      
286   will result in a composite fixed substring 'foo'.
287   
288   For each string some basic information is maintained:
289   
290   - offset or min_offset
291     This is the position the string must appear at, or not before.
292     It also implicitly (when combined with minlenp) tells us how many
293     characters must match before the string we are searching for.
294     Likewise when combined with minlenp and the length of the string it
295     tells us how many characters must appear after the string we have 
296     found.
297   
298   - max_offset
299     Only used for floating strings. This is the rightmost point that
300     the string can appear at. If set to I32 max it indicates that the
301     string can occur infinitely far to the right.
302   
303   - minlenp
304     A pointer to the minimum number of characters of the pattern that the
305     string was found inside. This is important as in the case of positive
306     lookahead or positive lookbehind we can have multiple patterns 
307     involved. Consider
308     
309     /(?=FOO).*F/
310     
311     The minimum length of the pattern overall is 3, the minimum length
312     of the lookahead part is 3, but the minimum length of the part that
313     will actually match is 1. So 'FOO's minimum length is 3, but the 
314     minimum length for the F is 1. This is important as the minimum length
315     is used to determine offsets in front of and behind the string being 
316     looked for.  Since strings can be composites this is the length of the
317     pattern at the time it was committed with a scan_commit. Note that
318     the length is calculated by study_chunk, so that the minimum lengths
319     are not known until the full pattern has been compiled, thus the 
320     pointer to the value.
321   
322   - lookbehind
323   
324     In the case of lookbehind the string being searched for can be
325     offset past the start point of the final matching string. 
326     If this value was just blithely removed from the min_offset it would
327     invalidate some of the calculations for how many chars must match
328     before or after (as they are derived from min_offset and minlen and
329     the length of the string being searched for). 
330     When the final pattern is compiled and the data is moved from the
331     scan_data_t structure into the regexp structure the information
332     about lookbehind is factored in, with the information that would 
333     have been lost precalculated in the end_shift field for the 
334     associated string.
335
336   The fields pos_min and pos_delta are used to store the minimum offset
337   and the delta to the maximum offset at the current point in the pattern.    
338
339 */
340
341 typedef struct scan_data_t {
342     /*I32 len_min;      unused */
343     /*I32 len_delta;    unused */
344     I32 pos_min;
345     I32 pos_delta;
346     SV *last_found;
347     I32 last_end;           /* min value, <0 unless valid. */
348     I32 last_start_min;
349     I32 last_start_max;
350     SV **longest;           /* Either &l_fixed, or &l_float. */
351     SV *longest_fixed;      /* longest fixed string found in pattern */
352     I32 offset_fixed;       /* offset where it starts */
353     I32 *minlen_fixed;      /* pointer to the minlen relevant to the string */
354     I32 lookbehind_fixed;   /* is the position of the string modfied by LB */
355     SV *longest_float;      /* longest floating string found in pattern */
356     I32 offset_float_min;   /* earliest point in string it can appear */
357     I32 offset_float_max;   /* latest point in string it can appear */
358     I32 *minlen_float;      /* pointer to the minlen relevant to the string */
359     I32 lookbehind_float;   /* is the position of the string modified by LB */
360     I32 flags;
361     I32 whilem_c;
362     I32 *last_closep;
363     struct regnode_charclass_class *start_class;
364 } scan_data_t;
365
366 /*
367  * Forward declarations for pregcomp()'s friends.
368  */
369
370 static const scan_data_t zero_scan_data =
371   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
372
373 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
374 #define SF_BEFORE_SEOL          0x0001
375 #define SF_BEFORE_MEOL          0x0002
376 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
377 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
378
379 #ifdef NO_UNARY_PLUS
380 #  define SF_FIX_SHIFT_EOL      (0+2)
381 #  define SF_FL_SHIFT_EOL               (0+4)
382 #else
383 #  define SF_FIX_SHIFT_EOL      (+2)
384 #  define SF_FL_SHIFT_EOL               (+4)
385 #endif
386
387 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
388 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
389
390 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
391 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
392 #define SF_IS_INF               0x0040
393 #define SF_HAS_PAR              0x0080
394 #define SF_IN_PAR               0x0100
395 #define SF_HAS_EVAL             0x0200
396 #define SCF_DO_SUBSTR           0x0400
397 #define SCF_DO_STCLASS_AND      0x0800
398 #define SCF_DO_STCLASS_OR       0x1000
399 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
400 #define SCF_WHILEM_VISITED_POS  0x2000
401
402 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
403 #define SCF_SEEN_ACCEPT         0x8000 
404
405 #define UTF cBOOL(RExC_utf8)
406
407 /* The enums for all these are ordered so things work out correctly */
408 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
409 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_DEPENDS_CHARSET)
410 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
411 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags) >= REGEX_UNICODE_CHARSET)
412 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_RESTRICTED_CHARSET)
413 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags) >= REGEX_ASCII_RESTRICTED_CHARSET)
414 #define ASCII_FOLD_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
415
416 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
417
418 #define OOB_NAMEDCLASS          -1
419
420 /* There is no code point that is out-of-bounds, so this is problematic.  But
421  * its only current use is to initialize a variable that is always set before
422  * looked at. */
423 #define OOB_UNICODE             0xDEADBEEF
424
425 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
426 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
427
428
429 /* length of regex to show in messages that don't mark a position within */
430 #define RegexLengthToShowInErrorMessages 127
431
432 /*
433  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
434  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
435  * op/pragma/warn/regcomp.
436  */
437 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
438 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
439
440 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
441
442 /*
443  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
444  * arg. Show regex, up to a maximum length. If it's too long, chop and add
445  * "...".
446  */
447 #define _FAIL(code) STMT_START {                                        \
448     const char *ellipses = "";                                          \
449     IV len = RExC_end - RExC_precomp;                                   \
450                                                                         \
451     if (!SIZE_ONLY)                                                     \
452         SAVEFREESV(RExC_rx_sv);                                         \
453     if (len > RegexLengthToShowInErrorMessages) {                       \
454         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
455         len = RegexLengthToShowInErrorMessages - 10;                    \
456         ellipses = "...";                                               \
457     }                                                                   \
458     code;                                                               \
459 } STMT_END
460
461 #define FAIL(msg) _FAIL(                            \
462     Perl_croak(aTHX_ "%s in regex m/%.*s%s/",       \
463             msg, (int)len, RExC_precomp, ellipses))
464
465 #define FAIL2(msg,arg) _FAIL(                       \
466     Perl_croak(aTHX_ msg " in regex m/%.*s%s/",     \
467             arg, (int)len, RExC_precomp, ellipses))
468
469 /*
470  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
471  */
472 #define Simple_vFAIL(m) STMT_START {                                    \
473     const IV offset = RExC_parse - RExC_precomp;                        \
474     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
475             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
476 } STMT_END
477
478 /*
479  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
480  */
481 #define vFAIL(m) STMT_START {                           \
482     if (!SIZE_ONLY)                                     \
483         SAVEFREESV(RExC_rx_sv);                         \
484     Simple_vFAIL(m);                                    \
485 } STMT_END
486
487 /*
488  * Like Simple_vFAIL(), but accepts two arguments.
489  */
490 #define Simple_vFAIL2(m,a1) STMT_START {                        \
491     const IV offset = RExC_parse - RExC_precomp;                        \
492     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1,                   \
493             (int)offset, RExC_precomp, RExC_precomp + offset);  \
494 } STMT_END
495
496 /*
497  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
498  */
499 #define vFAIL2(m,a1) STMT_START {                       \
500     if (!SIZE_ONLY)                                     \
501         SAVEFREESV(RExC_rx_sv);                         \
502     Simple_vFAIL2(m, a1);                               \
503 } STMT_END
504
505
506 /*
507  * Like Simple_vFAIL(), but accepts three arguments.
508  */
509 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
510     const IV offset = RExC_parse - RExC_precomp;                \
511     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2,               \
512             (int)offset, RExC_precomp, RExC_precomp + offset);  \
513 } STMT_END
514
515 /*
516  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
517  */
518 #define vFAIL3(m,a1,a2) STMT_START {                    \
519     if (!SIZE_ONLY)                                     \
520         SAVEFREESV(RExC_rx_sv);                         \
521     Simple_vFAIL3(m, a1, a2);                           \
522 } STMT_END
523
524 /*
525  * Like Simple_vFAIL(), but accepts four arguments.
526  */
527 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
528     const IV offset = RExC_parse - RExC_precomp;                \
529     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3,           \
530             (int)offset, RExC_precomp, RExC_precomp + offset);  \
531 } STMT_END
532
533 #define ckWARNreg(loc,m) STMT_START {                                   \
534     const IV offset = loc - RExC_precomp;                               \
535     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
536             (int)offset, RExC_precomp, RExC_precomp + offset);          \
537 } STMT_END
538
539 #define ckWARNregdep(loc,m) STMT_START {                                \
540     const IV offset = loc - RExC_precomp;                               \
541     Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),     \
542             m REPORT_LOCATION,                                          \
543             (int)offset, RExC_precomp, RExC_precomp + offset);          \
544 } STMT_END
545
546 #define ckWARN2regdep(loc,m, a1) STMT_START {                           \
547     const IV offset = loc - RExC_precomp;                               \
548     Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),     \
549             m REPORT_LOCATION,                                          \
550             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
551 } STMT_END
552
553 #define ckWARN2reg(loc, m, a1) STMT_START {                             \
554     const IV offset = loc - RExC_precomp;                               \
555     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
556             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
557 } STMT_END
558
559 #define vWARN3(loc, m, a1, a2) STMT_START {                             \
560     const IV offset = loc - RExC_precomp;                               \
561     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
562             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
563 } STMT_END
564
565 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                         \
566     const IV offset = loc - RExC_precomp;                               \
567     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
568             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
569 } STMT_END
570
571 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
572     const IV offset = loc - RExC_precomp;                               \
573     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
574             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
575 } STMT_END
576
577 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
578     const IV offset = loc - RExC_precomp;                               \
579     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
580             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
581 } STMT_END
582
583 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
584     const IV offset = loc - RExC_precomp;                               \
585     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
586             a1, a2, a3, a4, (int)offset, RExC_precomp, RExC_precomp + offset); \
587 } STMT_END
588
589
590 /* Allow for side effects in s */
591 #define REGC(c,s) STMT_START {                  \
592     if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
593 } STMT_END
594
595 /* Macros for recording node offsets.   20001227 mjd@plover.com 
596  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
597  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
598  * Element 0 holds the number n.
599  * Position is 1 indexed.
600  */
601 #ifndef RE_TRACK_PATTERN_OFFSETS
602 #define Set_Node_Offset_To_R(node,byte)
603 #define Set_Node_Offset(node,byte)
604 #define Set_Cur_Node_Offset
605 #define Set_Node_Length_To_R(node,len)
606 #define Set_Node_Length(node,len)
607 #define Set_Node_Cur_Length(node)
608 #define Node_Offset(n) 
609 #define Node_Length(n) 
610 #define Set_Node_Offset_Length(node,offset,len)
611 #define ProgLen(ri) ri->u.proglen
612 #define SetProgLen(ri,x) ri->u.proglen = x
613 #else
614 #define ProgLen(ri) ri->u.offsets[0]
615 #define SetProgLen(ri,x) ri->u.offsets[0] = x
616 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
617     if (! SIZE_ONLY) {                                                  \
618         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
619                     __LINE__, (int)(node), (int)(byte)));               \
620         if((node) < 0) {                                                \
621             Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \
622         } else {                                                        \
623             RExC_offsets[2*(node)-1] = (byte);                          \
624         }                                                               \
625     }                                                                   \
626 } STMT_END
627
628 #define Set_Node_Offset(node,byte) \
629     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
630 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
631
632 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
633     if (! SIZE_ONLY) {                                                  \
634         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
635                 __LINE__, (int)(node), (int)(len)));                    \
636         if((node) < 0) {                                                \
637             Perl_croak(aTHX_ "value of node is %d in Length macro", (int)(node)); \
638         } else {                                                        \
639             RExC_offsets[2*(node)] = (len);                             \
640         }                                                               \
641     }                                                                   \
642 } STMT_END
643
644 #define Set_Node_Length(node,len) \
645     Set_Node_Length_To_R((node)-RExC_emit_start, len)
646 #define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
647 #define Set_Node_Cur_Length(node) \
648     Set_Node_Length(node, RExC_parse - parse_start)
649
650 /* Get offsets and lengths */
651 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
652 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
653
654 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
655     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
656     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
657 } STMT_END
658 #endif
659
660 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
661 #define EXPERIMENTAL_INPLACESCAN
662 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
663
664 #define DEBUG_STUDYDATA(str,data,depth)                              \
665 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
666     PerlIO_printf(Perl_debug_log,                                    \
667         "%*s" str "Pos:%"IVdf"/%"IVdf                                \
668         " Flags: 0x%"UVXf" Whilem_c: %"IVdf" Lcp: %"IVdf" %s",       \
669         (int)(depth)*2, "",                                          \
670         (IV)((data)->pos_min),                                       \
671         (IV)((data)->pos_delta),                                     \
672         (UV)((data)->flags),                                         \
673         (IV)((data)->whilem_c),                                      \
674         (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
675         is_inf ? "INF " : ""                                         \
676     );                                                               \
677     if ((data)->last_found)                                          \
678         PerlIO_printf(Perl_debug_log,                                \
679             "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
680             " %sFloat: '%s' @ %"IVdf"/%"IVdf"",                      \
681             SvPVX_const((data)->last_found),                         \
682             (IV)((data)->last_end),                                  \
683             (IV)((data)->last_start_min),                            \
684             (IV)((data)->last_start_max),                            \
685             ((data)->longest &&                                      \
686              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
687             SvPVX_const((data)->longest_fixed),                      \
688             (IV)((data)->offset_fixed),                              \
689             ((data)->longest &&                                      \
690              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
691             SvPVX_const((data)->longest_float),                      \
692             (IV)((data)->offset_float_min),                          \
693             (IV)((data)->offset_float_max)                           \
694         );                                                           \
695     PerlIO_printf(Perl_debug_log,"\n");                              \
696 });
697
698 /* Mark that we cannot extend a found fixed substring at this point.
699    Update the longest found anchored substring and the longest found
700    floating substrings if needed. */
701
702 STATIC void
703 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp, int is_inf)
704 {
705     const STRLEN l = CHR_SVLEN(data->last_found);
706     const STRLEN old_l = CHR_SVLEN(*data->longest);
707     GET_RE_DEBUG_FLAGS_DECL;
708
709     PERL_ARGS_ASSERT_SCAN_COMMIT;
710
711     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
712         SvSetMagicSV(*data->longest, data->last_found);
713         if (*data->longest == data->longest_fixed) {
714             data->offset_fixed = l ? data->last_start_min : data->pos_min;
715             if (data->flags & SF_BEFORE_EOL)
716                 data->flags
717                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
718             else
719                 data->flags &= ~SF_FIX_BEFORE_EOL;
720             data->minlen_fixed=minlenp;
721             data->lookbehind_fixed=0;
722         }
723         else { /* *data->longest == data->longest_float */
724             data->offset_float_min = l ? data->last_start_min : data->pos_min;
725             data->offset_float_max = (l
726                                       ? data->last_start_max
727                                       : data->pos_min + data->pos_delta);
728             if (is_inf || (U32)data->offset_float_max > (U32)I32_MAX)
729                 data->offset_float_max = I32_MAX;
730             if (data->flags & SF_BEFORE_EOL)
731                 data->flags
732                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
733             else
734                 data->flags &= ~SF_FL_BEFORE_EOL;
735             data->minlen_float=minlenp;
736             data->lookbehind_float=0;
737         }
738     }
739     SvCUR_set(data->last_found, 0);
740     {
741         SV * const sv = data->last_found;
742         if (SvUTF8(sv) && SvMAGICAL(sv)) {
743             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
744             if (mg)
745                 mg->mg_len = 0;
746         }
747     }
748     data->last_end = -1;
749     data->flags &= ~SF_BEFORE_EOL;
750     DEBUG_STUDYDATA("commit: ",data,0);
751 }
752
753 /* Can match anything (initialization) */
754 STATIC void
755 S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
756 {
757     PERL_ARGS_ASSERT_CL_ANYTHING;
758
759     ANYOF_BITMAP_SETALL(cl);
760     cl->flags = ANYOF_CLASS|ANYOF_EOS|ANYOF_UNICODE_ALL
761                 |ANYOF_NON_UTF8_LATIN1_ALL;
762
763     /* If any portion of the regex is to operate under locale rules,
764      * initialization includes it.  The reason this isn't done for all regexes
765      * is that the optimizer was written under the assumption that locale was
766      * all-or-nothing.  Given the complexity and lack of documentation in the
767      * optimizer, and that there are inadequate test cases for locale, so many
768      * parts of it may not work properly, it is safest to avoid locale unless
769      * necessary. */
770     if (RExC_contains_locale) {
771         ANYOF_CLASS_SETALL(cl);     /* /l uses class */
772         cl->flags |= ANYOF_LOCALE|ANYOF_LOC_FOLD;
773     }
774     else {
775         ANYOF_CLASS_ZERO(cl);       /* Only /l uses class now */
776     }
777 }
778
779 /* Can match anything (initialization) */
780 STATIC int
781 S_cl_is_anything(const struct regnode_charclass_class *cl)
782 {
783     int value;
784
785     PERL_ARGS_ASSERT_CL_IS_ANYTHING;
786
787     for (value = 0; value <= ANYOF_MAX; value += 2)
788         if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
789             return 1;
790     if (!(cl->flags & ANYOF_UNICODE_ALL))
791         return 0;
792     if (!ANYOF_BITMAP_TESTALLSET((const void*)cl))
793         return 0;
794     return 1;
795 }
796
797 /* Can match anything (initialization) */
798 STATIC void
799 S_cl_init(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
800 {
801     PERL_ARGS_ASSERT_CL_INIT;
802
803     Zero(cl, 1, struct regnode_charclass_class);
804     cl->type = ANYOF;
805     cl_anything(pRExC_state, cl);
806     ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
807 }
808
809 /* These two functions currently do the exact same thing */
810 #define cl_init_zero            S_cl_init
811
812 /* 'AND' a given class with another one.  Can create false positives.  'cl'
813  * should not be inverted.  'and_with->flags & ANYOF_CLASS' should be 0 if
814  * 'and_with' is a regnode_charclass instead of a regnode_charclass_class. */
815 STATIC void
816 S_cl_and(struct regnode_charclass_class *cl,
817         const struct regnode_charclass_class *and_with)
818 {
819     PERL_ARGS_ASSERT_CL_AND;
820
821     assert(and_with->type == ANYOF);
822
823     /* I (khw) am not sure all these restrictions are necessary XXX */
824     if (!(ANYOF_CLASS_TEST_ANY_SET(and_with))
825         && !(ANYOF_CLASS_TEST_ANY_SET(cl))
826         && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
827         && !(and_with->flags & ANYOF_LOC_FOLD)
828         && !(cl->flags & ANYOF_LOC_FOLD)) {
829         int i;
830
831         if (and_with->flags & ANYOF_INVERT)
832             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
833                 cl->bitmap[i] &= ~and_with->bitmap[i];
834         else
835             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
836                 cl->bitmap[i] &= and_with->bitmap[i];
837     } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
838
839     if (and_with->flags & ANYOF_INVERT) {
840
841         /* Here, the and'ed node is inverted.  Get the AND of the flags that
842          * aren't affected by the inversion.  Those that are affected are
843          * handled individually below */
844         U8 affected_flags = cl->flags & ~INVERSION_UNAFFECTED_FLAGS;
845         cl->flags &= (and_with->flags & INVERSION_UNAFFECTED_FLAGS);
846         cl->flags |= affected_flags;
847
848         /* We currently don't know how to deal with things that aren't in the
849          * bitmap, but we know that the intersection is no greater than what
850          * is already in cl, so let there be false positives that get sorted
851          * out after the synthetic start class succeeds, and the node is
852          * matched for real. */
853
854         /* The inversion of these two flags indicate that the resulting
855          * intersection doesn't have them */
856         if (and_with->flags & ANYOF_UNICODE_ALL) {
857             cl->flags &= ~ANYOF_UNICODE_ALL;
858         }
859         if (and_with->flags & ANYOF_NON_UTF8_LATIN1_ALL) {
860             cl->flags &= ~ANYOF_NON_UTF8_LATIN1_ALL;
861         }
862     }
863     else {   /* and'd node is not inverted */
864         U8 outside_bitmap_but_not_utf8; /* Temp variable */
865
866         if (! ANYOF_NONBITMAP(and_with)) {
867
868             /* Here 'and_with' doesn't match anything outside the bitmap
869              * (except possibly ANYOF_UNICODE_ALL), which means the
870              * intersection can't either, except for ANYOF_UNICODE_ALL, in
871              * which case we don't know what the intersection is, but it's no
872              * greater than what cl already has, so can just leave it alone,
873              * with possible false positives */
874             if (! (and_with->flags & ANYOF_UNICODE_ALL)) {
875                 ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
876                 cl->flags &= ~ANYOF_NONBITMAP_NON_UTF8;
877             }
878         }
879         else if (! ANYOF_NONBITMAP(cl)) {
880
881             /* Here, 'and_with' does match something outside the bitmap, and cl
882              * doesn't have a list of things to match outside the bitmap.  If
883              * cl can match all code points above 255, the intersection will
884              * be those above-255 code points that 'and_with' matches.  If cl
885              * can't match all Unicode code points, it means that it can't
886              * match anything outside the bitmap (since the 'if' that got us
887              * into this block tested for that), so we leave the bitmap empty.
888              */
889             if (cl->flags & ANYOF_UNICODE_ALL) {
890                 ARG_SET(cl, ARG(and_with));
891
892                 /* and_with's ARG may match things that don't require UTF8.
893                  * And now cl's will too, in spite of this being an 'and'.  See
894                  * the comments below about the kludge */
895                 cl->flags |= and_with->flags & ANYOF_NONBITMAP_NON_UTF8;
896             }
897         }
898         else {
899             /* Here, both 'and_with' and cl match something outside the
900              * bitmap.  Currently we do not do the intersection, so just match
901              * whatever cl had at the beginning.  */
902         }
903
904
905         /* Take the intersection of the two sets of flags.  However, the
906          * ANYOF_NONBITMAP_NON_UTF8 flag is treated as an 'or'.  This is a
907          * kludge around the fact that this flag is not treated like the others
908          * which are initialized in cl_anything().  The way the optimizer works
909          * is that the synthetic start class (SSC) is initialized to match
910          * anything, and then the first time a real node is encountered, its
911          * values are AND'd with the SSC's with the result being the values of
912          * the real node.  However, there are paths through the optimizer where
913          * the AND never gets called, so those initialized bits are set
914          * inappropriately, which is not usually a big deal, as they just cause
915          * false positives in the SSC, which will just mean a probably
916          * imperceptible slow down in execution.  However this bit has a
917          * higher false positive consequence in that it can cause utf8.pm,
918          * utf8_heavy.pl ... to be loaded when not necessary, which is a much
919          * bigger slowdown and also causes significant extra memory to be used.
920          * In order to prevent this, the code now takes a different tack.  The
921          * bit isn't set unless some part of the regular expression needs it,
922          * but once set it won't get cleared.  This means that these extra
923          * modules won't get loaded unless there was some path through the
924          * pattern that would have required them anyway, and  so any false
925          * positives that occur by not ANDing them out when they could be
926          * aren't as severe as they would be if we treated this bit like all
927          * the others */
928         outside_bitmap_but_not_utf8 = (cl->flags | and_with->flags)
929                                       & ANYOF_NONBITMAP_NON_UTF8;
930         cl->flags &= and_with->flags;
931         cl->flags |= outside_bitmap_but_not_utf8;
932     }
933 }
934
935 /* 'OR' a given class with another one.  Can create false positives.  'cl'
936  * should not be inverted.  'or_with->flags & ANYOF_CLASS' should be 0 if
937  * 'or_with' is a regnode_charclass instead of a regnode_charclass_class. */
938 STATIC void
939 S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
940 {
941     PERL_ARGS_ASSERT_CL_OR;
942
943     if (or_with->flags & ANYOF_INVERT) {
944
945         /* Here, the or'd node is to be inverted.  This means we take the
946          * complement of everything not in the bitmap, but currently we don't
947          * know what that is, so give up and match anything */
948         if (ANYOF_NONBITMAP(or_with)) {
949             cl_anything(pRExC_state, cl);
950         }
951         /* We do not use
952          * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
953          *   <= (B1 | !B2) | (CL1 | !CL2)
954          * which is wasteful if CL2 is small, but we ignore CL2:
955          *   (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
956          * XXXX Can we handle case-fold?  Unclear:
957          *   (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
958          *   (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
959          */
960         else if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
961              && !(or_with->flags & ANYOF_LOC_FOLD)
962              && !(cl->flags & ANYOF_LOC_FOLD) ) {
963             int i;
964
965             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
966                 cl->bitmap[i] |= ~or_with->bitmap[i];
967         } /* XXXX: logic is complicated otherwise */
968         else {
969             cl_anything(pRExC_state, cl);
970         }
971
972         /* And, we can just take the union of the flags that aren't affected
973          * by the inversion */
974         cl->flags |= or_with->flags & INVERSION_UNAFFECTED_FLAGS;
975
976         /* For the remaining flags:
977             ANYOF_UNICODE_ALL and inverted means to not match anything above
978                     255, which means that the union with cl should just be
979                     what cl has in it, so can ignore this flag
980             ANYOF_NON_UTF8_LATIN1_ALL and inverted means if not utf8 and ord
981                     is 127-255 to match them, but then invert that, so the
982                     union with cl should just be what cl has in it, so can
983                     ignore this flag
984          */
985     } else {    /* 'or_with' is not inverted */
986         /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
987         if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
988              && (!(or_with->flags & ANYOF_LOC_FOLD)
989                  || (cl->flags & ANYOF_LOC_FOLD)) ) {
990             int i;
991
992             /* OR char bitmap and class bitmap separately */
993             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
994                 cl->bitmap[i] |= or_with->bitmap[i];
995             ANYOF_CLASS_OR(or_with, cl);
996         }
997         else { /* XXXX: logic is complicated, leave it along for a moment. */
998             cl_anything(pRExC_state, cl);
999         }
1000
1001         if (ANYOF_NONBITMAP(or_with)) {
1002
1003             /* Use the added node's outside-the-bit-map match if there isn't a
1004              * conflict.  If there is a conflict (both nodes match something
1005              * outside the bitmap, but what they match outside is not the same
1006              * pointer, and hence not easily compared until XXX we extend
1007              * inversion lists this far), give up and allow the start class to
1008              * match everything outside the bitmap.  If that stuff is all above
1009              * 255, can just set UNICODE_ALL, otherwise caould be anything. */
1010             if (! ANYOF_NONBITMAP(cl)) {
1011                 ARG_SET(cl, ARG(or_with));
1012             }
1013             else if (ARG(cl) != ARG(or_with)) {
1014
1015                 if ((or_with->flags & ANYOF_NONBITMAP_NON_UTF8)) {
1016                     cl_anything(pRExC_state, cl);
1017                 }
1018                 else {
1019                     cl->flags |= ANYOF_UNICODE_ALL;
1020                 }
1021             }
1022         }
1023
1024         /* Take the union */
1025         cl->flags |= or_with->flags;
1026     }
1027 }
1028
1029 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1030 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
1031 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1032 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list ? (TRIE_LIST_CUR( idx ) - 1) : 0 )
1033
1034
1035 #ifdef DEBUGGING
1036 /*
1037    dump_trie(trie,widecharmap,revcharmap)
1038    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1039    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1040
1041    These routines dump out a trie in a somewhat readable format.
1042    The _interim_ variants are used for debugging the interim
1043    tables that are used to generate the final compressed
1044    representation which is what dump_trie expects.
1045
1046    Part of the reason for their existence is to provide a form
1047    of documentation as to how the different representations function.
1048
1049 */
1050
1051 /*
1052   Dumps the final compressed table form of the trie to Perl_debug_log.
1053   Used for debugging make_trie().
1054 */
1055
1056 STATIC void
1057 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1058             AV *revcharmap, U32 depth)
1059 {
1060     U32 state;
1061     SV *sv=sv_newmortal();
1062     int colwidth= widecharmap ? 6 : 4;
1063     U16 word;
1064     GET_RE_DEBUG_FLAGS_DECL;
1065
1066     PERL_ARGS_ASSERT_DUMP_TRIE;
1067
1068     PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
1069         (int)depth * 2 + 2,"",
1070         "Match","Base","Ofs" );
1071
1072     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1073         SV ** const tmp = av_fetch( revcharmap, state, 0);
1074         if ( tmp ) {
1075             PerlIO_printf( Perl_debug_log, "%*s", 
1076                 colwidth,
1077                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1078                             PL_colors[0], PL_colors[1],
1079                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1080                             PERL_PV_ESCAPE_FIRSTCHAR 
1081                 ) 
1082             );
1083         }
1084     }
1085     PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
1086         (int)depth * 2 + 2,"");
1087
1088     for( state = 0 ; state < trie->uniquecharcount ; state++ )
1089         PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
1090     PerlIO_printf( Perl_debug_log, "\n");
1091
1092     for( state = 1 ; state < trie->statecount ; state++ ) {
1093         const U32 base = trie->states[ state ].trans.base;
1094
1095         PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state);
1096
1097         if ( trie->states[ state ].wordnum ) {
1098             PerlIO_printf( Perl_debug_log, " W%4X", trie->states[ state ].wordnum );
1099         } else {
1100             PerlIO_printf( Perl_debug_log, "%6s", "" );
1101         }
1102
1103         PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
1104
1105         if ( base ) {
1106             U32 ofs = 0;
1107
1108             while( ( base + ofs  < trie->uniquecharcount ) ||
1109                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
1110                      && trie->trans[ base + ofs - trie->uniquecharcount ].check != state))
1111                     ofs++;
1112
1113             PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
1114
1115             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
1116                 if ( ( base + ofs >= trie->uniquecharcount ) &&
1117                      ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
1118                      trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
1119                 {
1120                    PerlIO_printf( Perl_debug_log, "%*"UVXf,
1121                     colwidth,
1122                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
1123                 } else {
1124                     PerlIO_printf( Perl_debug_log, "%*s",colwidth,"   ." );
1125                 }
1126             }
1127
1128             PerlIO_printf( Perl_debug_log, "]");
1129
1130         }
1131         PerlIO_printf( Perl_debug_log, "\n" );
1132     }
1133     PerlIO_printf(Perl_debug_log, "%*sword_info N:(prev,len)=", (int)depth*2, "");
1134     for (word=1; word <= trie->wordcount; word++) {
1135         PerlIO_printf(Perl_debug_log, " %d:(%d,%d)",
1136             (int)word, (int)(trie->wordinfo[word].prev),
1137             (int)(trie->wordinfo[word].len));
1138     }
1139     PerlIO_printf(Perl_debug_log, "\n" );
1140 }    
1141 /*
1142   Dumps a fully constructed but uncompressed trie in list form.
1143   List tries normally only are used for construction when the number of 
1144   possible chars (trie->uniquecharcount) is very high.
1145   Used for debugging make_trie().
1146 */
1147 STATIC void
1148 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
1149                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
1150                          U32 depth)
1151 {
1152     U32 state;
1153     SV *sv=sv_newmortal();
1154     int colwidth= widecharmap ? 6 : 4;
1155     GET_RE_DEBUG_FLAGS_DECL;
1156
1157     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
1158
1159     /* print out the table precompression.  */
1160     PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
1161         (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
1162         "------:-----+-----------------\n" );
1163     
1164     for( state=1 ; state < next_alloc ; state ++ ) {
1165         U16 charid;
1166     
1167         PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
1168             (int)depth * 2 + 2,"", (UV)state  );
1169         if ( ! trie->states[ state ].wordnum ) {
1170             PerlIO_printf( Perl_debug_log, "%5s| ","");
1171         } else {
1172             PerlIO_printf( Perl_debug_log, "W%4x| ",
1173                 trie->states[ state ].wordnum
1174             );
1175         }
1176         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
1177             SV ** const tmp = av_fetch( revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
1178             if ( tmp ) {
1179                 PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
1180                     colwidth,
1181                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1182                             PL_colors[0], PL_colors[1],
1183                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1184                             PERL_PV_ESCAPE_FIRSTCHAR 
1185                     ) ,
1186                     TRIE_LIST_ITEM(state,charid).forid,
1187                     (UV)TRIE_LIST_ITEM(state,charid).newstate
1188                 );
1189                 if (!(charid % 10)) 
1190                     PerlIO_printf(Perl_debug_log, "\n%*s| ",
1191                         (int)((depth * 2) + 14), "");
1192             }
1193         }
1194         PerlIO_printf( Perl_debug_log, "\n");
1195     }
1196 }    
1197
1198 /*
1199   Dumps a fully constructed but uncompressed trie in table form.
1200   This is the normal DFA style state transition table, with a few 
1201   twists to facilitate compression later. 
1202   Used for debugging make_trie().
1203 */
1204 STATIC void
1205 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
1206                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
1207                           U32 depth)
1208 {
1209     U32 state;
1210     U16 charid;
1211     SV *sv=sv_newmortal();
1212     int colwidth= widecharmap ? 6 : 4;
1213     GET_RE_DEBUG_FLAGS_DECL;
1214
1215     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
1216     
1217     /*
1218        print out the table precompression so that we can do a visual check
1219        that they are identical.
1220      */
1221     
1222     PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
1223
1224     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1225         SV ** const tmp = av_fetch( revcharmap, charid, 0);
1226         if ( tmp ) {
1227             PerlIO_printf( Perl_debug_log, "%*s", 
1228                 colwidth,
1229                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1230                             PL_colors[0], PL_colors[1],
1231                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1232                             PERL_PV_ESCAPE_FIRSTCHAR 
1233                 ) 
1234             );
1235         }
1236     }
1237
1238     PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
1239
1240     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
1241         PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
1242     }
1243
1244     PerlIO_printf( Perl_debug_log, "\n" );
1245
1246     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
1247
1248         PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ", 
1249             (int)depth * 2 + 2,"",
1250             (UV)TRIE_NODENUM( state ) );
1251
1252         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1253             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
1254             if (v)
1255                 PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
1256             else
1257                 PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
1258         }
1259         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1260             PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check );
1261         } else {
1262             PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n", (UV)trie->trans[ state ].check,
1263             trie->states[ TRIE_NODENUM( state ) ].wordnum );
1264         }
1265     }
1266 }
1267
1268 #endif
1269
1270
1271 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
1272   startbranch: the first branch in the whole branch sequence
1273   first      : start branch of sequence of branch-exact nodes.
1274                May be the same as startbranch
1275   last       : Thing following the last branch.
1276                May be the same as tail.
1277   tail       : item following the branch sequence
1278   count      : words in the sequence
1279   flags      : currently the OP() type we will be building one of /EXACT(|F|Fl)/
1280   depth      : indent depth
1281
1282 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
1283
1284 A trie is an N'ary tree where the branches are determined by digital
1285 decomposition of the key. IE, at the root node you look up the 1st character and
1286 follow that branch repeat until you find the end of the branches. Nodes can be
1287 marked as "accepting" meaning they represent a complete word. Eg:
1288
1289   /he|she|his|hers/
1290
1291 would convert into the following structure. Numbers represent states, letters
1292 following numbers represent valid transitions on the letter from that state, if
1293 the number is in square brackets it represents an accepting state, otherwise it
1294 will be in parenthesis.
1295
1296       +-h->+-e->[3]-+-r->(8)-+-s->[9]
1297       |    |
1298       |   (2)
1299       |    |
1300      (1)   +-i->(6)-+-s->[7]
1301       |
1302       +-s->(3)-+-h->(4)-+-e->[5]
1303
1304       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
1305
1306 This shows that when matching against the string 'hers' we will begin at state 1
1307 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
1308 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
1309 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
1310 single traverse. We store a mapping from accepting to state to which word was
1311 matched, and then when we have multiple possibilities we try to complete the
1312 rest of the regex in the order in which they occured in the alternation.
1313
1314 The only prior NFA like behaviour that would be changed by the TRIE support is
1315 the silent ignoring of duplicate alternations which are of the form:
1316
1317  / (DUPE|DUPE) X? (?{ ... }) Y /x
1318
1319 Thus EVAL blocks following a trie may be called a different number of times with
1320 and without the optimisation. With the optimisations dupes will be silently
1321 ignored. This inconsistent behaviour of EVAL type nodes is well established as
1322 the following demonstrates:
1323
1324  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
1325
1326 which prints out 'word' three times, but
1327
1328  'words'=~/(word|word|word)(?{ print $1 })S/
1329
1330 which doesnt print it out at all. This is due to other optimisations kicking in.
1331
1332 Example of what happens on a structural level:
1333
1334 The regexp /(ac|ad|ab)+/ will produce the following debug output:
1335
1336    1: CURLYM[1] {1,32767}(18)
1337    5:   BRANCH(8)
1338    6:     EXACT <ac>(16)
1339    8:   BRANCH(11)
1340    9:     EXACT <ad>(16)
1341   11:   BRANCH(14)
1342   12:     EXACT <ab>(16)
1343   16:   SUCCEED(0)
1344   17:   NOTHING(18)
1345   18: END(0)
1346
1347 This would be optimizable with startbranch=5, first=5, last=16, tail=16
1348 and should turn into:
1349
1350    1: CURLYM[1] {1,32767}(18)
1351    5:   TRIE(16)
1352         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
1353           <ac>
1354           <ad>
1355           <ab>
1356   16:   SUCCEED(0)
1357   17:   NOTHING(18)
1358   18: END(0)
1359
1360 Cases where tail != last would be like /(?foo|bar)baz/:
1361
1362    1: BRANCH(4)
1363    2:   EXACT <foo>(8)
1364    4: BRANCH(7)
1365    5:   EXACT <bar>(8)
1366    7: TAIL(8)
1367    8: EXACT <baz>(10)
1368   10: END(0)
1369
1370 which would be optimizable with startbranch=1, first=1, last=7, tail=8
1371 and would end up looking like:
1372
1373     1: TRIE(8)
1374       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
1375         <foo>
1376         <bar>
1377    7: TAIL(8)
1378    8: EXACT <baz>(10)
1379   10: END(0)
1380
1381     d = uvuni_to_utf8_flags(d, uv, 0);
1382
1383 is the recommended Unicode-aware way of saying
1384
1385     *(d++) = uv;
1386 */
1387
1388 #define TRIE_STORE_REVCHAR(val)                                            \
1389     STMT_START {                                                           \
1390         if (UTF) {                                                         \
1391             SV *zlopp = newSV(7); /* XXX: optimize me */                   \
1392             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
1393             unsigned const char *const kapow = uvuni_to_utf8(flrbbbbb, val); \
1394             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
1395             SvPOK_on(zlopp);                                               \
1396             SvUTF8_on(zlopp);                                              \
1397             av_push(revcharmap, zlopp);                                    \
1398         } else {                                                           \
1399             char ooooff = (char)val;                                           \
1400             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
1401         }                                                                  \
1402         } STMT_END
1403
1404 #define TRIE_READ_CHAR STMT_START {                                                     \
1405     wordlen++;                                                                          \
1406     if ( UTF ) {                                                                        \
1407         /* if it is UTF then it is either already folded, or does not need folding */   \
1408         uvc = utf8n_to_uvuni( (const U8*) uc, UTF8_MAXLEN, &len, uniflags);             \
1409     }                                                                                   \
1410     else if (folder == PL_fold_latin1) {                                                \
1411         /* if we use this folder we have to obey unicode rules on latin-1 data */       \
1412         if ( foldlen > 0 ) {                                                            \
1413            uvc = utf8n_to_uvuni( (const U8*) scan, UTF8_MAXLEN, &len, uniflags );       \
1414            foldlen -= len;                                                              \
1415            scan += len;                                                                 \
1416            len = 0;                                                                     \
1417         } else {                                                                        \
1418             len = 1;                                                                    \
1419             uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, 1);                     \
1420             skiplen = UNISKIP(uvc);                                                     \
1421             foldlen -= skiplen;                                                         \
1422             scan = foldbuf + skiplen;                                                   \
1423         }                                                                               \
1424     } else {                                                                            \
1425         /* raw data, will be folded later if needed */                                  \
1426         uvc = (U32)*uc;                                                                 \
1427         len = 1;                                                                        \
1428     }                                                                                   \
1429 } STMT_END
1430
1431
1432
1433 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
1434     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
1435         U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
1436         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
1437     }                                                           \
1438     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
1439     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
1440     TRIE_LIST_CUR( state )++;                                   \
1441 } STMT_END
1442
1443 #define TRIE_LIST_NEW(state) STMT_START {                       \
1444     Newxz( trie->states[ state ].trans.list,               \
1445         4, reg_trie_trans_le );                                 \
1446      TRIE_LIST_CUR( state ) = 1;                                \
1447      TRIE_LIST_LEN( state ) = 4;                                \
1448 } STMT_END
1449
1450 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
1451     U16 dupe= trie->states[ state ].wordnum;                    \
1452     regnode * const noper_next = regnext( noper );              \
1453                                                                 \
1454     DEBUG_r({                                                   \
1455         /* store the word for dumping */                        \
1456         SV* tmp;                                                \
1457         if (OP(noper) != NOTHING)                               \
1458             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
1459         else                                                    \
1460             tmp = newSVpvn_utf8( "", 0, UTF );                  \
1461         av_push( trie_words, tmp );                             \
1462     });                                                         \
1463                                                                 \
1464     curword++;                                                  \
1465     trie->wordinfo[curword].prev   = 0;                         \
1466     trie->wordinfo[curword].len    = wordlen;                   \
1467     trie->wordinfo[curword].accept = state;                     \
1468                                                                 \
1469     if ( noper_next < tail ) {                                  \
1470         if (!trie->jump)                                        \
1471             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, sizeof(U16) ); \
1472         trie->jump[curword] = (U16)(noper_next - convert);      \
1473         if (!jumper)                                            \
1474             jumper = noper_next;                                \
1475         if (!nextbranch)                                        \
1476             nextbranch= regnext(cur);                           \
1477     }                                                           \
1478                                                                 \
1479     if ( dupe ) {                                               \
1480         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
1481         /* chain, so that when the bits of chain are later    */\
1482         /* linked together, the dups appear in the chain      */\
1483         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
1484         trie->wordinfo[dupe].prev = curword;                    \
1485     } else {                                                    \
1486         /* we haven't inserted this word yet.                */ \
1487         trie->states[ state ].wordnum = curword;                \
1488     }                                                           \
1489 } STMT_END
1490
1491
1492 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
1493      ( ( base + charid >=  ucharcount                                   \
1494          && base + charid < ubound                                      \
1495          && state == trie->trans[ base - ucharcount + charid ].check    \
1496          && trie->trans[ base - ucharcount + charid ].next )            \
1497            ? trie->trans[ base - ucharcount + charid ].next             \
1498            : ( state==1 ? special : 0 )                                 \
1499       )
1500
1501 #define MADE_TRIE       1
1502 #define MADE_JUMP_TRIE  2
1503 #define MADE_EXACT_TRIE 4
1504
1505 STATIC I32
1506 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth)
1507 {
1508     dVAR;
1509     /* first pass, loop through and scan words */
1510     reg_trie_data *trie;
1511     HV *widecharmap = NULL;
1512     AV *revcharmap = newAV();
1513     regnode *cur;
1514     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1515     STRLEN len = 0;
1516     UV uvc = 0;
1517     U16 curword = 0;
1518     U32 next_alloc = 0;
1519     regnode *jumper = NULL;
1520     regnode *nextbranch = NULL;
1521     regnode *convert = NULL;
1522     U32 *prev_states; /* temp array mapping each state to previous one */
1523     /* we just use folder as a flag in utf8 */
1524     const U8 * folder = NULL;
1525
1526 #ifdef DEBUGGING
1527     const U32 data_slot = add_data( pRExC_state, 4, "tuuu" );
1528     AV *trie_words = NULL;
1529     /* along with revcharmap, this only used during construction but both are
1530      * useful during debugging so we store them in the struct when debugging.
1531      */
1532 #else
1533     const U32 data_slot = add_data( pRExC_state, 2, "tu" );
1534     STRLEN trie_charcount=0;
1535 #endif
1536     SV *re_trie_maxbuff;
1537     GET_RE_DEBUG_FLAGS_DECL;
1538
1539     PERL_ARGS_ASSERT_MAKE_TRIE;
1540 #ifndef DEBUGGING
1541     PERL_UNUSED_ARG(depth);
1542 #endif
1543
1544     switch (flags) {
1545         case EXACT: break;
1546         case EXACTFA:
1547         case EXACTFU_SS:
1548         case EXACTFU_TRICKYFOLD:
1549         case EXACTFU: folder = PL_fold_latin1; break;
1550         case EXACTF:  folder = PL_fold; break;
1551         case EXACTFL: folder = PL_fold_locale; break;
1552         default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
1553     }
1554
1555     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
1556     trie->refcount = 1;
1557     trie->startstate = 1;
1558     trie->wordcount = word_count;
1559     RExC_rxi->data->data[ data_slot ] = (void*)trie;
1560     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
1561     if (flags == EXACT)
1562         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
1563     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
1564                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
1565
1566     DEBUG_r({
1567         trie_words = newAV();
1568     });
1569
1570     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
1571     if (!SvIOK(re_trie_maxbuff)) {
1572         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
1573     }
1574     DEBUG_TRIE_COMPILE_r({
1575                 PerlIO_printf( Perl_debug_log,
1576                   "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
1577                   (int)depth * 2 + 2, "", 
1578                   REG_NODE_NUM(startbranch),REG_NODE_NUM(first), 
1579                   REG_NODE_NUM(last), REG_NODE_NUM(tail),
1580                   (int)depth);
1581     });
1582    
1583    /* Find the node we are going to overwrite */
1584     if ( first == startbranch && OP( last ) != BRANCH ) {
1585         /* whole branch chain */
1586         convert = first;
1587     } else {
1588         /* branch sub-chain */
1589         convert = NEXTOPER( first );
1590     }
1591         
1592     /*  -- First loop and Setup --
1593
1594        We first traverse the branches and scan each word to determine if it
1595        contains widechars, and how many unique chars there are, this is
1596        important as we have to build a table with at least as many columns as we
1597        have unique chars.
1598
1599        We use an array of integers to represent the character codes 0..255
1600        (trie->charmap) and we use a an HV* to store Unicode characters. We use the
1601        native representation of the character value as the key and IV's for the
1602        coded index.
1603
1604        *TODO* If we keep track of how many times each character is used we can
1605        remap the columns so that the table compression later on is more
1606        efficient in terms of memory by ensuring the most common value is in the
1607        middle and the least common are on the outside.  IMO this would be better
1608        than a most to least common mapping as theres a decent chance the most
1609        common letter will share a node with the least common, meaning the node
1610        will not be compressible. With a middle is most common approach the worst
1611        case is when we have the least common nodes twice.
1612
1613      */
1614
1615     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1616         regnode *noper = NEXTOPER( cur );
1617         const U8 *uc = (U8*)STRING( noper );
1618         const U8 *e  = uc + STR_LEN( noper );
1619         STRLEN foldlen = 0;
1620         U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1621         STRLEN skiplen = 0;
1622         const U8 *scan = (U8*)NULL;
1623         U32 wordlen      = 0;         /* required init */
1624         STRLEN chars = 0;
1625         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the bitmap?*/
1626
1627         if (OP(noper) == NOTHING) {
1628             regnode *noper_next= regnext(noper);
1629             if (noper_next != tail && OP(noper_next) == flags) {
1630                 noper = noper_next;
1631                 uc= (U8*)STRING(noper);
1632                 e= uc + STR_LEN(noper);
1633                 trie->minlen= STR_LEN(noper);
1634             } else {
1635                 trie->minlen= 0;
1636                 continue;
1637             }
1638         }
1639
1640         if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
1641             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
1642                                           regardless of encoding */
1643             if (OP( noper ) == EXACTFU_SS) {
1644                 /* false positives are ok, so just set this */
1645                 TRIE_BITMAP_SET(trie,0xDF);
1646             }
1647         }
1648         for ( ; uc < e ; uc += len ) {
1649             TRIE_CHARCOUNT(trie)++;
1650             TRIE_READ_CHAR;
1651             chars++;
1652             if ( uvc < 256 ) {
1653                 if ( folder ) {
1654                     U8 folded= folder[ (U8) uvc ];
1655                     if ( !trie->charmap[ folded ] ) {
1656                         trie->charmap[ folded ]=( ++trie->uniquecharcount );
1657                         TRIE_STORE_REVCHAR( folded );
1658                     }
1659                 }
1660                 if ( !trie->charmap[ uvc ] ) {
1661                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
1662                     TRIE_STORE_REVCHAR( uvc );
1663                 }
1664                 if ( set_bit ) {
1665                     /* store the codepoint in the bitmap, and its folded
1666                      * equivalent. */
1667                     TRIE_BITMAP_SET(trie, uvc);
1668
1669                     /* store the folded codepoint */
1670                     if ( folder ) TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);
1671
1672                     if ( !UTF ) {
1673                         /* store first byte of utf8 representation of
1674                            variant codepoints */
1675                         if (! UNI_IS_INVARIANT(uvc)) {
1676                             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));
1677                         }
1678                     }
1679                     set_bit = 0; /* We've done our bit :-) */
1680                 }
1681             } else {
1682                 SV** svpp;
1683                 if ( !widecharmap )
1684                     widecharmap = newHV();
1685
1686                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
1687
1688                 if ( !svpp )
1689                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
1690
1691                 if ( !SvTRUE( *svpp ) ) {
1692                     sv_setiv( *svpp, ++trie->uniquecharcount );
1693                     TRIE_STORE_REVCHAR(uvc);
1694                 }
1695             }
1696         }
1697         if( cur == first ) {
1698             trie->minlen = chars;
1699             trie->maxlen = chars;
1700         } else if (chars < trie->minlen) {
1701             trie->minlen = chars;
1702         } else if (chars > trie->maxlen) {
1703             trie->maxlen = chars;
1704         }
1705         if (OP( noper ) == EXACTFU_SS) {
1706             /* XXX: workaround - 'ss' could match "\x{DF}" so minlen could be 1 and not 2*/
1707             if (trie->minlen > 1)
1708                 trie->minlen= 1;
1709         }
1710         if (OP( noper ) == EXACTFU_TRICKYFOLD) {
1711             /* XXX: workround - things like "\x{1FBE}\x{0308}\x{0301}" can match "\x{0390}" 
1712              *                - We assume that any such sequence might match a 2 byte string */
1713             if (trie->minlen > 2 )
1714                 trie->minlen= 2;
1715         }
1716
1717     } /* end first pass */
1718     DEBUG_TRIE_COMPILE_r(
1719         PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
1720                 (int)depth * 2 + 2,"",
1721                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
1722                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
1723                 (int)trie->minlen, (int)trie->maxlen )
1724     );
1725
1726     /*
1727         We now know what we are dealing with in terms of unique chars and
1728         string sizes so we can calculate how much memory a naive
1729         representation using a flat table  will take. If it's over a reasonable
1730         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
1731         conservative but potentially much slower representation using an array
1732         of lists.
1733
1734         At the end we convert both representations into the same compressed
1735         form that will be used in regexec.c for matching with. The latter
1736         is a form that cannot be used to construct with but has memory
1737         properties similar to the list form and access properties similar
1738         to the table form making it both suitable for fast searches and
1739         small enough that its feasable to store for the duration of a program.
1740
1741         See the comment in the code where the compressed table is produced
1742         inplace from the flat tabe representation for an explanation of how
1743         the compression works.
1744
1745     */
1746
1747
1748     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
1749     prev_states[1] = 0;
1750
1751     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1) > SvIV(re_trie_maxbuff) ) {
1752         /*
1753             Second Pass -- Array Of Lists Representation
1754
1755             Each state will be represented by a list of charid:state records
1756             (reg_trie_trans_le) the first such element holds the CUR and LEN
1757             points of the allocated array. (See defines above).
1758
1759             We build the initial structure using the lists, and then convert
1760             it into the compressed table form which allows faster lookups
1761             (but cant be modified once converted).
1762         */
1763
1764         STRLEN transcount = 1;
1765
1766         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
1767             "%*sCompiling trie using list compiler\n",
1768             (int)depth * 2 + 2, ""));
1769
1770         trie->states = (reg_trie_state *)
1771             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1772                                   sizeof(reg_trie_state) );
1773         TRIE_LIST_NEW(1);
1774         next_alloc = 2;
1775
1776         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1777
1778             regnode *noper   = NEXTOPER( cur );
1779             U8 *uc           = (U8*)STRING( noper );
1780             const U8 *e      = uc + STR_LEN( noper );
1781             U32 state        = 1;         /* required init */
1782             U16 charid       = 0;         /* sanity init */
1783             U8 *scan         = (U8*)NULL; /* sanity init */
1784             STRLEN foldlen   = 0;         /* required init */
1785             U32 wordlen      = 0;         /* required init */
1786             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1787             STRLEN skiplen   = 0;
1788
1789             if (OP(noper) == NOTHING) {
1790                 regnode *noper_next= regnext(noper);
1791                 if (noper_next != tail && OP(noper_next) == flags) {
1792                     noper = noper_next;
1793                     uc= (U8*)STRING(noper);
1794                     e= uc + STR_LEN(noper);
1795                 }
1796             }
1797
1798             if (OP(noper) != NOTHING) {
1799                 for ( ; uc < e ; uc += len ) {
1800
1801                     TRIE_READ_CHAR;
1802
1803                     if ( uvc < 256 ) {
1804                         charid = trie->charmap[ uvc ];
1805                     } else {
1806                         SV** const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1807                         if ( !svpp ) {
1808                             charid = 0;
1809                         } else {
1810                             charid=(U16)SvIV( *svpp );
1811                         }
1812                     }
1813                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
1814                     if ( charid ) {
1815
1816                         U16 check;
1817                         U32 newstate = 0;
1818
1819                         charid--;
1820                         if ( !trie->states[ state ].trans.list ) {
1821                             TRIE_LIST_NEW( state );
1822                         }
1823                         for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) {
1824                             if ( TRIE_LIST_ITEM( state, check ).forid == charid ) {
1825                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
1826                                 break;
1827                             }
1828                         }
1829                         if ( ! newstate ) {
1830                             newstate = next_alloc++;
1831                             prev_states[newstate] = state;
1832                             TRIE_LIST_PUSH( state, charid, newstate );
1833                             transcount++;
1834                         }
1835                         state = newstate;
1836                     } else {
1837                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1838                     }
1839                 }
1840             }
1841             TRIE_HANDLE_WORD(state);
1842
1843         } /* end second pass */
1844
1845         /* next alloc is the NEXT state to be allocated */
1846         trie->statecount = next_alloc; 
1847         trie->states = (reg_trie_state *)
1848             PerlMemShared_realloc( trie->states,
1849                                    next_alloc
1850                                    * sizeof(reg_trie_state) );
1851
1852         /* and now dump it out before we compress it */
1853         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
1854                                                          revcharmap, next_alloc,
1855                                                          depth+1)
1856         );
1857
1858         trie->trans = (reg_trie_trans *)
1859             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
1860         {
1861             U32 state;
1862             U32 tp = 0;
1863             U32 zp = 0;
1864
1865
1866             for( state=1 ; state < next_alloc ; state ++ ) {
1867                 U32 base=0;
1868
1869                 /*
1870                 DEBUG_TRIE_COMPILE_MORE_r(
1871                     PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
1872                 );
1873                 */
1874
1875                 if (trie->states[state].trans.list) {
1876                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
1877                     U16 maxid=minid;
1878                     U16 idx;
1879
1880                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1881                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
1882                         if ( forid < minid ) {
1883                             minid=forid;
1884                         } else if ( forid > maxid ) {
1885                             maxid=forid;
1886                         }
1887                     }
1888                     if ( transcount < tp + maxid - minid + 1) {
1889                         transcount *= 2;
1890                         trie->trans = (reg_trie_trans *)
1891                             PerlMemShared_realloc( trie->trans,
1892                                                      transcount
1893                                                      * sizeof(reg_trie_trans) );
1894                         Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans );
1895                     }
1896                     base = trie->uniquecharcount + tp - minid;
1897                     if ( maxid == minid ) {
1898                         U32 set = 0;
1899                         for ( ; zp < tp ; zp++ ) {
1900                             if ( ! trie->trans[ zp ].next ) {
1901                                 base = trie->uniquecharcount + zp - minid;
1902                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1903                                 trie->trans[ zp ].check = state;
1904                                 set = 1;
1905                                 break;
1906                             }
1907                         }
1908                         if ( !set ) {
1909                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1910                             trie->trans[ tp ].check = state;
1911                             tp++;
1912                             zp = tp;
1913                         }
1914                     } else {
1915                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1916                             const U32 tid = base -  trie->uniquecharcount + TRIE_LIST_ITEM( state, idx ).forid;
1917                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state, idx ).newstate;
1918                             trie->trans[ tid ].check = state;
1919                         }
1920                         tp += ( maxid - minid + 1 );
1921                     }
1922                     Safefree(trie->states[ state ].trans.list);
1923                 }
1924                 /*
1925                 DEBUG_TRIE_COMPILE_MORE_r(
1926                     PerlIO_printf( Perl_debug_log, " base: %d\n",base);
1927                 );
1928                 */
1929                 trie->states[ state ].trans.base=base;
1930             }
1931             trie->lasttrans = tp + 1;
1932         }
1933     } else {
1934         /*
1935            Second Pass -- Flat Table Representation.
1936
1937            we dont use the 0 slot of either trans[] or states[] so we add 1 to each.
1938            We know that we will need Charcount+1 trans at most to store the data
1939            (one row per char at worst case) So we preallocate both structures
1940            assuming worst case.
1941
1942            We then construct the trie using only the .next slots of the entry
1943            structs.
1944
1945            We use the .check field of the first entry of the node temporarily to
1946            make compression both faster and easier by keeping track of how many non
1947            zero fields are in the node.
1948
1949            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
1950            transition.
1951
1952            There are two terms at use here: state as a TRIE_NODEIDX() which is a
1953            number representing the first entry of the node, and state as a
1954            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1) and
1955            TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3) if there
1956            are 2 entrys per node. eg:
1957
1958              A B       A B
1959           1. 2 4    1. 3 7
1960           2. 0 3    3. 0 5
1961           3. 0 0    5. 0 0
1962           4. 0 0    7. 0 0
1963
1964            The table is internally in the right hand, idx form. However as we also
1965            have to deal with the states array which is indexed by nodenum we have to
1966            use TRIE_NODENUM() to convert.
1967
1968         */
1969         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
1970             "%*sCompiling trie using table compiler\n",
1971             (int)depth * 2 + 2, ""));
1972
1973         trie->trans = (reg_trie_trans *)
1974             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
1975                                   * trie->uniquecharcount + 1,
1976                                   sizeof(reg_trie_trans) );
1977         trie->states = (reg_trie_state *)
1978             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1979                                   sizeof(reg_trie_state) );
1980         next_alloc = trie->uniquecharcount + 1;
1981
1982
1983         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1984
1985             regnode *noper   = NEXTOPER( cur );
1986             const U8 *uc     = (U8*)STRING( noper );
1987             const U8 *e      = uc + STR_LEN( noper );
1988
1989             U32 state        = 1;         /* required init */
1990
1991             U16 charid       = 0;         /* sanity init */
1992             U32 accept_state = 0;         /* sanity init */
1993             U8 *scan         = (U8*)NULL; /* sanity init */
1994
1995             STRLEN foldlen   = 0;         /* required init */
1996             U32 wordlen      = 0;         /* required init */
1997             STRLEN skiplen   = 0;
1998             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1999
2000             if (OP(noper) == NOTHING) {
2001                 regnode *noper_next= regnext(noper);
2002                 if (noper_next != tail && OP(noper_next) == flags) {
2003                     noper = noper_next;
2004                     uc= (U8*)STRING(noper);
2005                     e= uc + STR_LEN(noper);
2006                 }
2007             }
2008
2009             if ( OP(noper) != NOTHING ) {
2010                 for ( ; uc < e ; uc += len ) {
2011
2012                     TRIE_READ_CHAR;
2013
2014                     if ( uvc < 256 ) {
2015                         charid = trie->charmap[ uvc ];
2016                     } else {
2017                         SV* const * const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
2018                         charid = svpp ? (U16)SvIV(*svpp) : 0;
2019                     }
2020                     if ( charid ) {
2021                         charid--;
2022                         if ( !trie->trans[ state + charid ].next ) {
2023                             trie->trans[ state + charid ].next = next_alloc;
2024                             trie->trans[ state ].check++;
2025                             prev_states[TRIE_NODENUM(next_alloc)]
2026                                     = TRIE_NODENUM(state);
2027                             next_alloc += trie->uniquecharcount;
2028                         }
2029                         state = trie->trans[ state + charid ].next;
2030                     } else {
2031                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
2032                     }
2033                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
2034                 }
2035             }
2036             accept_state = TRIE_NODENUM( state );
2037             TRIE_HANDLE_WORD(accept_state);
2038
2039         } /* end second pass */
2040
2041         /* and now dump it out before we compress it */
2042         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
2043                                                           revcharmap,
2044                                                           next_alloc, depth+1));
2045
2046         {
2047         /*
2048            * Inplace compress the table.*
2049
2050            For sparse data sets the table constructed by the trie algorithm will
2051            be mostly 0/FAIL transitions or to put it another way mostly empty.
2052            (Note that leaf nodes will not contain any transitions.)
2053
2054            This algorithm compresses the tables by eliminating most such
2055            transitions, at the cost of a modest bit of extra work during lookup:
2056
2057            - Each states[] entry contains a .base field which indicates the
2058            index in the state[] array wheres its transition data is stored.
2059
2060            - If .base is 0 there are no valid transitions from that node.
2061
2062            - If .base is nonzero then charid is added to it to find an entry in
2063            the trans array.
2064
2065            -If trans[states[state].base+charid].check!=state then the
2066            transition is taken to be a 0/Fail transition. Thus if there are fail
2067            transitions at the front of the node then the .base offset will point
2068            somewhere inside the previous nodes data (or maybe even into a node
2069            even earlier), but the .check field determines if the transition is
2070            valid.
2071
2072            XXX - wrong maybe?
2073            The following process inplace converts the table to the compressed
2074            table: We first do not compress the root node 1,and mark all its
2075            .check pointers as 1 and set its .base pointer as 1 as well. This
2076            allows us to do a DFA construction from the compressed table later,
2077            and ensures that any .base pointers we calculate later are greater
2078            than 0.
2079
2080            - We set 'pos' to indicate the first entry of the second node.
2081
2082            - We then iterate over the columns of the node, finding the first and
2083            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
2084            and set the .check pointers accordingly, and advance pos
2085            appropriately and repreat for the next node. Note that when we copy
2086            the next pointers we have to convert them from the original
2087            NODEIDX form to NODENUM form as the former is not valid post
2088            compression.
2089
2090            - If a node has no transitions used we mark its base as 0 and do not
2091            advance the pos pointer.
2092
2093            - If a node only has one transition we use a second pointer into the
2094            structure to fill in allocated fail transitions from other states.
2095            This pointer is independent of the main pointer and scans forward
2096            looking for null transitions that are allocated to a state. When it
2097            finds one it writes the single transition into the "hole".  If the
2098            pointer doesnt find one the single transition is appended as normal.
2099
2100            - Once compressed we can Renew/realloc the structures to release the
2101            excess space.
2102
2103            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
2104            specifically Fig 3.47 and the associated pseudocode.
2105
2106            demq
2107         */
2108         const U32 laststate = TRIE_NODENUM( next_alloc );
2109         U32 state, charid;
2110         U32 pos = 0, zp=0;
2111         trie->statecount = laststate;
2112
2113         for ( state = 1 ; state < laststate ; state++ ) {
2114             U8 flag = 0;
2115             const U32 stateidx = TRIE_NODEIDX( state );
2116             const U32 o_used = trie->trans[ stateidx ].check;
2117             U32 used = trie->trans[ stateidx ].check;
2118             trie->trans[ stateidx ].check = 0;
2119
2120             for ( charid = 0 ; used && charid < trie->uniquecharcount ; charid++ ) {
2121                 if ( flag || trie->trans[ stateidx + charid ].next ) {
2122                     if ( trie->trans[ stateidx + charid ].next ) {
2123                         if (o_used == 1) {
2124                             for ( ; zp < pos ; zp++ ) {
2125                                 if ( ! trie->trans[ zp ].next ) {
2126                                     break;
2127                                 }
2128                             }
2129                             trie->states[ state ].trans.base = zp + trie->uniquecharcount - charid ;
2130                             trie->trans[ zp ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2131                             trie->trans[ zp ].check = state;
2132                             if ( ++zp > pos ) pos = zp;
2133                             break;
2134                         }
2135                         used--;
2136                     }
2137                     if ( !flag ) {
2138                         flag = 1;
2139                         trie->states[ state ].trans.base = pos + trie->uniquecharcount - charid ;
2140                     }
2141                     trie->trans[ pos ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2142                     trie->trans[ pos ].check = state;
2143                     pos++;
2144                 }
2145             }
2146         }
2147         trie->lasttrans = pos + 1;
2148         trie->states = (reg_trie_state *)
2149             PerlMemShared_realloc( trie->states, laststate
2150                                    * sizeof(reg_trie_state) );
2151         DEBUG_TRIE_COMPILE_MORE_r(
2152                 PerlIO_printf( Perl_debug_log,
2153                     "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
2154                     (int)depth * 2 + 2,"",
2155                     (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1 ),
2156                     (IV)next_alloc,
2157                     (IV)pos,
2158                     ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
2159             );
2160
2161         } /* end table compress */
2162     }
2163     DEBUG_TRIE_COMPILE_MORE_r(
2164             PerlIO_printf(Perl_debug_log, "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
2165                 (int)depth * 2 + 2, "",
2166                 (UV)trie->statecount,
2167                 (UV)trie->lasttrans)
2168     );
2169     /* resize the trans array to remove unused space */
2170     trie->trans = (reg_trie_trans *)
2171         PerlMemShared_realloc( trie->trans, trie->lasttrans
2172                                * sizeof(reg_trie_trans) );
2173
2174     {   /* Modify the program and insert the new TRIE node */ 
2175         U8 nodetype =(U8)(flags & 0xFF);
2176         char *str=NULL;
2177         
2178 #ifdef DEBUGGING
2179         regnode *optimize = NULL;
2180 #ifdef RE_TRACK_PATTERN_OFFSETS
2181
2182         U32 mjd_offset = 0;
2183         U32 mjd_nodelen = 0;
2184 #endif /* RE_TRACK_PATTERN_OFFSETS */
2185 #endif /* DEBUGGING */
2186         /*
2187            This means we convert either the first branch or the first Exact,
2188            depending on whether the thing following (in 'last') is a branch
2189            or not and whther first is the startbranch (ie is it a sub part of
2190            the alternation or is it the whole thing.)
2191            Assuming its a sub part we convert the EXACT otherwise we convert
2192            the whole branch sequence, including the first.
2193          */
2194         /* Find the node we are going to overwrite */
2195         if ( first != startbranch || OP( last ) == BRANCH ) {
2196             /* branch sub-chain */
2197             NEXT_OFF( first ) = (U16)(last - first);
2198 #ifdef RE_TRACK_PATTERN_OFFSETS
2199             DEBUG_r({
2200                 mjd_offset= Node_Offset((convert));
2201                 mjd_nodelen= Node_Length((convert));
2202             });
2203 #endif
2204             /* whole branch chain */
2205         }
2206 #ifdef RE_TRACK_PATTERN_OFFSETS
2207         else {
2208             DEBUG_r({
2209                 const  regnode *nop = NEXTOPER( convert );
2210                 mjd_offset= Node_Offset((nop));
2211                 mjd_nodelen= Node_Length((nop));
2212             });
2213         }
2214         DEBUG_OPTIMISE_r(
2215             PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
2216                 (int)depth * 2 + 2, "",
2217                 (UV)mjd_offset, (UV)mjd_nodelen)
2218         );
2219 #endif
2220         /* But first we check to see if there is a common prefix we can 
2221            split out as an EXACT and put in front of the TRIE node.  */
2222         trie->startstate= 1;
2223         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
2224             U32 state;
2225             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
2226                 U32 ofs = 0;
2227                 I32 idx = -1;
2228                 U32 count = 0;
2229                 const U32 base = trie->states[ state ].trans.base;
2230
2231                 if ( trie->states[state].wordnum )
2232                         count = 1;
2233
2234                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2235                     if ( ( base + ofs >= trie->uniquecharcount ) &&
2236                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
2237                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
2238                     {
2239                         if ( ++count > 1 ) {
2240                             SV **tmp = av_fetch( revcharmap, ofs, 0);
2241                             const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
2242                             if ( state == 1 ) break;
2243                             if ( count == 2 ) {
2244                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
2245                                 DEBUG_OPTIMISE_r(
2246                                     PerlIO_printf(Perl_debug_log,
2247                                         "%*sNew Start State=%"UVuf" Class: [",
2248                                         (int)depth * 2 + 2, "",
2249                                         (UV)state));
2250                                 if (idx >= 0) {
2251                                     SV ** const tmp = av_fetch( revcharmap, idx, 0);
2252                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
2253
2254                                     TRIE_BITMAP_SET(trie,*ch);
2255                                     if ( folder )
2256                                         TRIE_BITMAP_SET(trie, folder[ *ch ]);
2257                                     DEBUG_OPTIMISE_r(
2258                                         PerlIO_printf(Perl_debug_log, "%s", (char*)ch)
2259                                     );
2260                                 }
2261                             }
2262                             TRIE_BITMAP_SET(trie,*ch);
2263                             if ( folder )
2264                                 TRIE_BITMAP_SET(trie,folder[ *ch ]);
2265                             DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
2266                         }
2267                         idx = ofs;
2268                     }
2269                 }
2270                 if ( count == 1 ) {
2271                     SV **tmp = av_fetch( revcharmap, idx, 0);
2272                     STRLEN len;
2273                     char *ch = SvPV( *tmp, len );
2274                     DEBUG_OPTIMISE_r({
2275                         SV *sv=sv_newmortal();
2276                         PerlIO_printf( Perl_debug_log,
2277                             "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
2278                             (int)depth * 2 + 2, "",
2279                             (UV)state, (UV)idx, 
2280                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6, 
2281                                 PL_colors[0], PL_colors[1],
2282                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2283                                 PERL_PV_ESCAPE_FIRSTCHAR 
2284                             )
2285                         );
2286                     });
2287                     if ( state==1 ) {
2288                         OP( convert ) = nodetype;
2289                         str=STRING(convert);
2290                         STR_LEN(convert)=0;
2291                     }
2292                     STR_LEN(convert) += len;
2293                     while (len--)
2294                         *str++ = *ch++;
2295                 } else {
2296 #ifdef DEBUGGING            
2297                     if (state>1)
2298                         DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
2299 #endif
2300                     break;
2301                 }
2302             }
2303             trie->prefixlen = (state-1);
2304             if (str) {
2305                 regnode *n = convert+NODE_SZ_STR(convert);
2306                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
2307                 trie->startstate = state;
2308                 trie->minlen -= (state - 1);
2309                 trie->maxlen -= (state - 1);
2310 #ifdef DEBUGGING
2311                /* At least the UNICOS C compiler choked on this
2312                 * being argument to DEBUG_r(), so let's just have
2313                 * it right here. */
2314                if (
2315 #ifdef PERL_EXT_RE_BUILD
2316                    1
2317 #else
2318                    DEBUG_r_TEST
2319 #endif
2320                    ) {
2321                    regnode *fix = convert;
2322                    U32 word = trie->wordcount;
2323                    mjd_nodelen++;
2324                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
2325                    while( ++fix < n ) {
2326                        Set_Node_Offset_Length(fix, 0, 0);
2327                    }
2328                    while (word--) {
2329                        SV ** const tmp = av_fetch( trie_words, word, 0 );
2330                        if (tmp) {
2331                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
2332                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
2333                            else
2334                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
2335                        }
2336                    }
2337                }
2338 #endif
2339                 if (trie->maxlen) {
2340                     convert = n;
2341                 } else {
2342                     NEXT_OFF(convert) = (U16)(tail - convert);
2343                     DEBUG_r(optimize= n);
2344                 }
2345             }
2346         }
2347         if (!jumper) 
2348             jumper = last; 
2349         if ( trie->maxlen ) {
2350             NEXT_OFF( convert ) = (U16)(tail - convert);
2351             ARG_SET( convert, data_slot );
2352             /* Store the offset to the first unabsorbed branch in 
2353                jump[0], which is otherwise unused by the jump logic. 
2354                We use this when dumping a trie and during optimisation. */
2355             if (trie->jump) 
2356                 trie->jump[0] = (U16)(nextbranch - convert);
2357             
2358             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
2359              *   and there is a bitmap
2360              *   and the first "jump target" node we found leaves enough room
2361              * then convert the TRIE node into a TRIEC node, with the bitmap
2362              * embedded inline in the opcode - this is hypothetically faster.
2363              */
2364             if ( !trie->states[trie->startstate].wordnum
2365                  && trie->bitmap
2366                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
2367             {
2368                 OP( convert ) = TRIEC;
2369                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
2370                 PerlMemShared_free(trie->bitmap);
2371                 trie->bitmap= NULL;
2372             } else 
2373                 OP( convert ) = TRIE;
2374
2375             /* store the type in the flags */
2376             convert->flags = nodetype;
2377             DEBUG_r({
2378             optimize = convert 
2379                       + NODE_STEP_REGNODE 
2380                       + regarglen[ OP( convert ) ];
2381             });
2382             /* XXX We really should free up the resource in trie now, 
2383                    as we won't use them - (which resources?) dmq */
2384         }
2385         /* needed for dumping*/
2386         DEBUG_r(if (optimize) {
2387             regnode *opt = convert;
2388
2389             while ( ++opt < optimize) {
2390                 Set_Node_Offset_Length(opt,0,0);
2391             }
2392             /* 
2393                 Try to clean up some of the debris left after the 
2394                 optimisation.
2395              */
2396             while( optimize < jumper ) {
2397                 mjd_nodelen += Node_Length((optimize));
2398                 OP( optimize ) = OPTIMIZED;
2399                 Set_Node_Offset_Length(optimize,0,0);
2400                 optimize++;
2401             }
2402             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
2403         });
2404     } /* end node insert */
2405     REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, convert);
2406
2407     /*  Finish populating the prev field of the wordinfo array.  Walk back
2408      *  from each accept state until we find another accept state, and if
2409      *  so, point the first word's .prev field at the second word. If the
2410      *  second already has a .prev field set, stop now. This will be the
2411      *  case either if we've already processed that word's accept state,
2412      *  or that state had multiple words, and the overspill words were
2413      *  already linked up earlier.
2414      */
2415     {
2416         U16 word;
2417         U32 state;
2418         U16 prev;
2419
2420         for (word=1; word <= trie->wordcount; word++) {
2421             prev = 0;
2422             if (trie->wordinfo[word].prev)
2423                 continue;
2424             state = trie->wordinfo[word].accept;
2425             while (state) {
2426                 state = prev_states[state];
2427                 if (!state)
2428                     break;
2429                 prev = trie->states[state].wordnum;
2430                 if (prev)
2431                     break;
2432             }
2433             trie->wordinfo[word].prev = prev;
2434         }
2435         Safefree(prev_states);
2436     }
2437
2438
2439     /* and now dump out the compressed format */
2440     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
2441
2442     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
2443 #ifdef DEBUGGING
2444     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
2445     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
2446 #else
2447     SvREFCNT_dec(revcharmap);
2448 #endif
2449     return trie->jump 
2450            ? MADE_JUMP_TRIE 
2451            : trie->startstate>1 
2452              ? MADE_EXACT_TRIE 
2453              : MADE_TRIE;
2454 }
2455
2456 STATIC void
2457 S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source,  regnode *stclass, U32 depth)
2458 {
2459 /* The Trie is constructed and compressed now so we can build a fail array if it's needed
2460
2461    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
2462    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
2463    ISBN 0-201-10088-6
2464
2465    We find the fail state for each state in the trie, this state is the longest proper
2466    suffix of the current state's 'word' that is also a proper prefix of another word in our
2467    trie. State 1 represents the word '' and is thus the default fail state. This allows
2468    the DFA not to have to restart after its tried and failed a word at a given point, it
2469    simply continues as though it had been matching the other word in the first place.
2470    Consider
2471       'abcdgu'=~/abcdefg|cdgu/
2472    When we get to 'd' we are still matching the first word, we would encounter 'g' which would
2473    fail, which would bring us to the state representing 'd' in the second word where we would
2474    try 'g' and succeed, proceeding to match 'cdgu'.
2475  */
2476  /* add a fail transition */
2477     const U32 trie_offset = ARG(source);
2478     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
2479     U32 *q;
2480     const U32 ucharcount = trie->uniquecharcount;
2481     const U32 numstates = trie->statecount;
2482     const U32 ubound = trie->lasttrans + ucharcount;
2483     U32 q_read = 0;
2484     U32 q_write = 0;
2485     U32 charid;
2486     U32 base = trie->states[ 1 ].trans.base;
2487     U32 *fail;
2488     reg_ac_data *aho;
2489     const U32 data_slot = add_data( pRExC_state, 1, "T" );
2490     GET_RE_DEBUG_FLAGS_DECL;
2491
2492     PERL_ARGS_ASSERT_MAKE_TRIE_FAILTABLE;
2493 #ifndef DEBUGGING
2494     PERL_UNUSED_ARG(depth);
2495 #endif
2496
2497
2498     ARG_SET( stclass, data_slot );
2499     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
2500     RExC_rxi->data->data[ data_slot ] = (void*)aho;
2501     aho->trie=trie_offset;
2502     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
2503     Copy( trie->states, aho->states, numstates, reg_trie_state );
2504     Newxz( q, numstates, U32);
2505     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
2506     aho->refcount = 1;
2507     fail = aho->fail;
2508     /* initialize fail[0..1] to be 1 so that we always have
2509        a valid final fail state */
2510     fail[ 0 ] = fail[ 1 ] = 1;
2511
2512     for ( charid = 0; charid < ucharcount ; charid++ ) {
2513         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
2514         if ( newstate ) {
2515             q[ q_write ] = newstate;
2516             /* set to point at the root */
2517             fail[ q[ q_write++ ] ]=1;
2518         }
2519     }
2520     while ( q_read < q_write) {
2521         const U32 cur = q[ q_read++ % numstates ];
2522         base = trie->states[ cur ].trans.base;
2523
2524         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
2525             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
2526             if (ch_state) {
2527                 U32 fail_state = cur;
2528                 U32 fail_base;
2529                 do {
2530                     fail_state = fail[ fail_state ];
2531                     fail_base = aho->states[ fail_state ].trans.base;
2532                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
2533
2534                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
2535                 fail[ ch_state ] = fail_state;
2536                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
2537                 {
2538                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
2539                 }
2540                 q[ q_write++ % numstates] = ch_state;
2541             }
2542         }
2543     }
2544     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
2545        when we fail in state 1, this allows us to use the
2546        charclass scan to find a valid start char. This is based on the principle
2547        that theres a good chance the string being searched contains lots of stuff
2548        that cant be a start char.
2549      */
2550     fail[ 0 ] = fail[ 1 ] = 0;
2551     DEBUG_TRIE_COMPILE_r({
2552         PerlIO_printf(Perl_debug_log,
2553                       "%*sStclass Failtable (%"UVuf" states): 0", 
2554                       (int)(depth * 2), "", (UV)numstates
2555         );
2556         for( q_read=1; q_read<numstates; q_read++ ) {
2557             PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
2558         }
2559         PerlIO_printf(Perl_debug_log, "\n");
2560     });
2561     Safefree(q);
2562     /*RExC_seen |= REG_SEEN_TRIEDFA;*/
2563 }
2564
2565
2566 /*
2567  * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2568  * These need to be revisited when a newer toolchain becomes available.
2569  */
2570 #if defined(__sparc64__) && defined(__GNUC__)
2571 #   if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2572 #       undef  SPARC64_GCC_WORKAROUND
2573 #       define SPARC64_GCC_WORKAROUND 1
2574 #   endif
2575 #endif
2576
2577 #define DEBUG_PEEP(str,scan,depth) \
2578     DEBUG_OPTIMISE_r({if (scan){ \
2579        SV * const mysv=sv_newmortal(); \
2580        regnode *Next = regnext(scan); \
2581        regprop(RExC_rx, mysv, scan); \
2582        PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
2583        (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
2584        Next ? (REG_NODE_NUM(Next)) : 0 ); \
2585    }});
2586
2587
2588 /* The below joins as many adjacent EXACTish nodes as possible into a single
2589  * one.  The regop may be changed if the node(s) contain certain sequences that
2590  * require special handling.  The joining is only done if:
2591  * 1) there is room in the current conglomerated node to entirely contain the
2592  *    next one.
2593  * 2) they are the exact same node type
2594  *
2595  * The adjacent nodes actually may be separated by NOTHING-kind nodes, and
2596  * these get optimized out
2597  *
2598  * If a node is to match under /i (folded), the number of characters it matches
2599  * can be different than its character length if it contains a multi-character
2600  * fold.  *min_subtract is set to the total delta of the input nodes.
2601  *
2602  * And *has_exactf_sharp_s is set to indicate whether or not the node is EXACTF
2603  * and contains LATIN SMALL LETTER SHARP S
2604  *
2605  * This is as good a place as any to discuss the design of handling these
2606  * multi-character fold sequences.  It's been wrong in Perl for a very long
2607  * time.  There are three code points in Unicode whose multi-character folds
2608  * were long ago discovered to mess things up.  The previous designs for
2609  * dealing with these involved assigning a special node for them.  This
2610  * approach doesn't work, as evidenced by this example:
2611  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
2612  * Both these fold to "sss", but if the pattern is parsed to create a node that
2613  * would match just the \xDF, it won't be able to handle the case where a
2614  * successful match would have to cross the node's boundary.  The new approach
2615  * that hopefully generally solves the problem generates an EXACTFU_SS node
2616  * that is "sss".
2617  *
2618  * It turns out that there are problems with all multi-character folds, and not
2619  * just these three.  Now the code is general, for all such cases, but the
2620  * three still have some special handling.  The approach taken is:
2621  * 1)   This routine examines each EXACTFish node that could contain multi-
2622  *      character fold sequences.  It returns in *min_subtract how much to
2623  *      subtract from the the actual length of the string to get a real minimum
2624  *      match length; it is 0 if there are no multi-char folds.  This delta is
2625  *      used by the caller to adjust the min length of the match, and the delta
2626  *      between min and max, so that the optimizer doesn't reject these
2627  *      possibilities based on size constraints.
2628  * 2)   Certain of these sequences require special handling by the trie code,
2629  *      so, if found, this code changes the joined node type to special ops:
2630  *      EXACTFU_TRICKYFOLD and EXACTFU_SS.
2631  * 3)   For the sequence involving the Sharp s (\xDF), the node type EXACTFU_SS
2632  *      is used for an EXACTFU node that contains at least one "ss" sequence in
2633  *      it.  For non-UTF-8 patterns and strings, this is the only case where
2634  *      there is a possible fold length change.  That means that a regular
2635  *      EXACTFU node without UTF-8 involvement doesn't have to concern itself
2636  *      with length changes, and so can be processed faster.  regexec.c takes
2637  *      advantage of this.  Generally, an EXACTFish node that is in UTF-8 is
2638  *      pre-folded by regcomp.c.  This saves effort in regex matching.
2639  *      However, the pre-folding isn't done for non-UTF8 patterns because the
2640  *      fold of the MICRO SIGN requires UTF-8, and we don't want to slow things
2641  *      down by forcing the pattern into UTF8 unless necessary.  Also what
2642  *      EXACTF and EXACTFL nodes fold to isn't known until runtime.  The fold
2643  *      possibilities for the non-UTF8 patterns are quite simple, except for
2644  *      the sharp s.  All the ones that don't involve a UTF-8 target string are
2645  *      members of a fold-pair, and arrays are set up for all of them so that
2646  *      the other member of the pair can be found quickly.  Code elsewhere in
2647  *      this file makes sure that in EXACTFU nodes, the sharp s gets folded to
2648  *      'ss', even if the pattern isn't UTF-8.  This avoids the issues
2649  *      described in the next item.
2650  * 4)   A problem remains for the sharp s in EXACTF nodes.  Whether it matches
2651  *      'ss' or not is not knowable at compile time.  It will match iff the
2652  *      target string is in UTF-8, unlike the EXACTFU nodes, where it always
2653  *      matches; and the EXACTFL and EXACTFA nodes where it never does.  Thus
2654  *      it can't be folded to "ss" at compile time, unlike EXACTFU does (as
2655  *      described in item 3).  An assumption that the optimizer part of
2656  *      regexec.c (probably unwittingly) makes is that a character in the
2657  *      pattern corresponds to at most a single character in the target string.
2658  *      (And I do mean character, and not byte here, unlike other parts of the
2659  *      documentation that have never been updated to account for multibyte
2660  *      Unicode.)  This assumption is wrong only in this case, as all other
2661  *      cases are either 1-1 folds when no UTF-8 is involved; or is true by
2662  *      virtue of having this file pre-fold UTF-8 patterns.   I'm
2663  *      reluctant to try to change this assumption, so instead the code punts.
2664  *      This routine examines EXACTF nodes for the sharp s, and returns a
2665  *      boolean indicating whether or not the node is an EXACTF node that
2666  *      contains a sharp s.  When it is true, the caller sets a flag that later
2667  *      causes the optimizer in this file to not set values for the floating
2668  *      and fixed string lengths, and thus avoids the optimizer code in
2669  *      regexec.c that makes the invalid assumption.  Thus, there is no
2670  *      optimization based on string lengths for EXACTF nodes that contain the
2671  *      sharp s.  This only happens for /id rules (which means the pattern
2672  *      isn't in UTF-8).
2673  */
2674
2675 #define JOIN_EXACT(scan,min_subtract,has_exactf_sharp_s, flags) \
2676     if (PL_regkind[OP(scan)] == EXACT) \
2677         join_exact(pRExC_state,(scan),(min_subtract),has_exactf_sharp_s, (flags),NULL,depth+1)
2678
2679 STATIC U32
2680 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) {
2681     /* Merge several consecutive EXACTish nodes into one. */
2682     regnode *n = regnext(scan);
2683     U32 stringok = 1;
2684     regnode *next = scan + NODE_SZ_STR(scan);
2685     U32 merged = 0;
2686     U32 stopnow = 0;
2687 #ifdef DEBUGGING
2688     regnode *stop = scan;
2689     GET_RE_DEBUG_FLAGS_DECL;
2690 #else
2691     PERL_UNUSED_ARG(depth);
2692 #endif
2693
2694     PERL_ARGS_ASSERT_JOIN_EXACT;
2695 #ifndef EXPERIMENTAL_INPLACESCAN
2696     PERL_UNUSED_ARG(flags);
2697     PERL_UNUSED_ARG(val);
2698 #endif
2699     DEBUG_PEEP("join",scan,depth);
2700
2701     /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
2702      * EXACT ones that are mergeable to the current one. */
2703     while (n
2704            && (PL_regkind[OP(n)] == NOTHING
2705                || (stringok && OP(n) == OP(scan)))
2706            && NEXT_OFF(n)
2707            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
2708     {
2709         
2710         if (OP(n) == TAIL || n > next)
2711             stringok = 0;
2712         if (PL_regkind[OP(n)] == NOTHING) {
2713             DEBUG_PEEP("skip:",n,depth);
2714             NEXT_OFF(scan) += NEXT_OFF(n);
2715             next = n + NODE_STEP_REGNODE;
2716 #ifdef DEBUGGING
2717             if (stringok)
2718                 stop = n;
2719 #endif
2720             n = regnext(n);
2721         }
2722         else if (stringok) {
2723             const unsigned int oldl = STR_LEN(scan);
2724             regnode * const nnext = regnext(n);
2725
2726             /* XXX I (khw) kind of doubt that this works on platforms where
2727              * U8_MAX is above 255 because of lots of other assumptions */
2728             if (oldl + STR_LEN(n) > U8_MAX)
2729                 break;
2730             
2731             DEBUG_PEEP("merg",n,depth);
2732             merged++;
2733
2734             NEXT_OFF(scan) += NEXT_OFF(n);
2735             STR_LEN(scan) += STR_LEN(n);
2736             next = n + NODE_SZ_STR(n);
2737             /* Now we can overwrite *n : */
2738             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
2739 #ifdef DEBUGGING
2740             stop = next - 1;
2741 #endif
2742             n = nnext;
2743             if (stopnow) break;
2744         }
2745
2746 #ifdef EXPERIMENTAL_INPLACESCAN
2747         if (flags && !NEXT_OFF(n)) {
2748             DEBUG_PEEP("atch", val, depth);
2749             if (reg_off_by_arg[OP(n)]) {
2750                 ARG_SET(n, val - n);
2751             }
2752             else {
2753                 NEXT_OFF(n) = val - n;
2754             }
2755             stopnow = 1;
2756         }
2757 #endif
2758     }
2759
2760     *min_subtract = 0;
2761     *has_exactf_sharp_s = FALSE;
2762
2763     /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
2764      * can now analyze for sequences of problematic code points.  (Prior to
2765      * this final joining, sequences could have been split over boundaries, and
2766      * hence missed).  The sequences only happen in folding, hence for any
2767      * non-EXACT EXACTish node */
2768     if (OP(scan) != EXACT) {
2769         const U8 * const s0 = (U8*) STRING(scan);
2770         const U8 * s = s0;
2771         const U8 * const s_end = s0 + STR_LEN(scan);
2772
2773         /* One pass is made over the node's string looking for all the
2774          * possibilities.  to avoid some tests in the loop, there are two main
2775          * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
2776          * non-UTF-8 */
2777         if (UTF) {
2778
2779             /* Examine the string for a multi-character fold sequence.  UTF-8
2780              * patterns have all characters pre-folded by the time this code is
2781              * executed */
2782             while (s < s_end - 1) /* Can stop 1 before the end, as minimum
2783                                      length sequence we are looking for is 2 */
2784             {
2785                 int count = 0;
2786                 int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
2787                 if (! len) {    /* Not a multi-char fold: get next char */
2788                     s += UTF8SKIP(s);
2789                     continue;
2790                 }
2791
2792                 /* Nodes with 'ss' require special handling, except for EXACTFL
2793                  * and EXACTFA for which there is no multi-char fold to this */
2794                 if (len == 2 && *s == 's' && *(s+1) == 's'
2795                     && OP(scan) != EXACTFL && OP(scan) != EXACTFA)
2796                 {
2797                     count = 2;
2798                     OP(scan) = EXACTFU_SS;
2799                     s += 2;
2800                 }
2801                 else if (len == 6   /* len is the same in both ASCII and EBCDIC for these */
2802                          && (memEQ(s, GREEK_SMALL_LETTER_IOTA_UTF8
2803                                       COMBINING_DIAERESIS_UTF8
2804                                       COMBINING_ACUTE_ACCENT_UTF8,
2805                                    6)
2806                              || memEQ(s, GREEK_SMALL_LETTER_UPSILON_UTF8
2807                                          COMBINING_DIAERESIS_UTF8
2808                                          COMBINING_ACUTE_ACCENT_UTF8,
2809                                      6)))
2810                 {
2811                     count = 3;
2812
2813                     /* These two folds require special handling by trie's, so
2814                      * change the node type to indicate this.  If EXACTFA and
2815                      * EXACTFL were ever to be handled by trie's, this would
2816                      * have to be changed.  If this node has already been
2817                      * changed to EXACTFU_SS in this loop, leave it as is.  (I
2818                      * (khw) think it doesn't matter in regexec.c for UTF
2819                      * patterns, but no need to change it */
2820                     if (OP(scan) == EXACTFU) {
2821                         OP(scan) = EXACTFU_TRICKYFOLD;
2822                     }
2823                     s += 6;
2824                 }
2825                 else { /* Here is a generic multi-char fold. */
2826                     const U8* multi_end  = s + len;
2827
2828                     /* Count how many characters in it.  In the case of /l and
2829                      * /aa, no folds which contain ASCII code points are
2830                      * allowed, so check for those, and skip if found.  (In
2831                      * EXACTFL, no folds are allowed to any Latin1 code point,
2832                      * not just ASCII.  But there aren't any of these
2833                      * currently, nor ever likely, so don't take the time to
2834                      * test for them.  The code that generates the
2835                      * is_MULTI_foo() macros croaks should one actually get put
2836                      * into Unicode .) */
2837                     if (OP(scan) != EXACTFL && OP(scan) != EXACTFA) {
2838                         count = utf8_length(s, multi_end);
2839                         s = multi_end;
2840                     }
2841                     else {
2842                         while (s < multi_end) {
2843                             if (isASCII(*s)) {
2844                                 s++;
2845                                 goto next_iteration;
2846                             }
2847                             else {
2848                                 s += UTF8SKIP(s);
2849                             }
2850                             count++;
2851                         }
2852                     }
2853                 }
2854
2855                 /* The delta is how long the sequence is minus 1 (1 is how long
2856                  * the character that folds to the sequence is) */
2857                 *min_subtract += count - 1;
2858             next_iteration: ;
2859             }
2860         }
2861         else if (OP(scan) != EXACTFL && OP(scan) != EXACTFA) {
2862
2863             /* Here, the pattern is not UTF-8.  Look for the multi-char folds
2864              * that are all ASCII.  As in the above case, EXACTFL and EXACTFA
2865              * nodes can't have multi-char folds to this range (and there are
2866              * no existing ones in the upper latin1 range).  In the EXACTF
2867              * case we look also for the sharp s, which can be in the final
2868              * position.  Otherwise we can stop looking 1 byte earlier because
2869              * have to find at least two characters for a multi-fold */
2870             const U8* upper = (OP(scan) == EXACTF) ? s_end : s_end -1;
2871
2872             /* The below is perhaps overboard, but this allows us to save a
2873              * test each time through the loop at the expense of a mask.  This
2874              * is because on both EBCDIC and ASCII machines, 'S' and 's' differ
2875              * by a single bit.  On ASCII they are 32 apart; on EBCDIC, they
2876              * are 64.  This uses an exclusive 'or' to find that bit and then
2877              * inverts it to form a mask, with just a single 0, in the bit
2878              * position where 'S' and 's' differ. */
2879             const U8 S_or_s_mask = (U8) ~ ('S' ^ 's');
2880             const U8 s_masked = 's' & S_or_s_mask;
2881
2882             while (s < upper) {
2883                 int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end);
2884                 if (! len) {    /* Not a multi-char fold. */
2885                     if (*s == LATIN_SMALL_LETTER_SHARP_S && OP(scan) == EXACTF)
2886                     {
2887                         *has_exactf_sharp_s = TRUE;
2888                     }
2889                     s++;
2890                     continue;
2891                 }
2892
2893                 if (len == 2
2894                     && ((*s & S_or_s_mask) == s_masked)
2895                     && ((*(s+1) & S_or_s_mask) == s_masked))
2896                 {
2897
2898                     /* EXACTF nodes need to know that the minimum length
2899                      * changed so that a sharp s in the string can match this
2900                      * ss in the pattern, but they remain EXACTF nodes, as they
2901                      * won't match this unless the target string is is UTF-8,
2902                      * which we don't know until runtime */
2903                     if (OP(scan) != EXACTF) {
2904                         OP(scan) = EXACTFU_SS;
2905                     }
2906                 }
2907
2908                 *min_subtract += len - 1;
2909                 s += len;
2910             }
2911         }
2912     }
2913
2914 #ifdef DEBUGGING
2915     /* Allow dumping but overwriting the collection of skipped
2916      * ops and/or strings with fake optimized ops */
2917     n = scan + NODE_SZ_STR(scan);
2918     while (n <= stop) {
2919         OP(n) = OPTIMIZED;
2920         FLAGS(n) = 0;
2921         NEXT_OFF(n) = 0;
2922         n++;
2923     }
2924 #endif
2925     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
2926     return stopnow;
2927 }
2928
2929 /* REx optimizer.  Converts nodes into quicker variants "in place".
2930    Finds fixed substrings.  */
2931
2932 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
2933    to the position after last scanned or to NULL. */
2934
2935 #define INIT_AND_WITHP \
2936     assert(!and_withp); \
2937     Newx(and_withp,1,struct regnode_charclass_class); \
2938     SAVEFREEPV(and_withp)
2939
2940 /* this is a chain of data about sub patterns we are processing that
2941    need to be handled separately/specially in study_chunk. Its so
2942    we can simulate recursion without losing state.  */
2943 struct scan_frame;
2944 typedef struct scan_frame {
2945     regnode *last;  /* last node to process in this frame */
2946     regnode *next;  /* next node to process when last is reached */
2947     struct scan_frame *prev; /*previous frame*/
2948     I32 stop; /* what stopparen do we use */
2949 } scan_frame;
2950
2951
2952 #define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf)
2953
2954 #define CASE_SYNST_FNC(nAmE)                                       \
2955 case nAmE:                                                         \
2956     if (flags & SCF_DO_STCLASS_AND) {                              \
2957             for (value = 0; value < 256; value++)                  \
2958                 if (!is_ ## nAmE ## _cp(value))                       \
2959                     ANYOF_BITMAP_CLEAR(data->start_class, value);  \
2960     }                                                              \
2961     else {                                                         \
2962             for (value = 0; value < 256; value++)                  \
2963                 if (is_ ## nAmE ## _cp(value))                        \
2964                     ANYOF_BITMAP_SET(data->start_class, value);    \
2965     }                                                              \
2966     break;                                                         \
2967 case N ## nAmE:                                                    \
2968     if (flags & SCF_DO_STCLASS_AND) {                              \
2969             for (value = 0; value < 256; value++)                   \
2970                 if (is_ ## nAmE ## _cp(value))                         \
2971                     ANYOF_BITMAP_CLEAR(data->start_class, value);   \
2972     }                                                               \
2973     else {                                                          \
2974             for (value = 0; value < 256; value++)                   \
2975                 if (!is_ ## nAmE ## _cp(value))                        \
2976                     ANYOF_BITMAP_SET(data->start_class, value);     \
2977     }                                                               \
2978     break
2979
2980
2981
2982 STATIC I32
2983 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
2984                         I32 *minlenp, I32 *deltap,
2985                         regnode *last,
2986                         scan_data_t *data,
2987                         I32 stopparen,
2988                         U8* recursed,
2989                         struct regnode_charclass_class *and_withp,
2990                         U32 flags, U32 depth)
2991                         /* scanp: Start here (read-write). */
2992                         /* deltap: Write maxlen-minlen here. */
2993                         /* last: Stop before this one. */
2994                         /* data: string data about the pattern */
2995                         /* stopparen: treat close N as END */
2996                         /* recursed: which subroutines have we recursed into */
2997                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
2998 {
2999     dVAR;
3000     I32 min = 0;    /* There must be at least this number of characters to match */
3001     I32 pars = 0, code;
3002     regnode *scan = *scanp, *next;
3003     I32 delta = 0;
3004     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
3005     int is_inf_internal = 0;            /* The studied chunk is infinite */
3006     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
3007     scan_data_t data_fake;
3008     SV *re_trie_maxbuff = NULL;
3009     regnode *first_non_open = scan;
3010     I32 stopmin = I32_MAX;
3011     scan_frame *frame = NULL;
3012     GET_RE_DEBUG_FLAGS_DECL;
3013
3014     PERL_ARGS_ASSERT_STUDY_CHUNK;
3015
3016 #ifdef DEBUGGING
3017     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
3018 #endif
3019
3020     if ( depth == 0 ) {
3021         while (first_non_open && OP(first_non_open) == OPEN)
3022             first_non_open=regnext(first_non_open);
3023     }
3024
3025
3026   fake_study_recurse:
3027     while ( scan && OP(scan) != END && scan < last ){
3028         UV min_subtract = 0;    /* How mmany chars to subtract from the minimum
3029                                    node length to get a real minimum (because
3030                                    the folded version may be shorter) */
3031         bool has_exactf_sharp_s = FALSE;
3032         /* Peephole optimizer: */
3033         DEBUG_STUDYDATA("Peep:", data,depth);
3034         DEBUG_PEEP("Peep",scan,depth);
3035
3036         /* Its not clear to khw or hv why this is done here, and not in the
3037          * clauses that deal with EXACT nodes.  khw's guess is that it's
3038          * because of a previous design */
3039         JOIN_EXACT(scan,&min_subtract, &has_exactf_sharp_s, 0);
3040
3041         /* Follow the next-chain of the current node and optimize
3042            away all the NOTHINGs from it.  */
3043         if (OP(scan) != CURLYX) {
3044             const int max = (reg_off_by_arg[OP(scan)]
3045                        ? I32_MAX
3046                        /* I32 may be smaller than U16 on CRAYs! */
3047                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
3048             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
3049             int noff;
3050             regnode *n = scan;
3051
3052             /* Skip NOTHING and LONGJMP. */
3053             while ((n = regnext(n))
3054                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
3055                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
3056                    && off + noff < max)
3057                 off += noff;
3058             if (reg_off_by_arg[OP(scan)])
3059                 ARG(scan) = off;
3060             else
3061                 NEXT_OFF(scan) = off;
3062         }
3063
3064
3065
3066         /* The principal pseudo-switch.  Cannot be a switch, since we
3067            look into several different things.  */
3068         if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
3069                    || OP(scan) == IFTHEN) {
3070             next = regnext(scan);
3071             code = OP(scan);
3072             /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
3073
3074             if (OP(next) == code || code == IFTHEN) {
3075                 /* NOTE - There is similar code to this block below for handling
3076                    TRIE nodes on a re-study.  If you change stuff here check there
3077                    too. */
3078                 I32 max1 = 0, min1 = I32_MAX, num = 0;
3079                 struct regnode_charclass_class accum;
3080                 regnode * const startbranch=scan;
3081
3082                 if (flags & SCF_DO_SUBSTR)
3083                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
3084                 if (flags & SCF_DO_STCLASS)
3085                     cl_init_zero(pRExC_state, &accum);
3086
3087                 while (OP(scan) == code) {
3088                     I32 deltanext, minnext, f = 0, fake;
3089                     struct regnode_charclass_class this_class;
3090
3091                     num++;
3092                     data_fake.flags = 0;
3093                     if (data) {
3094                         data_fake.whilem_c = data->whilem_c;
3095                         data_fake.last_closep = data->last_closep;
3096                     }
3097                     else
3098                         data_fake.last_closep = &fake;
3099
3100                     data_fake.pos_delta = delta;
3101                     next = regnext(scan);
3102                     scan = NEXTOPER(scan);
3103                     if (code != BRANCH)
3104                         scan = NEXTOPER(scan);
3105                     if (flags & SCF_DO_STCLASS) {
3106                         cl_init(pRExC_state, &this_class);
3107                         data_fake.start_class = &this_class;
3108                         f = SCF_DO_STCLASS_AND;
3109                     }
3110                     if (flags & SCF_WHILEM_VISITED_POS)
3111                         f |= SCF_WHILEM_VISITED_POS;
3112
3113                     /* we suppose the run is continuous, last=next...*/
3114                     minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
3115                                           next, &data_fake,
3116                                           stopparen, recursed, NULL, f,depth+1);
3117                     if (min1 > minnext)
3118                         min1 = minnext;
3119                     if (max1 < minnext + deltanext)
3120                         max1 = minnext + deltanext;
3121                     if (deltanext == I32_MAX)
3122                         is_inf = is_inf_internal = 1;
3123                     scan = next;
3124                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3125                         pars++;
3126                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
3127                         if ( stopmin > minnext) 
3128                             stopmin = min + min1;
3129                         flags &= ~SCF_DO_SUBSTR;
3130                         if (data)
3131                             data->flags |= SCF_SEEN_ACCEPT;
3132                     }
3133                     if (data) {
3134                         if (data_fake.flags & SF_HAS_EVAL)
3135                             data->flags |= SF_HAS_EVAL;
3136                         data->whilem_c = data_fake.whilem_c;
3137                     }
3138                     if (flags & SCF_DO_STCLASS)
3139                         cl_or(pRExC_state, &accum, &this_class);
3140                 }
3141                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
3142                     min1 = 0;
3143                 if (flags & SCF_DO_SUBSTR) {
3144                     data->pos_min += min1;
3145                     data->pos_delta += max1 - min1;
3146                     if (max1 != min1 || is_inf)
3147                         data->longest = &(data->longest_float);
3148                 }
3149                 min += min1;
3150                 delta += max1 - min1;
3151                 if (flags & SCF_DO_STCLASS_OR) {
3152                     cl_or(pRExC_state, data->start_class, &accum);
3153                     if (min1) {
3154                         cl_and(data->start_class, and_withp);
3155                         flags &= ~SCF_DO_STCLASS;
3156                     }
3157                 }
3158                 else if (flags & SCF_DO_STCLASS_AND) {
3159                     if (min1) {
3160                         cl_and(data->start_class, &accum);
3161                         flags &= ~SCF_DO_STCLASS;
3162                     }
3163                     else {
3164                         /* Switch to OR mode: cache the old value of
3165                          * data->start_class */
3166                         INIT_AND_WITHP;
3167                         StructCopy(data->start_class, and_withp,
3168                                    struct regnode_charclass_class);
3169                         flags &= ~SCF_DO_STCLASS_AND;
3170                         StructCopy(&accum, data->start_class,
3171                                    struct regnode_charclass_class);
3172                         flags |= SCF_DO_STCLASS_OR;
3173                         data->start_class->flags |= ANYOF_EOS;
3174                     }
3175                 }
3176
3177                 if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) == BRANCH ) {
3178                 /* demq.
3179
3180                    Assuming this was/is a branch we are dealing with: 'scan' now
3181                    points at the item that follows the branch sequence, whatever
3182                    it is. We now start at the beginning of the sequence and look
3183                    for subsequences of
3184
3185                    BRANCH->EXACT=>x1
3186                    BRANCH->EXACT=>x2
3187                    tail
3188
3189                    which would be constructed from a pattern like /A|LIST|OF|WORDS/
3190
3191                    If we can find such a subsequence we need to turn the first
3192                    element into a trie and then add the subsequent branch exact
3193                    strings to the trie.
3194
3195                    We have two cases
3196
3197                      1. patterns where the whole set of branches can be converted. 
3198
3199                      2. patterns where only a subset can be converted.
3200
3201                    In case 1 we can replace the whole set with a single regop
3202                    for the trie. In case 2 we need to keep the start and end
3203                    branches so
3204
3205                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
3206                      becomes BRANCH TRIE; BRANCH X;
3207
3208                   There is an additional case, that being where there is a 
3209                   common prefix, which gets split out into an EXACT like node
3210                   preceding the TRIE node.
3211
3212                   If x(1..n)==tail then we can do a simple trie, if not we make
3213                   a "jump" trie, such that when we match the appropriate word
3214                   we "jump" to the appropriate tail node. Essentially we turn
3215                   a nested if into a case structure of sorts.
3216
3217                 */
3218
3219                     int made=0;
3220                     if (!re_trie_maxbuff) {
3221                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
3222                         if (!SvIOK(re_trie_maxbuff))
3223                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
3224                     }
3225                     if ( SvIV(re_trie_maxbuff)>=0  ) {
3226                         regnode *cur;
3227                         regnode *first = (regnode *)NULL;
3228                         regnode *last = (regnode *)NULL;
3229                         regnode *tail = scan;
3230                         U8 trietype = 0;
3231                         U32 count=0;
3232
3233 #ifdef DEBUGGING
3234                         SV * const mysv = sv_newmortal();       /* for dumping */
3235 #endif
3236                         /* var tail is used because there may be a TAIL
3237                            regop in the way. Ie, the exacts will point to the
3238                            thing following the TAIL, but the last branch will
3239                            point at the TAIL. So we advance tail. If we
3240                            have nested (?:) we may have to move through several
3241                            tails.
3242                          */
3243
3244                         while ( OP( tail ) == TAIL ) {
3245                             /* this is the TAIL generated by (?:) */
3246                             tail = regnext( tail );
3247                         }
3248
3249                         
3250                         DEBUG_TRIE_COMPILE_r({
3251                             regprop(RExC_rx, mysv, tail );
3252                             PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
3253                                 (int)depth * 2 + 2, "", 
3254                                 "Looking for TRIE'able sequences. Tail node is: ", 
3255                                 SvPV_nolen_const( mysv )
3256                             );
3257                         });
3258                         
3259                         /*
3260
3261                             Step through the branches
3262                                 cur represents each branch,
3263                                 noper is the first thing to be matched as part of that branch
3264                                 noper_next is the regnext() of that node.
3265
3266                             We normally handle a case like this /FOO[xyz]|BAR[pqr]/
3267                             via a "jump trie" but we also support building with NOJUMPTRIE,
3268                             which restricts the trie logic to structures like /FOO|BAR/.
3269
3270                             If noper is a trieable nodetype then the branch is a possible optimization
3271                             target. If we are building under NOJUMPTRIE then we require that noper_next
3272                             is the same as scan (our current position in the regex program).
3273
3274                             Once we have two or more consecutive such branches we can create a
3275                             trie of the EXACT's contents and stitch it in place into the program.
3276
3277                             If the sequence represents all of the branches in the alternation we
3278                             replace the entire thing with a single TRIE node.
3279
3280                             Otherwise when it is a subsequence we need to stitch it in place and
3281                             replace only the relevant branches. This means the first branch has
3282                             to remain as it is used by the alternation logic, and its next pointer,
3283                             and needs to be repointed at the item on the branch chain following
3284                             the last branch we have optimized away.
3285
3286                             This could be either a BRANCH, in which case the subsequence is internal,
3287                             or it could be the item following the branch sequence in which case the
3288                             subsequence is at the end (which does not necessarily mean the first node
3289                             is the start of the alternation).
3290
3291                             TRIE_TYPE(X) is a define which maps the optype to a trietype.
3292
3293                                 optype          |  trietype
3294                                 ----------------+-----------
3295                                 NOTHING         | NOTHING
3296                                 EXACT           | EXACT
3297                                 EXACTFU         | EXACTFU
3298                                 EXACTFU_SS      | EXACTFU
3299                                 EXACTFU_TRICKYFOLD | EXACTFU
3300                                 EXACTFA         | 0
3301
3302
3303                         */
3304 #define TRIE_TYPE(X) ( ( NOTHING == (X) ) ? NOTHING :   \
3305                        ( EXACT == (X) )   ? EXACT :        \
3306                        ( EXACTFU == (X) || EXACTFU_SS == (X) || EXACTFU_TRICKYFOLD == (X) ) ? EXACTFU :        \
3307                        0 )
3308
3309                         /* dont use tail as the end marker for this traverse */
3310                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
3311                             regnode * const noper = NEXTOPER( cur );
3312                             U8 noper_type = OP( noper );
3313                             U8 noper_trietype = TRIE_TYPE( noper_type );
3314 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
3315                             regnode * const noper_next = regnext( noper );
3316                             U8 noper_next_type = (noper_next && noper_next != tail) ? OP(noper_next) : 0;
3317                             U8 noper_next_trietype = (noper_next && noper_next != tail) ? TRIE_TYPE( noper_next_type ) :0;
3318 #endif
3319
3320                             DEBUG_TRIE_COMPILE_r({
3321                                 regprop(RExC_rx, mysv, cur);
3322                                 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
3323                                    (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
3324
3325                                 regprop(RExC_rx, mysv, noper);
3326                                 PerlIO_printf( Perl_debug_log, " -> %s",
3327                                     SvPV_nolen_const(mysv));
3328
3329                                 if ( noper_next ) {
3330                                   regprop(RExC_rx, mysv, noper_next );
3331                                   PerlIO_printf( Perl_debug_log,"\t=> %s\t",
3332                                     SvPV_nolen_const(mysv));
3333                                 }
3334                                 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d,tt==%s,nt==%s,nnt==%s)\n",
3335                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
3336                                    PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype] 
3337                                 );
3338                             });
3339
3340                             /* Is noper a trieable nodetype that can be merged with the
3341                              * current trie (if there is one)? */
3342                             if ( noper_trietype
3343                                   &&
3344                                   (
3345                                         ( noper_trietype == NOTHING)
3346                                         || ( trietype == NOTHING )
3347                                         || ( trietype == noper_trietype )
3348                                   )
3349 #ifdef NOJUMPTRIE
3350                                   && noper_next == tail
3351 #endif
3352                                   && count < U16_MAX)
3353                             {
3354                                 /* Handle mergable triable node
3355                                  * Either we are the first node in a new trieable sequence,
3356                                  * in which case we do some bookkeeping, otherwise we update
3357                                  * the end pointer. */
3358                                 if ( !first ) {
3359                                     first = cur;
3360                                     if ( noper_trietype == NOTHING ) {
3361 #if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
3362                                         regnode * const noper_next = regnext( noper );
3363                                         U8 noper_next_type = (noper_next && noper_next!=tail) ? OP(noper_next) : 0;
3364                                         U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
3365 #endif
3366
3367                                         if ( noper_next_trietype ) {
3368                                             trietype = noper_next_trietype;
3369                                         } else if (noper_next_type)  {
3370                                             /* a NOTHING regop is 1 regop wide. We need at least two
3371                                              * for a trie so we can't merge this in */
3372                                             first = NULL;
3373                                         }
3374                                     } else {
3375                                         trietype = noper_trietype;
3376                                     }
3377                                 } else {
3378                                     if ( trietype == NOTHING )
3379                                         trietype = noper_trietype;
3380                                     last = cur;
3381                                 }
3382                                 if (first)
3383                                     count++;
3384                             } /* end handle mergable triable node */
3385                             else {
3386                                 /* handle unmergable node -
3387                                  * noper may either be a triable node which can not be tried
3388                                  * together with the current trie, or a non triable node */
3389                                 if ( last ) {
3390                                     /* If last is set and trietype is not NOTHING then we have found
3391                                      * at least two triable branch sequences in a row of a similar
3392                                      * trietype so we can turn them into a trie. If/when we
3393                                      * allow NOTHING to start a trie sequence this condition will be
3394                                      * required, and it isn't expensive so we leave it in for now. */
3395                                     if ( trietype && trietype != NOTHING )
3396                                         make_trie( pRExC_state,
3397                                                 startbranch, first, cur, tail, count,
3398                                                 trietype, depth+1 );
3399                                     last = NULL; /* note: we clear/update first, trietype etc below, so we dont do it here */
3400                                 }
3401                                 if ( noper_trietype
3402 #ifdef NOJUMPTRIE
3403                                      && noper_next == tail
3404 #endif
3405                                 ){
3406                                     /* noper is triable, so we can start a new trie sequence */
3407                                     count = 1;
3408                                     first = cur;
3409                                     trietype = noper_trietype;
3410                                 } else if (first) {
3411                                     /* if we already saw a first but the current node is not triable then we have
3412                                      * to reset the first information. */
3413                                     count = 0;
3414                                     first = NULL;
3415                                     trietype = 0;
3416                                 }
3417                             } /* end handle unmergable node */
3418                         } /* loop over branches */
3419                         DEBUG_TRIE_COMPILE_r({
3420                             regprop(RExC_rx, mysv, cur);
3421                             PerlIO_printf( Perl_debug_log,
3422                               "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
3423                               "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3424
3425                         });
3426                         if ( last && trietype ) {
3427                             if ( trietype != NOTHING ) {
3428                                 /* the last branch of the sequence was part of a trie,
3429                                  * so we have to construct it here outside of the loop
3430                                  */
3431                                 made= make_trie( pRExC_state, startbranch, first, scan, tail, count, trietype, depth+1 );
3432 #ifdef TRIE_STUDY_OPT
3433                                 if ( ((made == MADE_EXACT_TRIE &&
3434                                      startbranch == first)
3435                                      || ( first_non_open == first )) &&
3436                                      depth==0 ) {
3437                                     flags |= SCF_TRIE_RESTUDY;
3438                                     if ( startbranch == first
3439                                          && scan == tail )
3440                                     {
3441                                         RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
3442                                     }
3443                                 }
3444 #endif
3445                             } else {
3446                                 /* at this point we know whatever we have is a NOTHING sequence/branch
3447                                  * AND if 'startbranch' is 'first' then we can turn the whole thing into a NOTHING
3448                                  */
3449                                 if ( startbranch == first ) {
3450                                     regnode *opt;
3451                                     /* the entire thing is a NOTHING sequence, something like this:
3452                                      * (?:|) So we can turn it into a plain NOTHING op. */
3453                                     DEBUG_TRIE_COMPILE_r({
3454                                         regprop(RExC_rx, mysv, cur);
3455                                         PerlIO_printf( Perl_debug_log,
3456                                           "%*s- %s (%d) <NOTHING BRANCH SEQUENCE>\n", (int)depth * 2 + 2,
3457                                           "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3458
3459                                     });
3460                                     OP(startbranch)= NOTHING;
3461                                     NEXT_OFF(startbranch)= tail - startbranch;
3462                                     for ( opt= startbranch + 1; opt < tail ; opt++ )
3463                                         OP(opt)= OPTIMIZED;
3464                                 }
3465                             }
3466                         } /* end if ( last) */
3467                     } /* TRIE_MAXBUF is non zero */
3468                     
3469                 } /* do trie */
3470                 
3471             }
3472             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
3473                 scan = NEXTOPER(NEXTOPER(scan));
3474             } else                      /* single branch is optimized. */
3475                 scan = NEXTOPER(scan);
3476             continue;
3477         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
3478             scan_frame *newframe = NULL;
3479             I32 paren;
3480             regnode *start;
3481             regnode *end;
3482
3483             if (OP(scan) != SUSPEND) {
3484             /* set the pointer */
3485                 if (OP(scan) == GOSUB) {
3486                     paren = ARG(scan);
3487                     RExC_recurse[ARG2L(scan)] = scan;
3488                     start = RExC_open_parens[paren-1];
3489                     end   = RExC_close_parens[paren-1];
3490                 } else {
3491                     paren = 0;
3492                     start = RExC_rxi->program + 1;
3493                     end   = RExC_opend;
3494                 }
3495                 if (!recursed) {
3496                     Newxz(recursed, (((RExC_npar)>>3) +1), U8);
3497                     SAVEFREEPV(recursed);
3498                 }
3499                 if (!PAREN_TEST(recursed,paren+1)) {
3500                     PAREN_SET(recursed,paren+1);
3501                     Newx(newframe,1,scan_frame);
3502                 } else {
3503                     if (flags & SCF_DO_SUBSTR) {
3504                         SCAN_COMMIT(pRExC_state,data,minlenp);
3505                         data->longest = &(data->longest_float);
3506                     }
3507                     is_inf = is_inf_internal = 1;
3508                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3509                         cl_anything(pRExC_state, data->start_class);
3510                     flags &= ~SCF_DO_STCLASS;
3511                 }
3512             } else {
3513                 Newx(newframe,1,scan_frame);
3514                 paren = stopparen;
3515                 start = scan+2;
3516                 end = regnext(scan);
3517             }
3518             if (newframe) {
3519                 assert(start);
3520                 assert(end);
3521                 SAVEFREEPV(newframe);
3522                 newframe->next = regnext(scan);
3523                 newframe->last = last;
3524                 newframe->stop = stopparen;
3525                 newframe->prev = frame;
3526
3527                 frame = newframe;
3528                 scan =  start;
3529                 stopparen = paren;
3530                 last = end;
3531
3532                 continue;
3533             }
3534         }
3535         else if (OP(scan) == EXACT) {
3536             I32 l = STR_LEN(scan);
3537             UV uc;
3538             if (UTF) {
3539                 const U8 * const s = (U8*)STRING(scan);
3540                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
3541                 l = utf8_length(s, s + l);
3542             } else {
3543                 uc = *((U8*)STRING(scan));
3544             }
3545             min += l;
3546             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
3547                 /* The code below prefers earlier match for fixed
3548                    offset, later match for variable offset.  */
3549                 if (data->last_end == -1) { /* Update the start info. */
3550                     data->last_start_min = data->pos_min;
3551                     data->last_start_max = is_inf
3552                         ? I32_MAX : data->pos_min + data->pos_delta;
3553                 }
3554                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
3555                 if (UTF)
3556                     SvUTF8_on(data->last_found);
3557                 {
3558                     SV * const sv = data->last_found;
3559                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3560                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
3561                     if (mg && mg->mg_len >= 0)
3562                         mg->mg_len += utf8_length((U8*)STRING(scan),
3563                                                   (U8*)STRING(scan)+STR_LEN(scan));
3564                 }
3565                 data->last_end = data->pos_min + l;
3566                 data->pos_min += l; /* As in the first entry. */
3567                 data->flags &= ~SF_BEFORE_EOL;
3568             }
3569             if (flags & SCF_DO_STCLASS_AND) {
3570                 /* Check whether it is compatible with what we know already! */
3571                 int compat = 1;
3572
3573
3574                 /* If compatible, we or it in below.  It is compatible if is
3575                  * in the bitmp and either 1) its bit or its fold is set, or 2)
3576                  * it's for a locale.  Even if there isn't unicode semantics
3577                  * here, at runtime there may be because of matching against a
3578                  * utf8 string, so accept a possible false positive for
3579                  * latin1-range folds */
3580                 if (uc >= 0x100 ||
3581                     (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3582                     && !ANYOF_BITMAP_TEST(data->start_class, uc)
3583                     && (!(data->start_class->flags & ANYOF_LOC_FOLD)
3584                         || !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3585                     )
3586                 {
3587                     compat = 0;
3588                 }
3589                 ANYOF_CLASS_ZERO(data->start_class);
3590                 ANYOF_BITMAP_ZERO(data->start_class);
3591                 if (compat)
3592                     ANYOF_BITMAP_SET(data->start_class, uc);
3593                 else if (uc >= 0x100) {
3594                     int i;
3595
3596                     /* Some Unicode code points fold to the Latin1 range; as
3597                      * XXX temporary code, instead of figuring out if this is
3598                      * one, just assume it is and set all the start class bits
3599                      * that could be some such above 255 code point's fold
3600                      * which will generate fals positives.  As the code
3601                      * elsewhere that does compute the fold settles down, it
3602                      * can be extracted out and re-used here */
3603                     for (i = 0; i < 256; i++){
3604                         if (HAS_NONLATIN1_FOLD_CLOSURE(i)) {
3605                             ANYOF_BITMAP_SET(data->start_class, i);
3606                         }
3607                     }
3608                 }
3609                 data->start_class->flags &= ~ANYOF_EOS;
3610                 if (uc < 0x100)
3611                   data->start_class->flags &= ~ANYOF_UNICODE_ALL;
3612             }
3613             else if (flags & SCF_DO_STCLASS_OR) {
3614                 /* false positive possible if the class is case-folded */
3615                 if (uc < 0x100)
3616                     ANYOF_BITMAP_SET(data->start_class, uc);
3617                 else
3618                     data->start_class->flags |= ANYOF_UNICODE_ALL;
3619                 data->start_class->flags &= ~ANYOF_EOS;
3620                 cl_and(data->start_class, and_withp);
3621             }
3622             flags &= ~SCF_DO_STCLASS;
3623         }
3624         else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
3625             I32 l = STR_LEN(scan);
3626             UV uc = *((U8*)STRING(scan));
3627
3628             /* Search for fixed substrings supports EXACT only. */
3629             if (flags & SCF_DO_SUBSTR) {
3630                 assert(data);
3631                 SCAN_COMMIT(pRExC_state, data, minlenp);
3632             }
3633             if (UTF) {
3634                 const U8 * const s = (U8 *)STRING(scan);
3635                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
3636                 l = utf8_length(s, s + l);
3637             }
3638             if (has_exactf_sharp_s) {
3639                 RExC_seen |= REG_SEEN_EXACTF_SHARP_S;
3640             }
3641             min += l - min_subtract;
3642             assert (min >= 0);
3643             delta += min_subtract;
3644             if (flags & SCF_DO_SUBSTR) {
3645                 data->pos_min += l - min_subtract;
3646                 if (data->pos_min < 0) {
3647                     data->pos_min = 0;
3648                 }
3649                 data->pos_delta += min_subtract;
3650                 if (min_subtract) {
3651                     data->longest = &(data->longest_float);
3652                 }
3653             }
3654             if (flags & SCF_DO_STCLASS_AND) {
3655                 /* Check whether it is compatible with what we know already! */
3656                 int compat = 1;
3657                 if (uc >= 0x100 ||
3658                  (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3659                   && !ANYOF_BITMAP_TEST(data->start_class, uc)
3660                   && !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3661                 {
3662                     compat = 0;
3663                 }
3664                 ANYOF_CLASS_ZERO(data->start_class);
3665                 ANYOF_BITMAP_ZERO(data->start_class);
3666                 if (compat) {
3667                     ANYOF_BITMAP_SET(data->start_class, uc);
3668                     data->start_class->flags &= ~ANYOF_EOS;
3669                     if (OP(scan) == EXACTFL) {
3670                         /* XXX This set is probably no longer necessary, and
3671                          * probably wrong as LOCALE now is on in the initial
3672                          * state */
3673                         data->start_class->flags |= ANYOF_LOCALE|ANYOF_LOC_FOLD;
3674                     }
3675                     else {
3676
3677                         /* Also set the other member of the fold pair.  In case
3678                          * that unicode semantics is called for at runtime, use
3679                          * the full latin1 fold.  (Can't do this for locale,
3680                          * because not known until runtime) */
3681                         ANYOF_BITMAP_SET(data->start_class, PL_fold_latin1[uc]);
3682
3683                         /* All other (EXACTFL handled above) folds except under
3684                          * /iaa that include s, S, and sharp_s also may include
3685                          * the others */
3686                         if (OP(scan) != EXACTFA) {
3687                             if (uc == 's' || uc == 'S') {
3688                                 ANYOF_BITMAP_SET(data->start_class,
3689                                                  LATIN_SMALL_LETTER_SHARP_S);
3690                             }
3691                             else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3692                                 ANYOF_BITMAP_SET(data->start_class, 's');
3693                                 ANYOF_BITMAP_SET(data->start_class, 'S');
3694                             }
3695                         }
3696                     }
3697                 }
3698                 else if (uc >= 0x100) {
3699                     int i;
3700                     for (i = 0; i < 256; i++){
3701                         if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3702                             ANYOF_BITMAP_SET(data->start_class, i);
3703                         }
3704                     }
3705                 }
3706             }
3707             else if (flags & SCF_DO_STCLASS_OR) {
3708                 if (data->start_class->flags & ANYOF_LOC_FOLD) {
3709                     /* false positive possible if the class is case-folded.
3710                        Assume that the locale settings are the same... */
3711                     if (uc < 0x100) {
3712                         ANYOF_BITMAP_SET(data->start_class, uc);
3713                         if (OP(scan) != EXACTFL) {
3714
3715                             /* And set the other member of the fold pair, but
3716                              * can't do that in locale because not known until
3717                              * run-time */
3718                             ANYOF_BITMAP_SET(data->start_class,
3719                                              PL_fold_latin1[uc]);
3720
3721                             /* All folds except under /iaa that include s, S,
3722                              * and sharp_s also may include the others */
3723                             if (OP(scan) != EXACTFA) {
3724                                 if (uc == 's' || uc == 'S') {
3725                                     ANYOF_BITMAP_SET(data->start_class,
3726                                                    LATIN_SMALL_LETTER_SHARP_S);
3727                                 }
3728                                 else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3729                                     ANYOF_BITMAP_SET(data->start_class, 's');
3730                                     ANYOF_BITMAP_SET(data->start_class, 'S');
3731                                 }
3732                             }
3733                         }
3734                     }
3735                     data->start_class->flags &= ~ANYOF_EOS;
3736                 }
3737                 cl_and(data->start_class, and_withp);
3738             }
3739             flags &= ~SCF_DO_STCLASS;
3740         }
3741         else if (REGNODE_VARIES(OP(scan))) {
3742             I32 mincount, maxcount, minnext, deltanext, fl = 0;
3743             I32 f = flags, pos_before = 0;
3744             regnode * const oscan = scan;
3745             struct regnode_charclass_class this_class;
3746             struct regnode_charclass_class *oclass = NULL;
3747             I32 next_is_eval = 0;
3748
3749             switch (PL_regkind[OP(scan)]) {
3750             case WHILEM:                /* End of (?:...)* . */
3751                 scan = NEXTOPER(scan);
3752                 goto finish;
3753             case PLUS:
3754                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
3755                     next = NEXTOPER(scan);
3756                     if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
3757                         mincount = 1;
3758                         maxcount = REG_INFTY;
3759                         next = regnext(scan);
3760                         scan = NEXTOPER(scan);
3761                         goto do_curly;
3762                     }
3763                 }
3764                 if (flags & SCF_DO_SUBSTR)
3765                     data->pos_min++;
3766                 min++;
3767                 /* Fall through. */
3768             case STAR:
3769                 if (flags & SCF_DO_STCLASS) {
3770                     mincount = 0;
3771                     maxcount = REG_INFTY;
3772                     next = regnext(scan);
3773                     scan = NEXTOPER(scan);
3774                     goto do_curly;
3775                 }
3776                 is_inf = is_inf_internal = 1;
3777                 scan = regnext(scan);
3778                 if (flags & SCF_DO_SUBSTR) {
3779                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
3780                     data->longest = &(data->longest_float);
3781                 }
3782                 goto optimize_curly_tail;
3783             case CURLY:
3784                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
3785                     && (scan->flags == stopparen))
3786                 {
3787                     mincount = 1;
3788                     maxcount = 1;
3789                 } else {
3790                     mincount = ARG1(scan);
3791                     maxcount = ARG2(scan);
3792                 }
3793                 next = regnext(scan);
3794                 if (OP(scan) == CURLYX) {
3795                     I32 lp = (data ? *(data->last_closep) : 0);
3796                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
3797                 }
3798                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3799                 next_is_eval = (OP(scan) == EVAL);
3800               do_curly:
3801                 if (flags & SCF_DO_SUBSTR) {
3802                     if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
3803                     pos_before = data->pos_min;
3804                 }
3805                 if (data) {
3806                     fl = data->flags;
3807                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
3808                     if (is_inf)
3809                         data->flags |= SF_IS_INF;
3810                 }
3811                 if (flags & SCF_DO_STCLASS) {
3812                     cl_init(pRExC_state, &this_class);
3813                     oclass = data->start_class;
3814                     data->start_class = &this_class;
3815                     f |= SCF_DO_STCLASS_AND;
3816                     f &= ~SCF_DO_STCLASS_OR;
3817                 }
3818                 /* Exclude from super-linear cache processing any {n,m}
3819                    regops for which the combination of input pos and regex
3820                    pos is not enough information to determine if a match
3821                    will be possible.
3822
3823                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
3824                    regex pos at the \s*, the prospects for a match depend not
3825                    only on the input position but also on how many (bar\s*)
3826                    repeats into the {4,8} we are. */
3827                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
3828                     f &= ~SCF_WHILEM_VISITED_POS;
3829
3830                 /* This will finish on WHILEM, setting scan, or on NULL: */
3831                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, 
3832                                       last, data, stopparen, recursed, NULL,
3833                                       (mincount == 0
3834                                         ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
3835
3836                 if (flags & SCF_DO_STCLASS)
3837                     data->start_class = oclass;
3838                 if (mincount == 0 || minnext == 0) {
3839                     if (flags & SCF_DO_STCLASS_OR) {
3840                         cl_or(pRExC_state, data->start_class, &this_class);
3841                     }
3842                     else if (flags & SCF_DO_STCLASS_AND) {
3843                         /* Switch to OR mode: cache the old value of
3844                          * data->start_class */
3845                         INIT_AND_WITHP;
3846                         StructCopy(data->start_class, and_withp,
3847                                    struct regnode_charclass_class);
3848                         flags &= ~SCF_DO_STCLASS_AND;
3849                         StructCopy(&this_class, data->start_class,
3850                                    struct regnode_charclass_class);
3851                         flags |= SCF_DO_STCLASS_OR;
3852                         data->start_class->flags |= ANYOF_EOS;
3853                     }
3854                 } else {                /* Non-zero len */
3855                     if (flags & SCF_DO_STCLASS_OR) {
3856                         cl_or(pRExC_state, data->start_class, &this_class);
3857                         cl_and(data->start_class, and_withp);
3858                     }
3859                     else if (flags & SCF_DO_STCLASS_AND)
3860                         cl_and(data->start_class, &this_class);
3861                     flags &= ~SCF_DO_STCLASS;
3862                 }
3863                 if (!scan)              /* It was not CURLYX, but CURLY. */
3864                     scan = next;
3865                 if ( /* ? quantifier ok, except for (?{ ... }) */
3866                     (next_is_eval || !(mincount == 0 && maxcount == 1))
3867                     && (minnext == 0) && (deltanext == 0)
3868                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
3869                     && maxcount <= REG_INFTY/3) /* Complement check for big count */
3870                 {
3871                     /* Fatal warnings may leak the regexp without this: */
3872                     SAVEFREESV(RExC_rx_sv);
3873                     ckWARNreg(RExC_parse,
3874                               "Quantifier unexpected on zero-length expression");
3875                     (void)ReREFCNT_inc(RExC_rx_sv);
3876                 }
3877
3878                 min += minnext * mincount;
3879                 is_inf_internal |= ((maxcount == REG_INFTY
3880                                      && (minnext + deltanext) > 0)
3881                                     || deltanext == I32_MAX);
3882                 is_inf |= is_inf_internal;
3883                 delta += (minnext + deltanext) * maxcount - minnext * mincount;
3884
3885                 /* Try powerful optimization CURLYX => CURLYN. */
3886                 if (  OP(oscan) == CURLYX && data
3887                       && data->flags & SF_IN_PAR
3888                       && !(data->flags & SF_HAS_EVAL)
3889                       && !deltanext && minnext == 1 ) {
3890                     /* Try to optimize to CURLYN.  */
3891                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
3892                     regnode * const nxt1 = nxt;
3893 #ifdef DEBUGGING
3894                     regnode *nxt2;
3895 #endif
3896
3897                     /* Skip open. */
3898                     nxt = regnext(nxt);
3899                     if (!REGNODE_SIMPLE(OP(nxt))
3900                         && !(PL_regkind[OP(nxt)] == EXACT
3901                              && STR_LEN(nxt) == 1))
3902                         goto nogo;
3903 #ifdef DEBUGGING
3904                     nxt2 = nxt;
3905 #endif
3906                     nxt = regnext(nxt);
3907                     if (OP(nxt) != CLOSE)
3908                         goto nogo;
3909                     if (RExC_open_parens) {
3910                         RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3911                         RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
3912                     }
3913                     /* Now we know that nxt2 is the only contents: */
3914                     oscan->flags = (U8)ARG(nxt);
3915                     OP(oscan) = CURLYN;
3916                     OP(nxt1) = NOTHING; /* was OPEN. */
3917
3918 #ifdef DEBUGGING
3919                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3920                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
3921                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
3922                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
3923                     OP(nxt + 1) = OPTIMIZED; /* was count. */
3924                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
3925 #endif
3926                 }
3927               nogo:
3928
3929                 /* Try optimization CURLYX => CURLYM. */
3930                 if (  OP(oscan) == CURLYX && data
3931                       && !(data->flags & SF_HAS_PAR)
3932                       && !(data->flags & SF_HAS_EVAL)
3933                       && !deltanext     /* atom is fixed width */
3934                       && minnext != 0   /* CURLYM can't handle zero width */
3935                       && ! (RExC_seen & REG_SEEN_EXACTF_SHARP_S) /* Nor \xDF */
3936                 ) {
3937                     /* XXXX How to optimize if data == 0? */
3938                     /* Optimize to a simpler form.  */
3939                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
3940                     regnode *nxt2;
3941
3942                     OP(oscan) = CURLYM;
3943                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
3944                             && (OP(nxt2) != WHILEM))
3945                         nxt = nxt2;
3946                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
3947                     /* Need to optimize away parenths. */
3948                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
3949                         /* Set the parenth number.  */
3950                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
3951
3952                         oscan->flags = (U8)ARG(nxt);
3953                         if (RExC_open_parens) {
3954                             RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3955                             RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
3956                         }
3957                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
3958                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
3959
3960 #ifdef DEBUGGING
3961                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3962                         OP(nxt + 1) = OPTIMIZED; /* was count. */
3963                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
3964                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
3965 #endif
3966 #if 0
3967                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
3968                             regnode *nnxt = regnext(nxt1);
3969                             if (nnxt == nxt) {
3970                                 if (reg_off_by_arg[OP(nxt1)])
3971                                     ARG_SET(nxt1, nxt2 - nxt1);
3972                                 else if (nxt2 - nxt1 < U16_MAX)
3973                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
3974                                 else
3975                                     OP(nxt) = NOTHING;  /* Cannot beautify */
3976                             }
3977                             nxt1 = nnxt;
3978                         }
3979 #endif
3980                         /* Optimize again: */
3981                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
3982                                     NULL, stopparen, recursed, NULL, 0,depth+1);
3983                     }
3984                     else
3985                         oscan->flags = 0;
3986                 }
3987                 else if ((OP(oscan) == CURLYX)
3988                          && (flags & SCF_WHILEM_VISITED_POS)
3989                          /* See the comment on a similar expression above.
3990                             However, this time it's not a subexpression
3991                             we care about, but the expression itself. */
3992                          && (maxcount == REG_INFTY)
3993                          && data && ++data->whilem_c < 16) {
3994                     /* This stays as CURLYX, we can put the count/of pair. */
3995                     /* Find WHILEM (as in regexec.c) */
3996                     regnode *nxt = oscan + NEXT_OFF(oscan);
3997
3998                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
3999                         nxt += ARG(nxt);
4000                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
4001                         | (RExC_whilem_seen << 4)); /* On WHILEM */
4002                 }
4003                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
4004                     pars++;
4005                 if (flags & SCF_DO_SUBSTR) {
4006                     SV *last_str = NULL;
4007                     int counted = mincount != 0;
4008
4009                     if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
4010 #if defined(SPARC64_GCC_WORKAROUND)
4011                         I32 b = 0;
4012                         STRLEN l = 0;
4013                         const char *s = NULL;
4014                         I32 old = 0;
4015
4016                         if (pos_before >= data->last_start_min)
4017                             b = pos_before;
4018                         else
4019                             b = data->last_start_min;
4020
4021                         l = 0;
4022                         s = SvPV_const(data->last_found, l);
4023                         old = b - data->last_start_min;
4024
4025 #else
4026                         I32 b = pos_before >= data->last_start_min
4027                             ? pos_before : data->last_start_min;
4028                         STRLEN l;
4029                         const char * const s = SvPV_const(data->last_found, l);
4030                         I32 old = b - data->last_start_min;
4031 #endif
4032
4033                         if (UTF)
4034                             old = utf8_hop((U8*)s, old) - (U8*)s;
4035                         l -= old;
4036                         /* Get the added string: */
4037                         last_str = newSVpvn_utf8(s  + old, l, UTF);
4038                         if (deltanext == 0 && pos_before == b) {
4039                             /* What was added is a constant string */
4040                             if (mincount > 1) {
4041                                 SvGROW(last_str, (mincount * l) + 1);
4042                                 repeatcpy(SvPVX(last_str) + l,
4043                                           SvPVX_const(last_str), l, mincount - 1);
4044                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
4045                                 /* Add additional parts. */
4046                                 SvCUR_set(data->last_found,
4047                                           SvCUR(data->last_found) - l);
4048                                 sv_catsv(data->last_found, last_str);
4049                                 {
4050                                     SV * sv = data->last_found;
4051                                     MAGIC *mg =
4052                                         SvUTF8(sv) && SvMAGICAL(sv) ?
4053                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
4054                                     if (mg && mg->mg_len >= 0)
4055                                         mg->mg_len += CHR_SVLEN(last_str) - l;
4056                                 }
4057                                 data->last_end += l * (mincount - 1);
4058                             }
4059                         } else {
4060                             /* start offset must point into the last copy */
4061                             data->last_start_min += minnext * (mincount - 1);
4062                             data->last_start_max += is_inf ? I32_MAX
4063                                 : (maxcount - 1) * (minnext + data->pos_delta);
4064                         }
4065                     }
4066                     /* It is counted once already... */
4067                     data->pos_min += minnext * (mincount - counted);
4068                     data->pos_delta += - counted * deltanext +
4069                         (minnext + deltanext) * maxcount - minnext * mincount;
4070                     if (mincount != maxcount) {
4071                          /* Cannot extend fixed substrings found inside
4072                             the group.  */
4073                         SCAN_COMMIT(pRExC_state,data,minlenp);
4074                         if (mincount && last_str) {
4075                             SV * const sv = data->last_found;
4076                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4077                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
4078
4079                             if (mg)
4080                                 mg->mg_len = -1;
4081                             sv_setsv(sv, last_str);
4082                             data->last_end = data->pos_min;
4083                             data->last_start_min =
4084                                 data->pos_min - CHR_SVLEN(last_str);
4085                             data->last_start_max = is_inf
4086                                 ? I32_MAX
4087                                 : data->pos_min + data->pos_delta
4088                                 - CHR_SVLEN(last_str);
4089                         }
4090                         data->longest = &(data->longest_float);
4091                     }
4092                     SvREFCNT_dec(last_str);
4093                 }
4094                 if (data && (fl & SF_HAS_EVAL))
4095                     data->flags |= SF_HAS_EVAL;
4096               optimize_curly_tail:
4097                 if (OP(oscan) != CURLYX) {
4098                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
4099                            && NEXT_OFF(next))
4100                         NEXT_OFF(oscan) += NEXT_OFF(next);
4101                 }
4102                 continue;
4103             default:                    /* REF, ANYOFV, and CLUMP only? */
4104                 if (flags & SCF_DO_SUBSTR) {
4105                     SCAN_COMMIT(pRExC_state,data,minlenp);      /* Cannot expect anything... */
4106                     data->longest = &(data->longest_float);
4107                 }
4108                 is_inf = is_inf_internal = 1;
4109                 if (flags & SCF_DO_STCLASS_OR)
4110                     cl_anything(pRExC_state, data->start_class);
4111                 flags &= ~SCF_DO_STCLASS;
4112                 break;
4113             }
4114         }
4115         else if (OP(scan) == LNBREAK) {
4116             if (flags & SCF_DO_STCLASS) {
4117                 int value = 0;
4118                 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
4119                 if (flags & SCF_DO_STCLASS_AND) {
4120                     for (value = 0; value < 256; value++)
4121                         if (!is_VERTWS_cp(value))
4122                             ANYOF_BITMAP_CLEAR(data->start_class, value);
4123                 }
4124                 else {
4125                     for (value = 0; value < 256; value++)
4126                         if (is_VERTWS_cp(value))
4127                             ANYOF_BITMAP_SET(data->start_class, value);
4128                 }
4129                 if (flags & SCF_DO_STCLASS_OR)
4130                     cl_and(data->start_class, and_withp);
4131                 flags &= ~SCF_DO_STCLASS;
4132             }
4133             min++;
4134             delta++;    /* Because of the 2 char string cr-lf */
4135             if (flags & SCF_DO_SUBSTR) {
4136                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
4137                 data->pos_min += 1;
4138                 data->pos_delta += 1;
4139                 data->longest = &(data->longest_float);
4140             }
4141         }
4142         else if (REGNODE_SIMPLE(OP(scan))) {
4143             int value = 0;
4144
4145             if (flags & SCF_DO_SUBSTR) {
4146                 SCAN_COMMIT(pRExC_state,data,minlenp);
4147                 data->pos_min++;
4148             }
4149             min++;
4150             if (flags & SCF_DO_STCLASS) {
4151                 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
4152
4153                 /* Some of the logic below assumes that switching
4154                    locale on will only add false positives. */
4155                 switch (PL_regkind[OP(scan)]) {
4156                 case SANY:
4157                 default:
4158                   do_default:
4159                     /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
4160                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4161                         cl_anything(pRExC_state, data->start_class);
4162                     break;
4163                 case REG_ANY:
4164                     if (OP(scan) == SANY)
4165                         goto do_default;
4166                     if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
4167                         value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
4168                                  || ANYOF_CLASS_TEST_ANY_SET(data->start_class));
4169                         cl_anything(pRExC_state, data->start_class);
4170                     }
4171                     if (flags & SCF_DO_STCLASS_AND || !value)
4172                         ANYOF_BITMAP_CLEAR(data->start_class,'\n');
4173                     break;
4174                 case ANYOF:
4175                     if (flags & SCF_DO_STCLASS_AND)
4176                         cl_and(data->start_class,
4177                                (struct regnode_charclass_class*)scan);
4178                     else
4179                         cl_or(pRExC_state, data->start_class,
4180                               (struct regnode_charclass_class*)scan);
4181                     break;
4182                 case ALNUM:
4183                     if (flags & SCF_DO_STCLASS_AND) {
4184                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
4185                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NWORDCHAR);
4186                             if (OP(scan) == ALNUMU) {
4187                                 for (value = 0; value < 256; value++) {
4188                                     if (!isWORDCHAR_L1(value)) {
4189                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4190                                     }
4191                                 }
4192                             } else {
4193                                 for (value = 0; value < 256; value++) {
4194                                     if (!isALNUM(value)) {
4195                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4196                                     }
4197                                 }
4198                             }
4199                         }
4200                     }
4201                     else {
4202                         if (data->start_class->flags & ANYOF_LOCALE)
4203                             ANYOF_CLASS_SET(data->start_class,ANYOF_WORDCHAR);
4204
4205                         /* Even if under locale, set the bits for non-locale
4206                          * in case it isn't a true locale-node.  This will
4207                          * create false positives if it truly is locale */
4208                         if (OP(scan) == ALNUMU) {
4209                             for (value = 0; value < 256; value++) {
4210                                 if (isWORDCHAR_L1(value)) {
4211                                     ANYOF_BITMAP_SET(data->start_class, value);
4212                                 }
4213                             }
4214                         } else {
4215                             for (value = 0; value < 256; value++) {
4216                                 if (isALNUM(value)) {
4217                                     ANYOF_BITMAP_SET(data->start_class, value);
4218                                 }
4219                             }
4220                         }
4221                     }
4222                     break;
4223                 case NALNUM:
4224                     if (flags & SCF_DO_STCLASS_AND) {
4225                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
4226                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_WORDCHAR);
4227                             if (OP(scan) == NALNUMU) {
4228                                 for (value = 0; value < 256; value++) {
4229                                     if (isWORDCHAR_L1(value)) {
4230                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4231                                     }
4232                                 }
4233                             } else {
4234                                 for (value = 0; value < 256; value++) {
4235                                     if (isALNUM(value)) {
4236                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4237                                     }
4238                                 }
4239                             }
4240                         }
4241                     }
4242                     else {
4243                         if (data->start_class->flags & ANYOF_LOCALE)
4244                             ANYOF_CLASS_SET(data->start_class,ANYOF_NWORDCHAR);
4245
4246                         /* Even if under locale, set the bits for non-locale in
4247                          * case it isn't a true locale-node.  This will create
4248                          * false positives if it truly is locale */
4249                         if (OP(scan) == NALNUMU) {
4250                             for (value = 0; value < 256; value++) {
4251                                 if (! isWORDCHAR_L1(value)) {
4252                                     ANYOF_BITMAP_SET(data->start_class, value);
4253                                 }
4254                             }
4255                         } else {
4256                             for (value = 0; value < 256; value++) {
4257                                 if (! isALNUM(value)) {
4258                                     ANYOF_BITMAP_SET(data->start_class, value);
4259                                 }
4260                             }
4261                         }
4262                     }
4263                     break;
4264                 case SPACE:
4265                     if (flags & SCF_DO_STCLASS_AND) {
4266                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
4267                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
4268                             if (OP(scan) == SPACEU) {
4269                                 for (value = 0; value < 256; value++) {
4270                                     if (!isSPACE_L1(value)) {
4271                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4272                                     }
4273                                 }
4274                             } else {
4275                                 for (value = 0; value < 256; value++) {
4276                                     if (!isSPACE(value)) {
4277                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4278                                     }
4279                                 }
4280                             }
4281                         }
4282                     }
4283                     else {
4284                         if (data->start_class->flags & ANYOF_LOCALE) {
4285                             ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
4286                         }
4287                         if (OP(scan) == SPACEU) {
4288                             for (value = 0; value < 256; value++) {
4289                                 if (isSPACE_L1(value)) {
4290                                     ANYOF_BITMAP_SET(data->start_class, value);
4291                                 }
4292                             }
4293                         } else {
4294                             for (value = 0; value < 256; value++) {
4295                                 if (isSPACE(value)) {
4296                                     ANYOF_BITMAP_SET(data->start_class, value);
4297                                 }
4298                             }
4299                         }
4300                     }
4301                     break;
4302                 case NSPACE:
4303                     if (flags & SCF_DO_STCLASS_AND) {
4304                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
4305                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
4306                             if (OP(scan) == NSPACEU) {
4307                                 for (value = 0; value < 256; value++) {
4308                                     if (isSPACE_L1(value)) {
4309                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4310                                     }
4311                                 }
4312                             } else {
4313                                 for (value = 0; value < 256; value++) {
4314                                     if (isSPACE(value)) {
4315                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4316                                     }
4317                                 }
4318                             }
4319                         }
4320                     }
4321                     else {
4322                         if (data->start_class->flags & ANYOF_LOCALE)
4323                             ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
4324                         if (OP(scan) == NSPACEU) {
4325                             for (value = 0; value < 256; value++) {
4326                                 if (!isSPACE_L1(value)) {
4327                                     ANYOF_BITMAP_SET(data->start_class, value);
4328                                 }
4329                             }
4330                         }
4331                         else {
4332                             for (value = 0; value < 256; value++) {
4333                                 if (!isSPACE(value)) {
4334                                     ANYOF_BITMAP_SET(data->start_class, value);
4335                                 }
4336                             }
4337                         }
4338                     }
4339                     break;
4340                 case DIGIT:
4341                     if (flags & SCF_DO_STCLASS_AND) {
4342                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
4343                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
4344                             for (value = 0; value < 256; value++)
4345                                 if (!isDIGIT(value))
4346                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
4347                         }
4348                     }
4349                     else {
4350                         if (data->start_class->flags & ANYOF_LOCALE)
4351                             ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
4352                         for (value = 0; value < 256; value++)
4353                             if (isDIGIT(value))
4354                                 ANYOF_BITMAP_SET(data->start_class, value);
4355                     }
4356                     break;
4357                 case NDIGIT:
4358                     if (flags & SCF_DO_STCLASS_AND) {
4359                         if (!(data->start_class->flags & ANYOF_LOCALE))
4360                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
4361                         for (value = 0; value < 256; value++)
4362                             if (isDIGIT(value))
4363                                 ANYOF_BITMAP_CLEAR(data->start_class, value);
4364                     }
4365                     else {
4366                         if (data->start_class->flags & ANYOF_LOCALE)
4367                             ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
4368                         for (value = 0; value < 256; value++)
4369                             if (!isDIGIT(value))
4370                                 ANYOF_BITMAP_SET(data->start_class, value);
4371                     }
4372                     break;
4373                 CASE_SYNST_FNC(VERTWS);
4374                 CASE_SYNST_FNC(HORIZWS);
4375
4376                 }
4377                 if (flags & SCF_DO_STCLASS_OR)
4378                     cl_and(data->start_class, and_withp);
4379                 flags &= ~SCF_DO_STCLASS;
4380             }
4381         }
4382         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
4383             data->flags |= (OP(scan) == MEOL
4384                             ? SF_BEFORE_MEOL
4385                             : SF_BEFORE_SEOL);
4386             SCAN_COMMIT(pRExC_state, data, minlenp);
4387
4388         }
4389         else if (  PL_regkind[OP(scan)] == BRANCHJ
4390                  /* Lookbehind, or need to calculate parens/evals/stclass: */
4391                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
4392                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
4393             if ( OP(scan) == UNLESSM &&
4394                  scan->flags == 0 &&
4395                  OP(NEXTOPER(NEXTOPER(scan))) == NOTHING &&
4396                  OP(regnext(NEXTOPER(NEXTOPER(scan)))) == SUCCEED
4397             ) {
4398                 regnode *opt;
4399                 regnode *upto= regnext(scan);
4400                 DEBUG_PARSE_r({
4401                     SV * const mysv_val=sv_newmortal();
4402                     DEBUG_STUDYDATA("OPFAIL",data,depth);
4403
4404                     /*DEBUG_PARSE_MSG("opfail");*/
4405                     regprop(RExC_rx, mysv_val, upto);
4406                     PerlIO_printf(Perl_debug_log, "~ replace with OPFAIL pointed at %s (%"IVdf") offset %"IVdf"\n",
4407                                   SvPV_nolen_const(mysv_val),
4408                                   (IV)REG_NODE_NUM(upto),
4409                                   (IV)(upto - scan)
4410                     );
4411                 });
4412                 OP(scan) = OPFAIL;
4413                 NEXT_OFF(scan) = upto - scan;
4414                 for (opt= scan + 1; opt < upto ; opt++)
4415                     OP(opt) = OPTIMIZED;
4416                 scan= upto;
4417                 continue;
4418             }
4419             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY 
4420                 || OP(scan) == UNLESSM )
4421             {
4422                 /* Negative Lookahead/lookbehind
4423                    In this case we can't do fixed string optimisation.
4424                 */
4425
4426                 I32 deltanext, minnext, fake = 0;
4427                 regnode *nscan;
4428                 struct regnode_charclass_class intrnl;
4429                 int f = 0;
4430
4431                 data_fake.flags = 0;
4432                 if (data) {
4433                     data_fake.whilem_c = data->whilem_c;
4434                     data_fake.last_closep = data->last_closep;
4435                 }
4436                 else
4437                     data_fake.last_closep = &fake;
4438                 data_fake.pos_delta = delta;
4439                 if ( flags & SCF_DO_STCLASS && !scan->flags
4440                      && OP(scan) == IFMATCH ) { /* Lookahead */
4441                     cl_init(pRExC_state, &intrnl);
4442                     data_fake.start_class = &intrnl;
4443                     f |= SCF_DO_STCLASS_AND;
4444                 }
4445                 if (flags & SCF_WHILEM_VISITED_POS)
4446                     f |= SCF_WHILEM_VISITED_POS;
4447                 next = regnext(scan);
4448                 nscan = NEXTOPER(NEXTOPER(scan));
4449                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext, 
4450                     last, &data_fake, stopparen, recursed, NULL, f, depth+1);
4451                 if (scan->flags) {
4452                     if (deltanext) {
4453                         FAIL("Variable length lookbehind not implemented");
4454                     }
4455                     else if (minnext > (I32)U8_MAX) {
4456                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4457                     }
4458                     scan->flags = (U8)minnext;
4459                 }
4460                 if (data) {
4461                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4462                         pars++;
4463                     if (data_fake.flags & SF_HAS_EVAL)
4464                         data->flags |= SF_HAS_EVAL;
4465                     data->whilem_c = data_fake.whilem_c;
4466                 }
4467                 if (f & SCF_DO_STCLASS_AND) {
4468                     if (flags & SCF_DO_STCLASS_OR) {
4469                         /* OR before, AND after: ideally we would recurse with
4470                          * data_fake to get the AND applied by study of the
4471                          * remainder of the pattern, and then derecurse;
4472                          * *** HACK *** for now just treat as "no information".
4473                          * See [perl #56690].
4474                          */
4475                         cl_init(pRExC_state, data->start_class);
4476                     }  else {
4477                         /* AND before and after: combine and continue */
4478                         const int was = (data->start_class->flags & ANYOF_EOS);
4479
4480                         cl_and(data->start_class, &intrnl);
4481                         if (was)
4482                             data->start_class->flags |= ANYOF_EOS;
4483                     }
4484                 }
4485             }
4486 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
4487             else {
4488                 /* Positive Lookahead/lookbehind
4489                    In this case we can do fixed string optimisation,
4490                    but we must be careful about it. Note in the case of
4491                    lookbehind the positions will be offset by the minimum
4492                    length of the pattern, something we won't know about
4493                    until after the recurse.
4494                 */
4495                 I32 deltanext, fake = 0;
4496                 regnode *nscan;
4497                 struct regnode_charclass_class intrnl;
4498                 int f = 0;
4499                 /* We use SAVEFREEPV so that when the full compile 
4500                     is finished perl will clean up the allocated 
4501                     minlens when it's all done. This way we don't
4502                     have to worry about freeing them when we know
4503                     they wont be used, which would be a pain.
4504                  */
4505                 I32 *minnextp;
4506                 Newx( minnextp, 1, I32 );
4507                 SAVEFREEPV(minnextp);
4508
4509                 if (data) {
4510                     StructCopy(data, &data_fake, scan_data_t);
4511                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
4512                         f |= SCF_DO_SUBSTR;
4513                         if (scan->flags) 
4514                             SCAN_COMMIT(pRExC_state, &data_fake,minlenp);
4515                         data_fake.last_found=newSVsv(data->last_found);
4516                     }
4517                 }
4518                 else
4519                     data_fake.last_closep = &fake;
4520                 data_fake.flags = 0;
4521                 data_fake.pos_delta = delta;
4522                 if (is_inf)
4523                     data_fake.flags |= SF_IS_INF;
4524                 if ( flags & SCF_DO_STCLASS && !scan->flags
4525                      && OP(scan) == IFMATCH ) { /* Lookahead */
4526                     cl_init(pRExC_state, &intrnl);
4527                     data_fake.start_class = &intrnl;
4528                     f |= SCF_DO_STCLASS_AND;
4529                 }
4530                 if (flags & SCF_WHILEM_VISITED_POS)
4531                     f |= SCF_WHILEM_VISITED_POS;
4532                 next = regnext(scan);
4533                 nscan = NEXTOPER(NEXTOPER(scan));
4534
4535                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext, 
4536                     last, &data_fake, stopparen, recursed, NULL, f,depth+1);
4537                 if (scan->flags) {
4538                     if (deltanext) {
4539                         FAIL("Variable length lookbehind not implemented");
4540                     }
4541                     else if (*minnextp > (I32)U8_MAX) {
4542                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4543                     }
4544                     scan->flags = (U8)*minnextp;
4545                 }
4546
4547                 *minnextp += min;
4548
4549                 if (f & SCF_DO_STCLASS_AND) {
4550                     const int was = (data->start_class->flags & ANYOF_EOS);
4551
4552                     cl_and(data->start_class, &intrnl);
4553                     if (was)
4554                         data->start_class->flags |= ANYOF_EOS;
4555                 }
4556                 if (data) {
4557                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4558                         pars++;
4559                     if (data_fake.flags & SF_HAS_EVAL)
4560                         data->flags |= SF_HAS_EVAL;
4561                     data->whilem_c = data_fake.whilem_c;
4562                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
4563                         if (RExC_rx->minlen<*minnextp)
4564                             RExC_rx->minlen=*minnextp;
4565                         SCAN_COMMIT(pRExC_state, &data_fake, minnextp);
4566                         SvREFCNT_dec(data_fake.last_found);
4567                         
4568                         if ( data_fake.minlen_fixed != minlenp ) 
4569                         {
4570                             data->offset_fixed= data_fake.offset_fixed;
4571                             data->minlen_fixed= data_fake.minlen_fixed;
4572                             data->lookbehind_fixed+= scan->flags;
4573                         }
4574                         if ( data_fake.minlen_float != minlenp )
4575                         {
4576                             data->minlen_float= data_fake.minlen_float;
4577                             data->offset_float_min=data_fake.offset_float_min;
4578                             data->offset_float_max=data_fake.offset_float_max;
4579                             data->lookbehind_float+= scan->flags;
4580                         }
4581                     }
4582                 }
4583             }
4584 #endif
4585         }
4586         else if (OP(scan) == OPEN) {
4587             if (stopparen != (I32)ARG(scan))
4588                 pars++;
4589         }
4590         else if (OP(scan) == CLOSE) {
4591             if (stopparen == (I32)ARG(scan)) {
4592                 break;
4593             }
4594             if ((I32)ARG(scan) == is_par) {
4595                 next = regnext(scan);
4596
4597                 if ( next && (OP(next) != WHILEM) && next < last)
4598                     is_par = 0;         /* Disable optimization */
4599             }
4600             if (data)
4601                 *(data->last_closep) = ARG(scan);
4602         }
4603         else if (OP(scan) == EVAL) {
4604                 if (data)
4605                     data->flags |= SF_HAS_EVAL;
4606         }
4607         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
4608             if (flags & SCF_DO_SUBSTR) {
4609                 SCAN_COMMIT(pRExC_state,data,minlenp);
4610                 flags &= ~SCF_DO_SUBSTR;
4611             }
4612             if (data && OP(scan)==ACCEPT) {
4613                 data->flags |= SCF_SEEN_ACCEPT;
4614                 if (stopmin > min)
4615                     stopmin = min;
4616             }
4617         }
4618         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
4619         {
4620                 if (flags & SCF_DO_SUBSTR) {
4621                     SCAN_COMMIT(pRExC_state,data,minlenp);
4622                     data->longest = &(data->longest_float);
4623                 }
4624                 is_inf = is_inf_internal = 1;
4625                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4626                     cl_anything(pRExC_state, data->start_class);
4627                 flags &= ~SCF_DO_STCLASS;
4628         }
4629         else if (OP(scan) == GPOS) {
4630             if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) &&
4631                 !(delta || is_inf || (data && data->pos_delta))) 
4632             {
4633                 if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR))
4634                     RExC_rx->extflags |= RXf_ANCH_GPOS;
4635                 if (RExC_rx->gofs < (U32)min)
4636                     RExC_rx->gofs = min;
4637             } else {
4638                 RExC_rx->extflags |= RXf_GPOS_FLOAT;
4639                 RExC_rx->gofs = 0;
4640             }       
4641         }
4642 #ifdef TRIE_STUDY_OPT
4643 #ifdef FULL_TRIE_STUDY
4644         else if (PL_regkind[OP(scan)] == TRIE) {
4645             /* NOTE - There is similar code to this block above for handling
4646                BRANCH nodes on the initial study.  If you change stuff here
4647                check there too. */
4648             regnode *trie_node= scan;
4649             regnode *tail= regnext(scan);
4650             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4651             I32 max1 = 0, min1 = I32_MAX;
4652             struct regnode_charclass_class accum;
4653
4654             if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
4655                 SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
4656             if (flags & SCF_DO_STCLASS)
4657                 cl_init_zero(pRExC_state, &accum);
4658                 
4659             if (!trie->jump) {
4660                 min1= trie->minlen;
4661                 max1= trie->maxlen;
4662             } else {
4663                 const regnode *nextbranch= NULL;
4664                 U32 word;
4665                 
4666                 for ( word=1 ; word <= trie->wordcount ; word++) 
4667                 {
4668                     I32 deltanext=0, minnext=0, f = 0, fake;
4669                     struct regnode_charclass_class this_class;
4670                     
4671                     data_fake.flags = 0;
4672                     if (data) {
4673                         data_fake.whilem_c = data->whilem_c;
4674                         data_fake.last_closep = data->last_closep;
4675                     }
4676                     else
4677                         data_fake.last_closep = &fake;
4678                     data_fake.pos_delta = delta;
4679                     if (flags & SCF_DO_STCLASS) {
4680                         cl_init(pRExC_state, &this_class);
4681                         data_fake.start_class = &this_class;
4682                         f = SCF_DO_STCLASS_AND;
4683                     }
4684                     if (flags & SCF_WHILEM_VISITED_POS)
4685                         f |= SCF_WHILEM_VISITED_POS;
4686     
4687                     if (trie->jump[word]) {
4688                         if (!nextbranch)
4689                             nextbranch = trie_node + trie->jump[0];
4690                         scan= trie_node + trie->jump[word];
4691                         /* We go from the jump point to the branch that follows
4692                            it. Note this means we need the vestigal unused branches
4693                            even though they arent otherwise used.
4694                          */
4695                         minnext = study_chunk(pRExC_state, &scan, minlenp, 
4696                             &deltanext, (regnode *)nextbranch, &data_fake, 
4697                             stopparen, recursed, NULL, f,depth+1);
4698                     }
4699                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
4700                         nextbranch= regnext((regnode*)nextbranch);
4701                     
4702                     if (min1 > (I32)(minnext + trie->minlen))
4703                         min1 = minnext + trie->minlen;
4704                     if (max1 < (I32)(minnext + deltanext + trie->maxlen))
4705                         max1 = minnext + deltanext + trie->maxlen;
4706                     if (deltanext == I32_MAX)
4707                         is_inf = is_inf_internal = 1;
4708                     
4709                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4710                         pars++;
4711                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4712                         if ( stopmin > min + min1) 
4713                             stopmin = min + min1;
4714                         flags &= ~SCF_DO_SUBSTR;
4715                         if (data)
4716                             data->flags |= SCF_SEEN_ACCEPT;
4717                     }
4718                     if (data) {
4719                         if (data_fake.flags & SF_HAS_EVAL)
4720                             data->flags |= SF_HAS_EVAL;
4721                         data->whilem_c = data_fake.whilem_c;
4722                     }
4723                     if (flags & SCF_DO_STCLASS)
4724                         cl_or(pRExC_state, &accum, &this_class);
4725                 }
4726             }
4727             if (flags & SCF_DO_SUBSTR) {
4728                 data->pos_min += min1;
4729                 data->pos_delta += max1 - min1;
4730                 if (max1 != min1 || is_inf)
4731                     data->longest = &(data->longest_float);
4732             }
4733             min += min1;
4734             delta += max1 - min1;
4735             if (flags & SCF_DO_STCLASS_OR) {
4736                 cl_or(pRExC_state, data->start_class, &accum);
4737                 if (min1) {
4738                     cl_and(data->start_class, and_withp);
4739                     flags &= ~SCF_DO_STCLASS;
4740                 }
4741             }
4742             else if (flags & SCF_DO_STCLASS_AND) {
4743                 if (min1) {
4744                     cl_and(data->start_class, &accum);
4745                     flags &= ~SCF_DO_STCLASS;
4746                 }
4747                 else {
4748                     /* Switch to OR mode: cache the old value of
4749                      * data->start_class */
4750                     INIT_AND_WITHP;
4751                     StructCopy(data->start_class, and_withp,
4752                                struct regnode_charclass_class);
4753                     flags &= ~SCF_DO_STCLASS_AND;
4754                     StructCopy(&accum, data->start_class,
4755                                struct regnode_charclass_class);
4756                     flags |= SCF_DO_STCLASS_OR;
4757                     data->start_class->flags |= ANYOF_EOS;
4758                 }
4759             }
4760             scan= tail;
4761             continue;
4762         }
4763 #else
4764         else if (PL_regkind[OP(scan)] == TRIE) {
4765             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4766             U8*bang=NULL;
4767             
4768             min += trie->minlen;
4769             delta += (trie->maxlen - trie->minlen);
4770             flags &= ~SCF_DO_STCLASS; /* xxx */
4771             if (flags & SCF_DO_SUBSTR) {
4772                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
4773                 data->pos_min += trie->minlen;
4774                 data->pos_delta += (trie->maxlen - trie->minlen);
4775                 if (trie->maxlen != trie->minlen)
4776                     data->longest = &(data->longest_float);
4777             }
4778             if (trie->jump) /* no more substrings -- for now /grr*/
4779                 flags &= ~SCF_DO_SUBSTR; 
4780         }
4781 #endif /* old or new */
4782 #endif /* TRIE_STUDY_OPT */
4783
4784         /* Else: zero-length, ignore. */
4785         scan = regnext(scan);
4786     }
4787     if (frame) {
4788         last = frame->last;
4789         scan = frame->next;
4790         stopparen = frame->stop;
4791         frame = frame->prev;
4792         goto fake_study_recurse;
4793     }
4794
4795   finish:
4796     assert(!frame);
4797     DEBUG_STUDYDATA("pre-fin:",data,depth);
4798
4799     *scanp = scan;
4800     *deltap = is_inf_internal ? I32_MAX : delta;
4801     if (flags & SCF_DO_SUBSTR && is_inf)
4802         data->pos_delta = I32_MAX - data->pos_min;
4803     if (is_par > (I32)U8_MAX)
4804         is_par = 0;
4805     if (is_par && pars==1 && data) {
4806         data->flags |= SF_IN_PAR;
4807         data->flags &= ~SF_HAS_PAR;
4808     }
4809     else if (pars && data) {
4810         data->flags |= SF_HAS_PAR;
4811         data->flags &= ~SF_IN_PAR;
4812     }
4813     if (flags & SCF_DO_STCLASS_OR)
4814         cl_and(data->start_class, and_withp);
4815     if (flags & SCF_TRIE_RESTUDY)
4816         data->flags |=  SCF_TRIE_RESTUDY;
4817     
4818     DEBUG_STUDYDATA("post-fin:",data,depth);
4819     
4820     return min < stopmin ? min : stopmin;
4821 }
4822
4823 STATIC U32
4824 S_add_data(RExC_state_t *pRExC_state, U32 n, const char *s)
4825 {
4826     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
4827
4828     PERL_ARGS_ASSERT_ADD_DATA;
4829
4830     Renewc(RExC_rxi->data,
4831            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
4832            char, struct reg_data);
4833     if(count)
4834         Renew(RExC_rxi->data->what, count + n, U8);
4835     else
4836         Newx(RExC_rxi->data->what, n, U8);
4837     RExC_rxi->data->count = count + n;
4838     Copy(s, RExC_rxi->data->what + count, n, U8);
4839     return count;
4840 }
4841
4842 /*XXX: todo make this not included in a non debugging perl */
4843 #ifndef PERL_IN_XSUB_RE
4844 void
4845 Perl_reginitcolors(pTHX)
4846 {
4847     dVAR;
4848     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
4849     if (s) {
4850         char *t = savepv(s);
4851         int i = 0;
4852         PL_colors[0] = t;
4853         while (++i < 6) {
4854             t = strchr(t, '\t');
4855             if (t) {
4856                 *t = '\0';
4857                 PL_colors[i] = ++t;
4858             }
4859             else
4860                 PL_colors[i] = t = (char *)"";
4861         }
4862     } else {
4863         int i = 0;
4864         while (i < 6)
4865             PL_colors[i++] = (char *)"";
4866     }
4867     PL_colorset = 1;
4868 }
4869 #endif
4870
4871
4872 #ifdef TRIE_STUDY_OPT
4873 #define CHECK_RESTUDY_GOTO_butfirst(dOsomething)            \
4874     STMT_START {                                            \
4875         if (                                                \
4876               (data.flags & SCF_TRIE_RESTUDY)               \
4877               && ! restudied++                              \
4878         ) {                                                 \
4879             dOsomething;                                    \
4880             goto reStudy;                                   \
4881         }                                                   \
4882     } STMT_END
4883 #else
4884 #define CHECK_RESTUDY_GOTO_butfirst
4885 #endif        
4886
4887 /*
4888  * pregcomp - compile a regular expression into internal code
4889  *
4890  * Decides which engine's compiler to call based on the hint currently in
4891  * scope
4892  */
4893
4894 #ifndef PERL_IN_XSUB_RE 
4895
4896 /* return the currently in-scope regex engine (or the default if none)  */
4897
4898 regexp_engine const *
4899 Perl_current_re_engine(pTHX)
4900 {
4901     dVAR;
4902
4903     if (IN_PERL_COMPILETIME) {
4904         HV * const table = GvHV(PL_hintgv);
4905         SV **ptr;
4906
4907         if (!table)
4908             return &reh_regexp_engine;
4909         ptr = hv_fetchs(table, "regcomp", FALSE);
4910         if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
4911             return &reh_regexp_engine;
4912         return INT2PTR(regexp_engine*,SvIV(*ptr));
4913     }
4914     else {
4915         SV *ptr;
4916         if (!PL_curcop->cop_hints_hash)
4917             return &reh_regexp_engine;
4918         ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
4919         if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
4920             return &reh_regexp_engine;
4921         return INT2PTR(regexp_engine*,SvIV(ptr));
4922     }
4923 }
4924
4925
4926 REGEXP *
4927 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
4928 {
4929     dVAR;
4930     regexp_engine const *eng = current_re_engine();
4931     GET_RE_DEBUG_FLAGS_DECL;
4932
4933     PERL_ARGS_ASSERT_PREGCOMP;
4934
4935     /* Dispatch a request to compile a regexp to correct regexp engine. */
4936     DEBUG_COMPILE_r({
4937         PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
4938                         PTR2UV(eng));
4939     });
4940     return CALLREGCOMP_ENG(eng, pattern, flags);
4941 }
4942 #endif
4943
4944 /* public(ish) entry point for the perl core's own regex compiling code.
4945  * It's actually a wrapper for Perl_re_op_compile that only takes an SV
4946  * pattern rather than a list of OPs, and uses the internal engine rather
4947  * than the current one */
4948
4949 REGEXP *
4950 Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
4951 {
4952     SV *pat = pattern; /* defeat constness! */
4953     PERL_ARGS_ASSERT_RE_COMPILE;
4954     return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
4955 #ifdef PERL_IN_XSUB_RE
4956                                 &my_reg_engine,
4957 #else
4958                                 &reh_regexp_engine,
4959 #endif
4960                                 NULL, NULL, rx_flags, 0);
4961 }
4962
4963 /* see if there are any run-time code blocks in the pattern.
4964  * False positives are allowed */
4965
4966 static bool
4967 S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state, OP *expr,
4968                     U32 pm_flags, char *pat, STRLEN plen)
4969 {
4970     int n = 0;
4971     STRLEN s;
4972
4973     /* avoid infinitely recursing when we recompile the pattern parcelled up
4974      * as qr'...'. A single constant qr// string can't have have any
4975      * run-time component in it, and thus, no runtime code. (A non-qr
4976      * string, however, can, e.g. $x =~ '(?{})') */
4977     if  ((pm_flags & PMf_IS_QR) && expr && expr->op_type == OP_CONST)
4978         return 0;
4979
4980     for (s = 0; s < plen; s++) {
4981         if (n < pRExC_state->num_code_blocks
4982             && s == pRExC_state->code_blocks[n].start)
4983         {
4984             s = pRExC_state->code_blocks[n].end;
4985             n++;
4986             continue;
4987         }
4988         /* TODO ideally should handle [..], (#..), /#.../x to reduce false
4989          * positives here */
4990         if (pat[s] == '(' && pat[s+1] == '?' &&
4991             (pat[s+2] == '{' || (pat[s+2] == '?' && pat[s+3] == '{'))
4992         )
4993             return 1;
4994     }
4995     return 0;
4996 }
4997
4998 /* Handle run-time code blocks. We will already have compiled any direct
4999  * or indirect literal code blocks. Now, take the pattern 'pat' and make a
5000  * copy of it, but with any literal code blocks blanked out and
5001  * appropriate chars escaped; then feed it into
5002  *
5003  *    eval "qr'modified_pattern'"
5004  *
5005  * For example,
5006  *
5007  *       a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
5008  *
5009  * becomes
5010  *
5011  *    qr'a\\bc_______________________def\'ghi\\\\jkl(?{"this is runtime"})mno'
5012  *
5013  * After eval_sv()-ing that, grab any new code blocks from the returned qr
5014  * and merge them with any code blocks of the original regexp.
5015  *
5016  * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
5017  * instead, just save the qr and return FALSE; this tells our caller that
5018  * the original pattern needs upgrading to utf8.
5019  */
5020
5021 static bool
5022 S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
5023     char *pat, STRLEN plen)
5024 {
5025     SV *qr;
5026
5027     GET_RE_DEBUG_FLAGS_DECL;
5028
5029     if (pRExC_state->runtime_code_qr) {
5030         /* this is the second time we've been called; this should
5031          * only happen if the main pattern got upgraded to utf8
5032          * during compilation; re-use the qr we compiled first time
5033          * round (which should be utf8 too)
5034          */
5035         qr = pRExC_state->runtime_code_qr;
5036         pRExC_state->runtime_code_qr = NULL;
5037         assert(RExC_utf8 && SvUTF8(qr));
5038     }
5039     else {
5040         int n = 0;
5041         STRLEN s;
5042         char *p, *newpat;
5043         int newlen = plen + 6; /* allow for "qr''x\0" extra chars */
5044         SV *sv, *qr_ref;
5045         dSP;
5046
5047         /* determine how many extra chars we need for ' and \ escaping */
5048         for (s = 0; s < plen; s++) {
5049             if (pat[s] == '\'' || pat[s] == '\\')
5050                 newlen++;
5051         }
5052
5053         Newx(newpat, newlen, char);
5054         p = newpat;
5055         *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
5056
5057         for (s = 0; s < plen; s++) {
5058             if (n < pRExC_state->num_code_blocks
5059                 && s == pRExC_state->code_blocks[n].start)
5060             {
5061                 /* blank out literal code block */
5062                 assert(pat[s] == '(');
5063                 while (s <= pRExC_state->code_blocks[n].end) {
5064                     *p++ = '_';
5065                     s++;
5066                 }
5067                 s--;
5068                 n++;
5069                 continue;
5070             }
5071             if (pat[s] == '\'' || pat[s] == '\\')
5072                 *p++ = '\\';
5073             *p++ = pat[s];
5074         }
5075         *p++ = '\'';
5076         if (pRExC_state->pm_flags & RXf_PMf_EXTENDED)
5077             *p++ = 'x';
5078         *p++ = '\0';
5079         DEBUG_COMPILE_r({
5080             PerlIO_printf(Perl_debug_log,
5081                 "%sre-parsing pattern for runtime code:%s %s\n",
5082                 PL_colors[4],PL_colors[5],newpat);
5083         });
5084
5085         sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
5086         Safefree(newpat);
5087
5088         ENTER;
5089         SAVETMPS;
5090         save_re_context();
5091         PUSHSTACKi(PERLSI_REQUIRE);
5092         /* this causes the toker to collapse \\ into \ when parsing
5093          * qr''; normally only q'' does this. It also alters hints
5094          * handling */
5095         PL_reg_state.re_reparsing = TRUE;
5096         eval_sv(sv, G_SCALAR);
5097         SvREFCNT_dec(sv);
5098         SPAGAIN;
5099         qr_ref = POPs;
5100         PUTBACK;
5101         {
5102             SV * const errsv = ERRSV;
5103             if (SvTRUE_NN(errsv))
5104             {
5105                 Safefree(pRExC_state->code_blocks);
5106                 /* use croak_sv ? */
5107                 Perl_croak_nocontext("%s", SvPV_nolen_const(errsv));
5108             }
5109         }
5110         assert(SvROK(qr_ref));
5111         qr = SvRV(qr_ref);
5112         assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
5113         /* the leaving below frees the tmp qr_ref.
5114          * Give qr a life of its own */
5115         SvREFCNT_inc(qr);
5116         POPSTACK;
5117         FREETMPS;
5118         LEAVE;
5119
5120     }
5121
5122     if (!RExC_utf8 && SvUTF8(qr)) {
5123         /* first time through; the pattern got upgraded; save the
5124          * qr for the next time through */
5125         assert(!pRExC_state->runtime_code_qr);
5126         pRExC_state->runtime_code_qr = qr;
5127         return 0;
5128     }
5129
5130
5131     /* extract any code blocks within the returned qr//  */
5132
5133
5134     /* merge the main (r1) and run-time (r2) code blocks into one */
5135     {
5136         RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
5137         struct reg_code_block *new_block, *dst;
5138         RExC_state_t * const r1 = pRExC_state; /* convenient alias */
5139         int i1 = 0, i2 = 0;
5140
5141         if (!r2->num_code_blocks) /* we guessed wrong */
5142         {
5143             SvREFCNT_dec(qr);
5144             return 1;
5145         }
5146
5147         Newx(new_block,
5148             r1->num_code_blocks + r2->num_code_blocks,
5149             struct reg_code_block);
5150         dst = new_block;
5151
5152         while (    i1 < r1->num_code_blocks
5153                 || i2 < r2->num_code_blocks)
5154         {
5155             struct reg_code_block *src;
5156             bool is_qr = 0;
5157
5158             if (i1 == r1->num_code_blocks) {
5159                 src = &r2->code_blocks[i2++];
5160                 is_qr = 1;
5161             }
5162             else if (i2 == r2->num_code_blocks)
5163                 src = &r1->code_blocks[i1++];
5164             else if (  r1->code_blocks[i1].start
5165                      < r2->code_blocks[i2].start)
5166             {
5167                 src = &r1->code_blocks[i1++];
5168                 assert(src->end < r2->code_blocks[i2].start);
5169             }
5170             else {
5171                 assert(  r1->code_blocks[i1].start
5172                        > r2->code_blocks[i2].start);
5173                 src = &r2->code_blocks[i2++];
5174                 is_qr = 1;
5175                 assert(src->end < r1->code_blocks[i1].start);
5176             }
5177
5178             assert(pat[src->start] == '(');
5179             assert(pat[src->end]   == ')');
5180             dst->start      = src->start;
5181             dst->end        = src->end;
5182             dst->block      = src->block;
5183             dst->src_regex  = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
5184                                     : src->src_regex;
5185             dst++;
5186         }
5187         r1->num_code_blocks += r2->num_code_blocks;
5188         Safefree(r1->code_blocks);
5189         r1->code_blocks = new_block;
5190     }
5191
5192     SvREFCNT_dec(qr);
5193     return 1;
5194 }
5195
5196
5197 STATIC bool
5198 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)
5199 {
5200     /* This is the common code for setting up the floating and fixed length
5201      * string data extracted from Perlre_op_compile() below.  Returns a boolean
5202      * as to whether succeeded or not */
5203
5204     I32 t,ml;
5205
5206     if (! (longest_length
5207            || (eol /* Can't have SEOL and MULTI */
5208                && (! meol || (RExC_flags & RXf_PMf_MULTILINE)))
5209           )
5210             /* See comments for join_exact for why REG_SEEN_EXACTF_SHARP_S */
5211         || (RExC_seen & REG_SEEN_EXACTF_SHARP_S))
5212     {
5213         return FALSE;
5214     }
5215
5216     /* copy the information about the longest from the reg_scan_data
5217         over to the program. */
5218     if (SvUTF8(sv_longest)) {
5219         *rx_utf8 = sv_longest;
5220         *rx_substr = NULL;
5221     } else {
5222         *rx_substr = sv_longest;
5223         *rx_utf8 = NULL;
5224     }
5225     /* end_shift is how many chars that must be matched that
5226         follow this item. We calculate it ahead of time as once the
5227         lookbehind offset is added in we lose the ability to correctly
5228         calculate it.*/
5229     ml = minlen ? *(minlen) : (I32)longest_length;
5230     *rx_end_shift = ml - offset
5231         - longest_length + (SvTAIL(sv_longest) != 0)
5232         + lookbehind;
5233
5234     t = (eol/* Can't have SEOL and MULTI */
5235          && (! meol || (RExC_flags & RXf_PMf_MULTILINE)));
5236     fbm_compile(sv_longest, t ? FBMcf_TAIL : 0);
5237
5238     return TRUE;
5239 }
5240
5241 /*
5242  * Perl_re_op_compile - the perl internal RE engine's function to compile a
5243  * regular expression into internal code.
5244  * The pattern may be passed either as:
5245  *    a list of SVs (patternp plus pat_count)
5246  *    a list of OPs (expr)
5247  * If both are passed, the SV list is used, but the OP list indicates
5248  * which SVs are actually pre-compiled code blocks
5249  *
5250  * The SVs in the list have magic and qr overloading applied to them (and
5251  * the list may be modified in-place with replacement SVs in the latter
5252  * case).
5253  *
5254  * If the pattern hasn't changed from old_re, then old_re will be
5255  * returned.
5256  *
5257  * eng is the current engine. If that engine has an op_comp method, then
5258  * handle directly (i.e. we assume that op_comp was us); otherwise, just
5259  * do the initial concatenation of arguments and pass on to the external
5260  * engine.
5261  *
5262  * If is_bare_re is not null, set it to a boolean indicating whether the
5263  * arg list reduced (after overloading) to a single bare regex which has
5264  * been returned (i.e. /$qr/).
5265  *
5266  * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
5267  *
5268  * pm_flags contains the PMf_* flags, typically based on those from the
5269  * pm_flags field of the related PMOP. Currently we're only interested in
5270  * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL.
5271  *
5272  * We can't allocate space until we know how big the compiled form will be,
5273  * but we can't compile it (and thus know how big it is) until we've got a
5274  * place to put the code.  So we cheat:  we compile it twice, once with code
5275  * generation turned off and size counting turned on, and once "for real".
5276  * This also means that we don't allocate space until we are sure that the
5277  * thing really will compile successfully, and we never have to move the
5278  * code and thus invalidate pointers into it.  (Note that it has to be in
5279  * one piece because free() must be able to free it all.) [NB: not true in perl]
5280  *
5281  * Beware that the optimization-preparation code in here knows about some
5282  * of the structure of the compiled regexp.  [I'll say.]
5283  */
5284
5285 REGEXP *
5286 Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
5287                     OP *expr, const regexp_engine* eng, REGEXP *VOL old_re,
5288                      bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags)
5289 {
5290     dVAR;
5291     REGEXP *rx;
5292     struct regexp *r;
5293     regexp_internal *ri;
5294     STRLEN plen;
5295     char  * VOL exp;
5296     char* xend;
5297     regnode *scan;
5298     I32 flags;
5299     I32 minlen = 0;
5300     U32 rx_flags;
5301     SV * VOL pat;
5302     SV * VOL code_blocksv = NULL;
5303
5304     /* these are all flags - maybe they should be turned
5305      * into a single int with different bit masks */
5306     I32 sawlookahead = 0;
5307     I32 sawplus = 0;
5308     I32 sawopen = 0;
5309     bool used_setjump = FALSE;
5310     regex_charset initial_charset = get_regex_charset(orig_rx_flags);
5311     bool code_is_utf8 = 0;
5312     bool VOL recompile = 0;
5313     bool runtime_code = 0;
5314     U8 jump_ret = 0;
5315     dJMPENV;
5316     scan_data_t data;
5317     RExC_state_t RExC_state;
5318     RExC_state_t * const pRExC_state = &RExC_state;
5319 #ifdef TRIE_STUDY_OPT    
5320     int restudied;
5321     RExC_state_t copyRExC_state;
5322 #endif    
5323     GET_RE_DEBUG_FLAGS_DECL;
5324
5325     PERL_ARGS_ASSERT_RE_OP_COMPILE;
5326
5327     DEBUG_r(if (!PL_colorset) reginitcolors());
5328
5329 #ifndef PERL_IN_XSUB_RE
5330     /* Initialize these here instead of as-needed, as is quick and avoids
5331      * having to test them each time otherwise */
5332     if (! PL_AboveLatin1) {
5333         PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
5334         PL_ASCII = _new_invlist_C_array(ASCII_invlist);
5335         PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
5336
5337         PL_L1PosixAlnum = _new_invlist_C_array(L1PosixAlnum_invlist);
5338         PL_PosixAlnum = _new_invlist_C_array(PosixAlnum_invlist);
5339
5340         PL_L1PosixAlpha = _new_invlist_C_array(L1PosixAlpha_invlist);
5341         PL_PosixAlpha = _new_invlist_C_array(PosixAlpha_invlist);
5342
5343         PL_PosixBlank = _new_invlist_C_array(PosixBlank_invlist);
5344         PL_XPosixBlank = _new_invlist_C_array(XPosixBlank_invlist);
5345
5346         PL_L1Cased = _new_invlist_C_array(L1Cased_invlist);
5347
5348         PL_PosixCntrl = _new_invlist_C_array(PosixCntrl_invlist);
5349         PL_XPosixCntrl = _new_invlist_C_array(XPosixCntrl_invlist);
5350
5351         PL_PosixDigit = _new_invlist_C_array(PosixDigit_invlist);
5352
5353         PL_L1PosixGraph = _new_invlist_C_array(L1PosixGraph_invlist);
5354         PL_PosixGraph = _new_invlist_C_array(PosixGraph_invlist);
5355
5356         PL_L1PosixLower = _new_invlist_C_array(L1PosixLower_invlist);
5357         PL_PosixLower = _new_invlist_C_array(PosixLower_invlist);
5358
5359         PL_L1PosixPrint = _new_invlist_C_array(L1PosixPrint_invlist);
5360         PL_PosixPrint = _new_invlist_C_array(PosixPrint_invlist);
5361
5362         PL_L1PosixPunct = _new_invlist_C_array(L1PosixPunct_invlist);
5363         PL_PosixPunct = _new_invlist_C_array(PosixPunct_invlist);
5364
5365         PL_PerlSpace = _new_invlist_C_array(PerlSpace_invlist);
5366         PL_XPerlSpace = _new_invlist_C_array(XPerlSpace_invlist);
5367
5368         PL_PosixSpace = _new_invlist_C_array(PosixSpace_invlist);
5369         PL_XPosixSpace = _new_invlist_C_array(XPosixSpace_invlist);
5370
5371         PL_L1PosixUpper = _new_invlist_C_array(L1PosixUpper_invlist);
5372         PL_PosixUpper = _new_invlist_C_array(PosixUpper_invlist);
5373
5374         PL_VertSpace = _new_invlist_C_array(VertSpace_invlist);
5375
5376         PL_PosixWord = _new_invlist_C_array(PosixWord_invlist);
5377         PL_L1PosixWord = _new_invlist_C_array(L1PosixWord_invlist);
5378
5379         PL_PosixXDigit = _new_invlist_C_array(PosixXDigit_invlist);
5380         PL_XPosixXDigit = _new_invlist_C_array(XPosixXDigit_invlist);
5381
5382         PL_HasMultiCharFold = _new_invlist_C_array(_Perl_Multi_Char_Folds_invlist);
5383     }
5384 #endif
5385
5386     pRExC_state->code_blocks = NULL;
5387     pRExC_state->num_code_blocks = 0;
5388
5389     if (is_bare_re)
5390         *is_bare_re = FALSE;
5391
5392     if (expr && (expr->op_type == OP_LIST ||
5393                 (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
5394
5395         /* is the source UTF8, and how many code blocks are there? */
5396         OP *o;
5397         int ncode = 0;
5398
5399         for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
5400             if (o->op_type == OP_CONST && SvUTF8(cSVOPo_sv))
5401                 code_is_utf8 = 1;
5402             else if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
5403                 /* count of DO blocks */
5404                 ncode++;
5405         }
5406         if (ncode) {
5407             pRExC_state->num_code_blocks = ncode;
5408             Newx(pRExC_state->code_blocks, ncode, struct reg_code_block);
5409         }
5410     }
5411
5412     if (pat_count) {
5413         /* handle a list of SVs */
5414
5415         SV **svp;
5416
5417         /* apply magic and RE overloading to each arg */
5418         for (svp = patternp; svp < patternp + pat_count; svp++) {
5419             SV *rx = *svp;
5420             SvGETMAGIC(rx);
5421             if (SvROK(rx) && SvAMAGIC(rx)) {
5422                 SV *sv = AMG_CALLunary(rx, regexp_amg);
5423                 if (sv) {
5424                     if (SvROK(sv))
5425                         sv = SvRV(sv);
5426                     if (SvTYPE(sv) != SVt_REGEXP)
5427                         Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
5428                     *svp = sv;
5429                 }
5430             }
5431         }
5432
5433         if (pat_count > 1) {
5434             /* concat multiple args and find any code block indexes */
5435
5436             OP *o = NULL;
5437             int n = 0;
5438             bool utf8 = 0;
5439             STRLEN orig_patlen = 0;
5440
5441             if (pRExC_state->num_code_blocks) {
5442                 o = cLISTOPx(expr)->op_first;
5443                 assert(   o->op_type == OP_PUSHMARK
5444                        || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)
5445                        || o->op_type == OP_PADRANGE);
5446                 o = o->op_sibling;
5447             }
5448
5449             pat = newSVpvn("", 0);
5450             SAVEFREESV(pat);
5451
5452             /* determine if the pattern is going to be utf8 (needed
5453              * in advance to align code block indices correctly).
5454              * XXX This could fail to be detected for an arg with
5455              * overloading but not concat overloading; but the main effect
5456              * in this obscure case is to need a 'use re eval' for a
5457              * literal code block */
5458             for (svp = patternp; svp < patternp + pat_count; svp++) {
5459                 if (SvUTF8(*svp))
5460                     utf8 = 1;
5461             }
5462             if (utf8)
5463                 SvUTF8_on(pat);
5464
5465             for (svp = patternp; svp < patternp + pat_count; svp++) {
5466                 SV *sv, *msv = *svp;
5467                 SV *rx;
5468                 bool code = 0;
5469                 /* we make the assumption here that each op in the list of
5470                  * op_siblings maps to one SV pushed onto the stack,
5471                  * except for code blocks, with have both an OP_NULL and
5472                  * and OP_CONST.
5473                  * This allows us to match up the list of SVs against the
5474                  * list of OPs to find the next code block.
5475                  *
5476                  * Note that       PUSHMARK PADSV PADSV ..
5477                  * is optimised to
5478                  *                 PADRANGE NULL  NULL  ..
5479                  * so the alignment still works. */
5480                 if (o) {
5481                     if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5482                         assert(n < pRExC_state->num_code_blocks);
5483                         pRExC_state->code_blocks[n].start = SvCUR(pat);
5484                         pRExC_state->code_blocks[n].block = o;
5485                         pRExC_state->code_blocks[n].src_regex = NULL;
5486                         n++;
5487                         code = 1;
5488                         o = o->op_sibling; /* skip CONST */
5489                         assert(o);
5490                     }
5491                     o = o->op_sibling;;
5492                 }
5493
5494                 if ((SvAMAGIC(pat) || SvAMAGIC(msv)) &&
5495                         (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
5496                 {
5497                     sv_setsv(pat, sv);
5498                     /* overloading involved: all bets are off over literal
5499                      * code. Pretend we haven't seen it */
5500                     pRExC_state->num_code_blocks -= n;
5501                     n = 0;
5502                     rx = NULL;
5503
5504                 }
5505                 else  {
5506                     while (SvAMAGIC(msv)
5507                             && (sv = AMG_CALLunary(msv, string_amg))
5508                             && sv != msv
5509                             &&  !(   SvROK(msv)
5510                                   && SvROK(sv)
5511                                   && SvRV(msv) == SvRV(sv))
5512                     ) {
5513                         msv = sv;
5514                         SvGETMAGIC(msv);
5515                     }
5516                     if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
5517                         msv = SvRV(msv);
5518                     orig_patlen = SvCUR(pat);
5519                     sv_catsv_nomg(pat, msv);
5520                     rx = msv;
5521                     if (code)
5522                         pRExC_state->code_blocks[n-1].end = SvCUR(pat)-1;
5523                 }
5524
5525                 /* extract any code blocks within any embedded qr//'s */
5526                 if (rx && SvTYPE(rx) == SVt_REGEXP
5527                     && RX_ENGINE((REGEXP*)rx)->op_comp)
5528                 {
5529
5530                     RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
5531                     if (ri->num_code_blocks) {
5532                         int i;
5533                         /* the presence of an embedded qr// with code means
5534                          * we should always recompile: the text of the
5535                          * qr// may not have changed, but it may be a
5536                          * different closure than last time */
5537                         recompile = 1;
5538                         Renew(pRExC_state->code_blocks,
5539                             pRExC_state->num_code_blocks + ri->num_code_blocks,
5540                             struct reg_code_block);
5541                         pRExC_state->num_code_blocks += ri->num_code_blocks;
5542                         for (i=0; i < ri->num_code_blocks; i++) {
5543                             struct reg_code_block *src, *dst;
5544                             STRLEN offset =  orig_patlen
5545                                 + ReANY((REGEXP *)rx)->pre_prefix;
5546                             assert(n < pRExC_state->num_code_blocks);
5547                             src = &ri->code_blocks[i];
5548                             dst = &pRExC_state->code_blocks[n];
5549                             dst->start      = src->start + offset;
5550                             dst->end        = src->end   + offset;
5551                             dst->block      = src->block;
5552                             dst->src_regex  = (REGEXP*) SvREFCNT_inc( (SV*)
5553                                                     src->src_regex
5554                                                         ? src->src_regex
5555                                                         : (REGEXP*)rx);
5556                             n++;
5557                         }
5558                     }
5559                 }
5560             }
5561             SvSETMAGIC(pat);
5562         }
5563         else {
5564             SV *sv;
5565             pat = *patternp;
5566             while (SvAMAGIC(pat)
5567                     && (sv = AMG_CALLunary(pat, string_amg))
5568                     && sv != pat)
5569             {
5570                 pat = sv;
5571                 SvGETMAGIC(pat);
5572             }
5573         }
5574
5575         /* handle bare regex: foo =~ $re */
5576         {
5577             SV *re = pat;
5578             if (SvROK(re))
5579                 re = SvRV(re);
5580             if (SvTYPE(re) == SVt_REGEXP) {
5581                 if (is_bare_re)
5582                     *is_bare_re = TRUE;
5583                 SvREFCNT_inc(re);
5584                 Safefree(pRExC_state->code_blocks);
5585                 return (REGEXP*)re;
5586             }
5587         }
5588     }
5589     else {
5590         /* not a list of SVs, so must be a list of OPs */
5591         assert(expr);
5592         if (expr->op_type == OP_LIST) {
5593             int i = -1;
5594             bool is_code = 0;
5595             OP *o;
5596
5597             pat = newSVpvn("", 0);
5598             SAVEFREESV(pat);
5599             if (code_is_utf8)
5600                 SvUTF8_on(pat);
5601
5602             /* given a list of CONSTs and DO blocks in expr, append all
5603              * the CONSTs to pat, and record the start and end of each
5604              * code block in code_blocks[] (each DO{} op is followed by an
5605              * OP_CONST containing the corresponding literal '(?{...})
5606              * text)
5607              */
5608             for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
5609                 if (o->op_type == OP_CONST) {
5610                     sv_catsv(pat, cSVOPo_sv);
5611                     if (is_code) {
5612                         pRExC_state->code_blocks[i].end = SvCUR(pat)-1;
5613                         is_code = 0;
5614                     }
5615                 }
5616                 else if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5617                     assert(i+1 < pRExC_state->num_code_blocks);
5618                     pRExC_state->code_blocks[++i].start = SvCUR(pat);
5619                     pRExC_state->code_blocks[i].block = o;
5620                     pRExC_state->code_blocks[i].src_regex = NULL;
5621                     is_code = 1;
5622                 }
5623             }
5624         }
5625         else {
5626             assert(expr->op_type == OP_CONST);
5627             pat = cSVOPx_sv(expr);
5628         }
5629     }
5630
5631     exp = SvPV_nomg(pat, plen);
5632
5633     if (!eng->op_comp) {
5634         if ((SvUTF8(pat) && IN_BYTES)
5635                 || SvGMAGICAL(pat) || SvAMAGIC(pat))
5636         {
5637             /* make a temporary copy; either to convert to bytes,
5638              * or to avoid repeating get-magic / overloaded stringify */
5639             pat = newSVpvn_flags(exp, plen, SVs_TEMP |
5640                                         (IN_BYTES ? 0 : SvUTF8(pat)));
5641         }
5642         Safefree(pRExC_state->code_blocks);
5643         return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
5644     }
5645
5646     /* ignore the utf8ness if the pattern is 0 length */
5647     RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
5648     RExC_uni_semantics = 0;
5649     RExC_contains_locale = 0;
5650     pRExC_state->runtime_code_qr = NULL;
5651
5652     /****************** LONG JUMP TARGET HERE***********************/
5653     /* Longjmp back to here if have to switch in midstream to utf8 */
5654     if (! RExC_orig_utf8) {
5655         JMPENV_PUSH(jump_ret);
5656         used_setjump = TRUE;
5657     }
5658
5659     if (jump_ret == 0) {    /* First time through */
5660         xend = exp + plen;
5661
5662         DEBUG_COMPILE_r({
5663             SV *dsv= sv_newmortal();
5664             RE_PV_QUOTED_DECL(s, RExC_utf8,
5665                 dsv, exp, plen, 60);
5666             PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
5667                            PL_colors[4],PL_colors[5],s);
5668         });
5669     }
5670     else {  /* longjumped back */
5671         U8 *src, *dst;
5672         int n=0;
5673         STRLEN s = 0, d = 0;
5674         bool do_end = 0;
5675
5676         /* If the cause for the longjmp was other than changing to utf8, pop
5677          * our own setjmp, and longjmp to the correct handler */
5678         if (jump_ret != UTF8_LONGJMP) {
5679             JMPENV_POP;
5680             JMPENV_JUMP(jump_ret);
5681         }
5682
5683         GET_RE_DEBUG_FLAGS;
5684
5685         /* It's possible to write a regexp in ascii that represents Unicode
5686         codepoints outside of the byte range, such as via \x{100}. If we
5687         detect such a sequence we have to convert the entire pattern to utf8
5688         and then recompile, as our sizing calculation will have been based
5689         on 1 byte == 1 character, but we will need to use utf8 to encode
5690         at least some part of the pattern, and therefore must convert the whole
5691         thing.
5692         -- dmq */
5693         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
5694             "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
5695
5696         /* upgrade pattern to UTF8, and if there are code blocks,
5697          * recalculate the indices.
5698          * This is essentially an unrolled Perl_bytes_to_utf8() */
5699
5700         src = (U8*)SvPV_nomg(pat, plen);
5701         Newx(dst, plen * 2 + 1, U8);
5702
5703         while (s < plen) {
5704             const UV uv = NATIVE_TO_ASCII(src[s]);
5705             if (UNI_IS_INVARIANT(uv))
5706                 dst[d]   = (U8)UTF_TO_NATIVE(uv);
5707             else {
5708                 dst[d++] = (U8)UTF8_EIGHT_BIT_HI(uv);
5709                 dst[d]   = (U8)UTF8_EIGHT_BIT_LO(uv);
5710             }
5711             if (n < pRExC_state->num_code_blocks) {
5712                 if (!do_end && pRExC_state->code_blocks[n].start == s) {
5713                     pRExC_state->code_blocks[n].start = d;
5714                     assert(dst[d] == '(');
5715                     do_end = 1;
5716                 }
5717                 else if (do_end && pRExC_state->code_blocks[n].end == s) {
5718                     pRExC_state->code_blocks[n].end = d;
5719                     assert(dst[d] == ')');
5720                     do_end = 0;
5721                     n++;
5722                 }
5723             }
5724             s++;
5725             d++;
5726         }
5727         dst[d] = '\0';
5728         plen = d;
5729         exp = (char*) dst;
5730         xend = exp + plen;
5731         SAVEFREEPV(exp);
5732         RExC_orig_utf8 = RExC_utf8 = 1;
5733     }
5734
5735     /* return old regex if pattern hasn't changed */
5736
5737     if (   old_re
5738         && !recompile
5739         && !!RX_UTF8(old_re) == !!RExC_utf8
5740         && RX_PRECOMP(old_re)
5741         && RX_PRELEN(old_re) == plen
5742         && memEQ(RX_PRECOMP(old_re), exp, plen))
5743     {
5744         /* with runtime code, always recompile */
5745         runtime_code = S_has_runtime_code(aTHX_ pRExC_state, expr, pm_flags,
5746                                             exp, plen);
5747         if (!runtime_code) {
5748             if (used_setjump) {
5749                 JMPENV_POP;
5750             }
5751             Safefree(pRExC_state->code_blocks);
5752             return old_re;
5753         }
5754     }
5755     else if ((pm_flags & PMf_USE_RE_EVAL)
5756                 /* this second condition covers the non-regex literal case,
5757                  * i.e.  $foo =~ '(?{})'. */
5758                 || ( !PL_reg_state.re_reparsing && IN_PERL_COMPILETIME
5759                     && (PL_hints & HINT_RE_EVAL))
5760     )
5761         runtime_code = S_has_runtime_code(aTHX_ pRExC_state, expr, pm_flags,
5762                             exp, plen);
5763
5764 #ifdef TRIE_STUDY_OPT
5765     restudied = 0;
5766 #endif
5767
5768     rx_flags = orig_rx_flags;
5769
5770     if (initial_charset == REGEX_LOCALE_CHARSET) {
5771         RExC_contains_locale = 1;
5772     }
5773     else if (RExC_utf8 && initial_charset == REGEX_DEPENDS_CHARSET) {
5774
5775         /* Set to use unicode semantics if the pattern is in utf8 and has the
5776          * 'depends' charset specified, as it means unicode when utf8  */
5777         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
5778     }
5779
5780     RExC_precomp = exp;
5781     RExC_flags = rx_flags;
5782     RExC_pm_flags = pm_flags;
5783
5784     if (runtime_code) {
5785         if (TAINTING_get && TAINT_get)
5786             Perl_croak(aTHX_ "Eval-group in insecure regular expression");
5787
5788         if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
5789             /* whoops, we have a non-utf8 pattern, whilst run-time code
5790              * got compiled as utf8. Try again with a utf8 pattern */
5791              JMPENV_JUMP(UTF8_LONGJMP);
5792         }
5793     }
5794     assert(!pRExC_state->runtime_code_qr);
5795
5796     RExC_sawback = 0;
5797
5798     RExC_seen = 0;
5799     RExC_in_lookbehind = 0;
5800     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
5801     RExC_extralen = 0;
5802     RExC_override_recoding = 0;
5803     RExC_in_multi_char_class = 0;
5804
5805     /* First pass: determine size, legality. */
5806     RExC_parse = exp;
5807     RExC_start = exp;
5808     RExC_end = xend;
5809     RExC_naughty = 0;
5810     RExC_npar = 1;
5811     RExC_nestroot = 0;
5812     RExC_size = 0L;
5813     RExC_emit = &PL_regdummy;
5814     RExC_whilem_seen = 0;
5815     RExC_open_parens = NULL;
5816     RExC_close_parens = NULL;
5817     RExC_opend = NULL;
5818     RExC_paren_names = NULL;
5819 #ifdef DEBUGGING
5820     RExC_paren_name_list = NULL;
5821 #endif
5822     RExC_recurse = NULL;
5823     RExC_recurse_count = 0;
5824     pRExC_state->code_index = 0;
5825
5826 #if 0 /* REGC() is (currently) a NOP at the first pass.
5827        * Clever compilers notice this and complain. --jhi */
5828     REGC((U8)REG_MAGIC, (char*)RExC_emit);
5829 #endif
5830     DEBUG_PARSE_r(
5831         PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n");
5832         RExC_lastnum=0;
5833         RExC_lastparse=NULL;
5834     );
5835     /* reg may croak on us, not giving us a chance to free
5836        pRExC_state->code_blocks.  We cannot SAVEFREEPV it now, as we may
5837        need it to survive as long as the regexp (qr/(?{})/).
5838        We must check that code_blocksv is not already set, because we may
5839        have longjmped back. */
5840     if (pRExC_state->code_blocks && !code_blocksv) {
5841         code_blocksv = newSV_type(SVt_PV);
5842         SAVEFREESV(code_blocksv);
5843         SvPV_set(code_blocksv, (char *)pRExC_state->code_blocks);
5844         SvLEN_set(code_blocksv, 1); /*sufficient to make sv_clear free it*/
5845     }
5846     if (reg(pRExC_state, 0, &flags,1) == NULL) {
5847         RExC_precomp = NULL;
5848         return(NULL);
5849     }
5850     if (code_blocksv)
5851         SvLEN_set(code_blocksv,0); /* no you can't have it, sv_clear */
5852
5853     /* Here, finished first pass.  Get rid of any added setjmp */
5854     if (used_setjump) {
5855         JMPENV_POP;
5856     }
5857
5858     DEBUG_PARSE_r({
5859         PerlIO_printf(Perl_debug_log, 
5860             "Required size %"IVdf" nodes\n"
5861             "Starting second pass (creation)\n", 
5862             (IV)RExC_size);
5863         RExC_lastnum=0; 
5864         RExC_lastparse=NULL; 
5865     });
5866
5867     /* The first pass could have found things that force Unicode semantics */
5868     if ((RExC_utf8 || RExC_uni_semantics)
5869          && get_regex_charset(rx_flags) == REGEX_DEPENDS_CHARSET)
5870     {
5871         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
5872     }
5873
5874     /* Small enough for pointer-storage convention?
5875        If extralen==0, this means that we will not need long jumps. */
5876     if (RExC_size >= 0x10000L && RExC_extralen)
5877         RExC_size += RExC_extralen;
5878     else
5879         RExC_extralen = 0;
5880     if (RExC_whilem_seen > 15)
5881         RExC_whilem_seen = 15;
5882
5883     /* Allocate space and zero-initialize. Note, the two step process 
5884        of zeroing when in debug mode, thus anything assigned has to 
5885        happen after that */
5886     rx = (REGEXP*) newSV_type(SVt_REGEXP);
5887     r = ReANY(rx);
5888     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
5889          char, regexp_internal);
5890     if ( r == NULL || ri == NULL )
5891         FAIL("Regexp out of space");
5892 #ifdef DEBUGGING
5893     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
5894     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char);
5895 #else 
5896     /* bulk initialize base fields with 0. */
5897     Zero(ri, sizeof(regexp_internal), char);        
5898 #endif
5899
5900     /* non-zero initialization begins here */
5901     RXi_SET( r, ri );
5902     r->engine= eng;
5903     r->extflags = rx_flags;
5904     if (pm_flags & PMf_IS_QR) {
5905         ri->code_blocks = pRExC_state->code_blocks;
5906         ri->num_code_blocks = pRExC_state->num_code_blocks;
5907     }
5908     else
5909     {
5910         int n;
5911         for (n = 0; n < pRExC_state->num_code_blocks; n++)
5912             if (pRExC_state->code_blocks[n].src_regex)
5913                 SAVEFREESV(pRExC_state->code_blocks[n].src_regex);
5914         SAVEFREEPV(pRExC_state->code_blocks);
5915     }
5916
5917     {
5918         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
5919         bool has_charset = (get_regex_charset(r->extflags) != REGEX_DEPENDS_CHARSET);
5920
5921         /* The caret is output if there are any defaults: if not all the STD
5922          * flags are set, or if no character set specifier is needed */
5923         bool has_default =
5924                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
5925                     || ! has_charset);
5926         bool has_runon = ((RExC_seen & REG_SEEN_RUN_ON_COMMENT)==REG_SEEN_RUN_ON_COMMENT);
5927         U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD)
5928                             >> RXf_PMf_STD_PMMOD_SHIFT);
5929         const char *fptr = STD_PAT_MODS;        /*"msix"*/
5930         char *p;
5931         /* Allocate for the worst case, which is all the std flags are turned
5932          * on.  If more precision is desired, we could do a population count of
5933          * the flags set.  This could be done with a small lookup table, or by
5934          * shifting, masking and adding, or even, when available, assembly
5935          * language for a machine-language population count.
5936          * We never output a minus, as all those are defaults, so are
5937          * covered by the caret */
5938         const STRLEN wraplen = plen + has_p + has_runon
5939             + has_default       /* If needs a caret */
5940
5941                 /* If needs a character set specifier */
5942             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
5943             + (sizeof(STD_PAT_MODS) - 1)
5944             + (sizeof("(?:)") - 1);
5945
5946         Newx(p, wraplen + 1, char); /* +1 for the ending NUL */
5947         r->xpv_len_u.xpvlenu_pv = p;
5948         if (RExC_utf8)
5949             SvFLAGS(rx) |= SVf_UTF8;
5950         *p++='('; *p++='?';
5951
5952         /* If a default, cover it using the caret */
5953         if (has_default) {
5954             *p++= DEFAULT_PAT_MOD;
5955         }
5956         if (has_charset) {
5957             STRLEN len;
5958             const char* const name = get_regex_charset_name(r->extflags, &len);
5959             Copy(name, p, len, char);
5960             p += len;
5961         }
5962         if (has_p)
5963             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
5964         {
5965             char ch;
5966             while((ch = *fptr++)) {
5967                 if(reganch & 1)
5968                     *p++ = ch;
5969                 reganch >>= 1;
5970             }
5971         }
5972
5973         *p++ = ':';
5974         Copy(RExC_precomp, p, plen, char);
5975         assert ((RX_WRAPPED(rx) - p) < 16);
5976         r->pre_prefix = p - RX_WRAPPED(rx);
5977         p += plen;
5978         if (has_runon)
5979             *p++ = '\n';
5980         *p++ = ')';
5981         *p = 0;
5982         SvCUR_set(rx, p - RX_WRAPPED(rx));
5983     }
5984
5985     r->intflags = 0;
5986     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
5987     
5988     if (RExC_seen & REG_SEEN_RECURSE) {
5989         Newxz(RExC_open_parens, RExC_npar,regnode *);
5990         SAVEFREEPV(RExC_open_parens);
5991         Newxz(RExC_close_parens,RExC_npar,regnode *);
5992         SAVEFREEPV(RExC_close_parens);
5993     }
5994
5995     /* Useful during FAIL. */
5996 #ifdef RE_TRACK_PATTERN_OFFSETS
5997     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
5998     DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
5999                           "%s %"UVuf" bytes for offset annotations.\n",
6000                           ri->u.offsets ? "Got" : "Couldn't get",
6001                           (UV)((2*RExC_size+1) * sizeof(U32))));
6002 #endif
6003     SetProgLen(ri,RExC_size);
6004     RExC_rx_sv = rx;
6005     RExC_rx = r;
6006     RExC_rxi = ri;
6007     REH_CALL_COMP_BEGIN_HOOK(pRExC_state->rx);
6008
6009     /* Second pass: emit code. */
6010     RExC_flags = rx_flags;      /* don't let top level (?i) bleed */
6011     RExC_pm_flags = pm_flags;
6012     RExC_parse = exp;
6013     RExC_end = xend;
6014     RExC_naughty = 0;
6015     RExC_npar = 1;
6016     RExC_emit_start = ri->program;
6017     RExC_emit = ri->program;
6018     RExC_emit_bound = ri->program + RExC_size + 1;
6019     pRExC_state->code_index = 0;
6020
6021     REGC((U8)REG_MAGIC, (char*) RExC_emit++);
6022     if (reg(pRExC_state, 0, &flags,1) == NULL) {
6023         ReREFCNT_dec(rx);   
6024         return(NULL);
6025     }
6026     /* XXXX To minimize changes to RE engine we always allocate
6027        3-units-long substrs field. */
6028     Newx(r->substrs, 1, struct reg_substr_data);
6029     if (RExC_recurse_count) {
6030         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
6031         SAVEFREEPV(RExC_recurse);
6032     }
6033
6034 reStudy:
6035     r->minlen = minlen = sawlookahead = sawplus = sawopen = 0;
6036     Zero(r->substrs, 1, struct reg_substr_data);
6037
6038 #ifdef TRIE_STUDY_OPT
6039     if (!restudied) {
6040         StructCopy(&zero_scan_data, &data, scan_data_t);
6041         copyRExC_state = RExC_state;
6042     } else {
6043         U32 seen=RExC_seen;
6044         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
6045         
6046         RExC_state = copyRExC_state;
6047         if (seen & REG_TOP_LEVEL_BRANCHES) 
6048             RExC_seen |= REG_TOP_LEVEL_BRANCHES;
6049         else
6050             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES;
6051         StructCopy(&zero_scan_data, &data, scan_data_t);
6052     }
6053 #else
6054     StructCopy(&zero_scan_data, &data, scan_data_t);
6055 #endif    
6056
6057     /* Dig out information for optimizations. */
6058     r->extflags = RExC_flags; /* was pm_op */
6059     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
6060  
6061     if (UTF)
6062         SvUTF8_on(rx);  /* Unicode in it? */
6063     ri->regstclass = NULL;
6064     if (RExC_naughty >= 10)     /* Probably an expensive pattern. */
6065         r->intflags |= PREGf_NAUGHTY;
6066     scan = ri->program + 1;             /* First BRANCH. */
6067
6068     /* testing for BRANCH here tells us whether there is "must appear"
6069        data in the pattern. If there is then we can use it for optimisations */
6070     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /*  Only one top-level choice. */
6071         I32 fake;
6072         STRLEN longest_float_length, longest_fixed_length;
6073         struct regnode_charclass_class ch_class; /* pointed to by data */
6074         int stclass_flag;
6075         I32 last_close = 0; /* pointed to by data */
6076         regnode *first= scan;
6077         regnode *first_next= regnext(first);
6078         /*
6079          * Skip introductions and multiplicators >= 1
6080          * so that we can extract the 'meat' of the pattern that must 
6081          * match in the large if() sequence following.
6082          * NOTE that EXACT is NOT covered here, as it is normally
6083          * picked up by the optimiser separately. 
6084          *
6085          * This is unfortunate as the optimiser isnt handling lookahead
6086          * properly currently.
6087          *
6088          */
6089         while ((OP(first) == OPEN && (sawopen = 1)) ||
6090                /* An OR of *one* alternative - should not happen now. */
6091             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
6092             /* for now we can't handle lookbehind IFMATCH*/
6093             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
6094             (OP(first) == PLUS) ||
6095             (OP(first) == MINMOD) ||
6096                /* An {n,m} with n>0 */
6097             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
6098             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
6099         {
6100                 /* 
6101                  * the only op that could be a regnode is PLUS, all the rest
6102                  * will be regnode_1 or regnode_2.
6103                  *
6104                  */
6105                 if (OP(first) == PLUS)
6106                     sawplus = 1;
6107                 else
6108                     first += regarglen[OP(first)];
6109
6110                 first = NEXTOPER(first);
6111                 first_next= regnext(first);
6112         }
6113
6114         /* Starting-point info. */
6115       again:
6116         DEBUG_PEEP("first:",first,0);
6117         /* Ignore EXACT as we deal with it later. */
6118         if (PL_regkind[OP(first)] == EXACT) {
6119             if (OP(first) == EXACT)
6120                 NOOP;   /* Empty, get anchored substr later. */
6121             else
6122                 ri->regstclass = first;
6123         }
6124 #ifdef TRIE_STCLASS
6125         else if (PL_regkind[OP(first)] == TRIE &&
6126                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0) 
6127         {
6128             regnode *trie_op;
6129             /* this can happen only on restudy */
6130             if ( OP(first) == TRIE ) {
6131                 struct regnode_1 *trieop = (struct regnode_1 *)
6132                     PerlMemShared_calloc(1, sizeof(struct regnode_1));
6133                 StructCopy(first,trieop,struct regnode_1);
6134                 trie_op=(regnode *)trieop;
6135             } else {
6136                 struct regnode_charclass *trieop = (struct regnode_charclass *)
6137                     PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
6138                 StructCopy(first,trieop,struct regnode_charclass);
6139                 trie_op=(regnode *)trieop;
6140             }
6141             OP(trie_op)+=2;
6142             make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
6143             ri->regstclass = trie_op;
6144         }
6145 #endif
6146         else if (REGNODE_SIMPLE(OP(first)))
6147             ri->regstclass = first;
6148         else if (PL_regkind[OP(first)] == BOUND ||
6149                  PL_regkind[OP(first)] == NBOUND)
6150             ri->regstclass = first;
6151         else if (PL_regkind[OP(first)] == BOL) {
6152             r->extflags |= (OP(first) == MBOL
6153                            ? RXf_ANCH_MBOL
6154                            : (OP(first) == SBOL
6155                               ? RXf_ANCH_SBOL
6156                               : RXf_ANCH_BOL));
6157             first = NEXTOPER(first);
6158             goto again;
6159         }
6160         else if (OP(first) == GPOS) {
6161             r->extflags |= RXf_ANCH_GPOS;
6162             first = NEXTOPER(first);
6163             goto again;
6164         }
6165         else if ((!sawopen || !RExC_sawback) &&
6166             (OP(first) == STAR &&
6167             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
6168             !(r->extflags & RXf_ANCH) && !pRExC_state->num_code_blocks)
6169         {
6170             /* turn .* into ^.* with an implied $*=1 */
6171             const int type =
6172                 (OP(NEXTOPER(first)) == REG_ANY)
6173                     ? RXf_ANCH_MBOL
6174                     : RXf_ANCH_SBOL;
6175             r->extflags |= type;
6176             r->intflags |= PREGf_IMPLICIT;
6177             first = NEXTOPER(first);
6178             goto again;
6179         }
6180         if (sawplus && !sawlookahead && (!sawopen || !RExC_sawback)
6181             && !pRExC_state->num_code_blocks) /* May examine pos and $& */
6182             /* x+ must match at the 1st pos of run of x's */
6183             r->intflags |= PREGf_SKIP;
6184
6185         /* Scan is after the zeroth branch, first is atomic matcher. */
6186 #ifdef TRIE_STUDY_OPT
6187         DEBUG_PARSE_r(
6188             if (!restudied)
6189                 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
6190                               (IV)(first - scan + 1))
6191         );
6192 #else
6193         DEBUG_PARSE_r(
6194             PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
6195                 (IV)(first - scan + 1))
6196         );
6197 #endif
6198
6199
6200         /*
6201         * If there's something expensive in the r.e., find the
6202         * longest literal string that must appear and make it the
6203         * regmust.  Resolve ties in favor of later strings, since
6204         * the regstart check works with the beginning of the r.e.
6205         * and avoiding duplication strengthens checking.  Not a
6206         * strong reason, but sufficient in the absence of others.
6207         * [Now we resolve ties in favor of the earlier string if
6208         * it happens that c_offset_min has been invalidated, since the
6209         * earlier string may buy us something the later one won't.]
6210         */
6211
6212         data.longest_fixed = newSVpvs("");
6213         data.longest_float = newSVpvs("");
6214         data.last_found = newSVpvs("");
6215         data.longest = &(data.longest_fixed);
6216         ENTER_with_name("study_chunk");
6217         SAVEFREESV(data.longest_fixed);
6218         SAVEFREESV(data.longest_float);
6219         SAVEFREESV(data.last_found);
6220         first = scan;
6221         if (!ri->regstclass) {
6222             cl_init(pRExC_state, &ch_class);
6223             data.start_class = &ch_class;
6224             stclass_flag = SCF_DO_STCLASS_AND;
6225         } else                          /* XXXX Check for BOUND? */
6226             stclass_flag = 0;
6227         data.last_closep = &last_close;
6228         
6229         minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */
6230             &data, -1, NULL, NULL,
6231             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
6232
6233
6234         CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
6235
6236
6237         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
6238              && data.last_start_min == 0 && data.last_end > 0
6239              && !RExC_seen_zerolen
6240              && !(RExC_seen & REG_SEEN_VERBARG)
6241              && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
6242             r->extflags |= RXf_CHECK_ALL;
6243         scan_commit(pRExC_state, &data,&minlen,0);
6244
6245         longest_float_length = CHR_SVLEN(data.longest_float);
6246
6247         if (! ((SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
6248                    && data.offset_fixed == data.offset_float_min
6249                    && SvCUR(data.longest_fixed) == SvCUR(data.longest_float)))
6250             && S_setup_longest (aTHX_ pRExC_state,
6251                                     data.longest_float,
6252                                     &(r->float_utf8),
6253                                     &(r->float_substr),
6254                                     &(r->float_end_shift),
6255                                     data.lookbehind_float,
6256                                     data.offset_float_min,
6257                                     data.minlen_float,
6258                                     longest_float_length,
6259                                     data.flags & SF_FL_BEFORE_EOL,
6260                                     data.flags & SF_FL_BEFORE_MEOL))
6261         {
6262             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
6263             r->float_max_offset = data.offset_float_max;
6264             if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
6265                 r->float_max_offset -= data.lookbehind_float;
6266             SvREFCNT_inc_simple_void_NN(data.longest_float);
6267         }
6268         else {
6269             r->float_substr = r->float_utf8 = NULL;
6270             longest_float_length = 0;
6271         }
6272
6273         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
6274
6275         if (S_setup_longest (aTHX_ pRExC_state,
6276                                 data.longest_fixed,
6277                                 &(r->anchored_utf8),
6278                                 &(r->anchored_substr),
6279                                 &(r->anchored_end_shift),
6280                                 data.lookbehind_fixed,
6281                                 data.offset_fixed,
6282                                 data.minlen_fixed,
6283                                 longest_fixed_length,
6284                                 data.flags & SF_FIX_BEFORE_EOL,
6285                                 data.flags & SF_FIX_BEFORE_MEOL))
6286         {
6287             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
6288             SvREFCNT_inc_simple_void_NN(data.longest_fixed);
6289         }
6290         else {
6291             r->anchored_substr = r->anchored_utf8 = NULL;
6292             longest_fixed_length = 0;
6293         }
6294         LEAVE_with_name("study_chunk");
6295
6296         if (ri->regstclass
6297             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
6298             ri->regstclass = NULL;
6299
6300         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
6301             && stclass_flag
6302             && !(data.start_class->flags & ANYOF_EOS)
6303             && !cl_is_anything(data.start_class))
6304         {
6305             const U32 n = add_data(pRExC_state, 1, "f");
6306             data.start_class->flags |= ANYOF_IS_SYNTHETIC;
6307
6308             Newx(RExC_rxi->data->data[n], 1,
6309                 struct regnode_charclass_class);
6310             StructCopy(data.start_class,
6311                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
6312                        struct regnode_charclass_class);
6313             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
6314             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
6315             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
6316                       regprop(r, sv, (regnode*)data.start_class);
6317                       PerlIO_printf(Perl_debug_log,
6318                                     "synthetic stclass \"%s\".\n",
6319                                     SvPVX_const(sv));});
6320         }
6321
6322         /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
6323         if (longest_fixed_length > longest_float_length) {
6324             r->check_end_shift = r->anchored_end_shift;
6325             r->check_substr = r->anchored_substr;
6326             r->check_utf8 = r->anchored_utf8;
6327             r->check_offset_min = r->check_offset_max = r->anchored_offset;
6328             if (r->extflags & RXf_ANCH_SINGLE)
6329                 r->extflags |= RXf_NOSCAN;
6330         }
6331         else {
6332             r->check_end_shift = r->float_end_shift;
6333             r->check_substr = r->float_substr;
6334             r->check_utf8 = r->float_utf8;
6335             r->check_offset_min = r->float_min_offset;
6336             r->check_offset_max = r->float_max_offset;
6337         }
6338         /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
6339            This should be changed ASAP!  */
6340         if ((r->check_substr || r->check_utf8) && !(r->extflags & RXf_ANCH_GPOS)) {
6341             r->extflags |= RXf_USE_INTUIT;
6342             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
6343                 r->extflags |= RXf_INTUIT_TAIL;
6344         }
6345         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
6346         if ( (STRLEN)minlen < longest_float_length )
6347             minlen= longest_float_length;
6348         if ( (STRLEN)minlen < longest_fixed_length )
6349             minlen= longest_fixed_length;     
6350         */
6351     }
6352     else {
6353         /* Several toplevels. Best we can is to set minlen. */
6354         I32 fake;
6355         struct regnode_charclass_class ch_class;
6356         I32 last_close = 0;
6357
6358         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
6359
6360         scan = ri->program + 1;
6361         cl_init(pRExC_state, &ch_class);
6362         data.start_class = &ch_class;
6363         data.last_closep = &last_close;
6364
6365         
6366         minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
6367             &data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
6368         
6369         CHECK_RESTUDY_GOTO_butfirst(NOOP);
6370
6371         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
6372                 = r->float_substr = r->float_utf8 = NULL;
6373
6374         if (!(data.start_class->flags & ANYOF_EOS)
6375             && !cl_is_anything(data.start_class))
6376         {
6377             const U32 n = add_data(pRExC_state, 1, "f");
6378             data.start_class->flags |= ANYOF_IS_SYNTHETIC;
6379
6380             Newx(RExC_rxi->data->data[n], 1,
6381                 struct regnode_charclass_class);
6382             StructCopy(data.start_class,
6383                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
6384                        struct regnode_charclass_class);
6385             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
6386             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
6387             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
6388                       regprop(r, sv, (regnode*)data.start_class);
6389                       PerlIO_printf(Perl_debug_log,
6390                                     "synthetic stclass \"%s\".\n",
6391                                     SvPVX_const(sv));});
6392         }
6393     }
6394
6395     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
6396        the "real" pattern. */
6397     DEBUG_OPTIMISE_r({
6398         PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n",
6399                       (IV)minlen, (IV)r->minlen);
6400     });
6401     r->minlenret = minlen;
6402     if (r->minlen < minlen) 
6403         r->minlen = minlen;
6404     
6405     if (RExC_seen & REG_SEEN_GPOS)
6406         r->extflags |= RXf_GPOS_SEEN;
6407     if (RExC_seen & REG_SEEN_LOOKBEHIND)
6408         r->extflags |= RXf_LOOKBEHIND_SEEN;
6409     if (pRExC_state->num_code_blocks)
6410         r->extflags |= RXf_EVAL_SEEN;
6411     if (RExC_seen & REG_SEEN_CANY)
6412         r->extflags |= RXf_CANY_SEEN;
6413     if (RExC_seen & REG_SEEN_VERBARG)
6414     {
6415         r->intflags |= PREGf_VERBARG_SEEN;
6416         r->extflags |= RXf_MODIFIES_VARS;
6417     }
6418     if (RExC_seen & REG_SEEN_CUTGROUP)
6419         r->intflags |= PREGf_CUTGROUP_SEEN;
6420     if (pm_flags & PMf_USE_RE_EVAL)
6421         r->intflags |= PREGf_USE_RE_EVAL;
6422     if (RExC_paren_names)
6423         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
6424     else
6425         RXp_PAREN_NAMES(r) = NULL;
6426
6427 #ifdef STUPID_PATTERN_CHECKS            
6428     if (RX_PRELEN(rx) == 0)
6429         r->extflags |= RXf_NULL;
6430     if (RX_PRELEN(rx) == 3 && memEQ("\\s+", RX_PRECOMP(rx), 3))
6431         r->extflags |= RXf_WHITE;
6432     else if (RX_PRELEN(rx) == 1 && RXp_PRECOMP(rx)[0] == '^')
6433         r->extflags |= RXf_START_ONLY;
6434 #else
6435     {
6436         regnode *first = ri->program + 1;
6437         U8 fop = OP(first);
6438
6439         if (PL_regkind[fop] == NOTHING && OP(NEXTOPER(first)) == END)
6440             r->extflags |= RXf_NULL;
6441         else if (PL_regkind[fop] == BOL && OP(NEXTOPER(first)) == END)
6442             r->extflags |= RXf_START_ONLY;
6443         else if (fop == PLUS && OP(NEXTOPER(first)) == SPACE
6444                              && OP(regnext(first)) == END)
6445             r->extflags |= RXf_WHITE;    
6446     }
6447 #endif
6448 #ifdef DEBUGGING
6449     if (RExC_paren_names) {
6450         ri->name_list_idx = add_data( pRExC_state, 1, "a" );
6451         ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list);
6452     } else
6453 #endif
6454         ri->name_list_idx = 0;
6455
6456     if (RExC_recurse_count) {
6457         for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
6458             const regnode *scan = RExC_recurse[RExC_recurse_count-1];
6459             ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
6460         }
6461     }
6462     Newxz(r->offs, RExC_npar, regexp_paren_pair);
6463     /* assume we don't need to swap parens around before we match */
6464
6465     DEBUG_DUMP_r({
6466         PerlIO_printf(Perl_debug_log,"Final program:\n");
6467         regdump(r);
6468     });
6469 #ifdef RE_TRACK_PATTERN_OFFSETS
6470     DEBUG_OFFSETS_r(if (ri->u.offsets) {
6471         const U32 len = ri->u.offsets[0];
6472         U32 i;
6473         GET_RE_DEBUG_FLAGS_DECL;
6474         PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
6475         for (i = 1; i <= len; i++) {
6476             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
6477                 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
6478                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
6479             }
6480         PerlIO_printf(Perl_debug_log, "\n");
6481     });
6482 #endif
6483     return rx;
6484 }
6485
6486
6487 SV*
6488 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
6489                     const U32 flags)
6490 {
6491     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
6492
6493     PERL_UNUSED_ARG(value);
6494
6495     if (flags & RXapif_FETCH) {
6496         return reg_named_buff_fetch(rx, key, flags);
6497     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
6498         Perl_croak_no_modify();
6499         return NULL;
6500     } else if (flags & RXapif_EXISTS) {
6501         return reg_named_buff_exists(rx, key, flags)
6502             ? &PL_sv_yes
6503             : &PL_sv_no;
6504     } else if (flags & RXapif_REGNAMES) {
6505         return reg_named_buff_all(rx, flags);
6506     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
6507         return reg_named_buff_scalar(rx, flags);
6508     } else {
6509         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
6510         return NULL;
6511     }
6512 }
6513
6514 SV*
6515 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
6516                          const U32 flags)
6517 {
6518     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
6519     PERL_UNUSED_ARG(lastkey);
6520
6521     if (flags & RXapif_FIRSTKEY)
6522         return reg_named_buff_firstkey(rx, flags);
6523     else if (flags & RXapif_NEXTKEY)
6524         return reg_named_buff_nextkey(rx, flags);
6525     else {
6526         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter", (int)flags);
6527         return NULL;
6528     }
6529 }
6530
6531 SV*
6532 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
6533                           const U32 flags)
6534 {
6535     AV *retarray = NULL;
6536     SV *ret;
6537     struct regexp *const rx = ReANY(r);
6538
6539     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
6540
6541     if (flags & RXapif_ALL)
6542         retarray=newAV();
6543
6544     if (rx && RXp_PAREN_NAMES(rx)) {
6545         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
6546         if (he_str) {
6547             IV i;
6548             SV* sv_dat=HeVAL(he_str);
6549             I32 *nums=(I32*)SvPVX(sv_dat);
6550             for ( i=0; i<SvIVX(sv_dat); i++ ) {
6551                 if ((I32)(rx->nparens) >= nums[i]
6552                     && rx->offs[nums[i]].start != -1
6553                     && rx->offs[nums[i]].end != -1)
6554                 {
6555                     ret = newSVpvs("");
6556                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
6557                     if (!retarray)
6558                         return ret;
6559                 } else {
6560                     if (retarray)
6561                         ret = newSVsv(&PL_sv_undef);
6562                 }
6563                 if (retarray)
6564                     av_push(retarray, ret);
6565             }
6566             if (retarray)
6567                 return newRV_noinc(MUTABLE_SV(retarray));
6568         }
6569     }
6570     return NULL;
6571 }
6572
6573 bool
6574 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
6575                            const U32 flags)
6576 {
6577     struct regexp *const rx = ReANY(r);
6578
6579     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
6580
6581     if (rx && RXp_PAREN_NAMES(rx)) {
6582         if (flags & RXapif_ALL) {
6583             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
6584         } else {
6585             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
6586             if (sv) {
6587                 SvREFCNT_dec(sv);
6588                 return TRUE;
6589             } else {
6590                 return FALSE;
6591             }
6592         }
6593     } else {
6594         return FALSE;
6595     }
6596 }
6597
6598 SV*
6599 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
6600 {
6601     struct regexp *const rx = ReANY(r);
6602
6603     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
6604
6605     if ( rx && RXp_PAREN_NAMES(rx) ) {
6606         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
6607
6608         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
6609     } else {
6610         return FALSE;
6611     }
6612 }
6613
6614 SV*
6615 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
6616 {
6617     struct regexp *const rx = ReANY(r);
6618     GET_RE_DEBUG_FLAGS_DECL;
6619
6620     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
6621
6622     if (rx && RXp_PAREN_NAMES(rx)) {
6623         HV *hv = RXp_PAREN_NAMES(rx);
6624         HE *temphe;
6625         while ( (temphe = hv_iternext_flags(hv,0)) ) {
6626             IV i;
6627             IV parno = 0;
6628             SV* sv_dat = HeVAL(temphe);
6629             I32 *nums = (I32*)SvPVX(sv_dat);
6630             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
6631                 if ((I32)(rx->lastparen) >= nums[i] &&
6632                     rx->offs[nums[i]].start != -1 &&
6633                     rx->offs[nums[i]].end != -1)
6634                 {
6635                     parno = nums[i];
6636                     break;
6637                 }
6638             }
6639             if (parno || flags & RXapif_ALL) {
6640                 return newSVhek(HeKEY_hek(temphe));
6641             }
6642         }
6643     }
6644     return NULL;
6645 }
6646
6647 SV*
6648 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
6649 {
6650     SV *ret;
6651     AV *av;
6652     I32 length;
6653     struct regexp *const rx = ReANY(r);
6654
6655     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
6656
6657     if (rx && RXp_PAREN_NAMES(rx)) {
6658         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
6659             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
6660         } else if (flags & RXapif_ONE) {
6661             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
6662             av = MUTABLE_AV(SvRV(ret));
6663             length = av_len(av);
6664             SvREFCNT_dec(ret);
6665             return newSViv(length + 1);
6666         } else {
6667             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", (int)flags);
6668             return NULL;
6669         }
6670     }
6671     return &PL_sv_undef;
6672 }
6673
6674 SV*
6675 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
6676 {
6677     struct regexp *const rx = ReANY(r);
6678     AV *av = newAV();
6679
6680     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
6681
6682     if (rx && RXp_PAREN_NAMES(rx)) {
6683         HV *hv= RXp_PAREN_NAMES(rx);
6684         HE *temphe;
6685         (void)hv_iterinit(hv);
6686         while ( (temphe = hv_iternext_flags(hv,0)) ) {
6687             IV i;
6688             IV parno = 0;
6689             SV* sv_dat = HeVAL(temphe);
6690             I32 *nums = (I32*)SvPVX(sv_dat);
6691             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
6692                 if ((I32)(rx->lastparen) >= nums[i] &&
6693                     rx->offs[nums[i]].start != -1 &&
6694                     rx->offs[nums[i]].end != -1)
6695                 {
6696                     parno = nums[i];
6697                     break;
6698                 }
6699             }
6700             if (parno || flags & RXapif_ALL) {
6701                 av_push(av, newSVhek(HeKEY_hek(temphe)));
6702             }
6703         }
6704     }
6705
6706     return newRV_noinc(MUTABLE_SV(av));
6707 }
6708
6709 void
6710 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
6711                              SV * const sv)
6712 {
6713     struct regexp *const rx = ReANY(r);
6714     char *s = NULL;
6715     I32 i = 0;
6716     I32 s1, t1;
6717     I32 n = paren;
6718
6719     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
6720         
6721     if ( (    n == RX_BUFF_IDX_CARET_PREMATCH
6722            || n == RX_BUFF_IDX_CARET_FULLMATCH
6723            || n == RX_BUFF_IDX_CARET_POSTMATCH
6724          )
6725          && !(rx->extflags & RXf_PMf_KEEPCOPY)
6726     )
6727         goto ret_undef;
6728
6729     if (!rx->subbeg)
6730         goto ret_undef;
6731
6732     if (n == RX_BUFF_IDX_CARET_FULLMATCH)
6733         /* no need to distinguish between them any more */
6734         n = RX_BUFF_IDX_FULLMATCH;
6735
6736     if ((n == RX_BUFF_IDX_PREMATCH || n == RX_BUFF_IDX_CARET_PREMATCH)
6737         && rx->offs[0].start != -1)
6738     {
6739         /* $`, ${^PREMATCH} */
6740         i = rx->offs[0].start;
6741         s = rx->subbeg;
6742     }
6743     else 
6744     if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
6745         && rx->offs[0].end != -1)
6746     {
6747         /* $', ${^POSTMATCH} */
6748         s = rx->subbeg - rx->suboffset + rx->offs[0].end;
6749         i = rx->sublen + rx->suboffset - rx->offs[0].end;
6750     } 
6751     else
6752     if ( 0 <= n && n <= (I32)rx->nparens &&
6753         (s1 = rx->offs[n].start) != -1 &&
6754         (t1 = rx->offs[n].end) != -1)
6755     {
6756         /* $&, ${^MATCH},  $1 ... */
6757         i = t1 - s1;
6758         s = rx->subbeg + s1 - rx->suboffset;
6759     } else {
6760         goto ret_undef;
6761     }          
6762
6763     assert(s >= rx->subbeg);
6764     assert(rx->sublen >= (s - rx->subbeg) + i );
6765     if (i >= 0) {
6766 #if NO_TAINT_SUPPORT
6767         sv_setpvn(sv, s, i);
6768 #else
6769         const int oldtainted = TAINT_get;
6770         TAINT_NOT;
6771         sv_setpvn(sv, s, i);
6772         TAINT_set(oldtainted);
6773 #endif
6774         if ( (rx->extflags & RXf_CANY_SEEN)
6775             ? (RXp_MATCH_UTF8(rx)
6776                         && (!i || is_utf8_string((U8*)s, i)))
6777             : (RXp_MATCH_UTF8(rx)) )
6778         {
6779             SvUTF8_on(sv);
6780         }
6781         else
6782             SvUTF8_off(sv);
6783         if (TAINTING_get) {
6784             if (RXp_MATCH_TAINTED(rx)) {
6785                 if (SvTYPE(sv) >= SVt_PVMG) {
6786                     MAGIC* const mg = SvMAGIC(sv);
6787                     MAGIC* mgt;
6788                     TAINT;
6789                     SvMAGIC_set(sv, mg->mg_moremagic);
6790                     SvTAINT(sv);
6791                     if ((mgt = SvMAGIC(sv))) {
6792                         mg->mg_moremagic = mgt;
6793                         SvMAGIC_set(sv, mg);
6794                     }
6795                 } else {
6796                     TAINT;
6797                     SvTAINT(sv);
6798                 }
6799             } else 
6800                 SvTAINTED_off(sv);
6801         }
6802     } else {
6803       ret_undef:
6804         sv_setsv(sv,&PL_sv_undef);
6805         return;
6806     }
6807 }
6808
6809 void
6810 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
6811                                                          SV const * const value)
6812 {
6813     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
6814
6815     PERL_UNUSED_ARG(rx);
6816     PERL_UNUSED_ARG(paren);
6817     PERL_UNUSED_ARG(value);
6818
6819     if (!PL_localizing)
6820         Perl_croak_no_modify();
6821 }
6822
6823 I32
6824 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
6825                               const I32 paren)
6826 {
6827     struct regexp *const rx = ReANY(r);
6828     I32 i;
6829     I32 s1, t1;
6830
6831     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
6832
6833     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
6834     switch (paren) {
6835       case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */
6836          if (!(rx->extflags & RXf_PMf_KEEPCOPY))
6837             goto warn_undef;
6838         /*FALLTHROUGH*/
6839
6840       case RX_BUFF_IDX_PREMATCH:       /* $` */
6841         if (rx->offs[0].start != -1) {
6842                         i = rx->offs[0].start;
6843                         if (i > 0) {
6844                                 s1 = 0;
6845                                 t1 = i;
6846                                 goto getlen;
6847                         }
6848             }
6849         return 0;
6850
6851       case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */
6852          if (!(rx->extflags & RXf_PMf_KEEPCOPY))
6853             goto warn_undef;
6854       case RX_BUFF_IDX_POSTMATCH:       /* $' */
6855             if (rx->offs[0].end != -1) {
6856                         i = rx->sublen - rx->offs[0].end;
6857                         if (i > 0) {
6858                                 s1 = rx->offs[0].end;
6859                                 t1 = rx->sublen;
6860                                 goto getlen;
6861                         }
6862             }
6863         return 0;
6864
6865       case RX_BUFF_IDX_CARET_FULLMATCH: /* ${^MATCH} */
6866          if (!(rx->extflags & RXf_PMf_KEEPCOPY))
6867             goto warn_undef;
6868         /*FALLTHROUGH*/
6869
6870       /* $& / ${^MATCH}, $1, $2, ... */
6871       default:
6872             if (paren <= (I32)rx->nparens &&
6873             (s1 = rx->offs[paren].start) != -1 &&
6874             (t1 = rx->offs[paren].end) != -1)
6875             {
6876             i = t1 - s1;
6877             goto getlen;
6878         } else {
6879           warn_undef:
6880             if (ckWARN(WARN_UNINITIALIZED))
6881                 report_uninit((const SV *)sv);
6882             return 0;
6883         }
6884     }
6885   getlen:
6886     if (i > 0 && RXp_MATCH_UTF8(rx)) {
6887         const char * const s = rx->subbeg - rx->suboffset + s1;
6888         const U8 *ep;
6889         STRLEN el;
6890
6891         i = t1 - s1;
6892         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
6893                         i = el;
6894     }
6895     return i;
6896 }
6897
6898 SV*
6899 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
6900 {
6901     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
6902         PERL_UNUSED_ARG(rx);
6903         if (0)
6904             return NULL;
6905         else
6906             return newSVpvs("Regexp");
6907 }
6908
6909 /* Scans the name of a named buffer from the pattern.
6910  * If flags is REG_RSN_RETURN_NULL returns null.
6911  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
6912  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
6913  * to the parsed name as looked up in the RExC_paren_names hash.
6914  * If there is an error throws a vFAIL().. type exception.
6915  */
6916
6917 #define REG_RSN_RETURN_NULL    0
6918 #define REG_RSN_RETURN_NAME    1
6919 #define REG_RSN_RETURN_DATA    2
6920
6921 STATIC SV*
6922 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
6923 {
6924     char *name_start = RExC_parse;
6925
6926     PERL_ARGS_ASSERT_REG_SCAN_NAME;
6927
6928     if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
6929          /* skip IDFIRST by using do...while */
6930         if (UTF)
6931             do {
6932                 RExC_parse += UTF8SKIP(RExC_parse);
6933             } while (isALNUM_utf8((U8*)RExC_parse));
6934         else
6935             do {
6936                 RExC_parse++;
6937             } while (isALNUM(*RExC_parse));
6938     } else {
6939         RExC_parse++; /* so the <- from the vFAIL is after the offending character */
6940         vFAIL("Group name must start with a non-digit word character");
6941     }
6942     if ( flags ) {
6943         SV* sv_name
6944             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
6945                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
6946         if ( flags == REG_RSN_RETURN_NAME)
6947             return sv_name;
6948         else if (flags==REG_RSN_RETURN_DATA) {
6949             HE *he_str = NULL;
6950             SV *sv_dat = NULL;
6951             if ( ! sv_name )      /* should not happen*/
6952                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
6953             if (RExC_paren_names)
6954                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
6955             if ( he_str )
6956                 sv_dat = HeVAL(he_str);
6957             if ( ! sv_dat )
6958                 vFAIL("Reference to nonexistent named group");
6959             return sv_dat;
6960         }
6961         else {
6962             Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
6963                        (unsigned long) flags);
6964         }
6965         assert(0); /* NOT REACHED */
6966     }
6967     return NULL;
6968 }
6969
6970 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
6971     int rem=(int)(RExC_end - RExC_parse);                       \
6972     int cut;                                                    \
6973     int num;                                                    \
6974     int iscut=0;                                                \
6975     if (rem>10) {                                               \
6976         rem=10;                                                 \
6977         iscut=1;                                                \
6978     }                                                           \
6979     cut=10-rem;                                                 \
6980     if (RExC_lastparse!=RExC_parse)                             \
6981         PerlIO_printf(Perl_debug_log," >%.*s%-*s",              \
6982             rem, RExC_parse,                                    \
6983             cut + 4,                                            \
6984             iscut ? "..." : "<"                                 \
6985         );                                                      \
6986     else                                                        \
6987         PerlIO_printf(Perl_debug_log,"%16s","");                \
6988                                                                 \
6989     if (SIZE_ONLY)                                              \
6990        num = RExC_size + 1;                                     \
6991     else                                                        \
6992        num=REG_NODE_NUM(RExC_emit);                             \
6993     if (RExC_lastnum!=num)                                      \
6994        PerlIO_printf(Perl_debug_log,"|%4d",num);                \
6995     else                                                        \
6996        PerlIO_printf(Perl_debug_log,"|%4s","");                 \
6997     PerlIO_printf(Perl_debug_log,"|%*s%-4s",                    \
6998         (int)((depth*2)), "",                                   \
6999         (funcname)                                              \
7000     );                                                          \
7001     RExC_lastnum=num;                                           \
7002     RExC_lastparse=RExC_parse;                                  \
7003 })
7004
7005
7006
7007 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
7008     DEBUG_PARSE_MSG((funcname));                            \
7009     PerlIO_printf(Perl_debug_log,"%4s","\n");               \
7010 })
7011 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({           \
7012     DEBUG_PARSE_MSG((funcname));                            \
7013     PerlIO_printf(Perl_debug_log,fmt "\n",args);               \
7014 })
7015
7016 /* This section of code defines the inversion list object and its methods.  The
7017  * interfaces are highly subject to change, so as much as possible is static to
7018  * this file.  An inversion list is here implemented as a malloc'd C UV array
7019  * with some added info that is placed as UVs at the beginning in a header
7020  * portion.  An inversion list for Unicode is an array of code points, sorted
7021  * by ordinal number.  The zeroth element is the first code point in the list.
7022  * The 1th element is the first element beyond that not in the list.  In other
7023  * words, the first range is
7024  *  invlist[0]..(invlist[1]-1)
7025  * The other ranges follow.  Thus every element whose index is divisible by two
7026  * marks the beginning of a range that is in the list, and every element not
7027  * divisible by two marks the beginning of a range not in the list.  A single
7028  * element inversion list that contains the single code point N generally
7029  * consists of two elements
7030  *  invlist[0] == N
7031  *  invlist[1] == N+1
7032  * (The exception is when N is the highest representable value on the
7033  * machine, in which case the list containing just it would be a single
7034  * element, itself.  By extension, if the last range in the list extends to
7035  * infinity, then the first element of that range will be in the inversion list
7036  * at a position that is divisible by two, and is the final element in the
7037  * list.)
7038  * Taking the complement (inverting) an inversion list is quite simple, if the
7039  * first element is 0, remove it; otherwise add a 0 element at the beginning.
7040  * This implementation reserves an element at the beginning of each inversion
7041  * list to contain 0 when the list contains 0, and contains 1 otherwise.  The
7042  * actual beginning of the list is either that element if 0, or the next one if
7043  * 1.
7044  *
7045  * More about inversion lists can be found in "Unicode Demystified"
7046  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
7047  * More will be coming when functionality is added later.
7048  *
7049  * The inversion list data structure is currently implemented as an SV pointing
7050  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
7051  * array of UV whose memory management is automatically handled by the existing
7052  * facilities for SV's.
7053  *
7054  * Some of the methods should always be private to the implementation, and some
7055  * should eventually be made public */
7056
7057 /* The header definitions are in F<inline_invlist.c> */
7058
7059 #define TO_INTERNAL_SIZE(x) ((x + HEADER_LENGTH) * sizeof(UV))
7060 #define FROM_INTERNAL_SIZE(x) ((x / sizeof(UV)) - HEADER_LENGTH)
7061
7062 #define INVLIST_INITIAL_LEN 10
7063
7064 PERL_STATIC_INLINE UV*
7065 S__invlist_array_init(pTHX_ SV* const invlist, const bool will_have_0)
7066 {
7067     /* Returns a pointer to the first element in the inversion list's array.
7068      * This is called upon initialization of an inversion list.  Where the
7069      * array begins depends on whether the list has the code point U+0000
7070      * in it or not.  The other parameter tells it whether the code that
7071      * follows this call is about to put a 0 in the inversion list or not.
7072      * The first element is either the element with 0, if 0, or the next one,
7073      * if 1 */
7074
7075     UV* zero = get_invlist_zero_addr(invlist);
7076
7077     PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
7078
7079     /* Must be empty */
7080     assert(! *_get_invlist_len_addr(invlist));
7081
7082     /* 1^1 = 0; 1^0 = 1 */
7083     *zero = 1 ^ will_have_0;
7084     return zero + *zero;
7085 }
7086
7087 PERL_STATIC_INLINE UV*
7088 S_invlist_array(pTHX_ SV* const invlist)
7089 {
7090     /* Returns the pointer to the inversion list's array.  Every time the
7091      * length changes, this needs to be called in case malloc or realloc moved
7092      * it */
7093
7094     PERL_ARGS_ASSERT_INVLIST_ARRAY;
7095
7096     /* Must not be empty.  If these fail, you probably didn't check for <len>
7097      * being non-zero before trying to get the array */
7098     assert(*_get_invlist_len_addr(invlist));
7099     assert(*get_invlist_zero_addr(invlist) == 0
7100            || *get_invlist_zero_addr(invlist) == 1);
7101
7102     /* The array begins either at the element reserved for zero if the
7103      * list contains 0 (that element will be set to 0), or otherwise the next
7104      * element (in which case the reserved element will be set to 1). */
7105     return (UV *) (get_invlist_zero_addr(invlist)
7106                    + *get_invlist_zero_addr(invlist));
7107 }
7108
7109 PERL_STATIC_INLINE void
7110 S_invlist_set_len(pTHX_ SV* const invlist, const UV len)
7111 {
7112     /* Sets the current number of elements stored in the inversion list */
7113
7114     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
7115
7116     *_get_invlist_len_addr(invlist) = len;
7117
7118     assert(len <= SvLEN(invlist));
7119
7120     SvCUR_set(invlist, TO_INTERNAL_SIZE(len));
7121     /* If the list contains U+0000, that element is part of the header,
7122      * and should not be counted as part of the array.  It will contain
7123      * 0 in that case, and 1 otherwise.  So we could flop 0=>1, 1=>0 and
7124      * subtract:
7125      *  SvCUR_set(invlist,
7126      *            TO_INTERNAL_SIZE(len
7127      *                             - (*get_invlist_zero_addr(inv_list) ^ 1)));
7128      * But, this is only valid if len is not 0.  The consequences of not doing
7129      * this is that the memory allocation code may think that 1 more UV is
7130      * being used than actually is, and so might do an unnecessary grow.  That
7131      * seems worth not bothering to make this the precise amount.
7132      *
7133      * Note that when inverting, SvCUR shouldn't change */
7134 }
7135
7136 PERL_STATIC_INLINE IV*
7137 S_get_invlist_previous_index_addr(pTHX_ SV* invlist)
7138 {
7139     /* Return the address of the UV that is reserved to hold the cached index
7140      * */
7141
7142     PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR;
7143
7144     return (IV *) (SvPVX(invlist) + (INVLIST_PREVIOUS_INDEX_OFFSET * sizeof (UV)));
7145 }
7146
7147 PERL_STATIC_INLINE IV
7148 S_invlist_previous_index(pTHX_ SV* const invlist)
7149 {
7150     /* Returns cached index of previous search */
7151
7152     PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX;
7153
7154     return *get_invlist_previous_index_addr(invlist);
7155 }
7156
7157 PERL_STATIC_INLINE void
7158 S_invlist_set_previous_index(pTHX_ SV* const invlist, const IV index)
7159 {
7160     /* Caches <index> for later retrieval */
7161
7162     PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX;
7163
7164     assert(index == 0 || index < (int) _invlist_len(invlist));
7165
7166     *get_invlist_previous_index_addr(invlist) = index;
7167 }
7168
7169 PERL_STATIC_INLINE UV
7170 S_invlist_max(pTHX_ SV* const invlist)
7171 {
7172     /* Returns the maximum number of elements storable in the inversion list's
7173      * array, without having to realloc() */
7174
7175     PERL_ARGS_ASSERT_INVLIST_MAX;
7176
7177     return FROM_INTERNAL_SIZE(SvLEN(invlist));
7178 }
7179
7180 PERL_STATIC_INLINE UV*
7181 S_get_invlist_zero_addr(pTHX_ SV* invlist)
7182 {
7183     /* Return the address of the UV that is reserved to hold 0 if the inversion
7184      * list contains 0.  This has to be the last element of the heading, as the
7185      * list proper starts with either it if 0, or the next element if not.
7186      * (But we force it to contain either 0 or 1) */
7187
7188     PERL_ARGS_ASSERT_GET_INVLIST_ZERO_ADDR;
7189
7190     return (UV *) (SvPVX(invlist) + (INVLIST_ZERO_OFFSET * sizeof (UV)));
7191 }
7192
7193 #ifndef PERL_IN_XSUB_RE
7194 SV*
7195 Perl__new_invlist(pTHX_ IV initial_size)
7196 {
7197
7198     /* Return a pointer to a newly constructed inversion list, with enough
7199      * space to store 'initial_size' elements.  If that number is negative, a
7200      * system default is used instead */
7201
7202     SV* new_list;
7203
7204     if (initial_size < 0) {
7205         initial_size = INVLIST_INITIAL_LEN;
7206     }
7207
7208     /* Allocate the initial space */
7209     new_list = newSV(TO_INTERNAL_SIZE(initial_size));
7210     invlist_set_len(new_list, 0);
7211
7212     /* Force iterinit() to be used to get iteration to work */
7213     *get_invlist_iter_addr(new_list) = UV_MAX;
7214
7215     /* This should force a segfault if a method doesn't initialize this
7216      * properly */
7217     *get_invlist_zero_addr(new_list) = UV_MAX;
7218
7219     *get_invlist_previous_index_addr(new_list) = 0;
7220     *get_invlist_version_id_addr(new_list) = INVLIST_VERSION_ID;
7221 #if HEADER_LENGTH != 5
7222 #   error Need to regenerate VERSION_ID by running perl -E 'say int(rand 2**31-1)', and then changing the #if to the new length
7223 #endif
7224
7225     return new_list;
7226 }
7227 #endif
7228
7229 STATIC SV*
7230 S__new_invlist_C_array(pTHX_ UV* list)
7231 {
7232     /* Return a pointer to a newly constructed inversion list, initialized to
7233      * point to <list>, which has to be in the exact correct inversion list
7234      * form, including internal fields.  Thus this is a dangerous routine that
7235      * should not be used in the wrong hands */
7236
7237     SV* invlist = newSV_type(SVt_PV);
7238
7239     PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
7240
7241     SvPV_set(invlist, (char *) list);
7242     SvLEN_set(invlist, 0);  /* Means we own the contents, and the system
7243                                shouldn't touch it */
7244     SvCUR_set(invlist, TO_INTERNAL_SIZE(_invlist_len(invlist)));
7245
7246     if (*get_invlist_version_id_addr(invlist) != INVLIST_VERSION_ID) {
7247         Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
7248     }
7249
7250     return invlist;
7251 }
7252
7253 STATIC void
7254 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
7255 {
7256     /* Grow the maximum size of an inversion list */
7257
7258     PERL_ARGS_ASSERT_INVLIST_EXTEND;
7259
7260     SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max));
7261 }
7262
7263 PERL_STATIC_INLINE void
7264 S_invlist_trim(pTHX_ SV* const invlist)
7265 {
7266     PERL_ARGS_ASSERT_INVLIST_TRIM;
7267
7268     /* Change the length of the inversion list to how many entries it currently
7269      * has */
7270
7271     SvPV_shrink_to_cur((SV *) invlist);
7272 }
7273
7274 #define _invlist_union_complement_2nd(a, b, output) _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
7275
7276 STATIC void
7277 S__append_range_to_invlist(pTHX_ SV* const invlist, const UV start, const UV end)
7278 {
7279    /* Subject to change or removal.  Append the range from 'start' to 'end' at
7280     * the end of the inversion list.  The range must be above any existing
7281     * ones. */
7282
7283     UV* array;
7284     UV max = invlist_max(invlist);
7285     UV len = _invlist_len(invlist);
7286
7287     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
7288
7289     if (len == 0) { /* Empty lists must be initialized */
7290         array = _invlist_array_init(invlist, start == 0);
7291     }
7292     else {
7293         /* Here, the existing list is non-empty. The current max entry in the
7294          * list is generally the first value not in the set, except when the
7295          * set extends to the end of permissible values, in which case it is
7296          * the first entry in that final set, and so this call is an attempt to
7297          * append out-of-order */
7298
7299         UV final_element = len - 1;
7300         array = invlist_array(invlist);
7301         if (array[final_element] > start
7302             || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
7303         {
7304             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",
7305                        array[final_element], start,
7306                        ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
7307         }
7308
7309         /* Here, it is a legal append.  If the new range begins with the first
7310          * value not in the set, it is extending the set, so the new first
7311          * value not in the set is one greater than the newly extended range.
7312          * */
7313         if (array[final_element] == start) {
7314             if (end != UV_MAX) {
7315                 array[final_element] = end + 1;
7316             }
7317             else {
7318                 /* But if the end is the maximum representable on the machine,
7319                  * just let the range that this would extend to have no end */
7320                 invlist_set_len(invlist, len - 1);
7321             }
7322             return;
7323         }
7324     }
7325
7326     /* Here the new range doesn't extend any existing set.  Add it */
7327
7328     len += 2;   /* Includes an element each for the start and end of range */
7329
7330     /* If overflows the existing space, extend, which may cause the array to be
7331      * moved */
7332     if (max < len) {
7333         invlist_extend(invlist, len);
7334         invlist_set_len(invlist, len);  /* Have to set len here to avoid assert
7335                                            failure in invlist_array() */
7336         array = invlist_array(invlist);
7337     }
7338     else {
7339         invlist_set_len(invlist, len);
7340     }
7341
7342     /* The next item on the list starts the range, the one after that is
7343      * one past the new range.  */
7344     array[len - 2] = start;
7345     if (end != UV_MAX) {
7346         array[len - 1] = end + 1;
7347     }
7348     else {
7349         /* But if the end is the maximum representable on the machine, just let
7350          * the range have no end */
7351         invlist_set_len(invlist, len - 1);
7352     }
7353 }
7354
7355 #ifndef PERL_IN_XSUB_RE
7356
7357 IV
7358 Perl__invlist_search(pTHX_ SV* const invlist, const UV cp)
7359 {
7360     /* Searches the inversion list for the entry that contains the input code
7361      * point <cp>.  If <cp> is not in the list, -1 is returned.  Otherwise, the
7362      * return value is the index into the list's array of the range that
7363      * contains <cp> */
7364
7365     IV low = 0;
7366     IV mid;
7367     IV high = _invlist_len(invlist);
7368     const IV highest_element = high - 1;
7369     const UV* array;
7370
7371     PERL_ARGS_ASSERT__INVLIST_SEARCH;
7372
7373     /* If list is empty, return failure. */
7374     if (high == 0) {
7375         return -1;
7376     }
7377
7378     /* If the code point is before the first element, return failure.  (We
7379      * can't combine this with the test above, because we can't get the array
7380      * unless we know the list is non-empty) */
7381     array = invlist_array(invlist);
7382
7383     mid = invlist_previous_index(invlist);
7384     assert(mid >=0 && mid <= highest_element);
7385
7386     /* <mid> contains the cache of the result of the previous call to this
7387      * function (0 the first time).  See if this call is for the same result,
7388      * or if it is for mid-1.  This is under the theory that calls to this
7389      * function will often be for related code points that are near each other.
7390      * And benchmarks show that caching gives better results.  We also test
7391      * here if the code point is within the bounds of the list.  These tests
7392      * replace others that would have had to be made anyway to make sure that
7393      * the array bounds were not exceeded, and these give us extra information
7394      * at the same time */
7395     if (cp >= array[mid]) {
7396         if (cp >= array[highest_element]) {
7397             return highest_element;
7398         }
7399
7400         /* Here, array[mid] <= cp < array[highest_element].  This means that
7401          * the final element is not the answer, so can exclude it; it also
7402          * means that <mid> is not the final element, so can refer to 'mid + 1'
7403          * safely */
7404         if (cp < array[mid + 1]) {
7405             return mid;
7406         }
7407         high--;
7408         low = mid + 1;
7409     }
7410     else { /* cp < aray[mid] */
7411         if (cp < array[0]) { /* Fail if outside the array */
7412             return -1;
7413         }
7414         high = mid;
7415         if (cp >= array[mid - 1]) {
7416             goto found_entry;
7417         }
7418     }
7419
7420     /* Binary search.  What we are looking for is <i> such that
7421      *  array[i] <= cp < array[i+1]
7422      * The loop below converges on the i+1.  Note that there may not be an
7423      * (i+1)th element in the array, and things work nonetheless */
7424     while (low < high) {
7425         mid = (low + high) / 2;
7426         assert(mid <= highest_element);
7427         if (array[mid] <= cp) { /* cp >= array[mid] */
7428             low = mid + 1;
7429
7430             /* We could do this extra test to exit the loop early.
7431             if (cp < array[low]) {
7432                 return mid;
7433             }
7434             */
7435         }
7436         else { /* cp < array[mid] */
7437             high = mid;
7438         }
7439     }
7440
7441   found_entry:
7442     high--;
7443     invlist_set_previous_index(invlist, high);
7444     return high;
7445 }
7446
7447 void
7448 Perl__invlist_populate_swatch(pTHX_ SV* const invlist, const UV start, const UV end, U8* swatch)
7449 {
7450     /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
7451      * but is used when the swash has an inversion list.  This makes this much
7452      * faster, as it uses a binary search instead of a linear one.  This is
7453      * intimately tied to that function, and perhaps should be in utf8.c,
7454      * except it is intimately tied to inversion lists as well.  It assumes
7455      * that <swatch> is all 0's on input */
7456
7457     UV current = start;
7458     const IV len = _invlist_len(invlist);
7459     IV i;
7460     const UV * array;
7461
7462     PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
7463
7464     if (len == 0) { /* Empty inversion list */
7465         return;
7466     }
7467
7468     array = invlist_array(invlist);
7469
7470     /* Find which element it is */
7471     i = _invlist_search(invlist, start);
7472
7473     /* We populate from <start> to <end> */
7474     while (current < end) {
7475         UV upper;
7476
7477         /* The inversion list gives the results for every possible code point
7478          * after the first one in the list.  Only those ranges whose index is
7479          * even are ones that the inversion list matches.  For the odd ones,
7480          * and if the initial code point is not in the list, we have to skip
7481          * forward to the next element */
7482         if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
7483             i++;
7484             if (i >= len) { /* Finished if beyond the end of the array */
7485                 return;
7486             }
7487             current = array[i];
7488             if (current >= end) {   /* Finished if beyond the end of what we
7489                                        are populating */
7490                 if (LIKELY(end < UV_MAX)) {
7491                     return;
7492                 }
7493
7494                 /* We get here when the upper bound is the maximum
7495                  * representable on the machine, and we are looking for just
7496                  * that code point.  Have to special case it */
7497                 i = len;
7498                 goto join_end_of_list;
7499             }
7500         }
7501         assert(current >= start);
7502
7503         /* The current range ends one below the next one, except don't go past
7504          * <end> */
7505         i++;
7506         upper = (i < len && array[i] < end) ? array[i] : end;
7507
7508         /* Here we are in a range that matches.  Populate a bit in the 3-bit U8
7509          * for each code point in it */
7510         for (; current < upper; current++) {
7511             const STRLEN offset = (STRLEN)(current - start);
7512             swatch[offset >> 3] |= 1 << (offset & 7);
7513         }
7514
7515     join_end_of_list:
7516
7517         /* Quit if at the end of the list */
7518         if (i >= len) {
7519
7520             /* But first, have to deal with the highest possible code point on
7521              * the platform.  The previous code assumes that <end> is one
7522              * beyond where we want to populate, but that is impossible at the
7523              * platform's infinity, so have to handle it specially */
7524             if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
7525             {
7526                 const STRLEN offset = (STRLEN)(end - start);
7527                 swatch[offset >> 3] |= 1 << (offset & 7);
7528             }
7529             return;
7530         }
7531
7532         /* Advance to the next range, which will be for code points not in the
7533          * inversion list */
7534         current = array[i];
7535     }
7536
7537     return;
7538 }
7539
7540 void
7541 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** output)
7542 {
7543     /* Take the union of two inversion lists and point <output> to it.  *output
7544      * should be defined upon input, and if it points to one of the two lists,
7545      * the reference count to that list will be decremented.  The first list,
7546      * <a>, may be NULL, in which case a copy of the second list is returned.
7547      * If <complement_b> is TRUE, the union is taken of the complement
7548      * (inversion) of <b> instead of b itself.
7549      *
7550      * The basis for this comes from "Unicode Demystified" Chapter 13 by
7551      * Richard Gillam, published by Addison-Wesley, and explained at some
7552      * length there.  The preface says to incorporate its examples into your
7553      * code at your own risk.
7554      *
7555      * The algorithm is like a merge sort.
7556      *
7557      * XXX A potential performance improvement is to keep track as we go along
7558      * if only one of the inputs contributes to the result, meaning the other
7559      * is a subset of that one.  In that case, we can skip the final copy and
7560      * return the larger of the input lists, but then outside code might need
7561      * to keep track of whether to free the input list or not */
7562
7563     UV* array_a;    /* a's array */
7564     UV* array_b;
7565     UV len_a;       /* length of a's array */
7566     UV len_b;
7567
7568     SV* u;                      /* the resulting union */
7569     UV* array_u;
7570     UV len_u;
7571
7572     UV i_a = 0;             /* current index into a's array */
7573     UV i_b = 0;
7574     UV i_u = 0;
7575
7576     /* running count, as explained in the algorithm source book; items are
7577      * stopped accumulating and are output when the count changes to/from 0.
7578      * The count is incremented when we start a range that's in the set, and
7579      * decremented when we start a range that's not in the set.  So its range
7580      * is 0 to 2.  Only when the count is zero is something not in the set.
7581      */
7582     UV count = 0;
7583
7584     PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
7585     assert(a != b);
7586
7587     /* If either one is empty, the union is the other one */
7588     if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
7589         if (*output == a) {
7590             if (a != NULL) {
7591                 SvREFCNT_dec(a);
7592             }
7593         }
7594         if (*output != b) {
7595             *output = invlist_clone(b);
7596             if (complement_b) {
7597                 _invlist_invert(*output);
7598             }
7599         } /* else *output already = b; */
7600         return;
7601     }
7602     else if ((len_b = _invlist_len(b)) == 0) {
7603         if (*output == b) {
7604             SvREFCNT_dec(b);
7605         }
7606
7607         /* The complement of an empty list is a list that has everything in it,
7608          * so the union with <a> includes everything too */
7609         if (complement_b) {
7610             if (a == *output) {
7611                 SvREFCNT_dec(a);
7612             }
7613             *output = _new_invlist(1);
7614             _append_range_to_invlist(*output, 0, UV_MAX);
7615         }
7616         else if (*output != a) {
7617             *output = invlist_clone(a);
7618         }
7619         /* else *output already = a; */
7620         return;
7621     }
7622
7623     /* Here both lists exist and are non-empty */
7624     array_a = invlist_array(a);
7625     array_b = invlist_array(b);
7626
7627     /* If are to take the union of 'a' with the complement of b, set it
7628      * up so are looking at b's complement. */
7629     if (complement_b) {
7630
7631         /* To complement, we invert: if the first element is 0, remove it.  To
7632          * do this, we just pretend the array starts one later, and clear the
7633          * flag as we don't have to do anything else later */
7634         if (array_b[0] == 0) {
7635             array_b++;
7636             len_b--;
7637             complement_b = FALSE;
7638         }
7639         else {
7640
7641             /* But if the first element is not zero, we unshift a 0 before the
7642              * array.  The data structure reserves a space for that 0 (which
7643              * should be a '1' right now), so physical shifting is unneeded,
7644              * but temporarily change that element to 0.  Before exiting the
7645              * routine, we must restore the element to '1' */
7646             array_b--;
7647             len_b++;
7648             array_b[0] = 0;
7649         }
7650     }
7651
7652     /* Size the union for the worst case: that the sets are completely
7653      * disjoint */
7654     u = _new_invlist(len_a + len_b);
7655
7656     /* Will contain U+0000 if either component does */
7657     array_u = _invlist_array_init(u, (len_a > 0 && array_a[0] == 0)
7658                                       || (len_b > 0 && array_b[0] == 0));
7659
7660     /* Go through each list item by item, stopping when exhausted one of
7661      * them */
7662     while (i_a < len_a && i_b < len_b) {
7663         UV cp;      /* The element to potentially add to the union's array */
7664         bool cp_in_set;   /* is it in the the input list's set or not */
7665
7666         /* We need to take one or the other of the two inputs for the union.
7667          * Since we are merging two sorted lists, we take the smaller of the
7668          * next items.  In case of a tie, we take the one that is in its set
7669          * first.  If we took one not in the set first, it would decrement the
7670          * count, possibly to 0 which would cause it to be output as ending the
7671          * range, and the next time through we would take the same number, and
7672          * output it again as beginning the next range.  By doing it the
7673          * opposite way, there is no possibility that the count will be
7674          * momentarily decremented to 0, and thus the two adjoining ranges will
7675          * be seamlessly merged.  (In a tie and both are in the set or both not
7676          * in the set, it doesn't matter which we take first.) */
7677         if (array_a[i_a] < array_b[i_b]
7678             || (array_a[i_a] == array_b[i_b]
7679                 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
7680         {
7681             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
7682             cp= array_a[i_a++];
7683         }
7684         else {
7685             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
7686             cp= array_b[i_b++];
7687         }
7688
7689         /* Here, have chosen which of the two inputs to look at.  Only output
7690          * if the running count changes to/from 0, which marks the
7691          * beginning/end of a range in that's in the set */
7692         if (cp_in_set) {
7693             if (count == 0) {
7694                 array_u[i_u++] = cp;
7695             }
7696             count++;
7697         }
7698         else {
7699             count--;
7700             if (count == 0) {
7701                 array_u[i_u++] = cp;
7702             }
7703         }
7704     }
7705
7706     /* Here, we are finished going through at least one of the lists, which
7707      * means there is something remaining in at most one.  We check if the list
7708      * that hasn't been exhausted is positioned such that we are in the middle
7709      * of a range in its set or not.  (i_a and i_b point to the element beyond
7710      * the one we care about.) If in the set, we decrement 'count'; if 0, there
7711      * is potentially more to output.
7712      * There are four cases:
7713      *  1) Both weren't in their sets, count is 0, and remains 0.  What's left
7714      *     in the union is entirely from the non-exhausted set.
7715      *  2) Both were in their sets, count is 2.  Nothing further should
7716      *     be output, as everything that remains will be in the exhausted
7717      *     list's set, hence in the union; decrementing to 1 but not 0 insures
7718      *     that
7719      *  3) the exhausted was in its set, non-exhausted isn't, count is 1.
7720      *     Nothing further should be output because the union includes
7721      *     everything from the exhausted set.  Not decrementing ensures that.
7722      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1;
7723      *     decrementing to 0 insures that we look at the remainder of the
7724      *     non-exhausted set */
7725     if ((i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
7726         || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
7727     {
7728         count--;
7729     }
7730
7731     /* The final length is what we've output so far, plus what else is about to
7732      * be output.  (If 'count' is non-zero, then the input list we exhausted
7733      * has everything remaining up to the machine's limit in its set, and hence
7734      * in the union, so there will be no further output. */
7735     len_u = i_u;
7736     if (count == 0) {
7737         /* At most one of the subexpressions will be non-zero */
7738         len_u += (len_a - i_a) + (len_b - i_b);
7739     }
7740
7741     /* Set result to final length, which can change the pointer to array_u, so
7742      * re-find it */
7743     if (len_u != _invlist_len(u)) {
7744         invlist_set_len(u, len_u);
7745         invlist_trim(u);
7746         array_u = invlist_array(u);
7747     }
7748
7749     /* When 'count' is 0, the list that was exhausted (if one was shorter than
7750      * the other) ended with everything above it not in its set.  That means
7751      * that the remaining part of the union is precisely the same as the
7752      * non-exhausted list, so can just copy it unchanged.  (If both list were
7753      * exhausted at the same time, then the operations below will be both 0.)
7754      */
7755     if (count == 0) {
7756         IV copy_count; /* At most one will have a non-zero copy count */
7757         if ((copy_count = len_a - i_a) > 0) {
7758             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
7759         }
7760         else if ((copy_count = len_b - i_b) > 0) {
7761             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
7762         }
7763     }
7764
7765     /*  We may be removing a reference to one of the inputs */
7766     if (a == *output || b == *output) {
7767         SvREFCNT_dec(*output);
7768     }
7769
7770     /* If we've changed b, restore it */
7771     if (complement_b) {
7772         array_b[0] = 1;
7773     }
7774
7775     *output = u;
7776     return;
7777 }
7778
7779 void
7780 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** i)
7781 {
7782     /* Take the intersection of two inversion lists and point <i> to it.  *i
7783      * should be defined upon input, and if it points to one of the two lists,
7784      * the reference count to that list will be decremented.
7785      * If <complement_b> is TRUE, the result will be the intersection of <a>
7786      * and the complement (or inversion) of <b> instead of <b> directly.
7787      *
7788      * The basis for this comes from "Unicode Demystified" Chapter 13 by
7789      * Richard Gillam, published by Addison-Wesley, and explained at some
7790      * length there.  The preface says to incorporate its examples into your
7791      * code at your own risk.  In fact, it had bugs
7792      *
7793      * The algorithm is like a merge sort, and is essentially the same as the
7794      * union above
7795      */
7796
7797     UV* array_a;                /* a's array */
7798     UV* array_b;
7799     UV len_a;   /* length of a's array */
7800     UV len_b;
7801
7802     SV* r;                   /* the resulting intersection */
7803     UV* array_r;
7804     UV len_r;
7805
7806     UV i_a = 0;             /* current index into a's array */
7807     UV i_b = 0;
7808     UV i_r = 0;
7809
7810     /* running count, as explained in the algorithm source book; items are
7811      * stopped accumulating and are output when the count changes to/from 2.
7812      * The count is incremented when we start a range that's in the set, and
7813      * decremented when we start a range that's not in the set.  So its range
7814      * is 0 to 2.  Only when the count is 2 is something in the intersection.
7815      */
7816     UV count = 0;
7817
7818     PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
7819     assert(a != b);
7820
7821     /* Special case if either one is empty */
7822     len_a = _invlist_len(a);
7823     if ((len_a == 0) || ((len_b = _invlist_len(b)) == 0)) {
7824
7825         if (len_a != 0 && complement_b) {
7826
7827             /* Here, 'a' is not empty, therefore from the above 'if', 'b' must
7828              * be empty.  Here, also we are using 'b's complement, which hence
7829              * must be every possible code point.  Thus the intersection is
7830              * simply 'a'. */
7831             if (*i != a) {
7832                 *i = invlist_clone(a);
7833
7834                 if (*i == b) {
7835                     SvREFCNT_dec(b);
7836                 }
7837             }
7838             /* else *i is already 'a' */
7839             return;
7840         }
7841
7842         /* Here, 'a' or 'b' is empty and not using the complement of 'b'.  The
7843          * intersection must be empty */
7844         if (*i == a) {
7845             SvREFCNT_dec(a);
7846         }
7847         else if (*i == b) {
7848             SvREFCNT_dec(b);
7849         }
7850         *i = _new_invlist(0);
7851         return;
7852     }
7853
7854     /* Here both lists exist and are non-empty */
7855     array_a = invlist_array(a);
7856     array_b = invlist_array(b);
7857
7858     /* If are to take the intersection of 'a' with the complement of b, set it
7859      * up so are looking at b's complement. */
7860     if (complement_b) {
7861
7862         /* To complement, we invert: if the first element is 0, remove it.  To
7863          * do this, we just pretend the array starts one later, and clear the
7864          * flag as we don't have to do anything else later */
7865         if (array_b[0] == 0) {
7866             array_b++;
7867             len_b--;
7868             complement_b = FALSE;
7869         }
7870         else {
7871
7872             /* But if the first element is not zero, we unshift a 0 before the
7873              * array.  The data structure reserves a space for that 0 (which
7874              * should be a '1' right now), so physical shifting is unneeded,
7875              * but temporarily change that element to 0.  Before exiting the
7876              * routine, we must restore the element to '1' */
7877             array_b--;
7878             len_b++;
7879             array_b[0] = 0;
7880         }
7881     }
7882
7883     /* Size the intersection for the worst case: that the intersection ends up
7884      * fragmenting everything to be completely disjoint */
7885     r= _new_invlist(len_a + len_b);
7886
7887     /* Will contain U+0000 iff both components do */
7888     array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
7889                                      && len_b > 0 && array_b[0] == 0);
7890
7891     /* Go through each list item by item, stopping when exhausted one of
7892      * them */
7893     while (i_a < len_a && i_b < len_b) {
7894         UV cp;      /* The element to potentially add to the intersection's
7895                        array */
7896         bool cp_in_set; /* Is it in the input list's set or not */
7897
7898         /* We need to take one or the other of the two inputs for the
7899          * intersection.  Since we are merging two sorted lists, we take the
7900          * smaller of the next items.  In case of a tie, we take the one that
7901          * is not in its set first (a difference from the union algorithm).  If
7902          * we took one in the set first, it would increment the count, possibly
7903          * to 2 which would cause it to be output as starting a range in the
7904          * intersection, and the next time through we would take that same
7905          * number, and output it again as ending the set.  By doing it the
7906          * opposite of this, there is no possibility that the count will be
7907          * momentarily incremented to 2.  (In a tie and both are in the set or
7908          * both not in the set, it doesn't matter which we take first.) */
7909         if (array_a[i_a] < array_b[i_b]
7910             || (array_a[i_a] == array_b[i_b]
7911                 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
7912         {
7913             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
7914             cp= array_a[i_a++];
7915         }
7916         else {
7917             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
7918             cp= array_b[i_b++];
7919         }
7920
7921         /* Here, have chosen which of the two inputs to look at.  Only output
7922          * if the running count changes to/from 2, which marks the
7923          * beginning/end of a range that's in the intersection */
7924         if (cp_in_set) {
7925             count++;
7926             if (count == 2) {
7927                 array_r[i_r++] = cp;
7928             }
7929         }
7930         else {
7931             if (count == 2) {
7932                 array_r[i_r++] = cp;
7933             }
7934             count--;
7935         }
7936     }
7937
7938     /* Here, we are finished going through at least one of the lists, which
7939      * means there is something remaining in at most one.  We check if the list
7940      * that has been exhausted is positioned such that we are in the middle
7941      * of a range in its set or not.  (i_a and i_b point to elements 1 beyond
7942      * the ones we care about.)  There are four cases:
7943      *  1) Both weren't in their sets, count is 0, and remains 0.  There's
7944      *     nothing left in the intersection.
7945      *  2) Both were in their sets, count is 2 and perhaps is incremented to
7946      *     above 2.  What should be output is exactly that which is in the
7947      *     non-exhausted set, as everything it has is also in the intersection
7948      *     set, and everything it doesn't have can't be in the intersection
7949      *  3) The exhausted was in its set, non-exhausted isn't, count is 1, and
7950      *     gets incremented to 2.  Like the previous case, the intersection is
7951      *     everything that remains in the non-exhausted set.
7952      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1, and
7953      *     remains 1.  And the intersection has nothing more. */
7954     if ((i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
7955         || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
7956     {
7957         count++;
7958     }
7959
7960     /* The final length is what we've output so far plus what else is in the
7961      * intersection.  At most one of the subexpressions below will be non-zero */
7962     len_r = i_r;
7963     if (count >= 2) {
7964         len_r += (len_a - i_a) + (len_b - i_b);
7965     }
7966
7967     /* Set result to final length, which can change the pointer to array_r, so
7968      * re-find it */
7969     if (len_r != _invlist_len(r)) {
7970         invlist_set_len(r, len_r);
7971         invlist_trim(r);
7972         array_r = invlist_array(r);
7973     }
7974
7975     /* Finish outputting any remaining */
7976     if (count >= 2) { /* At most one will have a non-zero copy count */
7977         IV copy_count;
7978         if ((copy_count = len_a - i_a) > 0) {
7979             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
7980         }
7981         else if ((copy_count = len_b - i_b) > 0) {
7982             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
7983         }
7984     }
7985
7986     /*  We may be removing a reference to one of the inputs */
7987     if (a == *i || b == *i) {
7988         SvREFCNT_dec(*i);
7989     }
7990
7991     /* If we've changed b, restore it */
7992     if (complement_b) {
7993         array_b[0] = 1;
7994     }
7995
7996     *i = r;
7997     return;
7998 }
7999
8000 SV*
8001 Perl__add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end)
8002 {
8003     /* Add the range from 'start' to 'end' inclusive to the inversion list's
8004      * set.  A pointer to the inversion list is returned.  This may actually be
8005      * a new list, in which case the passed in one has been destroyed.  The
8006      * passed in inversion list can be NULL, in which case a new one is created
8007      * with just the one range in it */
8008
8009     SV* range_invlist;
8010     UV len;
8011
8012     if (invlist == NULL) {
8013         invlist = _new_invlist(2);
8014         len = 0;
8015     }
8016     else {
8017         len = _invlist_len(invlist);
8018     }
8019
8020     /* If comes after the final entry, can just append it to the end */
8021     if (len == 0
8022         || start >= invlist_array(invlist)
8023                                     [_invlist_len(invlist) - 1])
8024     {
8025         _append_range_to_invlist(invlist, start, end);
8026         return invlist;
8027     }
8028
8029     /* Here, can't just append things, create and return a new inversion list
8030      * which is the union of this range and the existing inversion list */
8031     range_invlist = _new_invlist(2);
8032     _append_range_to_invlist(range_invlist, start, end);
8033
8034     _invlist_union(invlist, range_invlist, &invlist);
8035
8036     /* The temporary can be freed */
8037     SvREFCNT_dec(range_invlist);
8038
8039     return invlist;
8040 }
8041
8042 #endif
8043
8044 PERL_STATIC_INLINE SV*
8045 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
8046     return _add_range_to_invlist(invlist, cp, cp);
8047 }
8048
8049 #ifndef PERL_IN_XSUB_RE
8050 void
8051 Perl__invlist_invert(pTHX_ SV* const invlist)
8052 {
8053     /* Complement the input inversion list.  This adds a 0 if the list didn't
8054      * have a zero; removes it otherwise.  As described above, the data
8055      * structure is set up so that this is very efficient */
8056
8057     UV* len_pos = _get_invlist_len_addr(invlist);
8058
8059     PERL_ARGS_ASSERT__INVLIST_INVERT;
8060
8061     /* The inverse of matching nothing is matching everything */
8062     if (*len_pos == 0) {
8063         _append_range_to_invlist(invlist, 0, UV_MAX);
8064         return;
8065     }
8066
8067     /* The exclusive or complents 0 to 1; and 1 to 0.  If the result is 1, the
8068      * zero element was a 0, so it is being removed, so the length decrements
8069      * by 1; and vice-versa.  SvCUR is unaffected */
8070     if (*get_invlist_zero_addr(invlist) ^= 1) {
8071         (*len_pos)--;
8072     }
8073     else {
8074         (*len_pos)++;
8075     }
8076 }
8077
8078 void
8079 Perl__invlist_invert_prop(pTHX_ SV* const invlist)
8080 {
8081     /* Complement the input inversion list (which must be a Unicode property,
8082      * all of which don't match above the Unicode maximum code point.)  And
8083      * Perl has chosen to not have the inversion match above that either.  This
8084      * adds a 0x110000 if the list didn't end with it, and removes it if it did
8085      */
8086
8087     UV len;
8088     UV* array;
8089
8090     PERL_ARGS_ASSERT__INVLIST_INVERT_PROP;
8091
8092     _invlist_invert(invlist);
8093
8094     len = _invlist_len(invlist);
8095
8096     if (len != 0) { /* If empty do nothing */
8097         array = invlist_array(invlist);
8098         if (array[len - 1] != PERL_UNICODE_MAX + 1) {
8099             /* Add 0x110000.  First, grow if necessary */
8100             len++;
8101             if (invlist_max(invlist) < len) {
8102                 invlist_extend(invlist, len);
8103                 array = invlist_array(invlist);
8104             }
8105             invlist_set_len(invlist, len);
8106             array[len - 1] = PERL_UNICODE_MAX + 1;
8107         }
8108         else {  /* Remove the 0x110000 */
8109             invlist_set_len(invlist, len - 1);
8110         }
8111     }
8112
8113     return;
8114 }
8115 #endif
8116
8117 PERL_STATIC_INLINE SV*
8118 S_invlist_clone(pTHX_ SV* const invlist)
8119 {
8120
8121     /* Return a new inversion list that is a copy of the input one, which is
8122      * unchanged */
8123
8124     /* Need to allocate extra space to accommodate Perl's addition of a
8125      * trailing NUL to SvPV's, since it thinks they are always strings */
8126     SV* new_invlist = _new_invlist(_invlist_len(invlist) + 1);
8127     STRLEN length = SvCUR(invlist);
8128
8129     PERL_ARGS_ASSERT_INVLIST_CLONE;
8130
8131     SvCUR_set(new_invlist, length); /* This isn't done automatically */
8132     Copy(SvPVX(invlist), SvPVX(new_invlist), length, char);
8133
8134     return new_invlist;
8135 }
8136
8137 PERL_STATIC_INLINE UV*
8138 S_get_invlist_iter_addr(pTHX_ SV* invlist)
8139 {
8140     /* Return the address of the UV that contains the current iteration
8141      * position */
8142
8143     PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
8144
8145     return (UV *) (SvPVX(invlist) + (INVLIST_ITER_OFFSET * sizeof (UV)));
8146 }
8147
8148 PERL_STATIC_INLINE UV*
8149 S_get_invlist_version_id_addr(pTHX_ SV* invlist)
8150 {
8151     /* Return the address of the UV that contains the version id. */
8152
8153     PERL_ARGS_ASSERT_GET_INVLIST_VERSION_ID_ADDR;
8154
8155     return (UV *) (SvPVX(invlist) + (INVLIST_VERSION_ID_OFFSET * sizeof (UV)));
8156 }
8157
8158 PERL_STATIC_INLINE void
8159 S_invlist_iterinit(pTHX_ SV* invlist)   /* Initialize iterator for invlist */
8160 {
8161     PERL_ARGS_ASSERT_INVLIST_ITERINIT;
8162
8163     *get_invlist_iter_addr(invlist) = 0;
8164 }
8165
8166 STATIC bool
8167 S_invlist_iternext(pTHX_ SV* invlist, UV* start, UV* end)
8168 {
8169     /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
8170      * This call sets in <*start> and <*end>, the next range in <invlist>.
8171      * Returns <TRUE> if successful and the next call will return the next
8172      * range; <FALSE> if was already at the end of the list.  If the latter,
8173      * <*start> and <*end> are unchanged, and the next call to this function
8174      * will start over at the beginning of the list */
8175
8176     UV* pos = get_invlist_iter_addr(invlist);
8177     UV len = _invlist_len(invlist);
8178     UV *array;
8179
8180     PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
8181
8182     if (*pos >= len) {
8183         *pos = UV_MAX;  /* Force iternit() to be required next time */
8184         return FALSE;
8185     }
8186
8187     array = invlist_array(invlist);
8188
8189     *start = array[(*pos)++];
8190
8191     if (*pos >= len) {
8192         *end = UV_MAX;
8193     }
8194     else {
8195         *end = array[(*pos)++] - 1;
8196     }
8197
8198     return TRUE;
8199 }
8200
8201 PERL_STATIC_INLINE UV
8202 S_invlist_highest(pTHX_ SV* const invlist)
8203 {
8204     /* Returns the highest code point that matches an inversion list.  This API
8205      * has an ambiguity, as it returns 0 under either the highest is actually
8206      * 0, or if the list is empty.  If this distinction matters to you, check
8207      * for emptiness before calling this function */
8208
8209     UV len = _invlist_len(invlist);
8210     UV *array;
8211
8212     PERL_ARGS_ASSERT_INVLIST_HIGHEST;
8213
8214     if (len == 0) {
8215         return 0;
8216     }
8217
8218     array = invlist_array(invlist);
8219
8220     /* The last element in the array in the inversion list always starts a
8221      * range that goes to infinity.  That range may be for code points that are
8222      * matched in the inversion list, or it may be for ones that aren't
8223      * matched.  In the latter case, the highest code point in the set is one
8224      * less than the beginning of this range; otherwise it is the final element
8225      * of this range: infinity */
8226     return (ELEMENT_RANGE_MATCHES_INVLIST(len - 1))
8227            ? UV_MAX
8228            : array[len - 1] - 1;
8229 }
8230
8231 #ifndef PERL_IN_XSUB_RE
8232 SV *
8233 Perl__invlist_contents(pTHX_ SV* const invlist)
8234 {
8235     /* Get the contents of an inversion list into a string SV so that they can
8236      * be printed out.  It uses the format traditionally done for debug tracing
8237      */
8238
8239     UV start, end;
8240     SV* output = newSVpvs("\n");
8241
8242     PERL_ARGS_ASSERT__INVLIST_CONTENTS;
8243
8244     invlist_iterinit(invlist);
8245     while (invlist_iternext(invlist, &start, &end)) {
8246         if (end == UV_MAX) {
8247             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\tINFINITY\n", start);
8248         }
8249         else if (end != start) {
8250             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\t%04"UVXf"\n",
8251                     start,       end);
8252         }
8253         else {
8254             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\n", start);
8255         }
8256     }
8257
8258     return output;
8259 }
8260 #endif
8261
8262 #ifdef PERL_ARGS_ASSERT__INVLIST_DUMP
8263 void
8264 Perl__invlist_dump(pTHX_ SV* const invlist, const char * const header)
8265 {
8266     /* Dumps out the ranges in an inversion list.  The string 'header'
8267      * if present is output on a line before the first range */
8268
8269     UV start, end;
8270
8271     PERL_ARGS_ASSERT__INVLIST_DUMP;
8272
8273     if (header && strlen(header)) {
8274         PerlIO_printf(Perl_debug_log, "%s\n", header);
8275     }
8276     invlist_iterinit(invlist);
8277     while (invlist_iternext(invlist, &start, &end)) {
8278         if (end == UV_MAX) {
8279             PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. INFINITY\n", start);
8280         }
8281         else if (end != start) {
8282             PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. 0x%04"UVXf"\n",
8283                                                  start,         end);
8284         }
8285         else {
8286             PerlIO_printf(Perl_debug_log, "0x%04"UVXf"\n", start);
8287         }
8288     }
8289 }
8290 #endif
8291
8292 #if 0
8293 bool
8294 S__invlistEQ(pTHX_ SV* const a, SV* const b, bool complement_b)
8295 {
8296     /* Return a boolean as to if the two passed in inversion lists are
8297      * identical.  The final argument, if TRUE, says to take the complement of
8298      * the second inversion list before doing the comparison */
8299
8300     UV* array_a = invlist_array(a);
8301     UV* array_b = invlist_array(b);
8302     UV len_a = _invlist_len(a);
8303     UV len_b = _invlist_len(b);
8304
8305     UV i = 0;               /* current index into the arrays */
8306     bool retval = TRUE;     /* Assume are identical until proven otherwise */
8307
8308     PERL_ARGS_ASSERT__INVLISTEQ;
8309
8310     /* If are to compare 'a' with the complement of b, set it
8311      * up so are looking at b's complement. */
8312     if (complement_b) {
8313
8314         /* The complement of nothing is everything, so <a> would have to have
8315          * just one element, starting at zero (ending at infinity) */
8316         if (len_b == 0) {
8317             return (len_a == 1 && array_a[0] == 0);
8318         }
8319         else if (array_b[0] == 0) {
8320
8321             /* Otherwise, to complement, we invert.  Here, the first element is
8322              * 0, just remove it.  To do this, we just pretend the array starts
8323              * one later, and clear the flag as we don't have to do anything
8324              * else later */
8325
8326             array_b++;
8327             len_b--;
8328             complement_b = FALSE;
8329         }
8330         else {
8331
8332             /* But if the first element is not zero, we unshift a 0 before the
8333              * array.  The data structure reserves a space for that 0 (which
8334              * should be a '1' right now), so physical shifting is unneeded,
8335              * but temporarily change that element to 0.  Before exiting the
8336              * routine, we must restore the element to '1' */
8337             array_b--;
8338             len_b++;
8339             array_b[0] = 0;
8340         }
8341     }
8342
8343     /* Make sure that the lengths are the same, as well as the final element
8344      * before looping through the remainder.  (Thus we test the length, final,
8345      * and first elements right off the bat) */
8346     if (len_a != len_b || array_a[len_a-1] != array_b[len_a-1]) {
8347         retval = FALSE;
8348     }
8349     else for (i = 0; i < len_a - 1; i++) {
8350         if (array_a[i] != array_b[i]) {
8351             retval = FALSE;
8352             break;
8353         }
8354     }
8355
8356     if (complement_b) {
8357         array_b[0] = 1;
8358     }
8359     return retval;
8360 }
8361 #endif
8362
8363 #undef HEADER_LENGTH
8364 #undef INVLIST_INITIAL_LENGTH
8365 #undef TO_INTERNAL_SIZE
8366 #undef FROM_INTERNAL_SIZE
8367 #undef INVLIST_LEN_OFFSET
8368 #undef INVLIST_ZERO_OFFSET
8369 #undef INVLIST_ITER_OFFSET
8370 #undef INVLIST_VERSION_ID
8371
8372 /* End of inversion list object */
8373
8374 /*
8375  - reg - regular expression, i.e. main body or parenthesized thing
8376  *
8377  * Caller must absorb opening parenthesis.
8378  *
8379  * Combining parenthesis handling with the base level of regular expression
8380  * is a trifle forced, but the need to tie the tails of the branches to what
8381  * follows makes it hard to avoid.
8382  */
8383 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
8384 #ifdef DEBUGGING
8385 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
8386 #else
8387 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
8388 #endif
8389
8390 STATIC regnode *
8391 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
8392     /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
8393 {
8394     dVAR;
8395     regnode *ret;               /* Will be the head of the group. */
8396     regnode *br;
8397     regnode *lastbr;
8398     regnode *ender = NULL;
8399     I32 parno = 0;
8400     I32 flags;
8401     U32 oregflags = RExC_flags;
8402     bool have_branch = 0;
8403     bool is_open = 0;
8404     I32 freeze_paren = 0;
8405     I32 after_freeze = 0;
8406
8407     /* for (?g), (?gc), and (?o) warnings; warning
8408        about (?c) will warn about (?g) -- japhy    */
8409
8410 #define WASTED_O  0x01
8411 #define WASTED_G  0x02
8412 #define WASTED_C  0x04
8413 #define WASTED_GC (0x02|0x04)
8414     I32 wastedflags = 0x00;
8415
8416     char * parse_start = RExC_parse; /* MJD */
8417     char * const oregcomp_parse = RExC_parse;
8418
8419     GET_RE_DEBUG_FLAGS_DECL;
8420
8421     PERL_ARGS_ASSERT_REG;
8422     DEBUG_PARSE("reg ");
8423
8424     *flagp = 0;                         /* Tentatively. */
8425
8426
8427     /* Make an OPEN node, if parenthesized. */
8428     if (paren) {
8429         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
8430             char *start_verb = RExC_parse;
8431             STRLEN verb_len = 0;
8432             char *start_arg = NULL;
8433             unsigned char op = 0;
8434             int argok = 1;
8435             int internal_argval = 0; /* internal_argval is only useful if !argok */
8436             while ( *RExC_parse && *RExC_parse != ')' ) {
8437                 if ( *RExC_parse == ':' ) {
8438                     start_arg = RExC_parse + 1;
8439                     break;
8440                 }
8441                 RExC_parse++;
8442             }
8443             ++start_verb;
8444             verb_len = RExC_parse - start_verb;
8445             if ( start_arg ) {
8446                 RExC_parse++;
8447                 while ( *RExC_parse && *RExC_parse != ')' ) 
8448                     RExC_parse++;
8449                 if ( *RExC_parse != ')' ) 
8450                     vFAIL("Unterminated verb pattern argument");
8451                 if ( RExC_parse == start_arg )
8452                     start_arg = NULL;
8453             } else {
8454                 if ( *RExC_parse != ')' )
8455                     vFAIL("Unterminated verb pattern");
8456             }
8457             
8458             switch ( *start_verb ) {
8459             case 'A':  /* (*ACCEPT) */
8460                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
8461                     op = ACCEPT;
8462                     internal_argval = RExC_nestroot;
8463                 }
8464                 break;
8465             case 'C':  /* (*COMMIT) */
8466                 if ( memEQs(start_verb,verb_len,"COMMIT") )
8467                     op = COMMIT;
8468                 break;
8469             case 'F':  /* (*FAIL) */
8470                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
8471                     op = OPFAIL;
8472                     argok = 0;
8473                 }
8474                 break;
8475             case ':':  /* (*:NAME) */
8476             case 'M':  /* (*MARK:NAME) */
8477                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
8478                     op = MARKPOINT;
8479                     argok = -1;
8480                 }
8481                 break;
8482             case 'P':  /* (*PRUNE) */
8483                 if ( memEQs(start_verb,verb_len,"PRUNE") )
8484                     op = PRUNE;
8485                 break;
8486             case 'S':   /* (*SKIP) */  
8487                 if ( memEQs(start_verb,verb_len,"SKIP") ) 
8488                     op = SKIP;
8489                 break;
8490             case 'T':  /* (*THEN) */
8491                 /* [19:06] <TimToady> :: is then */
8492                 if ( memEQs(start_verb,verb_len,"THEN") ) {
8493                     op = CUTGROUP;
8494                     RExC_seen |= REG_SEEN_CUTGROUP;
8495                 }
8496                 break;
8497             }
8498             if ( ! op ) {
8499                 RExC_parse++;
8500                 vFAIL3("Unknown verb pattern '%.*s'",
8501                     verb_len, start_verb);
8502             }
8503             if ( argok ) {
8504                 if ( start_arg && internal_argval ) {
8505                     vFAIL3("Verb pattern '%.*s' may not have an argument",
8506                         verb_len, start_verb); 
8507                 } else if ( argok < 0 && !start_arg ) {
8508                     vFAIL3("Verb pattern '%.*s' has a mandatory argument",
8509                         verb_len, start_verb);    
8510                 } else {
8511                     ret = reganode(pRExC_state, op, internal_argval);
8512                     if ( ! internal_argval && ! SIZE_ONLY ) {
8513                         if (start_arg) {
8514                             SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
8515                             ARG(ret) = add_data( pRExC_state, 1, "S" );
8516                             RExC_rxi->data->data[ARG(ret)]=(void*)sv;
8517                             ret->flags = 0;
8518                         } else {
8519                             ret->flags = 1; 
8520                         }
8521                     }               
8522                 }
8523                 if (!internal_argval)
8524                     RExC_seen |= REG_SEEN_VERBARG;
8525             } else if ( start_arg ) {
8526                 vFAIL3("Verb pattern '%.*s' may not have an argument",
8527                         verb_len, start_verb);    
8528             } else {
8529                 ret = reg_node(pRExC_state, op);
8530             }
8531             nextchar(pRExC_state);
8532             return ret;
8533         } else 
8534         if (*RExC_parse == '?') { /* (?...) */
8535             bool is_logical = 0;
8536             const char * const seqstart = RExC_parse;
8537             bool has_use_defaults = FALSE;
8538
8539             RExC_parse++;
8540             paren = *RExC_parse++;
8541             ret = NULL;                 /* For look-ahead/behind. */
8542             switch (paren) {
8543
8544             case 'P':   /* (?P...) variants for those used to PCRE/Python */
8545                 paren = *RExC_parse++;
8546                 if ( paren == '<')         /* (?P<...>) named capture */
8547                     goto named_capture;
8548                 else if (paren == '>') {   /* (?P>name) named recursion */
8549                     goto named_recursion;
8550                 }
8551                 else if (paren == '=') {   /* (?P=...)  named backref */
8552                     /* this pretty much dupes the code for \k<NAME> in regatom(), if
8553                        you change this make sure you change that */
8554                     char* name_start = RExC_parse;
8555                     U32 num = 0;
8556                     SV *sv_dat = reg_scan_name(pRExC_state,
8557                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8558                     if (RExC_parse == name_start || *RExC_parse != ')')
8559                         vFAIL2("Sequence %.3s... not terminated",parse_start);
8560
8561                     if (!SIZE_ONLY) {
8562                         num = add_data( pRExC_state, 1, "S" );
8563                         RExC_rxi->data->data[num]=(void*)sv_dat;
8564                         SvREFCNT_inc_simple_void(sv_dat);
8565                     }
8566                     RExC_sawback = 1;
8567                     ret = reganode(pRExC_state,
8568                                    ((! FOLD)
8569                                      ? NREF
8570                                      : (ASCII_FOLD_RESTRICTED)
8571                                        ? NREFFA
8572                                        : (AT_LEAST_UNI_SEMANTICS)
8573                                          ? NREFFU
8574                                          : (LOC)
8575                                            ? NREFFL
8576                                            : NREFF),
8577                                     num);
8578                     *flagp |= HASWIDTH;
8579
8580                     Set_Node_Offset(ret, parse_start+1);
8581                     Set_Node_Cur_Length(ret); /* MJD */
8582
8583                     nextchar(pRExC_state);
8584                     return ret;
8585                 }
8586                 RExC_parse++;
8587                 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8588                 /*NOTREACHED*/
8589             case '<':           /* (?<...) */
8590                 if (*RExC_parse == '!')
8591                     paren = ',';
8592                 else if (*RExC_parse != '=') 
8593               named_capture:
8594                 {               /* (?<...>) */
8595                     char *name_start;
8596                     SV *svname;
8597                     paren= '>';
8598             case '\'':          /* (?'...') */
8599                     name_start= RExC_parse;
8600                     svname = reg_scan_name(pRExC_state,
8601                         SIZE_ONLY ?  /* reverse test from the others */
8602                         REG_RSN_RETURN_NAME : 
8603                         REG_RSN_RETURN_NULL);
8604                     if (RExC_parse == name_start) {
8605                         RExC_parse++;
8606                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8607                         /*NOTREACHED*/
8608                     }
8609                     if (*RExC_parse != paren)
8610                         vFAIL2("Sequence (?%c... not terminated",
8611                             paren=='>' ? '<' : paren);
8612                     if (SIZE_ONLY) {
8613                         HE *he_str;
8614                         SV *sv_dat = NULL;
8615                         if (!svname) /* shouldn't happen */
8616                             Perl_croak(aTHX_
8617                                 "panic: reg_scan_name returned NULL");
8618                         if (!RExC_paren_names) {
8619                             RExC_paren_names= newHV();
8620                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
8621 #ifdef DEBUGGING
8622                             RExC_paren_name_list= newAV();
8623                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
8624 #endif
8625                         }
8626                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
8627                         if ( he_str )
8628                             sv_dat = HeVAL(he_str);
8629                         if ( ! sv_dat ) {
8630                             /* croak baby croak */
8631                             Perl_croak(aTHX_
8632                                 "panic: paren_name hash element allocation failed");
8633                         } else if ( SvPOK(sv_dat) ) {
8634                             /* (?|...) can mean we have dupes so scan to check
8635                                its already been stored. Maybe a flag indicating
8636                                we are inside such a construct would be useful,
8637                                but the arrays are likely to be quite small, so
8638                                for now we punt -- dmq */
8639                             IV count = SvIV(sv_dat);
8640                             I32 *pv = (I32*)SvPVX(sv_dat);
8641                             IV i;
8642                             for ( i = 0 ; i < count ; i++ ) {
8643                                 if ( pv[i] == RExC_npar ) {
8644                                     count = 0;
8645                                     break;
8646                                 }
8647                             }
8648                             if ( count ) {
8649                                 pv = (I32*)SvGROW(sv_dat, SvCUR(sv_dat) + sizeof(I32)+1);
8650                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
8651                                 pv[count] = RExC_npar;
8652                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
8653                             }
8654                         } else {
8655                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
8656                             sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
8657                             SvIOK_on(sv_dat);
8658                             SvIV_set(sv_dat, 1);
8659                         }
8660 #ifdef DEBUGGING
8661                         /* Yes this does cause a memory leak in debugging Perls */
8662                         if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
8663                             SvREFCNT_dec(svname);
8664 #endif
8665
8666                         /*sv_dump(sv_dat);*/
8667                     }
8668                     nextchar(pRExC_state);
8669                     paren = 1;
8670                     goto capturing_parens;
8671                 }
8672                 RExC_seen |= REG_SEEN_LOOKBEHIND;
8673                 RExC_in_lookbehind++;
8674                 RExC_parse++;
8675             case '=':           /* (?=...) */
8676                 RExC_seen_zerolen++;
8677                 break;
8678             case '!':           /* (?!...) */
8679                 RExC_seen_zerolen++;
8680                 if (*RExC_parse == ')') {
8681                     ret=reg_node(pRExC_state, OPFAIL);
8682                     nextchar(pRExC_state);
8683                     return ret;
8684                 }
8685                 break;
8686             case '|':           /* (?|...) */
8687                 /* branch reset, behave like a (?:...) except that
8688                    buffers in alternations share the same numbers */
8689                 paren = ':'; 
8690                 after_freeze = freeze_paren = RExC_npar;
8691                 break;
8692             case ':':           /* (?:...) */
8693             case '>':           /* (?>...) */
8694                 break;
8695             case '$':           /* (?$...) */
8696             case '@':           /* (?@...) */
8697                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
8698                 break;
8699             case '#':           /* (?#...) */
8700                 while (*RExC_parse && *RExC_parse != ')')
8701                     RExC_parse++;
8702                 if (*RExC_parse != ')')
8703                     FAIL("Sequence (?#... not terminated");
8704                 nextchar(pRExC_state);
8705                 *flagp = TRYAGAIN;
8706                 return NULL;
8707             case '0' :           /* (?0) */
8708             case 'R' :           /* (?R) */
8709                 if (*RExC_parse != ')')
8710                     FAIL("Sequence (?R) not terminated");
8711                 ret = reg_node(pRExC_state, GOSTART);
8712                 *flagp |= POSTPONED;
8713                 nextchar(pRExC_state);
8714                 return ret;
8715                 /*notreached*/
8716             { /* named and numeric backreferences */
8717                 I32 num;
8718             case '&':            /* (?&NAME) */
8719                 parse_start = RExC_parse - 1;
8720               named_recursion:
8721                 {
8722                     SV *sv_dat = reg_scan_name(pRExC_state,
8723                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8724                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
8725                 }
8726                 goto gen_recurse_regop;
8727                 assert(0); /* NOT REACHED */
8728             case '+':
8729                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
8730                     RExC_parse++;
8731                     vFAIL("Illegal pattern");
8732                 }
8733                 goto parse_recursion;
8734                 /* NOT REACHED*/
8735             case '-': /* (?-1) */
8736                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
8737                     RExC_parse--; /* rewind to let it be handled later */
8738                     goto parse_flags;
8739                 } 
8740                 /*FALLTHROUGH */
8741             case '1': case '2': case '3': case '4': /* (?1) */
8742             case '5': case '6': case '7': case '8': case '9':
8743                 RExC_parse--;
8744               parse_recursion:
8745                 num = atoi(RExC_parse);
8746                 parse_start = RExC_parse - 1; /* MJD */
8747                 if (*RExC_parse == '-')
8748                     RExC_parse++;
8749                 while (isDIGIT(*RExC_parse))
8750                         RExC_parse++;
8751                 if (*RExC_parse!=')') 
8752                     vFAIL("Expecting close bracket");
8753
8754               gen_recurse_regop:
8755                 if ( paren == '-' ) {
8756                     /*
8757                     Diagram of capture buffer numbering.
8758                     Top line is the normal capture buffer numbers
8759                     Bottom line is the negative indexing as from
8760                     the X (the (?-2))
8761
8762                     +   1 2    3 4 5 X          6 7
8763                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
8764                     -   5 4    3 2 1 X          x x
8765
8766                     */
8767                     num = RExC_npar + num;
8768                     if (num < 1)  {
8769                         RExC_parse++;
8770                         vFAIL("Reference to nonexistent group");
8771                     }
8772                 } else if ( paren == '+' ) {
8773                     num = RExC_npar + num - 1;
8774                 }
8775
8776                 ret = reganode(pRExC_state, GOSUB, num);
8777                 if (!SIZE_ONLY) {
8778                     if (num > (I32)RExC_rx->nparens) {
8779                         RExC_parse++;
8780                         vFAIL("Reference to nonexistent group");
8781                     }
8782                     ARG2L_SET( ret, RExC_recurse_count++);
8783                     RExC_emit++;
8784                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
8785                         "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
8786                 } else {
8787                     RExC_size++;
8788                 }
8789                 RExC_seen |= REG_SEEN_RECURSE;
8790                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
8791                 Set_Node_Offset(ret, parse_start); /* MJD */
8792
8793                 *flagp |= POSTPONED;
8794                 nextchar(pRExC_state);
8795                 return ret;
8796             } /* named and numeric backreferences */
8797             assert(0); /* NOT REACHED */
8798
8799             case '?':           /* (??...) */
8800                 is_logical = 1;
8801                 if (*RExC_parse != '{') {
8802                     RExC_parse++;
8803                     vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8804                     /*NOTREACHED*/
8805                 }
8806                 *flagp |= POSTPONED;
8807                 paren = *RExC_parse++;
8808                 /* FALL THROUGH */
8809             case '{':           /* (?{...}) */
8810             {
8811                 U32 n = 0;
8812                 struct reg_code_block *cb;
8813
8814                 RExC_seen_zerolen++;
8815
8816                 if (   !pRExC_state->num_code_blocks
8817                     || pRExC_state->code_index >= pRExC_state->num_code_blocks
8818                     || pRExC_state->code_blocks[pRExC_state->code_index].start
8819                         != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
8820                             - RExC_start)
8821                 ) {
8822                     if (RExC_pm_flags & PMf_USE_RE_EVAL)
8823                         FAIL("panic: Sequence (?{...}): no code block found\n");
8824                     FAIL("Eval-group not allowed at runtime, use re 'eval'");
8825                 }
8826                 /* this is a pre-compiled code block (?{...}) */
8827                 cb = &pRExC_state->code_blocks[pRExC_state->code_index];
8828                 RExC_parse = RExC_start + cb->end;
8829                 if (!SIZE_ONLY) {
8830                     OP *o = cb->block;
8831                     if (cb->src_regex) {
8832                         n = add_data(pRExC_state, 2, "rl");
8833                         RExC_rxi->data->data[n] =
8834                             (void*)SvREFCNT_inc((SV*)cb->src_regex);
8835                         RExC_rxi->data->data[n+1] = (void*)o;
8836                     }
8837                     else {
8838                         n = add_data(pRExC_state, 1,
8839                                (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l");
8840                         RExC_rxi->data->data[n] = (void*)o;
8841                     }
8842                 }
8843                 pRExC_state->code_index++;
8844                 nextchar(pRExC_state);
8845
8846                 if (is_logical) {
8847                     regnode *eval;
8848                     ret = reg_node(pRExC_state, LOGICAL);
8849                     eval = reganode(pRExC_state, EVAL, n);
8850                     if (!SIZE_ONLY) {
8851                         ret->flags = 2;
8852                         /* for later propagation into (??{}) return value */
8853                         eval->flags = (U8) (RExC_flags & RXf_PMf_COMPILETIME);
8854                     }
8855                     REGTAIL(pRExC_state, ret, eval);
8856                     /* deal with the length of this later - MJD */
8857                     return ret;
8858                 }
8859                 ret = reganode(pRExC_state, EVAL, n);
8860                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
8861                 Set_Node_Offset(ret, parse_start);
8862                 return ret;
8863             }
8864             case '(':           /* (?(?{...})...) and (?(?=...)...) */
8865             {
8866                 int is_define= 0;
8867                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
8868                     if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
8869                         || RExC_parse[1] == '<'
8870                         || RExC_parse[1] == '{') { /* Lookahead or eval. */
8871                         I32 flag;
8872
8873                         ret = reg_node(pRExC_state, LOGICAL);
8874                         if (!SIZE_ONLY)
8875                             ret->flags = 1;
8876                         REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
8877                         goto insert_if;
8878                     }
8879                 }
8880                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
8881                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
8882                 {
8883                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
8884                     char *name_start= RExC_parse++;
8885                     U32 num = 0;
8886                     SV *sv_dat=reg_scan_name(pRExC_state,
8887                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8888                     if (RExC_parse == name_start || *RExC_parse != ch)
8889                         vFAIL2("Sequence (?(%c... not terminated",
8890                             (ch == '>' ? '<' : ch));
8891                     RExC_parse++;
8892                     if (!SIZE_ONLY) {
8893                         num = add_data( pRExC_state, 1, "S" );
8894                         RExC_rxi->data->data[num]=(void*)sv_dat;
8895                         SvREFCNT_inc_simple_void(sv_dat);
8896                     }
8897                     ret = reganode(pRExC_state,NGROUPP,num);
8898                     goto insert_if_check_paren;
8899                 }
8900                 else if (RExC_parse[0] == 'D' &&
8901                          RExC_parse[1] == 'E' &&
8902                          RExC_parse[2] == 'F' &&
8903                          RExC_parse[3] == 'I' &&
8904                          RExC_parse[4] == 'N' &&
8905                          RExC_parse[5] == 'E')
8906                 {
8907                     ret = reganode(pRExC_state,DEFINEP,0);
8908                     RExC_parse +=6 ;
8909                     is_define = 1;
8910                     goto insert_if_check_paren;
8911                 }
8912                 else if (RExC_parse[0] == 'R') {
8913                     RExC_parse++;
8914                     parno = 0;
8915                     if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
8916                         parno = atoi(RExC_parse++);
8917                         while (isDIGIT(*RExC_parse))
8918                             RExC_parse++;
8919                     } else if (RExC_parse[0] == '&') {
8920                         SV *sv_dat;
8921                         RExC_parse++;
8922                         sv_dat = reg_scan_name(pRExC_state,
8923                             SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8924                         parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
8925                     }
8926                     ret = reganode(pRExC_state,INSUBP,parno); 
8927                     goto insert_if_check_paren;
8928                 }
8929                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
8930                     /* (?(1)...) */
8931                     char c;
8932                     parno = atoi(RExC_parse++);
8933
8934                     while (isDIGIT(*RExC_parse))
8935                         RExC_parse++;
8936                     ret = reganode(pRExC_state, GROUPP, parno);
8937
8938                  insert_if_check_paren:
8939                     if ((c = *nextchar(pRExC_state)) != ')')
8940                         vFAIL("Switch condition not recognized");
8941                   insert_if:
8942                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
8943                     br = regbranch(pRExC_state, &flags, 1,depth+1);
8944                     if (br == NULL)
8945                         br = reganode(pRExC_state, LONGJMP, 0);
8946                     else
8947                         REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
8948                     c = *nextchar(pRExC_state);
8949                     if (flags&HASWIDTH)
8950                         *flagp |= HASWIDTH;
8951                     if (c == '|') {
8952                         if (is_define) 
8953                             vFAIL("(?(DEFINE)....) does not allow branches");
8954                         lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
8955                         regbranch(pRExC_state, &flags, 1,depth+1);
8956                         REGTAIL(pRExC_state, ret, lastbr);
8957                         if (flags&HASWIDTH)
8958                             *flagp |= HASWIDTH;
8959                         c = *nextchar(pRExC_state);
8960                     }
8961                     else
8962                         lastbr = NULL;
8963                     if (c != ')')
8964                         vFAIL("Switch (?(condition)... contains too many branches");
8965                     ender = reg_node(pRExC_state, TAIL);
8966                     REGTAIL(pRExC_state, br, ender);
8967                     if (lastbr) {
8968                         REGTAIL(pRExC_state, lastbr, ender);
8969                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
8970                     }
8971                     else
8972                         REGTAIL(pRExC_state, ret, ender);
8973                     RExC_size++; /* XXX WHY do we need this?!!
8974                                     For large programs it seems to be required
8975                                     but I can't figure out why. -- dmq*/
8976                     return ret;
8977                 }
8978                 else {
8979                     vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
8980                 }
8981             }
8982             case 0:
8983                 RExC_parse--; /* for vFAIL to print correctly */
8984                 vFAIL("Sequence (? incomplete");
8985                 break;
8986             case DEFAULT_PAT_MOD:   /* Use default flags with the exceptions
8987                                        that follow */
8988                 has_use_defaults = TRUE;
8989                 STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
8990                 set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
8991                                                 ? REGEX_UNICODE_CHARSET
8992                                                 : REGEX_DEPENDS_CHARSET);
8993                 goto parse_flags;
8994             default:
8995                 --RExC_parse;
8996                 parse_flags:      /* (?i) */  
8997             {
8998                 U32 posflags = 0, negflags = 0;
8999                 U32 *flagsp = &posflags;
9000                 char has_charset_modifier = '\0';
9001                 regex_charset cs = get_regex_charset(RExC_flags);
9002                 if (cs == REGEX_DEPENDS_CHARSET
9003                     && (RExC_utf8 || RExC_uni_semantics))
9004                 {
9005                     cs = REGEX_UNICODE_CHARSET;
9006                 }
9007
9008                 while (*RExC_parse) {
9009                     /* && strchr("iogcmsx", *RExC_parse) */
9010                     /* (?g), (?gc) and (?o) are useless here
9011                        and must be globally applied -- japhy */
9012                     switch (*RExC_parse) {
9013                     CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
9014                     case LOCALE_PAT_MOD:
9015                         if (has_charset_modifier) {
9016                             goto excess_modifier;
9017                         }
9018                         else if (flagsp == &negflags) {
9019                             goto neg_modifier;
9020                         }
9021                         cs = REGEX_LOCALE_CHARSET;
9022                         has_charset_modifier = LOCALE_PAT_MOD;
9023                         RExC_contains_locale = 1;
9024                         break;
9025                     case UNICODE_PAT_MOD:
9026                         if (has_charset_modifier) {
9027                             goto excess_modifier;
9028                         }
9029                         else if (flagsp == &negflags) {
9030                             goto neg_modifier;
9031                         }
9032                         cs = REGEX_UNICODE_CHARSET;
9033                         has_charset_modifier = UNICODE_PAT_MOD;
9034                         break;
9035                     case ASCII_RESTRICT_PAT_MOD:
9036                         if (flagsp == &negflags) {
9037                             goto neg_modifier;
9038                         }
9039                         if (has_charset_modifier) {
9040                             if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
9041                                 goto excess_modifier;
9042                             }
9043                             /* Doubled modifier implies more restricted */
9044                             cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
9045                         }
9046                         else {
9047                             cs = REGEX_ASCII_RESTRICTED_CHARSET;
9048                         }
9049                         has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
9050                         break;
9051                     case DEPENDS_PAT_MOD:
9052                         if (has_use_defaults) {
9053                             goto fail_modifiers;
9054                         }
9055                         else if (flagsp == &negflags) {
9056                             goto neg_modifier;
9057                         }
9058                         else if (has_charset_modifier) {
9059                             goto excess_modifier;
9060                         }
9061
9062                         /* The dual charset means unicode semantics if the
9063                          * pattern (or target, not known until runtime) are
9064                          * utf8, or something in the pattern indicates unicode
9065                          * semantics */
9066                         cs = (RExC_utf8 || RExC_uni_semantics)
9067                              ? REGEX_UNICODE_CHARSET
9068                              : REGEX_DEPENDS_CHARSET;
9069                         has_charset_modifier = DEPENDS_PAT_MOD;
9070                         break;
9071                     excess_modifier:
9072                         RExC_parse++;
9073                         if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
9074                             vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
9075                         }
9076                         else if (has_charset_modifier == *(RExC_parse - 1)) {
9077                             vFAIL2("Regexp modifier \"%c\" may not appear twice", *(RExC_parse - 1));
9078                         }
9079                         else {
9080                             vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
9081                         }
9082                         /*NOTREACHED*/
9083                     neg_modifier:
9084                         RExC_parse++;
9085                         vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", *(RExC_parse - 1));
9086                         /*NOTREACHED*/
9087                     case ONCE_PAT_MOD: /* 'o' */
9088                     case GLOBAL_PAT_MOD: /* 'g' */
9089                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
9090                             const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
9091                             if (! (wastedflags & wflagbit) ) {
9092                                 wastedflags |= wflagbit;
9093                                 vWARN5(
9094                                     RExC_parse + 1,
9095                                     "Useless (%s%c) - %suse /%c modifier",
9096                                     flagsp == &negflags ? "?-" : "?",
9097                                     *RExC_parse,
9098                                     flagsp == &negflags ? "don't " : "",
9099                                     *RExC_parse
9100                                 );
9101                             }
9102                         }
9103                         break;
9104                         
9105                     case CONTINUE_PAT_MOD: /* 'c' */
9106                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
9107                             if (! (wastedflags & WASTED_C) ) {
9108                                 wastedflags |= WASTED_GC;
9109                                 vWARN3(
9110                                     RExC_parse + 1,
9111                                     "Useless (%sc) - %suse /gc modifier",
9112                                     flagsp == &negflags ? "?-" : "?",
9113                                     flagsp == &negflags ? "don't " : ""
9114                                 );
9115                             }
9116                         }
9117                         break;
9118                     case KEEPCOPY_PAT_MOD: /* 'p' */
9119                         if (flagsp == &negflags) {
9120                             if (SIZE_ONLY)
9121                                 ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
9122                         } else {
9123                             *flagsp |= RXf_PMf_KEEPCOPY;
9124                         }
9125                         break;
9126                     case '-':
9127                         /* A flag is a default iff it is following a minus, so
9128                          * if there is a minus, it means will be trying to
9129                          * re-specify a default which is an error */
9130                         if (has_use_defaults || flagsp == &negflags) {
9131             fail_modifiers:
9132                             RExC_parse++;
9133                             vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
9134                             /*NOTREACHED*/
9135                         }
9136                         flagsp = &negflags;
9137                         wastedflags = 0;  /* reset so (?g-c) warns twice */
9138                         break;
9139                     case ':':
9140                         paren = ':';
9141                         /*FALLTHROUGH*/
9142                     case ')':
9143                         RExC_flags |= posflags;
9144                         RExC_flags &= ~negflags;
9145                         set_regex_charset(&RExC_flags, cs);
9146                         if (paren != ':') {
9147                             oregflags |= posflags;
9148                             oregflags &= ~negflags;
9149                             set_regex_charset(&oregflags, cs);
9150                         }
9151                         nextchar(pRExC_state);
9152                         if (paren != ':') {
9153                             *flagp = TRYAGAIN;
9154                             return NULL;
9155                         } else {
9156                             ret = NULL;
9157                             goto parse_rest;
9158                         }
9159                         /*NOTREACHED*/
9160                     default:
9161                         RExC_parse++;
9162                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
9163                         /*NOTREACHED*/
9164                     }                           
9165                     ++RExC_parse;
9166                 }
9167             }} /* one for the default block, one for the switch */
9168         }
9169         else {                  /* (...) */
9170           capturing_parens:
9171             parno = RExC_npar;
9172             RExC_npar++;
9173             
9174             ret = reganode(pRExC_state, OPEN, parno);
9175             if (!SIZE_ONLY ){
9176                 if (!RExC_nestroot) 
9177                     RExC_nestroot = parno;
9178                 if (RExC_seen & REG_SEEN_RECURSE
9179                     && !RExC_open_parens[parno-1])
9180                 {
9181                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
9182                         "Setting open paren #%"IVdf" to %d\n", 
9183                         (IV)parno, REG_NODE_NUM(ret)));
9184                     RExC_open_parens[parno-1]= ret;
9185                 }
9186             }
9187             Set_Node_Length(ret, 1); /* MJD */
9188             Set_Node_Offset(ret, RExC_parse); /* MJD */
9189             is_open = 1;
9190         }
9191     }
9192     else                        /* ! paren */
9193         ret = NULL;
9194    
9195    parse_rest:
9196     /* Pick up the branches, linking them together. */
9197     parse_start = RExC_parse;   /* MJD */
9198     br = regbranch(pRExC_state, &flags, 1,depth+1);
9199
9200     /*     branch_len = (paren != 0); */
9201
9202     if (br == NULL)
9203         return(NULL);
9204     if (*RExC_parse == '|') {
9205         if (!SIZE_ONLY && RExC_extralen) {
9206             reginsert(pRExC_state, BRANCHJ, br, depth+1);
9207         }
9208         else {                  /* MJD */
9209             reginsert(pRExC_state, BRANCH, br, depth+1);
9210             Set_Node_Length(br, paren != 0);
9211             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
9212         }
9213         have_branch = 1;
9214         if (SIZE_ONLY)
9215             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
9216     }
9217     else if (paren == ':') {
9218         *flagp |= flags&SIMPLE;
9219     }
9220     if (is_open) {                              /* Starts with OPEN. */
9221         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
9222     }
9223     else if (paren != '?')              /* Not Conditional */
9224         ret = br;
9225     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
9226     lastbr = br;
9227     while (*RExC_parse == '|') {
9228         if (!SIZE_ONLY && RExC_extralen) {
9229             ender = reganode(pRExC_state, LONGJMP,0);
9230             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
9231         }
9232         if (SIZE_ONLY)
9233             RExC_extralen += 2;         /* Account for LONGJMP. */
9234         nextchar(pRExC_state);
9235         if (freeze_paren) {
9236             if (RExC_npar > after_freeze)
9237                 after_freeze = RExC_npar;
9238             RExC_npar = freeze_paren;       
9239         }
9240         br = regbranch(pRExC_state, &flags, 0, depth+1);
9241
9242         if (br == NULL)
9243             return(NULL);
9244         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
9245         lastbr = br;
9246         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
9247     }
9248
9249     if (have_branch || paren != ':') {
9250         /* Make a closing node, and hook it on the end. */
9251         switch (paren) {
9252         case ':':
9253             ender = reg_node(pRExC_state, TAIL);
9254             break;
9255         case 1:
9256             ender = reganode(pRExC_state, CLOSE, parno);
9257             if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
9258                 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
9259                         "Setting close paren #%"IVdf" to %d\n", 
9260                         (IV)parno, REG_NODE_NUM(ender)));
9261                 RExC_close_parens[parno-1]= ender;
9262                 if (RExC_nestroot == parno) 
9263                     RExC_nestroot = 0;
9264             }       
9265             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
9266             Set_Node_Length(ender,1); /* MJD */
9267             break;
9268         case '<':
9269         case ',':
9270         case '=':
9271         case '!':
9272             *flagp &= ~HASWIDTH;
9273             /* FALL THROUGH */
9274         case '>':
9275             ender = reg_node(pRExC_state, SUCCEED);
9276             break;
9277         case 0:
9278             ender = reg_node(pRExC_state, END);
9279             if (!SIZE_ONLY) {
9280                 assert(!RExC_opend); /* there can only be one! */
9281                 RExC_opend = ender;
9282             }
9283             break;
9284         }
9285         DEBUG_PARSE_r(if (!SIZE_ONLY) {
9286             SV * const mysv_val1=sv_newmortal();
9287             SV * const mysv_val2=sv_newmortal();
9288             DEBUG_PARSE_MSG("lsbr");
9289             regprop(RExC_rx, mysv_val1, lastbr);
9290             regprop(RExC_rx, mysv_val2, ender);
9291             PerlIO_printf(Perl_debug_log, "~ tying lastbr %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
9292                           SvPV_nolen_const(mysv_val1),
9293                           (IV)REG_NODE_NUM(lastbr),
9294                           SvPV_nolen_const(mysv_val2),
9295                           (IV)REG_NODE_NUM(ender),
9296                           (IV)(ender - lastbr)
9297             );
9298         });
9299         REGTAIL(pRExC_state, lastbr, ender);
9300
9301         if (have_branch && !SIZE_ONLY) {
9302             char is_nothing= 1;
9303             if (depth==1)
9304                 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
9305
9306             /* Hook the tails of the branches to the closing node. */
9307             for (br = ret; br; br = regnext(br)) {
9308                 const U8 op = PL_regkind[OP(br)];
9309                 if (op == BRANCH) {
9310                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
9311                     if (OP(NEXTOPER(br)) != NOTHING || regnext(NEXTOPER(br)) != ender)
9312                         is_nothing= 0;
9313                 }
9314                 else if (op == BRANCHJ) {
9315                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
9316                     /* for now we always disable this optimisation * /
9317                     if (OP(NEXTOPER(NEXTOPER(br))) != NOTHING || regnext(NEXTOPER(NEXTOPER(br))) != ender)
9318                     */
9319                         is_nothing= 0;
9320                 }
9321             }
9322             if (is_nothing) {
9323                 br= PL_regkind[OP(ret)] != BRANCH ? regnext(ret) : ret;
9324                 DEBUG_PARSE_r(if (!SIZE_ONLY) {
9325                     SV * const mysv_val1=sv_newmortal();
9326                     SV * const mysv_val2=sv_newmortal();
9327                     DEBUG_PARSE_MSG("NADA");
9328                     regprop(RExC_rx, mysv_val1, ret);
9329                     regprop(RExC_rx, mysv_val2, ender);
9330                     PerlIO_printf(Perl_debug_log, "~ converting ret %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
9331                                   SvPV_nolen_const(mysv_val1),
9332                                   (IV)REG_NODE_NUM(ret),
9333                                   SvPV_nolen_const(mysv_val2),
9334                                   (IV)REG_NODE_NUM(ender),
9335                                   (IV)(ender - ret)
9336                     );
9337                 });
9338                 OP(br)= NOTHING;
9339                 if (OP(ender) == TAIL) {
9340                     NEXT_OFF(br)= 0;
9341                     RExC_emit= br + 1;
9342                 } else {
9343                     regnode *opt;
9344                     for ( opt= br + 1; opt < ender ; opt++ )
9345                         OP(opt)= OPTIMIZED;
9346                     NEXT_OFF(br)= ender - br;
9347                 }
9348             }
9349         }
9350     }
9351
9352     {
9353         const char *p;
9354         static const char parens[] = "=!<,>";
9355
9356         if (paren && (p = strchr(parens, paren))) {
9357             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
9358             int flag = (p - parens) > 1;
9359
9360             if (paren == '>')
9361                 node = SUSPEND, flag = 0;
9362             reginsert(pRExC_state, node,ret, depth+1);
9363             Set_Node_Cur_Length(ret);
9364             Set_Node_Offset(ret, parse_start + 1);
9365             ret->flags = flag;
9366             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
9367         }
9368     }
9369
9370     /* Check for proper termination. */
9371     if (paren) {
9372         RExC_flags = oregflags;
9373         if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
9374             RExC_parse = oregcomp_parse;
9375             vFAIL("Unmatched (");
9376         }
9377     }
9378     else if (!paren && RExC_parse < RExC_end) {
9379         if (*RExC_parse == ')') {
9380             RExC_parse++;
9381             vFAIL("Unmatched )");
9382         }
9383         else
9384             FAIL("Junk on end of regexp");      /* "Can't happen". */
9385         assert(0); /* NOTREACHED */
9386     }
9387
9388     if (RExC_in_lookbehind) {
9389         RExC_in_lookbehind--;
9390     }
9391     if (after_freeze > RExC_npar)
9392         RExC_npar = after_freeze;
9393     return(ret);
9394 }
9395
9396 /*
9397  - regbranch - one alternative of an | operator
9398  *
9399  * Implements the concatenation operator.
9400  */
9401 STATIC regnode *
9402 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
9403 {
9404     dVAR;
9405     regnode *ret;
9406     regnode *chain = NULL;
9407     regnode *latest;
9408     I32 flags = 0, c = 0;
9409     GET_RE_DEBUG_FLAGS_DECL;
9410
9411     PERL_ARGS_ASSERT_REGBRANCH;
9412
9413     DEBUG_PARSE("brnc");
9414
9415     if (first)
9416         ret = NULL;
9417     else {
9418         if (!SIZE_ONLY && RExC_extralen)
9419             ret = reganode(pRExC_state, BRANCHJ,0);
9420         else {
9421             ret = reg_node(pRExC_state, BRANCH);
9422             Set_Node_Length(ret, 1);
9423         }
9424     }
9425
9426     if (!first && SIZE_ONLY)
9427         RExC_extralen += 1;                     /* BRANCHJ */
9428
9429     *flagp = WORST;                     /* Tentatively. */
9430
9431     RExC_parse--;
9432     nextchar(pRExC_state);
9433     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
9434         flags &= ~TRYAGAIN;
9435         latest = regpiece(pRExC_state, &flags,depth+1);
9436         if (latest == NULL) {
9437             if (flags & TRYAGAIN)
9438                 continue;
9439             return(NULL);
9440         }
9441         else if (ret == NULL)
9442             ret = latest;
9443         *flagp |= flags&(HASWIDTH|POSTPONED);
9444         if (chain == NULL)      /* First piece. */
9445             *flagp |= flags&SPSTART;
9446         else {
9447             RExC_naughty++;
9448             REGTAIL(pRExC_state, chain, latest);
9449         }
9450         chain = latest;
9451         c++;
9452     }
9453     if (chain == NULL) {        /* Loop ran zero times. */
9454         chain = reg_node(pRExC_state, NOTHING);
9455         if (ret == NULL)
9456             ret = chain;
9457     }
9458     if (c == 1) {
9459         *flagp |= flags&SIMPLE;
9460     }
9461
9462     return ret;
9463 }
9464
9465 /*
9466  - regpiece - something followed by possible [*+?]
9467  *
9468  * Note that the branching code sequences used for ? and the general cases
9469  * of * and + are somewhat optimized:  they use the same NOTHING node as
9470  * both the endmarker for their branch list and the body of the last branch.
9471  * It might seem that this node could be dispensed with entirely, but the
9472  * endmarker role is not redundant.
9473  */
9474 STATIC regnode *
9475 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
9476 {
9477     dVAR;
9478     regnode *ret;
9479     char op;
9480     char *next;
9481     I32 flags;
9482     const char * const origparse = RExC_parse;
9483     I32 min;
9484     I32 max = REG_INFTY;
9485 #ifdef RE_TRACK_PATTERN_OFFSETS
9486     char *parse_start;
9487 #endif
9488     const char *maxpos = NULL;
9489
9490     /* Save the original in case we change the emitted regop to a FAIL. */
9491     regnode * const orig_emit = RExC_emit;
9492
9493     GET_RE_DEBUG_FLAGS_DECL;
9494
9495     PERL_ARGS_ASSERT_REGPIECE;
9496
9497     DEBUG_PARSE("piec");
9498
9499     ret = regatom(pRExC_state, &flags,depth+1);
9500     if (ret == NULL) {
9501         if (flags & TRYAGAIN)
9502             *flagp |= TRYAGAIN;
9503         return(NULL);
9504     }
9505
9506     op = *RExC_parse;
9507
9508     if (op == '{' && regcurly(RExC_parse)) {
9509         maxpos = NULL;
9510 #ifdef RE_TRACK_PATTERN_OFFSETS
9511         parse_start = RExC_parse; /* MJD */
9512 #endif
9513         next = RExC_parse + 1;
9514         while (isDIGIT(*next) || *next == ',') {
9515             if (*next == ',') {
9516                 if (maxpos)
9517                     break;
9518                 else
9519                     maxpos = next;
9520             }
9521             next++;
9522         }
9523         if (*next == '}') {             /* got one */
9524             if (!maxpos)
9525                 maxpos = next;
9526             RExC_parse++;
9527             min = atoi(RExC_parse);
9528             if (*maxpos == ',')
9529                 maxpos++;
9530             else
9531                 maxpos = RExC_parse;
9532             max = atoi(maxpos);
9533             if (!max && *maxpos != '0')
9534                 max = REG_INFTY;                /* meaning "infinity" */
9535             else if (max >= REG_INFTY)
9536                 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
9537             RExC_parse = next;
9538             nextchar(pRExC_state);
9539             if (max < min) {    /* If can't match, warn and optimize to fail
9540                                    unconditionally */
9541                 if (SIZE_ONLY) {
9542                     ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
9543
9544                     /* We can't back off the size because we have to reserve
9545                      * enough space for all the things we are about to throw
9546                      * away, but we can shrink it by the ammount we are about
9547                      * to re-use here */
9548                     RExC_size = PREVOPER(RExC_size) - regarglen[(U8)OPFAIL];
9549                 }
9550                 else {
9551                     RExC_emit = orig_emit;
9552                 }
9553                 ret = reg_node(pRExC_state, OPFAIL);
9554                 return ret;
9555             }
9556
9557         do_curly:
9558             if ((flags&SIMPLE)) {
9559                 RExC_naughty += 2 + RExC_naughty / 2;
9560                 reginsert(pRExC_state, CURLY, ret, depth+1);
9561                 Set_Node_Offset(ret, parse_start+1); /* MJD */
9562                 Set_Node_Cur_Length(ret);
9563             }
9564             else {
9565                 regnode * const w = reg_node(pRExC_state, WHILEM);
9566
9567                 w->flags = 0;
9568                 REGTAIL(pRExC_state, ret, w);
9569                 if (!SIZE_ONLY && RExC_extralen) {
9570                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
9571                     reginsert(pRExC_state, NOTHING,ret, depth+1);
9572                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
9573                 }
9574                 reginsert(pRExC_state, CURLYX,ret, depth+1);
9575                                 /* MJD hk */
9576                 Set_Node_Offset(ret, parse_start+1);
9577                 Set_Node_Length(ret,
9578                                 op == '{' ? (RExC_parse - parse_start) : 1);
9579
9580                 if (!SIZE_ONLY && RExC_extralen)
9581                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
9582                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
9583                 if (SIZE_ONLY)
9584                     RExC_whilem_seen++, RExC_extralen += 3;
9585                 RExC_naughty += 4 + RExC_naughty;       /* compound interest */
9586             }
9587             ret->flags = 0;
9588
9589             if (min > 0)
9590                 *flagp = WORST;
9591             if (max > 0)
9592                 *flagp |= HASWIDTH;
9593             if (!SIZE_ONLY) {
9594                 ARG1_SET(ret, (U16)min);
9595                 ARG2_SET(ret, (U16)max);
9596             }
9597
9598             goto nest_check;
9599         }
9600     }
9601
9602     if (!ISMULT1(op)) {
9603         *flagp = flags;
9604         return(ret);
9605     }
9606
9607 #if 0                           /* Now runtime fix should be reliable. */
9608
9609     /* if this is reinstated, don't forget to put this back into perldiag:
9610
9611             =item Regexp *+ operand could be empty at {#} in regex m/%s/
9612
9613            (F) The part of the regexp subject to either the * or + quantifier
9614            could match an empty string. The {#} shows in the regular
9615            expression about where the problem was discovered.
9616
9617     */
9618
9619     if (!(flags&HASWIDTH) && op != '?')
9620       vFAIL("Regexp *+ operand could be empty");
9621 #endif
9622
9623 #ifdef RE_TRACK_PATTERN_OFFSETS
9624     parse_start = RExC_parse;
9625 #endif
9626     nextchar(pRExC_state);
9627
9628     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
9629
9630     if (op == '*' && (flags&SIMPLE)) {
9631         reginsert(pRExC_state, STAR, ret, depth+1);
9632         ret->flags = 0;
9633         RExC_naughty += 4;
9634     }
9635     else if (op == '*') {
9636         min = 0;
9637         goto do_curly;
9638     }
9639     else if (op == '+' && (flags&SIMPLE)) {
9640         reginsert(pRExC_state, PLUS, ret, depth+1);
9641         ret->flags = 0;
9642         RExC_naughty += 3;
9643     }
9644     else if (op == '+') {
9645         min = 1;
9646         goto do_curly;
9647     }
9648     else if (op == '?') {
9649         min = 0; max = 1;
9650         goto do_curly;
9651     }
9652   nest_check:
9653     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
9654         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
9655         ckWARN3reg(RExC_parse,
9656                    "%.*s matches null string many times",
9657                    (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
9658                    origparse);
9659         (void)ReREFCNT_inc(RExC_rx_sv);
9660     }
9661
9662     if (RExC_parse < RExC_end && *RExC_parse == '?') {
9663         nextchar(pRExC_state);
9664         reginsert(pRExC_state, MINMOD, ret, depth+1);
9665         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
9666     }
9667 #ifndef REG_ALLOW_MINMOD_SUSPEND
9668     else
9669 #endif
9670     if (RExC_parse < RExC_end && *RExC_parse == '+') {
9671         regnode *ender;
9672         nextchar(pRExC_state);
9673         ender = reg_node(pRExC_state, SUCCEED);
9674         REGTAIL(pRExC_state, ret, ender);
9675         reginsert(pRExC_state, SUSPEND, ret, depth+1);
9676         ret->flags = 0;
9677         ender = reg_node(pRExC_state, TAIL);
9678         REGTAIL(pRExC_state, ret, ender);
9679         /*ret= ender;*/
9680     }
9681
9682     if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
9683         RExC_parse++;
9684         vFAIL("Nested quantifiers");
9685     }
9686
9687     return(ret);
9688 }
9689
9690 STATIC bool
9691 S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, UV *valuep, I32 *flagp, U32 depth, bool in_char_class)
9692 {
9693    
9694  /* This is expected to be called by a parser routine that has recognized '\N'
9695    and needs to handle the rest. RExC_parse is expected to point at the first
9696    char following the N at the time of the call.  On successful return,
9697    RExC_parse has been updated to point to just after the sequence identified
9698    by this routine, and <*flagp> has been updated.
9699
9700    The \N may be inside (indicated by the boolean <in_char_class>) or outside a
9701    character class.
9702
9703    \N may begin either a named sequence, or if outside a character class, mean
9704    to match a non-newline.  For non single-quoted regexes, the tokenizer has
9705    attempted to decide which, and in the case of a named sequence, converted it
9706    into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...},
9707    where c1... are the characters in the sequence.  For single-quoted regexes,
9708    the tokenizer passes the \N sequence through unchanged; this code will not
9709    attempt to determine this nor expand those, instead raising a syntax error.
9710    The net effect is that if the beginning of the passed-in pattern isn't '{U+'
9711    or there is no '}', it signals that this \N occurrence means to match a
9712    non-newline.
9713
9714    Only the \N{U+...} form should occur in a character class, for the same
9715    reason that '.' inside a character class means to just match a period: it
9716    just doesn't make sense.
9717
9718    The function raises an error (via vFAIL), and doesn't return for various
9719    syntax errors.  Otherwise it returns TRUE and sets <node_p> or <valuep> on
9720    success; it returns FALSE otherwise.
9721
9722    If <valuep> is non-null, it means the caller can accept an input sequence
9723    consisting of a just a single code point; <*valuep> is set to that value
9724    if the input is such.
9725
9726    If <node_p> is non-null it signifies that the caller can accept any other
9727    legal sequence (i.e., one that isn't just a single code point).  <*node_p>
9728    is set as follows:
9729     1) \N means not-a-NL: points to a newly created REG_ANY node;
9730     2) \N{}:              points to a new NOTHING node;
9731     3) otherwise:         points to a new EXACT node containing the resolved
9732                           string.
9733    Note that FALSE is returned for single code point sequences if <valuep> is
9734    null.
9735  */
9736
9737     char * endbrace;    /* '}' following the name */
9738     char* p;
9739     char *endchar;      /* Points to '.' or '}' ending cur char in the input
9740                            stream */
9741     bool has_multiple_chars; /* true if the input stream contains a sequence of
9742                                 more than one character */
9743
9744     GET_RE_DEBUG_FLAGS_DECL;
9745  
9746     PERL_ARGS_ASSERT_GROK_BSLASH_N;
9747
9748     GET_RE_DEBUG_FLAGS;
9749
9750     assert(cBOOL(node_p) ^ cBOOL(valuep));  /* Exactly one should be set */
9751
9752     /* The [^\n] meaning of \N ignores spaces and comments under the /x
9753      * modifier.  The other meaning does not */
9754     p = (RExC_flags & RXf_PMf_EXTENDED)
9755         ? regwhite( pRExC_state, RExC_parse )
9756         : RExC_parse;
9757
9758     /* Disambiguate between \N meaning a named character versus \N meaning
9759      * [^\n].  The former is assumed when it can't be the latter. */
9760     if (*p != '{' || regcurly(p)) {
9761         RExC_parse = p;
9762         if (! node_p) {
9763             /* no bare \N in a charclass */
9764             if (in_char_class) {
9765                 vFAIL("\\N in a character class must be a named character: \\N{...}");
9766             }
9767             return FALSE;
9768         }
9769         nextchar(pRExC_state);
9770         *node_p = reg_node(pRExC_state, REG_ANY);
9771         *flagp |= HASWIDTH|SIMPLE;
9772         RExC_naughty++;
9773         RExC_parse--;
9774         Set_Node_Length(*node_p, 1); /* MJD */
9775         return TRUE;
9776     }
9777
9778     /* Here, we have decided it should be a named character or sequence */
9779
9780     /* The test above made sure that the next real character is a '{', but
9781      * under the /x modifier, it could be separated by space (or a comment and
9782      * \n) and this is not allowed (for consistency with \x{...} and the
9783      * tokenizer handling of \N{NAME}). */
9784     if (*RExC_parse != '{') {
9785         vFAIL("Missing braces on \\N{}");
9786     }
9787
9788     RExC_parse++;       /* Skip past the '{' */
9789
9790     if (! (endbrace = strchr(RExC_parse, '}')) /* no trailing brace */
9791         || ! (endbrace == RExC_parse            /* nothing between the {} */
9792               || (endbrace - RExC_parse >= 2    /* U+ (bad hex is checked below */
9793                   && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg) */
9794     {
9795         if (endbrace) RExC_parse = endbrace;    /* position msg's '<--HERE' */
9796         vFAIL("\\N{NAME} must be resolved by the lexer");
9797     }
9798
9799     if (endbrace == RExC_parse) {   /* empty: \N{} */
9800         bool ret = TRUE;
9801         if (node_p) {
9802             *node_p = reg_node(pRExC_state,NOTHING);
9803         }
9804         else if (in_char_class) {
9805             if (SIZE_ONLY && in_char_class) {
9806                 ckWARNreg(RExC_parse,
9807                         "Ignoring zero length \\N{} in character class"
9808                 );
9809             }
9810             ret = FALSE;
9811         }
9812         else {
9813             return FALSE;
9814         }
9815         nextchar(pRExC_state);
9816         return ret;
9817     }
9818
9819     RExC_uni_semantics = 1; /* Unicode named chars imply Unicode semantics */
9820     RExC_parse += 2;    /* Skip past the 'U+' */
9821
9822     endchar = RExC_parse + strcspn(RExC_parse, ".}");
9823
9824     /* Code points are separated by dots.  If none, there is only one code
9825      * point, and is terminated by the brace */
9826     has_multiple_chars = (endchar < endbrace);
9827
9828     if (valuep && (! has_multiple_chars || in_char_class)) {
9829         /* We only pay attention to the first char of
9830         multichar strings being returned in char classes. I kinda wonder
9831         if this makes sense as it does change the behaviour
9832         from earlier versions, OTOH that behaviour was broken
9833         as well. XXX Solution is to recharacterize as
9834         [rest-of-class]|multi1|multi2... */
9835
9836         STRLEN length_of_hex = (STRLEN)(endchar - RExC_parse);
9837         I32 grok_hex_flags = PERL_SCAN_ALLOW_UNDERSCORES
9838             | PERL_SCAN_DISALLOW_PREFIX
9839             | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
9840
9841         *valuep = grok_hex(RExC_parse, &length_of_hex, &grok_hex_flags, NULL);
9842
9843         /* The tokenizer should have guaranteed validity, but it's possible to
9844          * bypass it by using single quoting, so check */
9845         if (length_of_hex == 0
9846             || length_of_hex != (STRLEN)(endchar - RExC_parse) )
9847         {
9848             RExC_parse += length_of_hex;        /* Includes all the valid */
9849             RExC_parse += (RExC_orig_utf8)      /* point to after 1st invalid */
9850                             ? UTF8SKIP(RExC_parse)
9851                             : 1;
9852             /* Guard against malformed utf8 */
9853             if (RExC_parse >= endchar) {
9854                 RExC_parse = endchar;
9855             }
9856             vFAIL("Invalid hexadecimal number in \\N{U+...}");
9857         }
9858
9859         if (in_char_class && has_multiple_chars) {
9860             ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
9861         }
9862
9863         RExC_parse = endbrace + 1;
9864     }
9865     else if (! node_p || ! has_multiple_chars) {
9866
9867         /* Here, the input is legal, but not according to the caller's
9868          * options.  We fail without advancing the parse, so that the
9869          * caller can try again */
9870         RExC_parse = p;
9871         return FALSE;
9872     }
9873     else {
9874
9875         /* What is done here is to convert this to a sub-pattern of the form
9876          * (?:\x{char1}\x{char2}...)
9877          * and then call reg recursively.  That way, it retains its atomicness,
9878          * while not having to worry about special handling that some code
9879          * points may have.  toke.c has converted the original Unicode values
9880          * to native, so that we can just pass on the hex values unchanged.  We
9881          * do have to set a flag to keep recoding from happening in the
9882          * recursion */
9883
9884         SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP);
9885         STRLEN len;
9886         char *orig_end = RExC_end;
9887         I32 flags;
9888
9889         while (RExC_parse < endbrace) {
9890
9891             /* Convert to notation the rest of the code understands */
9892             sv_catpv(substitute_parse, "\\x{");
9893             sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
9894             sv_catpv(substitute_parse, "}");
9895
9896             /* Point to the beginning of the next character in the sequence. */
9897             RExC_parse = endchar + 1;
9898             endchar = RExC_parse + strcspn(RExC_parse, ".}");
9899         }
9900         sv_catpv(substitute_parse, ")");
9901
9902         RExC_parse = SvPV(substitute_parse, len);
9903
9904         /* Don't allow empty number */
9905         if (len < 8) {
9906             vFAIL("Invalid hexadecimal number in \\N{U+...}");
9907         }
9908         RExC_end = RExC_parse + len;
9909
9910         /* The values are Unicode, and therefore not subject to recoding */
9911         RExC_override_recoding = 1;
9912
9913         *node_p = reg(pRExC_state, 1, &flags, depth+1);
9914         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
9915
9916         RExC_parse = endbrace;
9917         RExC_end = orig_end;
9918         RExC_override_recoding = 0;
9919
9920         nextchar(pRExC_state);
9921     }
9922
9923     return TRUE;
9924 }
9925
9926
9927 /*
9928  * reg_recode
9929  *
9930  * It returns the code point in utf8 for the value in *encp.
9931  *    value: a code value in the source encoding
9932  *    encp:  a pointer to an Encode object
9933  *
9934  * If the result from Encode is not a single character,
9935  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
9936  */
9937 STATIC UV
9938 S_reg_recode(pTHX_ const char value, SV **encp)
9939 {
9940     STRLEN numlen = 1;
9941     SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP);
9942     const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
9943     const STRLEN newlen = SvCUR(sv);
9944     UV uv = UNICODE_REPLACEMENT;
9945
9946     PERL_ARGS_ASSERT_REG_RECODE;
9947
9948     if (newlen)
9949         uv = SvUTF8(sv)
9950              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
9951              : *(U8*)s;
9952
9953     if (!newlen || numlen != newlen) {
9954         uv = UNICODE_REPLACEMENT;
9955         *encp = NULL;
9956     }
9957     return uv;
9958 }
9959
9960 PERL_STATIC_INLINE U8
9961 S_compute_EXACTish(pTHX_ RExC_state_t *pRExC_state)
9962 {
9963     U8 op;
9964
9965     PERL_ARGS_ASSERT_COMPUTE_EXACTISH;
9966
9967     if (! FOLD) {
9968         return EXACT;
9969     }
9970
9971     op = get_regex_charset(RExC_flags);
9972     if (op >= REGEX_ASCII_RESTRICTED_CHARSET) {
9973         op--; /* /a is same as /u, and map /aa's offset to what /a's would have
9974                  been, so there is no hole */
9975     }
9976
9977     return op + EXACTF;
9978 }
9979
9980 PERL_STATIC_INLINE void
9981 S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state, regnode *node, I32* flagp, STRLEN len, UV code_point)
9982 {
9983     /* This knows the details about sizing an EXACTish node, setting flags for
9984      * it (by setting <*flagp>, and potentially populating it with a single
9985      * character.
9986      *
9987      * If <len> (the length in bytes) is non-zero, this function assumes that
9988      * the node has already been populated, and just does the sizing.  In this
9989      * case <code_point> should be the final code point that has already been
9990      * placed into the node.  This value will be ignored except that under some
9991      * circumstances <*flagp> is set based on it.
9992      *
9993      * If <len> is zero, the function assumes that the node is to contain only
9994      * the single character given by <code_point> and calculates what <len>
9995      * should be.  In pass 1, it sizes the node appropriately.  In pass 2, it
9996      * additionally will populate the node's STRING with <code_point>, if <len>
9997      * is 0.  In both cases <*flagp> is appropriately set
9998      *
9999      * It knows that under FOLD, UTF characters and the Latin Sharp S must be
10000      * folded (the latter only when the rules indicate it can match 'ss') */
10001
10002     bool len_passed_in = cBOOL(len != 0);
10003     U8 character[UTF8_MAXBYTES_CASE+1];
10004
10005     PERL_ARGS_ASSERT_ALLOC_MAYBE_POPULATE_EXACT;
10006
10007     if (! len_passed_in) {
10008         if (UTF) {
10009             if (FOLD) {
10010                 to_uni_fold(NATIVE_TO_UNI(code_point), character, &len);
10011             }
10012             else {
10013                 uvchr_to_utf8( character, code_point);
10014                 len = UTF8SKIP(character);
10015             }
10016         }
10017         else if (! FOLD
10018                  || code_point != LATIN_SMALL_LETTER_SHARP_S
10019                  || ASCII_FOLD_RESTRICTED
10020                  || ! AT_LEAST_UNI_SEMANTICS)
10021         {
10022             *character = (U8) code_point;
10023             len = 1;
10024         }
10025         else {
10026             *character = 's';
10027             *(character + 1) = 's';
10028             len = 2;
10029         }
10030     }
10031
10032     if (SIZE_ONLY) {
10033         RExC_size += STR_SZ(len);
10034     }
10035     else {
10036         RExC_emit += STR_SZ(len);
10037         STR_LEN(node) = len;
10038         if (! len_passed_in) {
10039             Copy((char *) character, STRING(node), len, char);
10040         }
10041     }
10042
10043     *flagp |= HASWIDTH;
10044
10045     /* A single character node is SIMPLE, except for the special-cased SHARP S
10046      * under /di. */
10047     if ((len == 1 || (UTF && len == UNISKIP(code_point)))
10048         && (code_point != LATIN_SMALL_LETTER_SHARP_S
10049             || ! FOLD || ! DEPENDS_SEMANTICS))
10050     {
10051         *flagp |= SIMPLE;
10052     }
10053 }
10054
10055 /*
10056  - regatom - the lowest level
10057
10058    Try to identify anything special at the start of the pattern. If there
10059    is, then handle it as required. This may involve generating a single regop,
10060    such as for an assertion; or it may involve recursing, such as to
10061    handle a () structure.
10062
10063    If the string doesn't start with something special then we gobble up
10064    as much literal text as we can.
10065
10066    Once we have been able to handle whatever type of thing started the
10067    sequence, we return.
10068
10069    Note: we have to be careful with escapes, as they can be both literal
10070    and special, and in the case of \10 and friends, context determines which.
10071
10072    A summary of the code structure is:
10073
10074    switch (first_byte) {
10075         cases for each special:
10076             handle this special;
10077             break;
10078         case '\\':
10079             switch (2nd byte) {
10080                 cases for each unambiguous special:
10081                     handle this special;
10082                     break;
10083                 cases for each ambigous special/literal:
10084                     disambiguate;
10085                     if (special)  handle here
10086                     else goto defchar;
10087                 default: // unambiguously literal:
10088                     goto defchar;
10089             }
10090         default:  // is a literal char
10091             // FALL THROUGH
10092         defchar:
10093             create EXACTish node for literal;
10094             while (more input and node isn't full) {
10095                 switch (input_byte) {
10096                    cases for each special;
10097                        make sure parse pointer is set so that the next call to
10098                            regatom will see this special first
10099                        goto loopdone; // EXACTish node terminated by prev. char
10100                    default:
10101                        append char to EXACTISH node;
10102                 }
10103                 get next input byte;
10104             }
10105         loopdone:
10106    }
10107    return the generated node;
10108
10109    Specifically there are two separate switches for handling
10110    escape sequences, with the one for handling literal escapes requiring
10111    a dummy entry for all of the special escapes that are actually handled
10112    by the other.
10113 */
10114
10115 STATIC regnode *
10116 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
10117 {
10118     dVAR;
10119     regnode *ret = NULL;
10120     I32 flags;
10121     char *parse_start = RExC_parse;
10122     U8 op;
10123     GET_RE_DEBUG_FLAGS_DECL;
10124     DEBUG_PARSE("atom");
10125     *flagp = WORST;             /* Tentatively. */
10126
10127     PERL_ARGS_ASSERT_REGATOM;
10128
10129 tryagain:
10130     switch ((U8)*RExC_parse) {
10131     case '^':
10132         RExC_seen_zerolen++;
10133         nextchar(pRExC_state);
10134         if (RExC_flags & RXf_PMf_MULTILINE)
10135             ret = reg_node(pRExC_state, MBOL);
10136         else if (RExC_flags & RXf_PMf_SINGLELINE)
10137             ret = reg_node(pRExC_state, SBOL);
10138         else
10139             ret = reg_node(pRExC_state, BOL);
10140         Set_Node_Length(ret, 1); /* MJD */
10141         break;
10142     case '$':
10143         nextchar(pRExC_state);
10144         if (*RExC_parse)
10145             RExC_seen_zerolen++;
10146         if (RExC_flags & RXf_PMf_MULTILINE)
10147             ret = reg_node(pRExC_state, MEOL);
10148         else if (RExC_flags & RXf_PMf_SINGLELINE)
10149             ret = reg_node(pRExC_state, SEOL);
10150         else
10151             ret = reg_node(pRExC_state, EOL);
10152         Set_Node_Length(ret, 1); /* MJD */
10153         break;
10154     case '.':
10155         nextchar(pRExC_state);
10156         if (RExC_flags & RXf_PMf_SINGLELINE)
10157             ret = reg_node(pRExC_state, SANY);
10158         else
10159             ret = reg_node(pRExC_state, REG_ANY);
10160         *flagp |= HASWIDTH|SIMPLE;
10161         RExC_naughty++;
10162         Set_Node_Length(ret, 1); /* MJD */
10163         break;
10164     case '[':
10165     {
10166         char * const oregcomp_parse = ++RExC_parse;
10167         ret = regclass(pRExC_state, flagp,depth+1);
10168         if (*RExC_parse != ']') {
10169             RExC_parse = oregcomp_parse;
10170             vFAIL("Unmatched [");
10171         }
10172         nextchar(pRExC_state);
10173         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
10174         break;
10175     }
10176     case '(':
10177         nextchar(pRExC_state);
10178         ret = reg(pRExC_state, 1, &flags,depth+1);
10179         if (ret == NULL) {
10180                 if (flags & TRYAGAIN) {
10181                     if (RExC_parse == RExC_end) {
10182                          /* Make parent create an empty node if needed. */
10183                         *flagp |= TRYAGAIN;
10184                         return(NULL);
10185                     }
10186                     goto tryagain;
10187                 }
10188                 return(NULL);
10189         }
10190         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
10191         break;
10192     case '|':
10193     case ')':
10194         if (flags & TRYAGAIN) {
10195             *flagp |= TRYAGAIN;
10196             return NULL;
10197         }
10198         vFAIL("Internal urp");
10199                                 /* Supposed to be caught earlier. */
10200         break;
10201     case '?':
10202     case '+':
10203     case '*':
10204         RExC_parse++;
10205         vFAIL("Quantifier follows nothing");
10206         break;
10207     case '\\':
10208         /* Special Escapes
10209
10210            This switch handles escape sequences that resolve to some kind
10211            of special regop and not to literal text. Escape sequnces that
10212            resolve to literal text are handled below in the switch marked
10213            "Literal Escapes".
10214
10215            Every entry in this switch *must* have a corresponding entry
10216            in the literal escape switch. However, the opposite is not
10217            required, as the default for this switch is to jump to the
10218            literal text handling code.
10219         */
10220         switch ((U8)*++RExC_parse) {
10221         /* Special Escapes */
10222         case 'A':
10223             RExC_seen_zerolen++;
10224             ret = reg_node(pRExC_state, SBOL);
10225             *flagp |= SIMPLE;
10226             goto finish_meta_pat;
10227         case 'G':
10228             ret = reg_node(pRExC_state, GPOS);
10229             RExC_seen |= REG_SEEN_GPOS;
10230             *flagp |= SIMPLE;
10231             goto finish_meta_pat;
10232         case 'K':
10233             RExC_seen_zerolen++;
10234             ret = reg_node(pRExC_state, KEEPS);
10235             *flagp |= SIMPLE;
10236             /* XXX:dmq : disabling in-place substitution seems to
10237              * be necessary here to avoid cases of memory corruption, as
10238              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
10239              */
10240             RExC_seen |= REG_SEEN_LOOKBEHIND;
10241             goto finish_meta_pat;
10242         case 'Z':
10243             ret = reg_node(pRExC_state, SEOL);
10244             *flagp |= SIMPLE;
10245             RExC_seen_zerolen++;                /* Do not optimize RE away */
10246             goto finish_meta_pat;
10247         case 'z':
10248             ret = reg_node(pRExC_state, EOS);
10249             *flagp |= SIMPLE;
10250             RExC_seen_zerolen++;                /* Do not optimize RE away */
10251             goto finish_meta_pat;
10252         case 'C':
10253             ret = reg_node(pRExC_state, CANY);
10254             RExC_seen |= REG_SEEN_CANY;
10255             *flagp |= HASWIDTH|SIMPLE;
10256             goto finish_meta_pat;
10257         case 'X':
10258             ret = reg_node(pRExC_state, CLUMP);
10259             *flagp |= HASWIDTH;
10260             goto finish_meta_pat;
10261         case 'w':
10262             op = ALNUM + get_regex_charset(RExC_flags);
10263             if (op > ALNUMA) {  /* /aa is same as /a */
10264                 op = ALNUMA;
10265             }
10266             ret = reg_node(pRExC_state, op);
10267             *flagp |= HASWIDTH|SIMPLE;
10268             goto finish_meta_pat;
10269         case 'W':
10270             op = NALNUM + get_regex_charset(RExC_flags);
10271             if (op > NALNUMA) { /* /aa is same as /a */
10272                 op = NALNUMA;
10273             }
10274             ret = reg_node(pRExC_state, op);
10275             *flagp |= HASWIDTH|SIMPLE;
10276             goto finish_meta_pat;
10277         case 'b':
10278             RExC_seen_zerolen++;
10279             RExC_seen |= REG_SEEN_LOOKBEHIND;
10280             op = BOUND + get_regex_charset(RExC_flags);
10281             if (op > BOUNDA) {  /* /aa is same as /a */
10282                 op = BOUNDA;
10283             }
10284             ret = reg_node(pRExC_state, op);
10285             FLAGS(ret) = get_regex_charset(RExC_flags);
10286             *flagp |= SIMPLE;
10287             goto finish_meta_pat;
10288         case 'B':
10289             RExC_seen_zerolen++;
10290             RExC_seen |= REG_SEEN_LOOKBEHIND;
10291             op = NBOUND + get_regex_charset(RExC_flags);
10292             if (op > NBOUNDA) { /* /aa is same as /a */
10293                 op = NBOUNDA;
10294             }
10295             ret = reg_node(pRExC_state, op);
10296             FLAGS(ret) = get_regex_charset(RExC_flags);
10297             *flagp |= SIMPLE;
10298             goto finish_meta_pat;
10299         case 's':
10300             op = SPACE + get_regex_charset(RExC_flags);
10301             if (op > SPACEA) {  /* /aa is same as /a */
10302                 op = SPACEA;
10303             }
10304             ret = reg_node(pRExC_state, op);
10305             *flagp |= HASWIDTH|SIMPLE;
10306             goto finish_meta_pat;
10307         case 'S':
10308             op = NSPACE + get_regex_charset(RExC_flags);
10309             if (op > NSPACEA) { /* /aa is same as /a */
10310                 op = NSPACEA;
10311             }
10312             ret = reg_node(pRExC_state, op);
10313             *flagp |= HASWIDTH|SIMPLE;
10314             goto finish_meta_pat;
10315         case 'D':
10316             op = NDIGIT;
10317             goto join_D_and_d;
10318         case 'd':
10319             op = DIGIT;
10320         join_D_and_d:
10321             {
10322                 U8 offset = get_regex_charset(RExC_flags);
10323                 if (offset == REGEX_UNICODE_CHARSET) {
10324                     offset = REGEX_DEPENDS_CHARSET;
10325                 }
10326                 else if (offset == REGEX_ASCII_MORE_RESTRICTED_CHARSET) {
10327                     offset = REGEX_ASCII_RESTRICTED_CHARSET;
10328                 }
10329                 op += offset;
10330             }
10331             ret = reg_node(pRExC_state, op);
10332             *flagp |= HASWIDTH|SIMPLE;
10333             goto finish_meta_pat;
10334         case 'R':
10335             ret = reg_node(pRExC_state, LNBREAK);
10336             *flagp |= HASWIDTH|SIMPLE;
10337             goto finish_meta_pat;
10338         case 'h':
10339             ret = reg_node(pRExC_state, HORIZWS);
10340             *flagp |= HASWIDTH|SIMPLE;
10341             goto finish_meta_pat;
10342         case 'H':
10343             ret = reg_node(pRExC_state, NHORIZWS);
10344             *flagp |= HASWIDTH|SIMPLE;
10345             goto finish_meta_pat;
10346         case 'v':
10347             ret = reg_node(pRExC_state, VERTWS);
10348             *flagp |= HASWIDTH|SIMPLE;
10349             goto finish_meta_pat;
10350         case 'V':
10351             ret = reg_node(pRExC_state, NVERTWS);
10352             *flagp |= HASWIDTH|SIMPLE;
10353          finish_meta_pat:           
10354             nextchar(pRExC_state);
10355             Set_Node_Length(ret, 2); /* MJD */
10356             break;          
10357         case 'p':
10358         case 'P':
10359             {
10360                 char* const oldregxend = RExC_end;
10361 #ifdef DEBUGGING
10362                 char* parse_start = RExC_parse - 2;
10363 #endif
10364
10365                 if (RExC_parse[1] == '{') {
10366                   /* a lovely hack--pretend we saw [\pX] instead */
10367                     RExC_end = strchr(RExC_parse, '}');
10368                     if (!RExC_end) {
10369                         const U8 c = (U8)*RExC_parse;
10370                         RExC_parse += 2;
10371                         RExC_end = oldregxend;
10372                         vFAIL2("Missing right brace on \\%c{}", c);
10373                     }
10374                     RExC_end++;
10375                 }
10376                 else {
10377                     RExC_end = RExC_parse + 2;
10378                     if (RExC_end > oldregxend)
10379                         RExC_end = oldregxend;
10380                 }
10381                 RExC_parse--;
10382
10383                 ret = regclass(pRExC_state, flagp,depth+1);
10384
10385                 RExC_end = oldregxend;
10386                 RExC_parse--;
10387
10388                 Set_Node_Offset(ret, parse_start + 2);
10389                 Set_Node_Cur_Length(ret);
10390                 nextchar(pRExC_state);
10391             }
10392             break;
10393         case 'N': 
10394             /* Handle \N and \N{NAME} with multiple code points here and not
10395              * below because it can be multicharacter. join_exact() will join
10396              * them up later on.  Also this makes sure that things like
10397              * /\N{BLAH}+/ and \N{BLAH} being multi char Just Happen. dmq.
10398              * The options to the grok function call causes it to fail if the
10399              * sequence is just a single code point.  We then go treat it as
10400              * just another character in the current EXACT node, and hence it
10401              * gets uniform treatment with all the other characters.  The
10402              * special treatment for quantifiers is not needed for such single
10403              * character sequences */
10404             ++RExC_parse;
10405             if (! grok_bslash_N(pRExC_state, &ret, NULL, flagp, depth, FALSE)) {
10406                 RExC_parse--;
10407                 goto defchar;
10408             }
10409             break;
10410         case 'k':    /* Handle \k<NAME> and \k'NAME' */
10411         parse_named_seq:
10412         {   
10413             char ch= RExC_parse[1];         
10414             if (ch != '<' && ch != '\'' && ch != '{') {
10415                 RExC_parse++;
10416                 vFAIL2("Sequence %.2s... not terminated",parse_start);
10417             } else {
10418                 /* this pretty much dupes the code for (?P=...) in reg(), if
10419                    you change this make sure you change that */
10420                 char* name_start = (RExC_parse += 2);
10421                 U32 num = 0;
10422                 SV *sv_dat = reg_scan_name(pRExC_state,
10423                     SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
10424                 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
10425                 if (RExC_parse == name_start || *RExC_parse != ch)
10426                     vFAIL2("Sequence %.3s... not terminated",parse_start);
10427
10428                 if (!SIZE_ONLY) {
10429                     num = add_data( pRExC_state, 1, "S" );
10430                     RExC_rxi->data->data[num]=(void*)sv_dat;
10431                     SvREFCNT_inc_simple_void(sv_dat);
10432                 }
10433
10434                 RExC_sawback = 1;
10435                 ret = reganode(pRExC_state,
10436                                ((! FOLD)
10437                                  ? NREF
10438                                  : (ASCII_FOLD_RESTRICTED)
10439                                    ? NREFFA
10440                                    : (AT_LEAST_UNI_SEMANTICS)
10441                                      ? NREFFU
10442                                      : (LOC)
10443                                        ? NREFFL
10444                                        : NREFF),
10445                                 num);
10446                 *flagp |= HASWIDTH;
10447
10448                 /* override incorrect value set in reganode MJD */
10449                 Set_Node_Offset(ret, parse_start+1);
10450                 Set_Node_Cur_Length(ret); /* MJD */
10451                 nextchar(pRExC_state);
10452
10453             }
10454             break;
10455         }
10456         case 'g': 
10457         case '1': case '2': case '3': case '4':
10458         case '5': case '6': case '7': case '8': case '9':
10459             {
10460                 I32 num;
10461                 bool isg = *RExC_parse == 'g';
10462                 bool isrel = 0; 
10463                 bool hasbrace = 0;
10464                 if (isg) {
10465                     RExC_parse++;
10466                     if (*RExC_parse == '{') {
10467                         RExC_parse++;
10468                         hasbrace = 1;
10469                     }
10470                     if (*RExC_parse == '-') {
10471                         RExC_parse++;
10472                         isrel = 1;
10473                     }
10474                     if (hasbrace && !isDIGIT(*RExC_parse)) {
10475                         if (isrel) RExC_parse--;
10476                         RExC_parse -= 2;                            
10477                         goto parse_named_seq;
10478                 }   }
10479                 num = atoi(RExC_parse);
10480                 if (isg && num == 0)
10481                     vFAIL("Reference to invalid group 0");
10482                 if (isrel) {
10483                     num = RExC_npar - num;
10484                     if (num < 1)
10485                         vFAIL("Reference to nonexistent or unclosed group");
10486                 }
10487                 if (!isg && num > 9 && num >= RExC_npar)
10488                     /* Probably a character specified in octal, e.g. \35 */
10489                     goto defchar;
10490                 else {
10491                     char * const parse_start = RExC_parse - 1; /* MJD */
10492                     while (isDIGIT(*RExC_parse))
10493                         RExC_parse++;
10494                     if (parse_start == RExC_parse - 1) 
10495                         vFAIL("Unterminated \\g... pattern");
10496                     if (hasbrace) {
10497                         if (*RExC_parse != '}') 
10498                             vFAIL("Unterminated \\g{...} pattern");
10499                         RExC_parse++;
10500                     }    
10501                     if (!SIZE_ONLY) {
10502                         if (num > (I32)RExC_rx->nparens)
10503                             vFAIL("Reference to nonexistent group");
10504                     }
10505                     RExC_sawback = 1;
10506                     ret = reganode(pRExC_state,
10507                                    ((! FOLD)
10508                                      ? REF
10509                                      : (ASCII_FOLD_RESTRICTED)
10510                                        ? REFFA
10511                                        : (AT_LEAST_UNI_SEMANTICS)
10512                                          ? REFFU
10513                                          : (LOC)
10514                                            ? REFFL
10515                                            : REFF),
10516                                     num);
10517                     *flagp |= HASWIDTH;
10518
10519                     /* override incorrect value set in reganode MJD */
10520                     Set_Node_Offset(ret, parse_start+1);
10521                     Set_Node_Cur_Length(ret); /* MJD */
10522                     RExC_parse--;
10523                     nextchar(pRExC_state);
10524                 }
10525             }
10526             break;
10527         case '\0':
10528             if (RExC_parse >= RExC_end)
10529                 FAIL("Trailing \\");
10530             /* FALL THROUGH */
10531         default:
10532             /* Do not generate "unrecognized" warnings here, we fall
10533                back into the quick-grab loop below */
10534             parse_start--;
10535             goto defchar;
10536         }
10537         break;
10538
10539     case '#':
10540         if (RExC_flags & RXf_PMf_EXTENDED) {
10541             if ( reg_skipcomment( pRExC_state ) )
10542                 goto tryagain;
10543         }
10544         /* FALL THROUGH */
10545
10546     default:
10547
10548             parse_start = RExC_parse - 1;
10549
10550             RExC_parse++;
10551
10552         defchar: {
10553             STRLEN len = 0;
10554             UV ender;
10555             char *p;
10556             char *s;
10557 #define MAX_NODE_STRING_SIZE 127
10558             char foldbuf[MAX_NODE_STRING_SIZE+UTF8_MAXBYTES_CASE];
10559             char *s0;
10560             U8 upper_parse = MAX_NODE_STRING_SIZE;
10561             STRLEN foldlen;
10562             U8 node_type;
10563             bool next_is_quantifier;
10564             char * oldp = NULL;
10565
10566             /* If a folding node contains only code points that don't
10567              * participate in folds, it can be changed into an EXACT node,
10568              * which allows the optimizer more things to look for */
10569             bool maybe_exact;
10570
10571             ender = 0;
10572             node_type = compute_EXACTish(pRExC_state);
10573             ret = reg_node(pRExC_state, node_type);
10574
10575             /* In pass1, folded, we use a temporary buffer instead of the
10576              * actual node, as the node doesn't exist yet */
10577             s = (SIZE_ONLY && FOLD) ? foldbuf : STRING(ret);
10578
10579             s0 = s;
10580
10581         reparse:
10582
10583             /* We do the EXACTFish to EXACT node only if folding, and not if in
10584              * locale, as whether a character folds or not isn't known until
10585              * runtime */
10586             maybe_exact = FOLD && ! LOC;
10587
10588             /* XXX The node can hold up to 255 bytes, yet this only goes to
10589              * 127.  I (khw) do not know why.  Keeping it somewhat less than
10590              * 255 allows us to not have to worry about overflow due to
10591              * converting to utf8 and fold expansion, but that value is
10592              * 255-UTF8_MAXBYTES_CASE.  join_exact() may join adjacent nodes
10593              * split up by this limit into a single one using the real max of
10594              * 255.  Even at 127, this breaks under rare circumstances.  If
10595              * folding, we do not want to split a node at a character that is a
10596              * non-final in a multi-char fold, as an input string could just
10597              * happen to want to match across the node boundary.  The join
10598              * would solve that problem if the join actually happens.  But a
10599              * series of more than two nodes in a row each of 127 would cause
10600              * the first join to succeed to get to 254, but then there wouldn't
10601              * be room for the next one, which could at be one of those split
10602              * multi-char folds.  I don't know of any fool-proof solution.  One
10603              * could back off to end with only a code point that isn't such a
10604              * non-final, but it is possible for there not to be any in the
10605              * entire node. */
10606             for (p = RExC_parse - 1;
10607                  len < upper_parse && p < RExC_end;
10608                  len++)
10609             {
10610                 oldp = p;
10611
10612                 if (RExC_flags & RXf_PMf_EXTENDED)
10613                     p = regwhite( pRExC_state, p );
10614                 switch ((U8)*p) {
10615                 case '^':
10616                 case '$':
10617                 case '.':
10618                 case '[':
10619                 case '(':
10620                 case ')':
10621                 case '|':
10622                     goto loopdone;
10623                 case '\\':
10624                     /* Literal Escapes Switch
10625
10626                        This switch is meant to handle escape sequences that
10627                        resolve to a literal character.
10628
10629                        Every escape sequence that represents something
10630                        else, like an assertion or a char class, is handled
10631                        in the switch marked 'Special Escapes' above in this
10632                        routine, but also has an entry here as anything that
10633                        isn't explicitly mentioned here will be treated as
10634                        an unescaped equivalent literal.
10635                     */
10636
10637                     switch ((U8)*++p) {
10638                     /* These are all the special escapes. */
10639                     case 'A':             /* Start assertion */
10640                     case 'b': case 'B':   /* Word-boundary assertion*/
10641                     case 'C':             /* Single char !DANGEROUS! */
10642                     case 'd': case 'D':   /* digit class */
10643                     case 'g': case 'G':   /* generic-backref, pos assertion */
10644                     case 'h': case 'H':   /* HORIZWS */
10645                     case 'k': case 'K':   /* named backref, keep marker */
10646                     case 'p': case 'P':   /* Unicode property */
10647                               case 'R':   /* LNBREAK */
10648                     case 's': case 'S':   /* space class */
10649                     case 'v': case 'V':   /* VERTWS */
10650                     case 'w': case 'W':   /* word class */
10651                     case 'X':             /* eXtended Unicode "combining character sequence" */
10652                     case 'z': case 'Z':   /* End of line/string assertion */
10653                         --p;
10654                         goto loopdone;
10655
10656                     /* Anything after here is an escape that resolves to a
10657                        literal. (Except digits, which may or may not)
10658                      */
10659                     case 'n':
10660                         ender = '\n';
10661                         p++;
10662                         break;
10663                     case 'N': /* Handle a single-code point named character. */
10664                         /* The options cause it to fail if a multiple code
10665                          * point sequence.  Handle those in the switch() above
10666                          * */
10667                         RExC_parse = p + 1;
10668                         if (! grok_bslash_N(pRExC_state, NULL, &ender,
10669                                             flagp, depth, FALSE))
10670                         {
10671                             RExC_parse = p = oldp;
10672                             goto loopdone;
10673                         }
10674                         p = RExC_parse;
10675                         if (ender > 0xff) {
10676                             REQUIRE_UTF8;
10677                         }
10678                         break;
10679                     case 'r':
10680                         ender = '\r';
10681                         p++;
10682                         break;
10683                     case 't':
10684                         ender = '\t';
10685                         p++;
10686                         break;
10687                     case 'f':
10688                         ender = '\f';
10689                         p++;
10690                         break;
10691                     case 'e':
10692                           ender = ASCII_TO_NATIVE('\033');
10693                         p++;
10694                         break;
10695                     case 'a':
10696                           ender = ASCII_TO_NATIVE('\007');
10697                         p++;
10698                         break;
10699                     case 'o':
10700                         {
10701                             STRLEN brace_len = len;
10702                             UV result;
10703                             const char* error_msg;
10704
10705                             bool valid = grok_bslash_o(p,
10706                                                        &result,
10707                                                        &brace_len,
10708                                                        &error_msg,
10709                                                        1);
10710                             p += brace_len;
10711                             if (! valid) {
10712                                 RExC_parse = p; /* going to die anyway; point
10713                                                    to exact spot of failure */
10714                                 vFAIL(error_msg);
10715                             }
10716                             else
10717                             {
10718                                 ender = result;
10719                             }
10720                             if (PL_encoding && ender < 0x100) {
10721                                 goto recode_encoding;
10722                             }
10723                             if (ender > 0xff) {
10724                                 REQUIRE_UTF8;
10725                             }
10726                             break;
10727                         }
10728                     case 'x':
10729                         {
10730                             STRLEN brace_len = len;
10731                             UV result;
10732                             const char* error_msg;
10733
10734                             bool valid = grok_bslash_x(p,
10735                                                        &result,
10736                                                        &brace_len,
10737                                                        &error_msg,
10738                                                        1);
10739                             p += brace_len;
10740                             if (! valid) {
10741                                 RExC_parse = p; /* going to die anyway; point
10742                                                    to exact spot of failure */
10743                                 vFAIL(error_msg);
10744                             }
10745                             else {
10746                                 ender = result;
10747                             }
10748                             if (PL_encoding && ender < 0x100) {
10749                                 goto recode_encoding;
10750                             }
10751                             if (ender > 0xff) {
10752                                 REQUIRE_UTF8;
10753                             }
10754                             break;
10755                         }
10756                     case 'c':
10757                         p++;
10758                         ender = grok_bslash_c(*p++, UTF, SIZE_ONLY);
10759                         break;
10760                     case '0': case '1': case '2': case '3':case '4':
10761                     case '5': case '6': case '7':
10762                         if (*p == '0' ||
10763                             (isDIGIT(p[1]) && atoi(p) >= RExC_npar))
10764                         {
10765                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
10766                             STRLEN numlen = 3;
10767                             ender = grok_oct(p, &numlen, &flags, NULL);
10768                             if (ender > 0xff) {
10769                                 REQUIRE_UTF8;
10770                             }
10771                             p += numlen;
10772                         }
10773                         else {
10774                             --p;
10775                             goto loopdone;
10776                         }
10777                         if (PL_encoding && ender < 0x100)
10778                             goto recode_encoding;
10779                         break;
10780                     recode_encoding:
10781                         if (! RExC_override_recoding) {
10782                             SV* enc = PL_encoding;
10783                             ender = reg_recode((const char)(U8)ender, &enc);
10784                             if (!enc && SIZE_ONLY)
10785                                 ckWARNreg(p, "Invalid escape in the specified encoding");
10786                             REQUIRE_UTF8;
10787                         }
10788                         break;
10789                     case '\0':
10790                         if (p >= RExC_end)
10791                             FAIL("Trailing \\");
10792                         /* FALL THROUGH */
10793                     default:
10794                         if (!SIZE_ONLY&& isALNUMC(*p)) {
10795                             ckWARN2reg(p + 1, "Unrecognized escape \\%.1s passed through", p);
10796                         }
10797                         goto normal_default;
10798                     }
10799                     break;
10800                 case '{':
10801                     /* Currently we don't warn when the lbrace is at the start
10802                      * of a construct.  This catches it in the middle of a
10803                      * literal string, or when its the first thing after
10804                      * something like "\b" */
10805                     if (! SIZE_ONLY
10806                         && (len || (p > RExC_start && isALPHA_A(*(p -1)))))
10807                     {
10808                         ckWARNregdep(p + 1, "Unescaped left brace in regex is deprecated, passed through");
10809                     }
10810                     /*FALLTHROUGH*/
10811                 default:
10812                   normal_default:
10813                     if (UTF8_IS_START(*p) && UTF) {
10814                         STRLEN numlen;
10815                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
10816                                                &numlen, UTF8_ALLOW_DEFAULT);
10817                         p += numlen;
10818                     }
10819                     else
10820                         ender = (U8) *p++;
10821                     break;
10822                 } /* End of switch on the literal */
10823
10824                 /* Here, have looked at the literal character and <ender>
10825                  * contains its ordinal, <p> points to the character after it
10826                  */
10827
10828                 if ( RExC_flags & RXf_PMf_EXTENDED)
10829                     p = regwhite( pRExC_state, p );
10830
10831                 /* If the next thing is a quantifier, it applies to this
10832                  * character only, which means that this character has to be in
10833                  * its own node and can't just be appended to the string in an
10834                  * existing node, so if there are already other characters in
10835                  * the node, close the node with just them, and set up to do
10836                  * this character again next time through, when it will be the
10837                  * only thing in its new node */
10838                 if ((next_is_quantifier = (p < RExC_end && ISMULT2(p))) && len)
10839                 {
10840                     p = oldp;
10841                     goto loopdone;
10842                 }
10843
10844                 if (FOLD) {
10845                     if (UTF
10846                             /* See comments for join_exact() as to why we fold
10847                              * this non-UTF at compile time */
10848                         || (node_type == EXACTFU
10849                             && ender == LATIN_SMALL_LETTER_SHARP_S))
10850                     {
10851
10852
10853                         /* Prime the casefolded buffer.  Locale rules, which
10854                          * apply only to code points < 256, aren't known until
10855                          * execution, so for them, just output the original
10856                          * character using utf8.  If we start to fold non-UTF
10857                          * patterns, be sure to update join_exact() */
10858                         if (LOC && ender < 256) {
10859                             if (UNI_IS_INVARIANT(ender)) {
10860                                 *s = (U8) ender;
10861                                 foldlen = 1;
10862                             } else {
10863                                 *s = UTF8_TWO_BYTE_HI(ender);
10864                                 *(s + 1) = UTF8_TWO_BYTE_LO(ender);
10865                                 foldlen = 2;
10866                             }
10867                         }
10868                         else {
10869                             UV folded = _to_uni_fold_flags(
10870                                            ender,
10871                                            (U8 *) s,
10872                                            &foldlen,
10873                                            FOLD_FLAGS_FULL
10874                                            | ((LOC) ?  FOLD_FLAGS_LOCALE
10875                                                     : (ASCII_FOLD_RESTRICTED)
10876                                                       ? FOLD_FLAGS_NOMIX_ASCII
10877                                                       : 0)
10878                                             );
10879
10880                             /* If this node only contains non-folding code
10881                              * points so far, see if this new one is also
10882                              * non-folding */
10883                             if (maybe_exact) {
10884                                 if (folded != ender) {
10885                                     maybe_exact = FALSE;
10886                                 }
10887                                 else {
10888                                     /* Here the fold is the original; we have
10889                                      * to check further to see if anything
10890                                      * folds to it */
10891                                     if (! PL_utf8_foldable) {
10892                                         SV* swash = swash_init("utf8",
10893                                                            "_Perl_Any_Folds",
10894                                                            &PL_sv_undef, 1, 0);
10895                                         PL_utf8_foldable =
10896                                                     _get_swash_invlist(swash);
10897                                         SvREFCNT_dec(swash);
10898                                     }
10899                                     if (_invlist_contains_cp(PL_utf8_foldable,
10900                                                              ender))
10901                                     {
10902                                         maybe_exact = FALSE;
10903                                     }
10904                                 }
10905                             }
10906                             ender = folded;
10907                         }
10908                         s += foldlen;
10909
10910                         /* The loop increments <len> each time, as all but this
10911                          * path (and the one just below for UTF) through it add
10912                          * a single byte to the EXACTish node.  But this one
10913                          * has changed len to be the correct final value, so
10914                          * subtract one to cancel out the increment that
10915                          * follows */
10916                         len += foldlen - 1;
10917                     }
10918                     else {
10919                         *(s++) = ender;
10920                         maybe_exact &= ! IS_IN_SOME_FOLD_L1(ender);
10921                     }
10922                 }
10923                 else if (UTF) {
10924                     const STRLEN unilen = reguni(pRExC_state, ender, s);
10925                     if (unilen > 0) {
10926                        s   += unilen;
10927                        len += unilen;
10928                     }
10929
10930                     /* See comment just above for - 1 */
10931                     len--;
10932                 }
10933                 else {
10934                     REGC((char)ender, s++);
10935                 }
10936
10937                 if (next_is_quantifier) {
10938
10939                     /* Here, the next input is a quantifier, and to get here,
10940                      * the current character is the only one in the node.
10941                      * Also, here <len> doesn't include the final byte for this
10942                      * character */
10943                     len++;
10944                     goto loopdone;
10945                 }
10946
10947             } /* End of loop through literal characters */
10948
10949             /* Here we have either exhausted the input or ran out of room in
10950              * the node.  (If we encountered a character that can't be in the
10951              * node, transfer is made directly to <loopdone>, and so we
10952              * wouldn't have fallen off the end of the loop.)  In the latter
10953              * case, we artificially have to split the node into two, because
10954              * we just don't have enough space to hold everything.  This
10955              * creates a problem if the final character participates in a
10956              * multi-character fold in the non-final position, as a match that
10957              * should have occurred won't, due to the way nodes are matched,
10958              * and our artificial boundary.  So back off until we find a non-
10959              * problematic character -- one that isn't at the beginning or
10960              * middle of such a fold.  (Either it doesn't participate in any
10961              * folds, or appears only in the final position of all the folds it
10962              * does participate in.)  A better solution with far fewer false
10963              * positives, and that would fill the nodes more completely, would
10964              * be to actually have available all the multi-character folds to
10965              * test against, and to back-off only far enough to be sure that
10966              * this node isn't ending with a partial one.  <upper_parse> is set
10967              * further below (if we need to reparse the node) to include just
10968              * up through that final non-problematic character that this code
10969              * identifies, so when it is set to less than the full node, we can
10970              * skip the rest of this */
10971             if (FOLD && p < RExC_end && upper_parse == MAX_NODE_STRING_SIZE) {
10972
10973                 const STRLEN full_len = len;
10974
10975                 assert(len >= MAX_NODE_STRING_SIZE);
10976
10977                 /* Here, <s> points to the final byte of the final character.
10978                  * Look backwards through the string until find a non-
10979                  * problematic character */
10980
10981                 if (! UTF) {
10982
10983                     /* These two have no multi-char folds to non-UTF characters
10984                      */
10985                     if (ASCII_FOLD_RESTRICTED || LOC) {
10986                         goto loopdone;
10987                     }
10988
10989                     while (--s >= s0 && IS_NON_FINAL_FOLD(*s)) { }
10990                     len = s - s0 + 1;
10991                 }
10992                 else {
10993                     if (!  PL_NonL1NonFinalFold) {
10994                         PL_NonL1NonFinalFold = _new_invlist_C_array(
10995                                         NonL1_Perl_Non_Final_Folds_invlist);
10996                     }
10997
10998                     /* Point to the first byte of the final character */
10999                     s = (char *) utf8_hop((U8 *) s, -1);
11000
11001                     while (s >= s0) {   /* Search backwards until find
11002                                            non-problematic char */
11003                         if (UTF8_IS_INVARIANT(*s)) {
11004
11005                             /* There are no ascii characters that participate
11006                              * in multi-char folds under /aa.  In EBCDIC, the
11007                              * non-ascii invariants are all control characters,
11008                              * so don't ever participate in any folds. */
11009                             if (ASCII_FOLD_RESTRICTED
11010                                 || ! IS_NON_FINAL_FOLD(*s))
11011                             {
11012                                 break;
11013                             }
11014                         }
11015                         else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
11016
11017                             /* No Latin1 characters participate in multi-char
11018                              * folds under /l */
11019                             if (LOC
11020                                 || ! IS_NON_FINAL_FOLD(TWO_BYTE_UTF8_TO_UNI(
11021                                                                 *s, *(s+1))))
11022                             {
11023                                 break;
11024                             }
11025                         }
11026                         else if (! _invlist_contains_cp(
11027                                         PL_NonL1NonFinalFold,
11028                                         valid_utf8_to_uvchr((U8 *) s, NULL)))
11029                         {
11030                             break;
11031                         }
11032
11033                         /* Here, the current character is problematic in that
11034                          * it does occur in the non-final position of some
11035                          * fold, so try the character before it, but have to
11036                          * special case the very first byte in the string, so
11037                          * we don't read outside the string */
11038                         s = (s == s0) ? s -1 : (char *) utf8_hop((U8 *) s, -1);
11039                     } /* End of loop backwards through the string */
11040
11041                     /* If there were only problematic characters in the string,
11042                      * <s> will point to before s0, in which case the length
11043                      * should be 0, otherwise include the length of the
11044                      * non-problematic character just found */
11045                     len = (s < s0) ? 0 : s - s0 + UTF8SKIP(s);
11046                 }
11047
11048                 /* Here, have found the final character, if any, that is
11049                  * non-problematic as far as ending the node without splitting
11050                  * it across a potential multi-char fold.  <len> contains the
11051                  * number of bytes in the node up-to and including that
11052                  * character, or is 0 if there is no such character, meaning
11053                  * the whole node contains only problematic characters.  In
11054                  * this case, give up and just take the node as-is.  We can't
11055                  * do any better */
11056                 if (len == 0) {
11057                     len = full_len;
11058                 } else {
11059
11060                     /* Here, the node does contain some characters that aren't
11061                      * problematic.  If one such is the final character in the
11062                      * node, we are done */
11063                     if (len == full_len) {
11064                         goto loopdone;
11065                     }
11066                     else if (len + ((UTF) ? UTF8SKIP(s) : 1) == full_len) {
11067
11068                         /* If the final character is problematic, but the
11069                          * penultimate is not, back-off that last character to
11070                          * later start a new node with it */
11071                         p = oldp;
11072                         goto loopdone;
11073                     }
11074
11075                     /* Here, the final non-problematic character is earlier
11076                      * in the input than the penultimate character.  What we do
11077                      * is reparse from the beginning, going up only as far as
11078                      * this final ok one, thus guaranteeing that the node ends
11079                      * in an acceptable character.  The reason we reparse is
11080                      * that we know how far in the character is, but we don't
11081                      * know how to correlate its position with the input parse.
11082                      * An alternate implementation would be to build that
11083                      * correlation as we go along during the original parse,
11084                      * but that would entail extra work for every node, whereas
11085                      * this code gets executed only when the string is too
11086                      * large for the node, and the final two characters are
11087                      * problematic, an infrequent occurrence.  Yet another
11088                      * possible strategy would be to save the tail of the
11089                      * string, and the next time regatom is called, initialize
11090                      * with that.  The problem with this is that unless you
11091                      * back off one more character, you won't be guaranteed
11092                      * regatom will get called again, unless regbranch,
11093                      * regpiece ... are also changed.  If you do back off that
11094                      * extra character, so that there is input guaranteed to
11095                      * force calling regatom, you can't handle the case where
11096                      * just the first character in the node is acceptable.  I
11097                      * (khw) decided to try this method which doesn't have that
11098                      * pitfall; if performance issues are found, we can do a
11099                      * combination of the current approach plus that one */
11100                     upper_parse = len;
11101                     len = 0;
11102                     s = s0;
11103                     goto reparse;
11104                 }
11105             }   /* End of verifying node ends with an appropriate char */
11106
11107         loopdone:   /* Jumped to when encounters something that shouldn't be in
11108                        the node */
11109
11110             /* If 'maybe_exact' is still set here, means there are no
11111              * code points in the node that participate in folds */
11112             if (FOLD && maybe_exact) {
11113                 OP(ret) = EXACT;
11114             }
11115
11116             /* I (khw) don't know if you can get here with zero length, but the
11117              * old code handled this situation by creating a zero-length EXACT
11118              * node.  Might as well be NOTHING instead */
11119             if (len == 0) {
11120                 OP(ret) = NOTHING;
11121             }
11122             else{
11123                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, len, ender);
11124             }
11125
11126             RExC_parse = p - 1;
11127             Set_Node_Cur_Length(ret); /* MJD */
11128             nextchar(pRExC_state);
11129             {
11130                 /* len is STRLEN which is unsigned, need to copy to signed */
11131                 IV iv = len;
11132                 if (iv < 0)
11133                     vFAIL("Internal disaster");
11134             }
11135
11136         } /* End of label 'defchar:' */
11137         break;
11138     } /* End of giant switch on input character */
11139
11140     return(ret);
11141 }
11142
11143 STATIC char *
11144 S_regwhite( RExC_state_t *pRExC_state, char *p )
11145 {
11146     const char *e = RExC_end;
11147
11148     PERL_ARGS_ASSERT_REGWHITE;
11149
11150     while (p < e) {
11151         if (isSPACE(*p))
11152             ++p;
11153         else if (*p == '#') {
11154             bool ended = 0;
11155             do {
11156                 if (*p++ == '\n') {
11157                     ended = 1;
11158                     break;
11159                 }
11160             } while (p < e);
11161             if (!ended)
11162                 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
11163         }
11164         else
11165             break;
11166     }
11167     return p;
11168 }
11169
11170 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
11171    Character classes ([:foo:]) can also be negated ([:^foo:]).
11172    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
11173    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
11174    but trigger failures because they are currently unimplemented. */
11175
11176 #define POSIXCC_DONE(c)   ((c) == ':')
11177 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
11178 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
11179
11180 PERL_STATIC_INLINE I32
11181 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value, SV *free_me)
11182 {
11183     dVAR;
11184     I32 namedclass = OOB_NAMEDCLASS;
11185
11186     PERL_ARGS_ASSERT_REGPPOSIXCC;
11187
11188     if (value == '[' && RExC_parse + 1 < RExC_end &&
11189         /* I smell either [: or [= or [. -- POSIX has been here, right? */
11190         POSIXCC(UCHARAT(RExC_parse))) {
11191         const char c = UCHARAT(RExC_parse);
11192         char* const s = RExC_parse++;
11193
11194         while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
11195             RExC_parse++;
11196         if (RExC_parse == RExC_end)
11197             /* Grandfather lone [:, [=, [. */
11198             RExC_parse = s;
11199         else {
11200             const char* const t = RExC_parse++; /* skip over the c */
11201             assert(*t == c);
11202
11203             if (UCHARAT(RExC_parse) == ']') {
11204                 const char *posixcc = s + 1;
11205                 RExC_parse++; /* skip over the ending ] */
11206
11207                 if (*s == ':') {
11208                     const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
11209                     const I32 skip = t - posixcc;
11210
11211                     /* Initially switch on the length of the name.  */
11212                     switch (skip) {
11213                     case 4:
11214                         if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
11215                             namedclass = ANYOF_WORDCHAR;
11216                         break;
11217                     case 5:
11218                         /* Names all of length 5.  */
11219                         /* alnum alpha ascii blank cntrl digit graph lower
11220                            print punct space upper  */
11221                         /* Offset 4 gives the best switch position.  */
11222                         switch (posixcc[4]) {
11223                         case 'a':
11224                             if (memEQ(posixcc, "alph", 4)) /* alpha */
11225                                 namedclass = ANYOF_ALPHA;
11226                             break;
11227                         case 'e':
11228                             if (memEQ(posixcc, "spac", 4)) /* space */
11229                                 namedclass = ANYOF_PSXSPC;
11230                             break;
11231                         case 'h':
11232                             if (memEQ(posixcc, "grap", 4)) /* graph */
11233                                 namedclass = ANYOF_GRAPH;
11234                             break;
11235                         case 'i':
11236                             if (memEQ(posixcc, "asci", 4)) /* ascii */
11237                                 namedclass = ANYOF_ASCII;
11238                             break;
11239                         case 'k':
11240                             if (memEQ(posixcc, "blan", 4)) /* blank */
11241                                 namedclass = ANYOF_BLANK;
11242                             break;
11243                         case 'l':
11244                             if (memEQ(posixcc, "cntr", 4)) /* cntrl */
11245                                 namedclass = ANYOF_CNTRL;
11246                             break;
11247                         case 'm':
11248                             if (memEQ(posixcc, "alnu", 4)) /* alnum */
11249                                 namedclass = ANYOF_ALNUMC;
11250                             break;
11251                         case 'r':
11252                             if (memEQ(posixcc, "lowe", 4)) /* lower */
11253                                 namedclass = ANYOF_LOWER;
11254                             else if (memEQ(posixcc, "uppe", 4)) /* upper */
11255                                 namedclass = ANYOF_UPPER;
11256                             break;
11257                         case 't':
11258                             if (memEQ(posixcc, "digi", 4)) /* digit */
11259                                 namedclass = ANYOF_DIGIT;
11260                             else if (memEQ(posixcc, "prin", 4)) /* print */
11261                                 namedclass = ANYOF_PRINT;
11262                             else if (memEQ(posixcc, "punc", 4)) /* punct */
11263                                 namedclass = ANYOF_PUNCT;
11264                             break;
11265                         }
11266                         break;
11267                     case 6:
11268                         if (memEQ(posixcc, "xdigit", 6))
11269                             namedclass = ANYOF_XDIGIT;
11270                         break;
11271                     }
11272
11273                     if (namedclass == OOB_NAMEDCLASS)
11274                         Simple_vFAIL3("POSIX class [:%.*s:] unknown",
11275                                       t - s - 1, s + 1);
11276
11277                     /* The #defines are structured so each complement is +1 to
11278                      * the normal one */
11279                     if (complement) {
11280                         namedclass++;
11281                     }
11282                     assert (posixcc[skip] == ':');
11283                     assert (posixcc[skip+1] == ']');
11284                 } else if (!SIZE_ONLY) {
11285                     /* [[=foo=]] and [[.foo.]] are still future. */
11286
11287                     /* adjust RExC_parse so the warning shows after
11288                        the class closes */
11289                     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
11290                         RExC_parse++;
11291                     SvREFCNT_dec(free_me);
11292                     vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
11293                 }
11294             } else {
11295                 /* Maternal grandfather:
11296                  * "[:" ending in ":" but not in ":]" */
11297                 RExC_parse = s;
11298             }
11299         }
11300     }
11301
11302     return namedclass;
11303 }
11304
11305 /* Generate the code to add a full posix character <class> to the bracketed
11306  * character class given by <node>.  (<node> is needed only under locale rules)
11307  * destlist     is the inversion list for non-locale rules that this class is
11308  *              to be added to
11309  * sourcelist   is the ASCII-range inversion list to add under /a rules
11310  * Xsourcelist  is the full Unicode range list to use otherwise. */
11311 #define DO_POSIX(node, class, destlist, sourcelist, Xsourcelist)           \
11312     if (LOC) {                                                             \
11313         SV* scratch_list = NULL;                                           \
11314                                                                            \
11315         /* Set this class in the node for runtime matching */              \
11316         ANYOF_CLASS_SET(node, class);                                      \
11317                                                                            \
11318         /* For above Latin1 code points, we use the full Unicode range */  \
11319         _invlist_intersection(PL_AboveLatin1,                              \
11320                               Xsourcelist,                                 \
11321                               &scratch_list);                              \
11322         /* And set the output to it, adding instead if there already is an \
11323          * output.  Checking if <destlist> is NULL first saves an extra    \
11324          * clone.  Its reference count will be decremented at the next     \
11325          * union, etc, or if this is the only instance, at the end of the  \
11326          * routine */                                                      \
11327         if (! destlist) {                                                  \
11328             destlist = scratch_list;                                       \
11329         }                                                                  \
11330         else {                                                             \
11331             _invlist_union(destlist, scratch_list, &destlist);             \
11332             SvREFCNT_dec(scratch_list);                                    \
11333         }                                                                  \
11334     }                                                                      \
11335     else {                                                                 \
11336         /* For non-locale, just add it to any existing list */             \
11337         _invlist_union(destlist,                                           \
11338                        (AT_LEAST_ASCII_RESTRICTED)                         \
11339                            ? sourcelist                                    \
11340                            : Xsourcelist,                                  \
11341                        &destlist);                                         \
11342     }
11343
11344 /* Like DO_POSIX, but matches the complement of <sourcelist> and <Xsourcelist>.
11345  */
11346 #define DO_N_POSIX(node, class, destlist, sourcelist, Xsourcelist)         \
11347     if (LOC) {                                                             \
11348         SV* scratch_list = NULL;                                           \
11349         ANYOF_CLASS_SET(node, class);                                      \
11350         _invlist_subtract(PL_AboveLatin1, Xsourcelist, &scratch_list);     \
11351         if (! destlist) {                                                  \
11352             destlist = scratch_list;                                       \
11353         }                                                                  \
11354         else {                                                             \
11355             _invlist_union(destlist, scratch_list, &destlist);             \
11356             SvREFCNT_dec(scratch_list);                                    \
11357         }                                                                  \
11358     }                                                                      \
11359     else {                                                                 \
11360         _invlist_union_complement_2nd(destlist,                            \
11361                                     (AT_LEAST_ASCII_RESTRICTED)            \
11362                                         ? sourcelist                       \
11363                                         : Xsourcelist,                     \
11364                                     &destlist);                            \
11365         /* Under /d, everything in the upper half of the Latin1 range      \
11366          * matches this complement */                                      \
11367         if (DEPENDS_SEMANTICS) {                                           \
11368             ANYOF_FLAGS(node) |= ANYOF_NON_UTF8_LATIN1_ALL;                \
11369         }                                                                  \
11370     }
11371
11372 /* Generate the code to add a posix character <class> to the bracketed
11373  * character class given by <node>.  (<node> is needed only under locale rules)
11374  * destlist       is the inversion list for non-locale rules that this class is
11375  *                to be added to
11376  * sourcelist     is the ASCII-range inversion list to add under /a rules
11377  * l1_sourcelist  is the Latin1 range list to use otherwise.
11378  * Xpropertyname  is the name to add to <run_time_list> of the property to
11379  *                specify the code points above Latin1 that will have to be
11380  *                determined at run-time
11381  * run_time_list  is a SV* that contains text names of properties that are to
11382  *                be computed at run time.  This concatenates <Xpropertyname>
11383  *                to it, appropriately
11384  * This is essentially DO_POSIX, but we know only the Latin1 values at compile
11385  * time */
11386 #define DO_POSIX_LATIN1_ONLY_KNOWN(node, class, destlist, sourcelist,      \
11387                               l1_sourcelist, Xpropertyname, run_time_list) \
11388         /* First, resolve whether to use the ASCII-only list or the L1     \
11389          * list */                                                         \
11390         DO_POSIX_LATIN1_ONLY_KNOWN_L1_RESOLVED(node, class, destlist,      \
11391                 ((AT_LEAST_ASCII_RESTRICTED) ? sourcelist : l1_sourcelist),\
11392                 Xpropertyname, run_time_list)
11393
11394 #define DO_POSIX_LATIN1_ONLY_KNOWN_L1_RESOLVED(node, class, destlist, sourcelist, \
11395                 Xpropertyname, run_time_list)                              \
11396     /* If not /a matching, there are going to be code points we will have  \
11397      * to defer to runtime to look-up */                                   \
11398     if (! AT_LEAST_ASCII_RESTRICTED) {                                     \
11399         Perl_sv_catpvf(aTHX_ run_time_list, "+utf8::%s\n", Xpropertyname); \
11400     }                                                                      \
11401     if (LOC) {                                                             \
11402         ANYOF_CLASS_SET(node, class);                                      \
11403     }                                                                      \
11404     else {                                                                 \
11405         _invlist_union(destlist, sourcelist, &destlist);                   \
11406     }
11407
11408 /* Like DO_POSIX_LATIN1_ONLY_KNOWN, but for the complement.  A combination of
11409  * this and DO_N_POSIX.  Sets <matches_above_unicode> only if it can; unchanged
11410  * otherwise */
11411 #define DO_N_POSIX_LATIN1_ONLY_KNOWN(node, class, destlist, sourcelist,    \
11412        l1_sourcelist, Xpropertyname, run_time_list, matches_above_unicode) \
11413     if (AT_LEAST_ASCII_RESTRICTED) {                                       \
11414         _invlist_union_complement_2nd(destlist, sourcelist, &destlist);    \
11415     }                                                                      \
11416     else {                                                                 \
11417         Perl_sv_catpvf(aTHX_ run_time_list, "!utf8::%s\n", Xpropertyname); \
11418         matches_above_unicode = TRUE;                                      \
11419         if (LOC) {                                                         \
11420             ANYOF_CLASS_SET(node, namedclass);                             \
11421         }                                                                  \
11422         else {                                                             \
11423             SV* scratch_list = NULL;                                       \
11424             _invlist_subtract(PL_Latin1, l1_sourcelist, &scratch_list);    \
11425             if (! destlist) {                                              \
11426                 destlist = scratch_list;                                   \
11427             }                                                              \
11428             else {                                                         \
11429                 _invlist_union(destlist, scratch_list, &destlist);         \
11430                 SvREFCNT_dec(scratch_list);                                \
11431             }                                                              \
11432             if (DEPENDS_SEMANTICS) {                                       \
11433                 ANYOF_FLAGS(node) |= ANYOF_NON_UTF8_LATIN1_ALL;            \
11434             }                                                              \
11435         }                                                                  \
11436     }
11437
11438 /* The names of properties whose definitions are not known at compile time are
11439  * stored in this SV, after a constant heading.  So if the length has been
11440  * changed since initialization, then there is a run-time definition. */
11441 #define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION (SvCUR(listsv) != initial_listsv_len)
11442
11443 /* This converts the named class defined in regcomp.h to its equivalent class
11444  * number defined in handy.h. */
11445 #define namedclass_to_classnum(class)  ((class) / 2)
11446
11447 STATIC regnode *
11448 S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
11449 {
11450     /* parse a bracketed class specification.  Most of these will produce an ANYOF node;
11451      * but something like [a] will produce an EXACT node; [aA], an EXACTFish
11452      * node; [[:ascii:]], a POSIXA node; etc.  It is more complex under /i with
11453      * multi-character folds: it will be rewritten following the paradigm of
11454      * this example, where the <multi-fold>s are characters which fold to
11455      * multiple character sequences:
11456      *      /[abc\x{multi-fold1}def\x{multi-fold2}ghi]/i
11457      * gets effectively rewritten as:
11458      *      /(?:\x{multi-fold1}|\x{multi-fold2}|[abcdefghi]/i
11459      * reg() gets called (recursively) on the rewritten version, and this
11460      * function will return what it constructs.  (Actually the <multi-fold>s
11461      * aren't physically removed from the [abcdefghi], it's just that they are
11462      * ignored in the recursion by means of a flag:
11463      * <RExC_in_multi_char_class>.)
11464      *
11465      * ANYOF nodes contain a bit map for the first 256 characters, with the
11466      * corresponding bit set if that character is in the list.  For characters
11467      * above 255, a range list or swash is used.  There are extra bits for \w,
11468      * etc. in locale ANYOFs, as what these match is not determinable at
11469      * compile time */
11470
11471     dVAR;
11472     UV nextvalue;
11473     UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE;
11474     IV range = 0;
11475     UV value = OOB_UNICODE, save_value = OOB_UNICODE;
11476     regnode *ret;
11477     STRLEN numlen;
11478     IV namedclass = OOB_NAMEDCLASS;
11479     char *rangebegin = NULL;
11480     bool need_class = 0;
11481     SV *listsv = NULL;
11482     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
11483                                       than just initialized.  */
11484     SV* properties = NULL;    /* Code points that match \p{} \P{} */
11485     SV* posixes = NULL;     /* Code points that match classes like, [:word:],
11486                                extended beyond the Latin1 range */
11487     UV element_count = 0;   /* Number of distinct elements in the class.
11488                                Optimizations may be possible if this is tiny */
11489     AV * multi_char_matches = NULL; /* Code points that fold to more than one
11490                                        character; used under /i */
11491     UV n;
11492
11493     /* Unicode properties are stored in a swash; this holds the current one
11494      * being parsed.  If this swash is the only above-latin1 component of the
11495      * character class, an optimization is to pass it directly on to the
11496      * execution engine.  Otherwise, it is set to NULL to indicate that there
11497      * are other things in the class that have to be dealt with at execution
11498      * time */
11499     SV* swash = NULL;           /* Code points that match \p{} \P{} */
11500
11501     /* Set if a component of this character class is user-defined; just passed
11502      * on to the engine */
11503     bool has_user_defined_property = FALSE;
11504
11505     /* inversion list of code points this node matches only when the target
11506      * string is in UTF-8.  (Because is under /d) */
11507     SV* depends_list = NULL;
11508
11509     /* inversion list of code points this node matches.  For much of the
11510      * function, it includes only those that match regardless of the utf8ness
11511      * of the target string */
11512     SV* cp_list = NULL;
11513
11514 #ifdef EBCDIC
11515     /* In a range, counts how many 0-2 of the ends of it came from literals,
11516      * not escapes.  Thus we can tell if 'A' was input vs \x{C1} */
11517     UV literal_endpoint = 0;
11518 #endif
11519     bool invert = FALSE;    /* Is this class to be complemented */
11520
11521     /* Is there any thing like \W or [:^digit:] that matches above the legal
11522      * Unicode range? */
11523     bool runtime_posix_matches_above_Unicode = FALSE;
11524
11525     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
11526         case we need to change the emitted regop to an EXACT. */
11527     const char * orig_parse = RExC_parse;
11528     const I32 orig_size = RExC_size;
11529     GET_RE_DEBUG_FLAGS_DECL;
11530
11531     PERL_ARGS_ASSERT_REGCLASS;
11532 #ifndef DEBUGGING
11533     PERL_UNUSED_ARG(depth);
11534 #endif
11535
11536     DEBUG_PARSE("clas");
11537
11538     /* Assume we are going to generate an ANYOF node. */
11539     ret = reganode(pRExC_state, ANYOF, 0);
11540
11541     if (!SIZE_ONLY) {
11542         ANYOF_FLAGS(ret) = 0;
11543     }
11544
11545     if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
11546         RExC_parse++;
11547         invert = TRUE;
11548         RExC_naughty++;
11549     }
11550
11551     if (SIZE_ONLY) {
11552         RExC_size += ANYOF_SKIP;
11553         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
11554     }
11555     else {
11556         RExC_emit += ANYOF_SKIP;
11557         if (LOC) {
11558             ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
11559         }
11560         listsv = newSVpvs("# comment\n");
11561         initial_listsv_len = SvCUR(listsv);
11562     }
11563
11564     nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
11565
11566     if (!SIZE_ONLY && POSIXCC(nextvalue))
11567     {
11568         const char *s = RExC_parse;
11569         const char  c = *s++;
11570
11571         while (isALNUM(*s))
11572             s++;
11573         if (*s && c == *s && s[1] == ']') {
11574             SAVEFREESV(RExC_rx_sv);
11575             SAVEFREESV(listsv);
11576             ckWARN3reg(s+2,
11577                        "POSIX syntax [%c %c] belongs inside character classes",
11578                        c, c);
11579             (void)ReREFCNT_inc(RExC_rx_sv);
11580             SvREFCNT_inc_simple_void_NN(listsv);
11581         }
11582     }
11583
11584     /* allow 1st char to be ] (allowing it to be - is dealt with later) */
11585     if (UCHARAT(RExC_parse) == ']')
11586         goto charclassloop;
11587
11588 parseit:
11589     while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
11590
11591     charclassloop:
11592
11593         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
11594         save_value = value;
11595         save_prevvalue = prevvalue;
11596
11597         if (!range) {
11598             rangebegin = RExC_parse;
11599             element_count++;
11600         }
11601         if (UTF) {
11602             value = utf8n_to_uvchr((U8*)RExC_parse,
11603                                    RExC_end - RExC_parse,
11604                                    &numlen, UTF8_ALLOW_DEFAULT);
11605             RExC_parse += numlen;
11606         }
11607         else
11608             value = UCHARAT(RExC_parse++);
11609
11610         nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
11611         if (value == '[' && POSIXCC(nextvalue))
11612             namedclass = regpposixcc(pRExC_state, value, listsv);
11613         else if (value == '\\') {
11614             if (UTF) {
11615                 value = utf8n_to_uvchr((U8*)RExC_parse,
11616                                    RExC_end - RExC_parse,
11617                                    &numlen, UTF8_ALLOW_DEFAULT);
11618                 RExC_parse += numlen;
11619             }
11620             else
11621                 value = UCHARAT(RExC_parse++);
11622             /* Some compilers cannot handle switching on 64-bit integer
11623              * values, therefore value cannot be an UV.  Yes, this will
11624              * be a problem later if we want switch on Unicode.
11625              * A similar issue a little bit later when switching on
11626              * namedclass. --jhi */
11627             switch ((I32)value) {
11628             case 'w':   namedclass = ANYOF_WORDCHAR;    break;
11629             case 'W':   namedclass = ANYOF_NWORDCHAR;   break;
11630             case 's':   namedclass = ANYOF_SPACE;       break;
11631             case 'S':   namedclass = ANYOF_NSPACE;      break;
11632             case 'd':   namedclass = ANYOF_DIGIT;       break;
11633             case 'D':   namedclass = ANYOF_NDIGIT;      break;
11634             case 'v':   namedclass = ANYOF_VERTWS;      break;
11635             case 'V':   namedclass = ANYOF_NVERTWS;     break;
11636             case 'h':   namedclass = ANYOF_HORIZWS;     break;
11637             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
11638             case 'N':  /* Handle \N{NAME} in class */
11639                 {
11640                     /* We only pay attention to the first char of 
11641                     multichar strings being returned. I kinda wonder
11642                     if this makes sense as it does change the behaviour
11643                     from earlier versions, OTOH that behaviour was broken
11644                     as well. */
11645                     if (! grok_bslash_N(pRExC_state, NULL, &value, flagp, depth,
11646                                       TRUE /* => charclass */))
11647                     {
11648                         goto parseit;
11649                     }
11650                 }
11651                 break;
11652             case 'p':
11653             case 'P':
11654                 {
11655                 char *e;
11656
11657                 /* This routine will handle any undefined properties */
11658                 U8 swash_init_flags = _CORE_SWASH_INIT_RETURN_IF_UNDEF;
11659
11660                 if (RExC_parse >= RExC_end)
11661                     vFAIL2("Empty \\%c{}", (U8)value);
11662                 if (*RExC_parse == '{') {
11663                     const U8 c = (U8)value;
11664                     e = strchr(RExC_parse++, '}');
11665                     if (!e)
11666                         vFAIL2("Missing right brace on \\%c{}", c);
11667                     while (isSPACE(UCHARAT(RExC_parse)))
11668                         RExC_parse++;
11669                     if (e == RExC_parse)
11670                         vFAIL2("Empty \\%c{}", c);
11671                     n = e - RExC_parse;
11672                     while (isSPACE(UCHARAT(RExC_parse + n - 1)))
11673                         n--;
11674                 }
11675                 else {
11676                     e = RExC_parse;
11677                     n = 1;
11678                 }
11679                 if (!SIZE_ONLY) {
11680                     SV* invlist;
11681                     char* name;
11682
11683                     if (UCHARAT(RExC_parse) == '^') {
11684                          RExC_parse++;
11685                          n--;
11686                          value = value == 'p' ? 'P' : 'p'; /* toggle */
11687                          while (isSPACE(UCHARAT(RExC_parse))) {
11688                               RExC_parse++;
11689                               n--;
11690                          }
11691                     }
11692                     /* Try to get the definition of the property into
11693                      * <invlist>.  If /i is in effect, the effective property
11694                      * will have its name be <__NAME_i>.  The design is
11695                      * discussed in commit
11696                      * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
11697                     Newx(name, n + sizeof("_i__\n"), char);
11698
11699                     sprintf(name, "%s%.*s%s\n",
11700                                     (FOLD) ? "__" : "",
11701                                     (int)n,
11702                                     RExC_parse,
11703                                     (FOLD) ? "_i" : ""
11704                     );
11705
11706                     /* Look up the property name, and get its swash and
11707                      * inversion list, if the property is found  */
11708                     if (swash) {
11709                         SvREFCNT_dec(swash);
11710                     }
11711                     swash = _core_swash_init("utf8", name, &PL_sv_undef,
11712                                              1, /* binary */
11713                                              0, /* not tr/// */
11714                                              NULL, /* No inversion list */
11715                                              &swash_init_flags
11716                                             );
11717                     if (! swash || ! (invlist = _get_swash_invlist(swash))) {
11718                         if (swash) {
11719                             SvREFCNT_dec(swash);
11720                             swash = NULL;
11721                         }
11722
11723                         /* Here didn't find it.  It could be a user-defined
11724                          * property that will be available at run-time.  Add it
11725                          * to the list to look up then */
11726                         Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s\n",
11727                                         (value == 'p' ? '+' : '!'),
11728                                         name);
11729                         has_user_defined_property = TRUE;
11730
11731                         /* We don't know yet, so have to assume that the
11732                          * property could match something in the Latin1 range,
11733                          * hence something that isn't utf8.  Note that this
11734                          * would cause things in <depends_list> to match
11735                          * inappropriately, except that any \p{}, including
11736                          * this one forces Unicode semantics, which means there
11737                          * is <no depends_list> */
11738                         ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
11739                     }
11740                     else {
11741
11742                         /* Here, did get the swash and its inversion list.  If
11743                          * the swash is from a user-defined property, then this
11744                          * whole character class should be regarded as such */
11745                         has_user_defined_property =
11746                                     (swash_init_flags
11747                                      & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY);
11748
11749                         /* Invert if asking for the complement */
11750                         if (value == 'P') {
11751                             _invlist_union_complement_2nd(properties,
11752                                                           invlist,
11753                                                           &properties);
11754
11755                             /* The swash can't be used as-is, because we've
11756                              * inverted things; delay removing it to here after
11757                              * have copied its invlist above */
11758                             SvREFCNT_dec(swash);
11759                             swash = NULL;
11760                         }
11761                         else {
11762                             _invlist_union(properties, invlist, &properties);
11763                         }
11764                     }
11765                     Safefree(name);
11766                 }
11767                 RExC_parse = e + 1;
11768                 namedclass = ANYOF_UNIPROP;  /* no official name, but it's named */
11769
11770                 /* \p means they want Unicode semantics */
11771                 RExC_uni_semantics = 1;
11772                 }
11773                 break;
11774             case 'n':   value = '\n';                   break;
11775             case 'r':   value = '\r';                   break;
11776             case 't':   value = '\t';                   break;
11777             case 'f':   value = '\f';                   break;
11778             case 'b':   value = '\b';                   break;
11779             case 'e':   value = ASCII_TO_NATIVE('\033');break;
11780             case 'a':   value = ASCII_TO_NATIVE('\007');break;
11781             case 'o':
11782                 RExC_parse--;   /* function expects to be pointed at the 'o' */
11783                 {
11784                     const char* error_msg;
11785                     bool valid = grok_bslash_o(RExC_parse,
11786                                                &value,
11787                                                &numlen,
11788                                                &error_msg,
11789                                                SIZE_ONLY);
11790                     RExC_parse += numlen;
11791                     if (! valid) {
11792                         vFAIL(error_msg);
11793                     }
11794                 }
11795                 if (PL_encoding && value < 0x100) {
11796                     goto recode_encoding;
11797                 }
11798                 break;
11799             case 'x':
11800                 RExC_parse--;   /* function expects to be pointed at the 'x' */
11801                 {
11802                     const char* error_msg;
11803                     bool valid = grok_bslash_x(RExC_parse,
11804                                                &value,
11805                                                &numlen,
11806                                                &error_msg,
11807                                                1);
11808                     RExC_parse += numlen;
11809                     if (! valid) {
11810                         vFAIL(error_msg);
11811                     }
11812                 }
11813                 if (PL_encoding && value < 0x100)
11814                     goto recode_encoding;
11815                 break;
11816             case 'c':
11817                 value = grok_bslash_c(*RExC_parse++, UTF, SIZE_ONLY);
11818                 break;
11819             case '0': case '1': case '2': case '3': case '4':
11820             case '5': case '6': case '7':
11821                 {
11822                     /* Take 1-3 octal digits */
11823                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
11824                     numlen = 3;
11825                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
11826                     RExC_parse += numlen;
11827                     if (PL_encoding && value < 0x100)
11828                         goto recode_encoding;
11829                     break;
11830                 }
11831             recode_encoding:
11832                 if (! RExC_override_recoding) {
11833                     SV* enc = PL_encoding;
11834                     value = reg_recode((const char)(U8)value, &enc);
11835                     if (!enc && SIZE_ONLY)
11836                         ckWARNreg(RExC_parse,
11837                                   "Invalid escape in the specified encoding");
11838                     break;
11839                 }
11840             default:
11841                 /* Allow \_ to not give an error */
11842                 if (!SIZE_ONLY && isALNUM(value) && value != '_') {
11843                     SAVEFREESV(RExC_rx_sv);
11844                     SAVEFREESV(listsv);
11845                     ckWARN2reg(RExC_parse,
11846                                "Unrecognized escape \\%c in character class passed through",
11847                                (int)value);
11848                     (void)ReREFCNT_inc(RExC_rx_sv);
11849                     SvREFCNT_inc_simple_void_NN(listsv);
11850                 }
11851                 break;
11852             }
11853         } /* end of \blah */
11854 #ifdef EBCDIC
11855         else
11856             literal_endpoint++;
11857 #endif
11858
11859             /* What matches in a locale is not known until runtime.  This
11860              * includes what the Posix classes (like \w, [:space:]) match.
11861              * Room must be reserved (one time per class) to store such
11862              * classes, either if Perl is compiled so that locale nodes always
11863              * should have this space, or if there is such class info to be
11864              * stored.  The space will contain a bit for each named class that
11865              * is to be matched against.  This isn't needed for \p{} and
11866              * pseudo-classes, as they are not affected by locale, and hence
11867              * are dealt with separately */
11868             if (LOC
11869                 && ! need_class
11870                 && (ANYOF_LOCALE == ANYOF_CLASS
11871                     || (namedclass > OOB_NAMEDCLASS && namedclass < ANYOF_MAX)))
11872             {
11873                 need_class = 1;
11874                 if (SIZE_ONLY) {
11875                     RExC_size += ANYOF_CLASS_SKIP - ANYOF_SKIP;
11876                 }
11877                 else {
11878                     RExC_emit += ANYOF_CLASS_SKIP - ANYOF_SKIP;
11879                     ANYOF_CLASS_ZERO(ret);
11880                 }
11881                 ANYOF_FLAGS(ret) |= ANYOF_CLASS;
11882             }
11883
11884         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
11885
11886             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
11887              * literal, as is the character that began the false range, i.e.
11888              * the 'a' in the examples */
11889             if (range) {
11890                 if (!SIZE_ONLY) {
11891                     const int w =
11892                         RExC_parse >= rangebegin ?
11893                         RExC_parse - rangebegin : 0;
11894                     SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
11895                     SAVEFREESV(listsv);
11896                     ckWARN4reg(RExC_parse,
11897                                "False [] range \"%*.*s\"",
11898                                w, w, rangebegin);
11899                     (void)ReREFCNT_inc(RExC_rx_sv);
11900                     SvREFCNT_inc_simple_void_NN(listsv);
11901                     cp_list = add_cp_to_invlist(cp_list, '-');
11902                     cp_list = add_cp_to_invlist(cp_list, prevvalue);
11903                 }
11904
11905                 range = 0; /* this was not a true range */
11906                 element_count += 2; /* So counts for three values */
11907             }
11908
11909             if (! SIZE_ONLY) {
11910                 switch ((I32)namedclass) {
11911
11912                 case ANYOF_ALNUMC: /* C's alnum, in contrast to \w */
11913                     DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
11914                         PL_PosixAlnum, PL_L1PosixAlnum, "XPosixAlnum", listsv);
11915                     break;
11916                 case ANYOF_NALNUMC:
11917                     DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
11918                         PL_PosixAlnum, PL_L1PosixAlnum, "XPosixAlnum", listsv,
11919                         runtime_posix_matches_above_Unicode);
11920                     break;
11921                 case ANYOF_ALPHA:
11922                     DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
11923                         PL_PosixAlpha, PL_L1PosixAlpha, "XPosixAlpha", listsv);
11924                     break;
11925                 case ANYOF_NALPHA:
11926                     DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
11927                         PL_PosixAlpha, PL_L1PosixAlpha, "XPosixAlpha", listsv,
11928                         runtime_posix_matches_above_Unicode);
11929                     break;
11930                 case ANYOF_ASCII:
11931 #ifdef HAS_ISASCII
11932                     if (LOC) {
11933                         ANYOF_CLASS_SET(ret, namedclass);
11934                     }
11935                     else
11936 #endif  /* Not isascii(); just use the hard-coded definition for it */
11937                         _invlist_union(posixes, PL_ASCII, &posixes);
11938                     break;
11939                 case ANYOF_NASCII:
11940 #ifdef HAS_ISASCII
11941                     if (LOC) {
11942                         ANYOF_CLASS_SET(ret, namedclass);
11943                     }
11944                     else {
11945 #endif
11946                         _invlist_union_complement_2nd(posixes,
11947                                                     PL_ASCII, &posixes);
11948                         if (DEPENDS_SEMANTICS) {
11949                             ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL;
11950                         }
11951 #ifdef HAS_ISASCII
11952                     }
11953 #endif
11954                     break;
11955                 case ANYOF_BLANK:
11956                     if (hasISBLANK || ! LOC) {
11957                         DO_POSIX(ret, namedclass, posixes,
11958                                             PL_PosixBlank, PL_XPosixBlank);
11959                     }
11960                     else { /* There is no isblank() and we are in locale:  We
11961                               use the ASCII range and the above-Latin1 range
11962                               code points */
11963                         SV* scratch_list = NULL;
11964
11965                         /* Include all above-Latin1 blanks */
11966                         _invlist_intersection(PL_AboveLatin1,
11967                                               PL_XPosixBlank,
11968                                               &scratch_list);
11969                         /* Add it to the running total of posix classes */
11970                         if (! posixes) {
11971                             posixes = scratch_list;
11972                         }
11973                         else {
11974                             _invlist_union(posixes, scratch_list, &posixes);
11975                             SvREFCNT_dec(scratch_list);
11976                         }
11977                         /* Add the ASCII-range blanks to the running total. */
11978                         _invlist_union(posixes, PL_PosixBlank, &posixes);
11979                     }
11980                     break;
11981                 case ANYOF_NBLANK:
11982                     if (hasISBLANK || ! LOC) {
11983                         DO_N_POSIX(ret, namedclass, posixes,
11984                                                 PL_PosixBlank, PL_XPosixBlank);
11985                     }
11986                     else { /* There is no isblank() and we are in locale */
11987                         SV* scratch_list = NULL;
11988
11989                         /* Include all above-Latin1 non-blanks */
11990                         _invlist_subtract(PL_AboveLatin1, PL_XPosixBlank,
11991                                           &scratch_list);
11992
11993                         /* Add them to the running total of posix classes */
11994                         _invlist_subtract(PL_AboveLatin1, PL_XPosixBlank,
11995                                           &scratch_list);
11996                         if (! posixes) {
11997                             posixes = scratch_list;
11998                         }
11999                         else {
12000                             _invlist_union(posixes, scratch_list, &posixes);
12001                             SvREFCNT_dec(scratch_list);
12002                         }
12003
12004                         /* Get the list of all non-ASCII-blanks in Latin 1, and
12005                          * add them to the running total */
12006                         _invlist_subtract(PL_Latin1, PL_PosixBlank,
12007                                           &scratch_list);
12008                         _invlist_union(posixes, scratch_list, &posixes);
12009                         SvREFCNT_dec(scratch_list);
12010                     }
12011                     break;
12012                 case ANYOF_CNTRL:
12013                     DO_POSIX(ret, namedclass, posixes,
12014                                             PL_PosixCntrl, PL_XPosixCntrl);
12015                     break;
12016                 case ANYOF_NCNTRL:
12017                     DO_N_POSIX(ret, namedclass, posixes,
12018                                             PL_PosixCntrl, PL_XPosixCntrl);
12019                     break;
12020                 case ANYOF_DIGIT:
12021                     /* There are no digits in the Latin1 range outside of
12022                      * ASCII, so call the macro that doesn't have to resolve
12023                      * them */
12024                     DO_POSIX_LATIN1_ONLY_KNOWN_L1_RESOLVED(ret, namedclass, posixes,
12025                         PL_PosixDigit, "XPosixDigit", listsv);
12026                     break;
12027                 case ANYOF_NDIGIT:
12028                     DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
12029                         PL_PosixDigit, PL_PosixDigit, "XPosixDigit", listsv,
12030                         runtime_posix_matches_above_Unicode);
12031                     break;
12032                 case ANYOF_GRAPH:
12033                     DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
12034                         PL_PosixGraph, PL_L1PosixGraph, "XPosixGraph", listsv);
12035                     break;
12036                 case ANYOF_NGRAPH:
12037                     DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
12038                         PL_PosixGraph, PL_L1PosixGraph, "XPosixGraph", listsv,
12039                         runtime_posix_matches_above_Unicode);
12040                     break;
12041                 case ANYOF_HORIZWS:
12042                     /* For these, we use the cp_list, as /d doesn't make a
12043                      * difference in what these match.  There would be problems
12044                      * if these characters had folds other than themselves, as
12045                      * cp_list is subject to folding.  It turns out that \h
12046                      * is just a synonym for XPosixBlank */
12047                     _invlist_union(cp_list, PL_XPosixBlank, &cp_list);
12048                     break;
12049                 case ANYOF_NHORIZWS:
12050                     _invlist_union_complement_2nd(cp_list,
12051                                                  PL_XPosixBlank, &cp_list);
12052                     break;
12053                 case ANYOF_LOWER:
12054                 case ANYOF_NLOWER:
12055                 {   /* These require special handling, as they differ under
12056                        folding, matching Cased there (which in the ASCII range
12057                        is the same as Alpha */
12058
12059                     SV* ascii_source;
12060                     SV* l1_source;
12061                     const char *Xname;
12062
12063                     if (FOLD && ! LOC) {
12064                         ascii_source = PL_PosixAlpha;
12065                         l1_source = PL_L1Cased;
12066                         Xname = "Cased";
12067                     }
12068                     else {
12069                         ascii_source = PL_PosixLower;
12070                         l1_source = PL_L1PosixLower;
12071                         Xname = "XPosixLower";
12072                     }
12073                     if (namedclass == ANYOF_LOWER) {
12074                         DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
12075                                     ascii_source, l1_source, Xname, listsv);
12076                     }
12077                     else {
12078                         DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass,
12079                             posixes, ascii_source, l1_source, Xname, listsv,
12080                             runtime_posix_matches_above_Unicode);
12081                     }
12082                     break;
12083                 }
12084                 case ANYOF_PRINT:
12085                     DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
12086                         PL_PosixPrint, PL_L1PosixPrint, "XPosixPrint", listsv);
12087                     break;
12088                 case ANYOF_NPRINT:
12089                     DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
12090                         PL_PosixPrint, PL_L1PosixPrint, "XPosixPrint", listsv,
12091                         runtime_posix_matches_above_Unicode);
12092                     break;
12093                 case ANYOF_PUNCT:
12094                     DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
12095                         PL_PosixPunct, PL_L1PosixPunct, "XPosixPunct", listsv);
12096                     break;
12097                 case ANYOF_NPUNCT:
12098                     DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
12099                         PL_PosixPunct, PL_L1PosixPunct, "XPosixPunct", listsv,
12100                         runtime_posix_matches_above_Unicode);
12101                     break;
12102                 case ANYOF_PSXSPC:
12103                     DO_POSIX(ret, namedclass, posixes,
12104                                             PL_PosixSpace, PL_XPosixSpace);
12105                     break;
12106                 case ANYOF_NPSXSPC:
12107                     DO_N_POSIX(ret, namedclass, posixes,
12108                                             PL_PosixSpace, PL_XPosixSpace);
12109                     break;
12110                 case ANYOF_SPACE:
12111                     DO_POSIX(ret, namedclass, posixes,
12112                                             PL_PerlSpace, PL_XPerlSpace);
12113                     break;
12114                 case ANYOF_NSPACE:
12115                     DO_N_POSIX(ret, namedclass, posixes,
12116                                             PL_PerlSpace, PL_XPerlSpace);
12117                     break;
12118                 case ANYOF_UPPER:   /* Same as LOWER, above */
12119                 case ANYOF_NUPPER:
12120                 {
12121                     SV* ascii_source;
12122                     SV* l1_source;
12123                     const char *Xname;
12124
12125                     if (FOLD && ! LOC) {
12126                         ascii_source = PL_PosixAlpha;
12127                         l1_source = PL_L1Cased;
12128                         Xname = "Cased";
12129                     }
12130                     else {
12131                         ascii_source = PL_PosixUpper;
12132                         l1_source = PL_L1PosixUpper;
12133                         Xname = "XPosixUpper";
12134                     }
12135                     if (namedclass == ANYOF_UPPER) {
12136                         DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
12137                                     ascii_source, l1_source, Xname, listsv);
12138                     }
12139                     else {
12140                         DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass,
12141                         posixes, ascii_source, l1_source, Xname, listsv,
12142                         runtime_posix_matches_above_Unicode);
12143                     }
12144                     break;
12145                 }
12146                 case ANYOF_WORDCHAR:
12147                     DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
12148                             PL_PosixWord, PL_L1PosixWord, "XPosixWord", listsv);
12149                     break;
12150                 case ANYOF_NWORDCHAR:
12151                     DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
12152                             PL_PosixWord, PL_L1PosixWord, "XPosixWord", listsv,
12153                             runtime_posix_matches_above_Unicode);
12154                     break;
12155                 case ANYOF_VERTWS:
12156                     /* For these, we use the cp_list, as /d doesn't make a
12157                      * difference in what these match.  There would be problems
12158                      * if these characters had folds other than themselves, as
12159                      * cp_list is subject to folding */
12160                     _invlist_union(cp_list, PL_VertSpace, &cp_list);
12161                     break;
12162                 case ANYOF_NVERTWS:
12163                     _invlist_union_complement_2nd(cp_list,
12164                                                     PL_VertSpace, &cp_list);
12165                     break;
12166                 case ANYOF_XDIGIT:
12167                     DO_POSIX(ret, namedclass, posixes,
12168                                             PL_PosixXDigit, PL_XPosixXDigit);
12169                     break;
12170                 case ANYOF_NXDIGIT:
12171                     DO_N_POSIX(ret, namedclass, posixes,
12172                                             PL_PosixXDigit, PL_XPosixXDigit);
12173                     break;
12174                 case ANYOF_UNIPROP: /* this is to handle \p and \P */
12175                     break;
12176                 default:
12177                     vFAIL("Invalid [::] class");
12178                     break;
12179                 }
12180
12181                 continue;   /* Go get next character */
12182             }
12183         } /* end of namedclass \blah */
12184
12185         if (range) {
12186             if (prevvalue > value) /* b-a */ {
12187                 const int w = RExC_parse - rangebegin;
12188                 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
12189                 range = 0; /* not a valid range */
12190             }
12191         }
12192         else {
12193             prevvalue = value; /* save the beginning of the potential range */
12194             if (RExC_parse+1 < RExC_end
12195                 && *RExC_parse == '-'
12196                 && RExC_parse[1] != ']')
12197             {
12198                 RExC_parse++;
12199
12200                 /* a bad range like \w-, [:word:]- ? */
12201                 if (namedclass > OOB_NAMEDCLASS) {
12202                     if (ckWARN(WARN_REGEXP)) {
12203                         const int w =
12204                             RExC_parse >= rangebegin ?
12205                             RExC_parse - rangebegin : 0;
12206                         vWARN4(RExC_parse,
12207                                "False [] range \"%*.*s\"",
12208                                w, w, rangebegin);
12209                     }
12210                     if (!SIZE_ONLY) {
12211                         cp_list = add_cp_to_invlist(cp_list, '-');
12212                     }
12213                     element_count++;
12214                 } else
12215                     range = 1;  /* yeah, it's a range! */
12216                 continue;       /* but do it the next time */
12217             }
12218         }
12219
12220         /* Here, <prevvalue> is the beginning of the range, if any; or <value>
12221          * if not */
12222
12223         /* non-Latin1 code point implies unicode semantics.  Must be set in
12224          * pass1 so is there for the whole of pass 2 */
12225         if (value > 255) {
12226             RExC_uni_semantics = 1;
12227         }
12228
12229         /* Ready to process either the single value, or the completed range.
12230          * For single-valued non-inverted ranges, we consider the possibility
12231          * of multi-char folds.  (We made a conscious decision to not do this
12232          * for the other cases because it can often lead to non-intuitive
12233          * results.  For example, you have the peculiar case that:
12234          *  "s s" =~ /^[^\xDF]+$/i => Y
12235          *  "ss"  =~ /^[^\xDF]+$/i => N
12236          *
12237          * See [perl #89750] */
12238         if (FOLD && ! invert && value == prevvalue) {
12239             if (value == LATIN_SMALL_LETTER_SHARP_S
12240                 || (value > 255 && _invlist_contains_cp(PL_HasMultiCharFold,
12241                                                         value)))
12242             {
12243                 /* Here <value> is indeed a multi-char fold.  Get what it is */
12244
12245                 U8 foldbuf[UTF8_MAXBYTES_CASE];
12246                 STRLEN foldlen;
12247
12248                 UV folded = _to_uni_fold_flags(
12249                                 value,
12250                                 foldbuf,
12251                                 &foldlen,
12252                                 FOLD_FLAGS_FULL
12253                                 | ((LOC) ?  FOLD_FLAGS_LOCALE
12254                                             : (ASCII_FOLD_RESTRICTED)
12255                                               ? FOLD_FLAGS_NOMIX_ASCII
12256                                               : 0)
12257                                 );
12258
12259                 /* Here, <folded> should be the first character of the
12260                  * multi-char fold of <value>, with <foldbuf> containing the
12261                  * whole thing.  But, if this fold is not allowed (because of
12262                  * the flags), <fold> will be the same as <value>, and should
12263                  * be processed like any other character, so skip the special
12264                  * handling */
12265                 if (folded != value) {
12266
12267                     /* Skip if we are recursed, currently parsing the class
12268                      * again.  Otherwise add this character to the list of
12269                      * multi-char folds. */
12270                     if (! RExC_in_multi_char_class) {
12271                         AV** this_array_ptr;
12272                         AV* this_array;
12273                         STRLEN cp_count = utf8_length(foldbuf,
12274                                                       foldbuf + foldlen);
12275                         SV* multi_fold = sv_2mortal(newSVpvn("", 0));
12276
12277                         Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%"UVXf"}", value);
12278
12279
12280                         if (! multi_char_matches) {
12281                             multi_char_matches = newAV();
12282                         }
12283
12284                         /* <multi_char_matches> is actually an array of arrays.
12285                          * There will be one or two top-level elements: [2],
12286                          * and/or [3].  The [2] element is an array, each
12287                          * element thereof is a character which folds to two
12288                          * characters; likewise for [3].  (Unicode guarantees a
12289                          * maximum of 3 characters in any fold.)  When we
12290                          * rewrite the character class below, we will do so
12291                          * such that the longest folds are written first, so
12292                          * that it prefers the longest matching strings first.
12293                          * This is done even if it turns out that any
12294                          * quantifier is non-greedy, out of programmer
12295                          * laziness.  Tom Christiansen has agreed that this is
12296                          * ok.  This makes the test for the ligature 'ffi' come
12297                          * before the test for 'ff' */
12298                         if (av_exists(multi_char_matches, cp_count)) {
12299                             this_array_ptr = (AV**) av_fetch(multi_char_matches,
12300                                                              cp_count, FALSE);
12301                             this_array = *this_array_ptr;
12302                         }
12303                         else {
12304                             this_array = newAV();
12305                             av_store(multi_char_matches, cp_count,
12306                                      (SV*) this_array);
12307                         }
12308                         av_push(this_array, multi_fold);
12309                     }
12310
12311                     /* This element should not be processed further in this
12312                      * class */
12313                     element_count--;
12314                     value = save_value;
12315                     prevvalue = save_prevvalue;
12316                     continue;
12317                 }
12318             }
12319         }
12320
12321         /* Deal with this element of the class */
12322         if (! SIZE_ONLY) {
12323 #ifndef EBCDIC
12324             cp_list = _add_range_to_invlist(cp_list, prevvalue, value);
12325 #else
12326             UV* this_range = _new_invlist(1);
12327             _append_range_to_invlist(this_range, prevvalue, value);
12328
12329             /* In EBCDIC, the ranges 'A-Z' and 'a-z' are each not contiguous.
12330              * If this range was specified using something like 'i-j', we want
12331              * to include only the 'i' and the 'j', and not anything in
12332              * between, so exclude non-ASCII, non-alphabetics from it.
12333              * However, if the range was specified with something like
12334              * [\x89-\x91] or [\x89-j], all code points within it should be
12335              * included.  literal_endpoint==2 means both ends of the range used
12336              * a literal character, not \x{foo} */
12337             if (literal_endpoint == 2
12338                 && (prevvalue >= 'a' && value <= 'z')
12339                     || (prevvalue >= 'A' && value <= 'Z'))
12340             {
12341                 _invlist_intersection(this_range, PL_ASCII, &this_range, );
12342                 _invlist_intersection(this_range, PL_Alpha, &this_range, );
12343             }
12344             _invlist_union(cp_list, this_range, &cp_list);
12345             literal_endpoint = 0;
12346 #endif
12347         }
12348
12349         range = 0; /* this range (if it was one) is done now */
12350     } /* End of loop through all the text within the brackets */
12351
12352     /* If anything in the class expands to more than one character, we have to
12353      * deal with them by building up a substitute parse string, and recursively
12354      * calling reg() on it, instead of proceeding */
12355     if (multi_char_matches) {
12356         SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
12357         I32 cp_count;
12358         STRLEN len;
12359         char *save_end = RExC_end;
12360         char *save_parse = RExC_parse;
12361         bool first_time = TRUE;     /* First multi-char occurrence doesn't get
12362                                        a "|" */
12363         I32 reg_flags;
12364
12365         assert(! invert);
12366 #if 0   /* Have decided not to deal with multi-char folds in inverted classes,
12367            because too confusing */
12368         if (invert) {
12369             sv_catpv(substitute_parse, "(?:");
12370         }
12371 #endif
12372
12373         /* Look at the longest folds first */
12374         for (cp_count = av_len(multi_char_matches); cp_count > 0; cp_count--) {
12375
12376             if (av_exists(multi_char_matches, cp_count)) {
12377                 AV** this_array_ptr;
12378                 SV* this_sequence;
12379
12380                 this_array_ptr = (AV**) av_fetch(multi_char_matches,
12381                                                  cp_count, FALSE);
12382                 while ((this_sequence = av_pop(*this_array_ptr)) !=
12383                                                                 &PL_sv_undef)
12384                 {
12385                     if (! first_time) {
12386                         sv_catpv(substitute_parse, "|");
12387                     }
12388                     first_time = FALSE;
12389
12390                     sv_catpv(substitute_parse, SvPVX(this_sequence));
12391                 }
12392             }
12393         }
12394
12395         /* If the character class contains anything else besides these
12396          * multi-character folds, have to include it in recursive parsing */
12397         if (element_count) {
12398             sv_catpv(substitute_parse, "|[");
12399             sv_catpvn(substitute_parse, orig_parse, RExC_parse - orig_parse);
12400             sv_catpv(substitute_parse, "]");
12401         }
12402
12403         sv_catpv(substitute_parse, ")");
12404 #if 0
12405         if (invert) {
12406             /* This is a way to get the parse to skip forward a whole named
12407              * sequence instead of matching the 2nd character when it fails the
12408              * first */
12409             sv_catpv(substitute_parse, "(*THEN)(*SKIP)(*FAIL)|.)");
12410         }
12411 #endif
12412
12413         RExC_parse = SvPV(substitute_parse, len);
12414         RExC_end = RExC_parse + len;
12415         RExC_in_multi_char_class = 1;
12416         RExC_emit = (regnode *)orig_emit;
12417
12418         ret = reg(pRExC_state, 1, &reg_flags, depth+1);
12419
12420         *flagp |= reg_flags&(HASWIDTH|SIMPLE|SPSTART|POSTPONED);
12421
12422         RExC_parse = save_parse;
12423         RExC_end = save_end;
12424         RExC_in_multi_char_class = 0;
12425         SvREFCNT_dec(multi_char_matches);
12426         SvREFCNT_dec(listsv);
12427         return ret;
12428     }
12429
12430     /* If the character class contains only a single element, it may be
12431      * optimizable into another node type which is smaller and runs faster.
12432      * Check if this is the case for this class */
12433     if (element_count == 1) {
12434         U8 op = END;
12435         U8 arg = 0;
12436
12437         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class, like \w or
12438                                               [:digit:] or \p{foo} */
12439
12440             /* Certain named classes have equivalents that can appear outside a
12441              * character class, e.g. \w, \H.  We use these instead of a
12442              * character class. */
12443             switch ((I32)namedclass) {
12444                 U8 offset;
12445
12446                 /* The first group is for node types that depend on the charset
12447                  * modifier to the regex.  We first calculate the base node
12448                  * type, and if it should be inverted */
12449
12450                 case ANYOF_NWORDCHAR:
12451                     invert = ! invert;
12452                     /* FALLTHROUGH */
12453                 case ANYOF_WORDCHAR:
12454                     op = ALNUM;
12455                     goto join_charset_classes;
12456
12457                 case ANYOF_NSPACE:
12458                     invert = ! invert;
12459                     /* FALLTHROUGH */
12460                 case ANYOF_SPACE:
12461                     op = SPACE;
12462                     goto join_charset_classes;
12463
12464                 case ANYOF_NDIGIT:
12465                     invert = ! invert;
12466                     /* FALLTHROUGH */
12467                 case ANYOF_DIGIT:
12468                     op = DIGIT;
12469
12470                   join_charset_classes:
12471
12472                     /* Now that we have the base node type, we take advantage
12473                      * of the enum ordering of the charset modifiers to get the
12474                      * exact node type,  For example the base SPACE also has
12475                      * SPACEL, SPACEU, and SPACEA */
12476
12477                     offset = get_regex_charset(RExC_flags);
12478
12479                     /* /aa is the same as /a for these */
12480                     if (offset == REGEX_ASCII_MORE_RESTRICTED_CHARSET) {
12481                         offset = REGEX_ASCII_RESTRICTED_CHARSET;
12482                     }
12483                     else if (op == DIGIT && offset == REGEX_UNICODE_CHARSET) {
12484                         offset = REGEX_DEPENDS_CHARSET; /* There is no DIGITU */
12485                     }
12486
12487                     op += offset;
12488
12489                     /* The number of varieties of each of these is the same,
12490                      * hence, so is the delta between the normal and
12491                      * complemented nodes */
12492                     if (invert) {
12493                         op += NALNUM - ALNUM;
12494                     }
12495                     *flagp |= HASWIDTH|SIMPLE;
12496                     break;
12497
12498                 /* The second group doesn't depend of the charset modifiers.
12499                  * We just have normal and complemented */
12500                 case ANYOF_NHORIZWS:
12501                     invert = ! invert;
12502                     /* FALLTHROUGH */
12503                 case ANYOF_HORIZWS:
12504                   is_horizws:
12505                     op = (invert) ? NHORIZWS : HORIZWS;
12506                     *flagp |= HASWIDTH|SIMPLE;
12507                     break;
12508
12509                 case ANYOF_NVERTWS:
12510                     invert = ! invert;
12511                     /* FALLTHROUGH */
12512                 case ANYOF_VERTWS:
12513                     op = (invert) ? NVERTWS : VERTWS;
12514                     *flagp |= HASWIDTH|SIMPLE;
12515                     break;
12516
12517                 case ANYOF_UNIPROP:
12518                     break;
12519
12520                 case ANYOF_NBLANK:
12521                     invert = ! invert;
12522                     /* FALLTHROUGH */
12523                 case ANYOF_BLANK:
12524                     if (AT_LEAST_UNI_SEMANTICS && ! AT_LEAST_ASCII_RESTRICTED) {
12525                         goto is_horizws;
12526                     }
12527                     /* FALLTHROUGH */
12528                 default:
12529                     /* A generic posix class.  All the /a ones can be handled
12530                      * by the POSIXA opcode.  And all are closed under folding
12531                      * in the ASCII range, so FOLD doesn't matter */
12532                     if (AT_LEAST_ASCII_RESTRICTED
12533                         || (! LOC && namedclass == ANYOF_ASCII))
12534                     {
12535                         /* The odd numbered ones are the complements of the
12536                          * next-lower even number one */
12537                         if (namedclass % 2 == 1) {
12538                             invert = ! invert;
12539                             namedclass--;
12540                         }
12541                         arg = namedclass_to_classnum(namedclass);
12542                         op = (invert) ? NPOSIXA : POSIXA;
12543                     }
12544                     break;
12545             }
12546         }
12547         else if (value == prevvalue) {
12548
12549             /* Here, the class consists of just a single code point */
12550
12551             if (invert) {
12552                 if (! LOC && value == '\n') {
12553                     op = REG_ANY; /* Optimize [^\n] */
12554                     *flagp |= HASWIDTH|SIMPLE;
12555                     RExC_naughty++;
12556                 }
12557             }
12558             else if (value < 256 || UTF) {
12559
12560                 /* Optimize a single value into an EXACTish node, but not if it
12561                  * would require converting the pattern to UTF-8. */
12562                 op = compute_EXACTish(pRExC_state);
12563             }
12564         } /* Otherwise is a range */
12565         else if (! LOC) {   /* locale could vary these */
12566             if (prevvalue == '0') {
12567                 if (value == '9') {
12568                     op = (invert) ? NDIGITA : DIGITA;
12569                     *flagp |= HASWIDTH|SIMPLE;
12570                 }
12571             }
12572         }
12573
12574         /* Here, we have changed <op> away from its initial value iff we found
12575          * an optimization */
12576         if (op != END) {
12577
12578             /* Throw away this ANYOF regnode, and emit the calculated one,
12579              * which should correspond to the beginning, not current, state of
12580              * the parse */
12581             const char * cur_parse = RExC_parse;
12582             RExC_parse = (char *)orig_parse;
12583             if ( SIZE_ONLY) {
12584                 if (! LOC) {
12585
12586                     /* To get locale nodes to not use the full ANYOF size would
12587                      * require moving the code above that writes the portions
12588                      * of it that aren't in other nodes to after this point.
12589                      * e.g.  ANYOF_CLASS_SET */
12590                     RExC_size = orig_size;
12591                 }
12592             }
12593             else {
12594                 RExC_emit = (regnode *)orig_emit;
12595             }
12596
12597             ret = reg_node(pRExC_state, op);
12598
12599             if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
12600                 if (! SIZE_ONLY) {
12601                     FLAGS(ret) = arg;
12602                 }
12603                 *flagp |= HASWIDTH|SIMPLE;
12604             }
12605             else if (PL_regkind[op] == EXACT) {
12606                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value);
12607             }
12608
12609             RExC_parse = (char *) cur_parse;
12610
12611             SvREFCNT_dec(posixes);
12612             SvREFCNT_dec(listsv);
12613             SvREFCNT_dec(cp_list);
12614             return ret;
12615         }
12616     }
12617
12618     if (SIZE_ONLY)
12619         return ret;
12620     /****** !SIZE_ONLY (Pass 2) AFTER HERE *********/
12621
12622     /* If folding, we calculate all characters that could fold to or from the
12623      * ones already on the list */
12624     if (FOLD && cp_list) {
12625         UV start, end;  /* End points of code point ranges */
12626
12627         SV* fold_intersection = NULL;
12628
12629         /* If the highest code point is within Latin1, we can use the
12630          * compiled-in Alphas list, and not have to go out to disk.  This
12631          * yields two false positives, the masculine and feminine ordinal
12632          * indicators, which are weeded out below using the
12633          * IS_IN_SOME_FOLD_L1() macro */
12634         if (invlist_highest(cp_list) < 256) {
12635             _invlist_intersection(PL_L1PosixAlpha, cp_list, &fold_intersection);
12636         }
12637         else {
12638
12639             /* Here, there are non-Latin1 code points, so we will have to go
12640              * fetch the list of all the characters that participate in folds
12641              */
12642             if (! PL_utf8_foldable) {
12643                 SV* swash = swash_init("utf8", "_Perl_Any_Folds",
12644                                        &PL_sv_undef, 1, 0);
12645                 PL_utf8_foldable = _get_swash_invlist(swash);
12646                 SvREFCNT_dec(swash);
12647             }
12648
12649             /* This is a hash that for a particular fold gives all characters
12650              * that are involved in it */
12651             if (! PL_utf8_foldclosures) {
12652
12653                 /* If we were unable to find any folds, then we likely won't be
12654                  * able to find the closures.  So just create an empty list.
12655                  * Folding will effectively be restricted to the non-Unicode
12656                  * rules hard-coded into Perl.  (This case happens legitimately
12657                  * during compilation of Perl itself before the Unicode tables
12658                  * are generated) */
12659                 if (_invlist_len(PL_utf8_foldable) == 0) {
12660                     PL_utf8_foldclosures = newHV();
12661                 }
12662                 else {
12663                     /* If the folds haven't been read in, call a fold function
12664                      * to force that */
12665                     if (! PL_utf8_tofold) {
12666                         U8 dummy[UTF8_MAXBYTES+1];
12667
12668                         /* This string is just a short named one above \xff */
12669                         to_utf8_fold((U8*) HYPHEN_UTF8, dummy, NULL);
12670                         assert(PL_utf8_tofold); /* Verify that worked */
12671                     }
12672                     PL_utf8_foldclosures =
12673                                     _swash_inversion_hash(PL_utf8_tofold);
12674                 }
12675             }
12676
12677             /* Only the characters in this class that participate in folds need
12678              * be checked.  Get the intersection of this class and all the
12679              * possible characters that are foldable.  This can quickly narrow
12680              * down a large class */
12681             _invlist_intersection(PL_utf8_foldable, cp_list,
12682                                   &fold_intersection);
12683         }
12684
12685         /* Now look at the foldable characters in this class individually */
12686         invlist_iterinit(fold_intersection);
12687         while (invlist_iternext(fold_intersection, &start, &end)) {
12688             UV j;
12689
12690             /* Locale folding for Latin1 characters is deferred until runtime */
12691             if (LOC && start < 256) {
12692                 start = 256;
12693             }
12694
12695             /* Look at every character in the range */
12696             for (j = start; j <= end; j++) {
12697
12698                 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
12699                 STRLEN foldlen;
12700                 SV** listp;
12701
12702                 if (j < 256) {
12703
12704                     /* We have the latin1 folding rules hard-coded here so that
12705                      * an innocent-looking character class, like /[ks]/i won't
12706                      * have to go out to disk to find the possible matches.
12707                      * XXX It would be better to generate these via regen, in
12708                      * case a new version of the Unicode standard adds new
12709                      * mappings, though that is not really likely, and may be
12710                      * caught by the default: case of the switch below. */
12711
12712                     if (IS_IN_SOME_FOLD_L1(j)) {
12713
12714                         /* ASCII is always matched; non-ASCII is matched only
12715                          * under Unicode rules */
12716                         if (isASCII(j) || AT_LEAST_UNI_SEMANTICS) {
12717                             cp_list =
12718                                 add_cp_to_invlist(cp_list, PL_fold_latin1[j]);
12719                         }
12720                         else {
12721                             depends_list =
12722                              add_cp_to_invlist(depends_list, PL_fold_latin1[j]);
12723                         }
12724                     }
12725
12726                     if (HAS_NONLATIN1_FOLD_CLOSURE(j)
12727                         && (! isASCII(j) || ! ASCII_FOLD_RESTRICTED))
12728                     {
12729                         /* Certain Latin1 characters have matches outside
12730                          * Latin1.  To get here, <j> is one of those
12731                          * characters.   None of these matches is valid for
12732                          * ASCII characters under /aa, which is why the 'if'
12733                          * just above excludes those.  These matches only
12734                          * happen when the target string is utf8.  The code
12735                          * below adds the single fold closures for <j> to the
12736                          * inversion list. */
12737                         switch (j) {
12738                             case 'k':
12739                             case 'K':
12740                                 cp_list =
12741                                     add_cp_to_invlist(cp_list, KELVIN_SIGN);
12742                                 break;
12743                             case 's':
12744                             case 'S':
12745                                 cp_list = add_cp_to_invlist(cp_list,
12746                                                     LATIN_SMALL_LETTER_LONG_S);
12747                                 break;
12748                             case MICRO_SIGN:
12749                                 cp_list = add_cp_to_invlist(cp_list,
12750                                                     GREEK_CAPITAL_LETTER_MU);
12751                                 cp_list = add_cp_to_invlist(cp_list,
12752                                                     GREEK_SMALL_LETTER_MU);
12753                                 break;
12754                             case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
12755                             case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
12756                                 cp_list =
12757                                     add_cp_to_invlist(cp_list, ANGSTROM_SIGN);
12758                                 break;
12759                             case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
12760                                 cp_list = add_cp_to_invlist(cp_list,
12761                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
12762                                 break;
12763                             case LATIN_SMALL_LETTER_SHARP_S:
12764                                 cp_list = add_cp_to_invlist(cp_list,
12765                                                 LATIN_CAPITAL_LETTER_SHARP_S);
12766                                 break;
12767                             case 'F': case 'f':
12768                             case 'I': case 'i':
12769                             case 'L': case 'l':
12770                             case 'T': case 't':
12771                             case 'A': case 'a':
12772                             case 'H': case 'h':
12773                             case 'J': case 'j':
12774                             case 'N': case 'n':
12775                             case 'W': case 'w':
12776                             case 'Y': case 'y':
12777                                 /* These all are targets of multi-character
12778                                  * folds from code points that require UTF8 to
12779                                  * express, so they can't match unless the
12780                                  * target string is in UTF-8, so no action here
12781                                  * is necessary, as regexec.c properly handles
12782                                  * the general case for UTF-8 matching and
12783                                  * multi-char folds */
12784                                 break;
12785                             default:
12786                                 /* Use deprecated warning to increase the
12787                                  * chances of this being output */
12788                                 ckWARN2regdep(RExC_parse, "Perl folding rules are not up-to-date for 0x%"UVXf"; please use the perlbug utility to report;", j);
12789                                 break;
12790                         }
12791                     }
12792                     continue;
12793                 }
12794
12795                 /* Here is an above Latin1 character.  We don't have the rules
12796                  * hard-coded for it.  First, get its fold.  This is the simple
12797                  * fold, as the multi-character folds have been handled earlier
12798                  * and separated out */
12799                 _to_uni_fold_flags(j, foldbuf, &foldlen,
12800                                                ((LOC)
12801                                                ? FOLD_FLAGS_LOCALE
12802                                                : (ASCII_FOLD_RESTRICTED)
12803                                                   ? FOLD_FLAGS_NOMIX_ASCII
12804                                                   : 0));
12805
12806                 /* Single character fold of above Latin1.  Add everything in
12807                  * its fold closure to the list that this node should match.
12808                  * The fold closures data structure is a hash with the keys
12809                  * being the UTF-8 of every character that is folded to, like
12810                  * 'k', and the values each an array of all code points that
12811                  * fold to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ].
12812                  * Multi-character folds are not included */
12813                 if ((listp = hv_fetch(PL_utf8_foldclosures,
12814                                       (char *) foldbuf, foldlen, FALSE)))
12815                 {
12816                     AV* list = (AV*) *listp;
12817                     IV k;
12818                     for (k = 0; k <= av_len(list); k++) {
12819                         SV** c_p = av_fetch(list, k, FALSE);
12820                         UV c;
12821                         if (c_p == NULL) {
12822                             Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
12823                         }
12824                         c = SvUV(*c_p);
12825
12826                         /* /aa doesn't allow folds between ASCII and non-; /l
12827                          * doesn't allow them between above and below 256 */
12828                         if ((ASCII_FOLD_RESTRICTED
12829                                   && (isASCII(c) != isASCII(j)))
12830                             || (LOC && ((c < 256) != (j < 256))))
12831                         {
12832                             continue;
12833                         }
12834
12835                         /* Folds involving non-ascii Latin1 characters
12836                          * under /d are added to a separate list */
12837                         if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS)
12838                         {
12839                             cp_list = add_cp_to_invlist(cp_list, c);
12840                         }
12841                         else {
12842                           depends_list = add_cp_to_invlist(depends_list, c);
12843                         }
12844                     }
12845                 }
12846             }
12847         }
12848         SvREFCNT_dec(fold_intersection);
12849     }
12850
12851     /* And combine the result (if any) with any inversion list from posix
12852      * classes.  The lists are kept separate up to now because we don't want to
12853      * fold the classes (folding of those is automatically handled by the swash
12854      * fetching code) */
12855     if (posixes) {
12856         if (! DEPENDS_SEMANTICS) {
12857             if (cp_list) {
12858                 _invlist_union(cp_list, posixes, &cp_list);
12859                 SvREFCNT_dec(posixes);
12860             }
12861             else {
12862                 cp_list = posixes;
12863             }
12864         }
12865         else {
12866             /* Under /d, we put into a separate list the Latin1 things that
12867              * match only when the target string is utf8 */
12868             SV* nonascii_but_latin1_properties = NULL;
12869             _invlist_intersection(posixes, PL_Latin1,
12870                                   &nonascii_but_latin1_properties);
12871             _invlist_subtract(nonascii_but_latin1_properties, PL_ASCII,
12872                               &nonascii_but_latin1_properties);
12873             _invlist_subtract(posixes, nonascii_but_latin1_properties,
12874                               &posixes);
12875             if (cp_list) {
12876                 _invlist_union(cp_list, posixes, &cp_list);
12877                 SvREFCNT_dec(posixes);
12878             }
12879             else {
12880                 cp_list = posixes;
12881             }
12882
12883             if (depends_list) {
12884                 _invlist_union(depends_list, nonascii_but_latin1_properties,
12885                                &depends_list);
12886                 SvREFCNT_dec(nonascii_but_latin1_properties);
12887             }
12888             else {
12889                 depends_list = nonascii_but_latin1_properties;
12890             }
12891         }
12892     }
12893
12894     /* And combine the result (if any) with any inversion list from properties.
12895      * The lists are kept separate up to now so that we can distinguish the two
12896      * in regards to matching above-Unicode.  A run-time warning is generated
12897      * if a Unicode property is matched against a non-Unicode code point. But,
12898      * we allow user-defined properties to match anything, without any warning,
12899      * and we also suppress the warning if there is a portion of the character
12900      * class that isn't a Unicode property, and which matches above Unicode, \W
12901      * or [\x{110000}] for example.
12902      * (Note that in this case, unlike the Posix one above, there is no
12903      * <depends_list>, because having a Unicode property forces Unicode
12904      * semantics */
12905     if (properties) {
12906         bool warn_super = ! has_user_defined_property;
12907         if (cp_list) {
12908
12909             /* If it matters to the final outcome, see if a non-property
12910              * component of the class matches above Unicode.  If so, the
12911              * warning gets suppressed.  This is true even if just a single
12912              * such code point is specified, as though not strictly correct if
12913              * another such code point is matched against, the fact that they
12914              * are using above-Unicode code points indicates they should know
12915              * the issues involved */
12916             if (warn_super) {
12917                 bool non_prop_matches_above_Unicode =
12918                             runtime_posix_matches_above_Unicode
12919                             | (invlist_highest(cp_list) > PERL_UNICODE_MAX);
12920                 if (invert) {
12921                     non_prop_matches_above_Unicode =
12922                                             !  non_prop_matches_above_Unicode;
12923                 }
12924                 warn_super = ! non_prop_matches_above_Unicode;
12925             }
12926
12927             _invlist_union(properties, cp_list, &cp_list);
12928             SvREFCNT_dec(properties);
12929         }
12930         else {
12931             cp_list = properties;
12932         }
12933
12934         if (warn_super) {
12935             ANYOF_FLAGS(ret) |= ANYOF_WARN_SUPER;
12936         }
12937     }
12938
12939     /* Here, we have calculated what code points should be in the character
12940      * class.
12941      *
12942      * Now we can see about various optimizations.  Fold calculation (which we
12943      * did above) needs to take place before inversion.  Otherwise /[^k]/i
12944      * would invert to include K, which under /i would match k, which it
12945      * shouldn't.  Therefore we can't invert folded locale now, as it won't be
12946      * folded until runtime */
12947
12948     /* Optimize inverted simple patterns (e.g. [^a-z]) when everything is known
12949      * at compile time.  Besides not inverting folded locale now, we can't
12950      * invert if there are things such as \w, which aren't known until runtime
12951      * */
12952     if (invert
12953         && ! (LOC && (FOLD || (ANYOF_FLAGS(ret) & ANYOF_CLASS)))
12954         && ! depends_list
12955         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
12956     {
12957         _invlist_invert(cp_list);
12958
12959         /* Any swash can't be used as-is, because we've inverted things */
12960         if (swash) {
12961             SvREFCNT_dec(swash);
12962             swash = NULL;
12963         }
12964
12965         /* Clear the invert flag since have just done it here */
12966         invert = FALSE;
12967     }
12968
12969     /* If we didn't do folding, it's because some information isn't available
12970      * until runtime; set the run-time fold flag for these.  (We don't have to
12971      * worry about properties folding, as that is taken care of by the swash
12972      * fetching) */
12973     if (FOLD && LOC)
12974     {
12975        ANYOF_FLAGS(ret) |= ANYOF_LOC_FOLD;
12976     }
12977
12978     /* Some character classes are equivalent to other nodes.  Such nodes take
12979      * up less room and generally fewer operations to execute than ANYOF nodes.
12980      * Above, we checked for and optimized into some such equivalents for
12981      * certain common classes that are easy to test.  Getting to this point in
12982      * the code means that the class didn't get optimized there.  Since this
12983      * code is only executed in Pass 2, it is too late to save space--it has
12984      * been allocated in Pass 1, and currently isn't given back.  But turning
12985      * things into an EXACTish node can allow the optimizer to join it to any
12986      * adjacent such nodes.  And if the class is equivalent to things like /./,
12987      * expensive run-time swashes can be avoided.  Now that we have more
12988      * complete information, we can find things necessarily missed by the
12989      * earlier code.  I (khw) am not sure how much to look for here.  It would
12990      * be easy, but perhaps too slow, to check any candidates against all the
12991      * node types they could possibly match using _invlistEQ(). */
12992
12993     if (cp_list
12994         && ! invert
12995         && ! depends_list
12996         && ! (ANYOF_FLAGS(ret) & ANYOF_CLASS)
12997         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
12998     {
12999        UV start, end;
13000        U8 op = END;  /* The optimzation node-type */
13001         const char * cur_parse= RExC_parse;
13002
13003        invlist_iterinit(cp_list);
13004        if (! invlist_iternext(cp_list, &start, &end)) {
13005
13006             /* Here, the list is empty.  This happens, for example, when a
13007              * Unicode property is the only thing in the character class, and
13008              * it doesn't match anything.  (perluniprops.pod notes such
13009              * properties) */
13010             op = OPFAIL;
13011             *flagp |= HASWIDTH|SIMPLE;
13012         }
13013         else if (start == end) {    /* The range is a single code point */
13014             if (! invlist_iternext(cp_list, &start, &end)
13015
13016                     /* Don't do this optimization if it would require changing
13017                      * the pattern to UTF-8 */
13018                 && (start < 256 || UTF))
13019             {
13020                 /* Here, the list contains a single code point.  Can optimize
13021                  * into an EXACT node */
13022
13023                 value = start;
13024
13025                 if (! FOLD) {
13026                     op = EXACT;
13027                 }
13028                 else if (LOC) {
13029
13030                     /* A locale node under folding with one code point can be
13031                      * an EXACTFL, as its fold won't be calculated until
13032                      * runtime */
13033                     op = EXACTFL;
13034                 }
13035                 else {
13036
13037                     /* Here, we are generally folding, but there is only one
13038                      * code point to match.  If we have to, we use an EXACT
13039                      * node, but it would be better for joining with adjacent
13040                      * nodes in the optimization pass if we used the same
13041                      * EXACTFish node that any such are likely to be.  We can
13042                      * do this iff the code point doesn't participate in any
13043                      * folds.  For example, an EXACTF of a colon is the same as
13044                      * an EXACT one, since nothing folds to or from a colon. */
13045                     if (value < 256) {
13046                         if (IS_IN_SOME_FOLD_L1(value)) {
13047                             op = EXACT;
13048                         }
13049                     }
13050                     else {
13051                         if (! PL_utf8_foldable) {
13052                             SV* swash = swash_init("utf8", "_Perl_Any_Folds",
13053                                                 &PL_sv_undef, 1, 0);
13054                             PL_utf8_foldable = _get_swash_invlist(swash);
13055                             SvREFCNT_dec(swash);
13056                         }
13057                         if (_invlist_contains_cp(PL_utf8_foldable, value)) {
13058                             op = EXACT;
13059                         }
13060                     }
13061
13062                     /* If we haven't found the node type, above, it means we
13063                      * can use the prevailing one */
13064                     if (op == END) {
13065                         op = compute_EXACTish(pRExC_state);
13066                     }
13067                 }
13068             }
13069         }
13070         else if (start == 0) {
13071             if (end == UV_MAX) {
13072                 op = SANY;
13073                 *flagp |= HASWIDTH|SIMPLE;
13074                 RExC_naughty++;
13075             }
13076             else if (end == '\n' - 1
13077                     && invlist_iternext(cp_list, &start, &end)
13078                     && start == '\n' + 1 && end == UV_MAX)
13079             {
13080                 op = REG_ANY;
13081                 *flagp |= HASWIDTH|SIMPLE;
13082                 RExC_naughty++;
13083             }
13084         }
13085
13086         if (op != END) {
13087             RExC_parse = (char *)orig_parse;
13088             RExC_emit = (regnode *)orig_emit;
13089
13090             ret = reg_node(pRExC_state, op);
13091
13092             RExC_parse = (char *)cur_parse;
13093
13094             if (PL_regkind[op] == EXACT) {
13095                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value);
13096             }
13097
13098             SvREFCNT_dec(cp_list);
13099             SvREFCNT_dec(listsv);
13100             return ret;
13101         }
13102     }
13103
13104     /* Here, <cp_list> contains all the code points we can determine at
13105      * compile time that match under all conditions.  Go through it, and
13106      * for things that belong in the bitmap, put them there, and delete from
13107      * <cp_list>.  While we are at it, see if everything above 255 is in the
13108      * list, and if so, set a flag to speed up execution */
13109     ANYOF_BITMAP_ZERO(ret);
13110     if (cp_list) {
13111
13112         /* This gets set if we actually need to modify things */
13113         bool change_invlist = FALSE;
13114
13115         UV start, end;
13116
13117         /* Start looking through <cp_list> */
13118         invlist_iterinit(cp_list);
13119         while (invlist_iternext(cp_list, &start, &end)) {
13120             UV high;
13121             int i;
13122
13123             if (end == UV_MAX && start <= 256) {
13124                 ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
13125             }
13126
13127             /* Quit if are above what we should change */
13128             if (start > 255) {
13129                 break;
13130             }
13131
13132             change_invlist = TRUE;
13133
13134             /* Set all the bits in the range, up to the max that we are doing */
13135             high = (end < 255) ? end : 255;
13136             for (i = start; i <= (int) high; i++) {
13137                 if (! ANYOF_BITMAP_TEST(ret, i)) {
13138                     ANYOF_BITMAP_SET(ret, i);
13139                     prevvalue = value;
13140                     value = i;
13141                 }
13142             }
13143         }
13144
13145         /* Done with loop; remove any code points that are in the bitmap from
13146          * <cp_list> */
13147         if (change_invlist) {
13148             _invlist_subtract(cp_list, PL_Latin1, &cp_list);
13149         }
13150
13151         /* If have completely emptied it, remove it completely */
13152         if (_invlist_len(cp_list) == 0) {
13153             SvREFCNT_dec(cp_list);
13154             cp_list = NULL;
13155         }
13156     }
13157
13158     if (invert) {
13159         ANYOF_FLAGS(ret) |= ANYOF_INVERT;
13160     }
13161
13162     /* Here, the bitmap has been populated with all the Latin1 code points that
13163      * always match.  Can now add to the overall list those that match only
13164      * when the target string is UTF-8 (<depends_list>). */
13165     if (depends_list) {
13166         if (cp_list) {
13167             _invlist_union(cp_list, depends_list, &cp_list);
13168             SvREFCNT_dec(depends_list);
13169         }
13170         else {
13171             cp_list = depends_list;
13172         }
13173     }
13174
13175     /* If there is a swash and more than one element, we can't use the swash in
13176      * the optimization below. */
13177     if (swash && element_count > 1) {
13178         SvREFCNT_dec(swash);
13179         swash = NULL;
13180     }
13181
13182     if (! cp_list
13183         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
13184     {
13185         ARG_SET(ret, ANYOF_NONBITMAP_EMPTY);
13186         SvREFCNT_dec(listsv);
13187     }
13188     else {
13189         /* av[0] stores the character class description in its textual form:
13190          *       used later (regexec.c:Perl_regclass_swash()) to initialize the
13191          *       appropriate swash, and is also useful for dumping the regnode.
13192          * av[1] if NULL, is a placeholder to later contain the swash computed
13193          *       from av[0].  But if no further computation need be done, the
13194          *       swash is stored there now.
13195          * av[2] stores the cp_list inversion list for use in addition or
13196          *       instead of av[0]; used only if av[1] is NULL
13197          * av[3] is set if any component of the class is from a user-defined
13198          *       property; used only if av[1] is NULL */
13199         AV * const av = newAV();
13200         SV *rv;
13201
13202         av_store(av, 0, (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
13203                         ? listsv
13204                         : (SvREFCNT_dec(listsv), &PL_sv_undef));
13205         if (swash) {
13206             av_store(av, 1, swash);
13207             SvREFCNT_dec(cp_list);
13208         }
13209         else {
13210             av_store(av, 1, NULL);
13211             if (cp_list) {
13212                 av_store(av, 2, cp_list);
13213                 av_store(av, 3, newSVuv(has_user_defined_property));
13214             }
13215         }
13216
13217         rv = newRV_noinc(MUTABLE_SV(av));
13218         n = add_data(pRExC_state, 1, "s");
13219         RExC_rxi->data->data[n] = (void*)rv;
13220         ARG_SET(ret, n);
13221     }
13222
13223     *flagp |= HASWIDTH|SIMPLE;
13224     return ret;
13225 }
13226 #undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
13227
13228
13229 /* reg_skipcomment()
13230
13231    Absorbs an /x style # comments from the input stream.
13232    Returns true if there is more text remaining in the stream.
13233    Will set the REG_SEEN_RUN_ON_COMMENT flag if the comment
13234    terminates the pattern without including a newline.
13235
13236    Note its the callers responsibility to ensure that we are
13237    actually in /x mode
13238
13239 */
13240
13241 STATIC bool
13242 S_reg_skipcomment(pTHX_ RExC_state_t *pRExC_state)
13243 {
13244     bool ended = 0;
13245
13246     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
13247
13248     while (RExC_parse < RExC_end)
13249         if (*RExC_parse++ == '\n') {
13250             ended = 1;
13251             break;
13252         }
13253     if (!ended) {
13254         /* we ran off the end of the pattern without ending
13255            the comment, so we have to add an \n when wrapping */
13256         RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
13257         return 0;
13258     } else
13259         return 1;
13260 }
13261
13262 /* nextchar()
13263
13264    Advances the parse position, and optionally absorbs
13265    "whitespace" from the inputstream.
13266
13267    Without /x "whitespace" means (?#...) style comments only,
13268    with /x this means (?#...) and # comments and whitespace proper.
13269
13270    Returns the RExC_parse point from BEFORE the scan occurs.
13271
13272    This is the /x friendly way of saying RExC_parse++.
13273 */
13274
13275 STATIC char*
13276 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
13277 {
13278     char* const retval = RExC_parse++;
13279
13280     PERL_ARGS_ASSERT_NEXTCHAR;
13281
13282     for (;;) {
13283         if (RExC_end - RExC_parse >= 3
13284             && *RExC_parse == '('
13285             && RExC_parse[1] == '?'
13286             && RExC_parse[2] == '#')
13287         {
13288             while (*RExC_parse != ')') {
13289                 if (RExC_parse == RExC_end)
13290                     FAIL("Sequence (?#... not terminated");
13291                 RExC_parse++;
13292             }
13293             RExC_parse++;
13294             continue;
13295         }
13296         if (RExC_flags & RXf_PMf_EXTENDED) {
13297             if (isSPACE(*RExC_parse)) {
13298                 RExC_parse++;
13299                 continue;
13300             }
13301             else if (*RExC_parse == '#') {
13302                 if ( reg_skipcomment( pRExC_state ) )
13303                     continue;
13304             }
13305         }
13306         return retval;
13307     }
13308 }
13309
13310 /*
13311 - reg_node - emit a node
13312 */
13313 STATIC regnode *                        /* Location. */
13314 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
13315 {
13316     dVAR;
13317     regnode *ptr;
13318     regnode * const ret = RExC_emit;
13319     GET_RE_DEBUG_FLAGS_DECL;
13320
13321     PERL_ARGS_ASSERT_REG_NODE;
13322
13323     if (SIZE_ONLY) {
13324         SIZE_ALIGN(RExC_size);
13325         RExC_size += 1;
13326         return(ret);
13327     }
13328     if (RExC_emit >= RExC_emit_bound)
13329         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
13330                    op, RExC_emit, RExC_emit_bound);
13331
13332     NODE_ALIGN_FILL(ret);
13333     ptr = ret;
13334     FILL_ADVANCE_NODE(ptr, op);
13335     REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (ptr) - 1);
13336 #ifdef RE_TRACK_PATTERN_OFFSETS
13337     if (RExC_offsets) {         /* MJD */
13338         MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n", 
13339               "reg_node", __LINE__, 
13340               PL_reg_name[op],
13341               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] 
13342                 ? "Overwriting end of array!\n" : "OK",
13343               (UV)(RExC_emit - RExC_emit_start),
13344               (UV)(RExC_parse - RExC_start),
13345               (UV)RExC_offsets[0])); 
13346         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
13347     }
13348 #endif
13349     RExC_emit = ptr;
13350     return(ret);
13351 }
13352
13353 /*
13354 - reganode - emit a node with an argument
13355 */
13356 STATIC regnode *                        /* Location. */
13357 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
13358 {
13359     dVAR;
13360     regnode *ptr;
13361     regnode * const ret = RExC_emit;
13362     GET_RE_DEBUG_FLAGS_DECL;
13363
13364     PERL_ARGS_ASSERT_REGANODE;
13365
13366     if (SIZE_ONLY) {
13367         SIZE_ALIGN(RExC_size);
13368         RExC_size += 2;
13369         /* 
13370            We can't do this:
13371            
13372            assert(2==regarglen[op]+1); 
13373
13374            Anything larger than this has to allocate the extra amount.
13375            If we changed this to be:
13376            
13377            RExC_size += (1 + regarglen[op]);
13378            
13379            then it wouldn't matter. Its not clear what side effect
13380            might come from that so its not done so far.
13381            -- dmq
13382         */
13383         return(ret);
13384     }
13385     if (RExC_emit >= RExC_emit_bound)
13386         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
13387                    op, RExC_emit, RExC_emit_bound);
13388
13389     NODE_ALIGN_FILL(ret);
13390     ptr = ret;
13391     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
13392     REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (ptr) - 2);
13393 #ifdef RE_TRACK_PATTERN_OFFSETS
13394     if (RExC_offsets) {         /* MJD */
13395         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
13396               "reganode",
13397               __LINE__,
13398               PL_reg_name[op],
13399               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? 
13400               "Overwriting end of array!\n" : "OK",
13401               (UV)(RExC_emit - RExC_emit_start),
13402               (UV)(RExC_parse - RExC_start),
13403               (UV)RExC_offsets[0])); 
13404         Set_Cur_Node_Offset;
13405     }
13406 #endif            
13407     RExC_emit = ptr;
13408     return(ret);
13409 }
13410
13411 /*
13412 - reguni - emit (if appropriate) a Unicode character
13413 */
13414 STATIC STRLEN
13415 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
13416 {
13417     dVAR;
13418
13419     PERL_ARGS_ASSERT_REGUNI;
13420
13421     return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
13422 }
13423
13424 /*
13425 - reginsert - insert an operator in front of already-emitted operand
13426 *
13427 * Means relocating the operand.
13428 */
13429 STATIC void
13430 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
13431 {
13432     dVAR;
13433     regnode *src;
13434     regnode *dst;
13435     regnode *place;
13436     const int offset = regarglen[(U8)op];
13437     const int size = NODE_STEP_REGNODE + offset;
13438     GET_RE_DEBUG_FLAGS_DECL;
13439
13440     PERL_ARGS_ASSERT_REGINSERT;
13441     PERL_UNUSED_ARG(depth);
13442 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
13443     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
13444     if (SIZE_ONLY) {
13445         RExC_size += size;
13446         return;
13447     }
13448
13449     src = RExC_emit;
13450     RExC_emit += size;
13451     dst = RExC_emit;
13452     if (RExC_open_parens) {
13453         int paren;
13454         /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
13455         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
13456             if ( RExC_open_parens[paren] >= opnd ) {
13457                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
13458                 RExC_open_parens[paren] += size;
13459             } else {
13460                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
13461             }
13462             if ( RExC_close_parens[paren] >= opnd ) {
13463                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
13464                 RExC_close_parens[paren] += size;
13465             } else {
13466                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
13467             }
13468         }
13469     }
13470
13471     while (src > opnd) {
13472         StructCopy(--src, --dst, regnode);
13473 #ifdef RE_TRACK_PATTERN_OFFSETS
13474         if (RExC_offsets) {     /* MJD 20010112 */
13475             MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
13476                   "reg_insert",
13477                   __LINE__,
13478                   PL_reg_name[op],
13479                   (UV)(dst - RExC_emit_start) > RExC_offsets[0] 
13480                     ? "Overwriting end of array!\n" : "OK",
13481                   (UV)(src - RExC_emit_start),
13482                   (UV)(dst - RExC_emit_start),
13483                   (UV)RExC_offsets[0])); 
13484             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
13485             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
13486         }
13487 #endif
13488     }
13489     
13490
13491     place = opnd;               /* Op node, where operand used to be. */
13492 #ifdef RE_TRACK_PATTERN_OFFSETS
13493     if (RExC_offsets) {         /* MJD */
13494         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
13495               "reginsert",
13496               __LINE__,
13497               PL_reg_name[op],
13498               (UV)(place - RExC_emit_start) > RExC_offsets[0] 
13499               ? "Overwriting end of array!\n" : "OK",
13500               (UV)(place - RExC_emit_start),
13501               (UV)(RExC_parse - RExC_start),
13502               (UV)RExC_offsets[0]));
13503         Set_Node_Offset(place, RExC_parse);
13504         Set_Node_Length(place, 1);
13505     }
13506 #endif    
13507     src = NEXTOPER(place);
13508     FILL_ADVANCE_NODE(place, op);
13509     REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (place) - 1);
13510     Zero(src, offset, regnode);
13511 }
13512
13513 /*
13514 - regtail - set the next-pointer at the end of a node chain of p to val.
13515 - SEE ALSO: regtail_study
13516 */
13517 /* TODO: All three parms should be const */
13518 STATIC void
13519 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
13520 {
13521     dVAR;
13522     regnode *scan;
13523     GET_RE_DEBUG_FLAGS_DECL;
13524
13525     PERL_ARGS_ASSERT_REGTAIL;
13526 #ifndef DEBUGGING
13527     PERL_UNUSED_ARG(depth);
13528 #endif
13529
13530     if (SIZE_ONLY)
13531         return;
13532
13533     /* Find last node. */
13534     scan = p;
13535     for (;;) {
13536         regnode * const temp = regnext(scan);
13537         DEBUG_PARSE_r({
13538             SV * const mysv=sv_newmortal();
13539             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
13540             regprop(RExC_rx, mysv, scan);
13541             PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
13542                 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
13543                     (temp == NULL ? "->" : ""),
13544                     (temp == NULL ? PL_reg_name[OP(val)] : "")
13545             );
13546         });
13547         if (temp == NULL)
13548             break;
13549         scan = temp;
13550     }
13551
13552     if (reg_off_by_arg[OP(scan)]) {
13553         ARG_SET(scan, val - scan);
13554     }
13555     else {
13556         NEXT_OFF(scan) = val - scan;
13557     }
13558 }
13559
13560 #ifdef DEBUGGING
13561 /*
13562 - regtail_study - set the next-pointer at the end of a node chain of p to val.
13563 - Look for optimizable sequences at the same time.
13564 - currently only looks for EXACT chains.
13565
13566 This is experimental code. The idea is to use this routine to perform 
13567 in place optimizations on branches and groups as they are constructed,
13568 with the long term intention of removing optimization from study_chunk so
13569 that it is purely analytical.
13570
13571 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
13572 to control which is which.
13573
13574 */
13575 /* TODO: All four parms should be const */
13576
13577 STATIC U8
13578 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
13579 {
13580     dVAR;
13581     regnode *scan;
13582     U8 exact = PSEUDO;
13583 #ifdef EXPERIMENTAL_INPLACESCAN
13584     I32 min = 0;
13585 #endif
13586     GET_RE_DEBUG_FLAGS_DECL;
13587
13588     PERL_ARGS_ASSERT_REGTAIL_STUDY;
13589
13590
13591     if (SIZE_ONLY)
13592         return exact;
13593
13594     /* Find last node. */
13595
13596     scan = p;
13597     for (;;) {
13598         regnode * const temp = regnext(scan);
13599 #ifdef EXPERIMENTAL_INPLACESCAN
13600         if (PL_regkind[OP(scan)] == EXACT) {
13601             bool has_exactf_sharp_s;    /* Unexamined in this routine */
13602             if (join_exact(pRExC_state,scan,&min, &has_exactf_sharp_s, 1,val,depth+1))
13603                 return EXACT;
13604         }
13605 #endif
13606         if ( exact ) {
13607             switch (OP(scan)) {
13608                 case EXACT:
13609                 case EXACTF:
13610                 case EXACTFA:
13611                 case EXACTFU:
13612                 case EXACTFU_SS:
13613                 case EXACTFU_TRICKYFOLD:
13614                 case EXACTFL:
13615                         if( exact == PSEUDO )
13616                             exact= OP(scan);
13617                         else if ( exact != OP(scan) )
13618                             exact= 0;
13619                 case NOTHING:
13620                     break;
13621                 default:
13622                     exact= 0;
13623             }
13624         }
13625         DEBUG_PARSE_r({
13626             SV * const mysv=sv_newmortal();
13627             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
13628             regprop(RExC_rx, mysv, scan);
13629             PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
13630                 SvPV_nolen_const(mysv),
13631                 REG_NODE_NUM(scan),
13632                 PL_reg_name[exact]);
13633         });
13634         if (temp == NULL)
13635             break;
13636         scan = temp;
13637     }
13638     DEBUG_PARSE_r({
13639         SV * const mysv_val=sv_newmortal();
13640         DEBUG_PARSE_MSG("");
13641         regprop(RExC_rx, mysv_val, val);
13642         PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
13643                       SvPV_nolen_const(mysv_val),
13644                       (IV)REG_NODE_NUM(val),
13645                       (IV)(val - scan)
13646         );
13647     });
13648     if (reg_off_by_arg[OP(scan)]) {
13649         ARG_SET(scan, val - scan);
13650     }
13651     else {
13652         NEXT_OFF(scan) = val - scan;
13653     }
13654
13655     return exact;
13656 }
13657 #endif
13658
13659 /*
13660  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
13661  */
13662 #ifdef DEBUGGING
13663 static void 
13664 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
13665 {
13666     int bit;
13667     int set=0;
13668     regex_charset cs;
13669
13670     for (bit=0; bit<32; bit++) {
13671         if (flags & (1<<bit)) {
13672             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
13673                 continue;
13674             }
13675             if (!set++ && lead) 
13676                 PerlIO_printf(Perl_debug_log, "%s",lead);
13677             PerlIO_printf(Perl_debug_log, "%s ",PL_reg_extflags_name[bit]);
13678         }               
13679     }      
13680     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
13681             if (!set++ && lead) {
13682                 PerlIO_printf(Perl_debug_log, "%s",lead);
13683             }
13684             switch (cs) {
13685                 case REGEX_UNICODE_CHARSET:
13686                     PerlIO_printf(Perl_debug_log, "UNICODE");
13687                     break;
13688                 case REGEX_LOCALE_CHARSET:
13689                     PerlIO_printf(Perl_debug_log, "LOCALE");
13690                     break;
13691                 case REGEX_ASCII_RESTRICTED_CHARSET:
13692                     PerlIO_printf(Perl_debug_log, "ASCII-RESTRICTED");
13693                     break;
13694                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
13695                     PerlIO_printf(Perl_debug_log, "ASCII-MORE_RESTRICTED");
13696                     break;
13697                 default:
13698                     PerlIO_printf(Perl_debug_log, "UNKNOWN CHARACTER SET");
13699                     break;
13700             }
13701     }
13702     if (lead)  {
13703         if (set) 
13704             PerlIO_printf(Perl_debug_log, "\n");
13705         else 
13706             PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
13707     }            
13708 }   
13709 #endif
13710
13711 void
13712 Perl_regdump(pTHX_ const regexp *r)
13713 {
13714 #ifdef DEBUGGING
13715     dVAR;
13716     SV * const sv = sv_newmortal();
13717     SV *dsv= sv_newmortal();
13718     RXi_GET_DECL(r,ri);
13719     GET_RE_DEBUG_FLAGS_DECL;
13720
13721     PERL_ARGS_ASSERT_REGDUMP;
13722
13723     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
13724
13725     /* Header fields of interest. */
13726     if (r->anchored_substr) {
13727         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr), 
13728             RE_SV_DUMPLEN(r->anchored_substr), 30);
13729         PerlIO_printf(Perl_debug_log,
13730                       "anchored %s%s at %"IVdf" ",
13731                       s, RE_SV_TAIL(r->anchored_substr),
13732                       (IV)r->anchored_offset);
13733     } else if (r->anchored_utf8) {
13734         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8), 
13735             RE_SV_DUMPLEN(r->anchored_utf8), 30);
13736         PerlIO_printf(Perl_debug_log,
13737                       "anchored utf8 %s%s at %"IVdf" ",
13738                       s, RE_SV_TAIL(r->anchored_utf8),
13739                       (IV)r->anchored_offset);
13740     }                 
13741     if (r->float_substr) {
13742         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr), 
13743             RE_SV_DUMPLEN(r->float_substr), 30);
13744         PerlIO_printf(Perl_debug_log,
13745                       "floating %s%s at %"IVdf"..%"UVuf" ",
13746                       s, RE_SV_TAIL(r->float_substr),
13747                       (IV)r->float_min_offset, (UV)r->float_max_offset);
13748     } else if (r->float_utf8) {
13749         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8), 
13750             RE_SV_DUMPLEN(r->float_utf8), 30);
13751         PerlIO_printf(Perl_debug_log,
13752                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
13753                       s, RE_SV_TAIL(r->float_utf8),
13754                       (IV)r->float_min_offset, (UV)r->float_max_offset);
13755     }
13756     if (r->check_substr || r->check_utf8)
13757         PerlIO_printf(Perl_debug_log,
13758                       (const char *)
13759                       (r->check_substr == r->float_substr
13760                        && r->check_utf8 == r->float_utf8
13761                        ? "(checking floating" : "(checking anchored"));
13762     if (r->extflags & RXf_NOSCAN)
13763         PerlIO_printf(Perl_debug_log, " noscan");
13764     if (r->extflags & RXf_CHECK_ALL)
13765         PerlIO_printf(Perl_debug_log, " isall");
13766     if (r->check_substr || r->check_utf8)
13767         PerlIO_printf(Perl_debug_log, ") ");
13768
13769     if (ri->regstclass) {
13770         regprop(r, sv, ri->regstclass);
13771         PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
13772     }
13773     if (r->extflags & RXf_ANCH) {
13774         PerlIO_printf(Perl_debug_log, "anchored");
13775         if (r->extflags & RXf_ANCH_BOL)
13776             PerlIO_printf(Perl_debug_log, "(BOL)");
13777         if (r->extflags & RXf_ANCH_MBOL)
13778             PerlIO_printf(Perl_debug_log, "(MBOL)");
13779         if (r->extflags & RXf_ANCH_SBOL)
13780             PerlIO_printf(Perl_debug_log, "(SBOL)");
13781         if (r->extflags & RXf_ANCH_GPOS)
13782             PerlIO_printf(Perl_debug_log, "(GPOS)");
13783         PerlIO_putc(Perl_debug_log, ' ');
13784     }
13785     if (r->extflags & RXf_GPOS_SEEN)
13786         PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
13787     if (r->intflags & PREGf_SKIP)
13788         PerlIO_printf(Perl_debug_log, "plus ");
13789     if (r->intflags & PREGf_IMPLICIT)
13790         PerlIO_printf(Perl_debug_log, "implicit ");
13791     PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
13792     if (r->extflags & RXf_EVAL_SEEN)
13793         PerlIO_printf(Perl_debug_log, "with eval ");
13794     PerlIO_printf(Perl_debug_log, "\n");
13795     DEBUG_FLAGS_r(regdump_extflags("r->extflags: ",r->extflags));            
13796 #else
13797     PERL_ARGS_ASSERT_REGDUMP;
13798     PERL_UNUSED_CONTEXT;
13799     PERL_UNUSED_ARG(r);
13800 #endif  /* DEBUGGING */
13801 }
13802
13803 /*
13804 - regprop - printable representation of opcode
13805 */
13806 #define EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags) \
13807 STMT_START { \
13808         if (do_sep) {                           \
13809             Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]); \
13810             if (flags & ANYOF_INVERT)           \
13811                 /*make sure the invert info is in each */ \
13812                 sv_catpvs(sv, "^");             \
13813             do_sep = 0;                         \
13814         }                                       \
13815 } STMT_END
13816
13817 void
13818 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
13819 {
13820 #ifdef DEBUGGING
13821     dVAR;
13822     int k;
13823
13824     /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
13825     static const char * const anyofs[] = {
13826 #if _CC_WORDCHAR != 0 || _CC_DIGIT != 1 || _CC_ALPHA != 2 || _CC_LOWER != 3 \
13827     || _CC_UPPER != 4 || _CC_PUNCT != 5 || _CC_PRINT != 6 || _CC_ALNUMC != 7 \
13828     || _CC_GRAPH != 8 || _CC_SPACE != 9 || _CC_BLANK != 10 \
13829     || _CC_XDIGIT != 11 || _CC_PSXSPC != 12 || _CC_CNTRL != 13 \
13830     || _CC_ASCII != 14 || _CC_VERTSPACE != 15
13831   #error Need to adjust order of anyofs[]
13832 #endif
13833         "[\\w]",
13834         "[\\W]",
13835         "[\\d]",
13836         "[\\D]",
13837         "[:alpha:]",
13838         "[:^alpha:]",
13839         "[:lower:]",
13840         "[:^lower:]",
13841         "[:upper:]",
13842         "[:^upper:]",
13843         "[:punct:]",
13844         "[:^punct:]",
13845         "[:print:]",
13846         "[:^print:]",
13847         "[:alnum:]",
13848         "[:^alnum:]",
13849         "[:graph:]",
13850         "[:^graph:]",
13851         "[\\s]",
13852         "[\\S]",
13853         "[:blank:]",
13854         "[:^blank:]",
13855         "[:xdigit:]",
13856         "[:^xdigit:]",
13857         "[:space:]",
13858         "[:^space:]",
13859         "[:cntrl:]",
13860         "[:^cntrl:]",
13861         "[:ascii:]",
13862         "[:^ascii:]",
13863         "[\\v]",
13864         "[\\V]"
13865     };
13866     RXi_GET_DECL(prog,progi);
13867     GET_RE_DEBUG_FLAGS_DECL;
13868     
13869     PERL_ARGS_ASSERT_REGPROP;
13870
13871     sv_setpvs(sv, "");
13872
13873     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
13874         /* It would be nice to FAIL() here, but this may be called from
13875            regexec.c, and it would be hard to supply pRExC_state. */
13876         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
13877     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
13878
13879     k = PL_regkind[OP(o)];
13880
13881     if (k == EXACT) {
13882         sv_catpvs(sv, " ");
13883         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT) 
13884          * is a crude hack but it may be the best for now since 
13885          * we have no flag "this EXACTish node was UTF-8" 
13886          * --jhi */
13887         pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
13888                   PERL_PV_ESCAPE_UNI_DETECT |
13889                   PERL_PV_ESCAPE_NONASCII   |
13890                   PERL_PV_PRETTY_ELLIPSES   |
13891                   PERL_PV_PRETTY_LTGT       |
13892                   PERL_PV_PRETTY_NOCLEAR
13893                   );
13894     } else if (k == TRIE) {
13895         /* print the details of the trie in dumpuntil instead, as
13896          * progi->data isn't available here */
13897         const char op = OP(o);
13898         const U32 n = ARG(o);
13899         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
13900                (reg_ac_data *)progi->data->data[n] :
13901                NULL;
13902         const reg_trie_data * const trie
13903             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
13904         
13905         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
13906         DEBUG_TRIE_COMPILE_r(
13907             Perl_sv_catpvf(aTHX_ sv,
13908                 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
13909                 (UV)trie->startstate,
13910                 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
13911                 (UV)trie->wordcount,
13912                 (UV)trie->minlen,
13913                 (UV)trie->maxlen,
13914                 (UV)TRIE_CHARCOUNT(trie),
13915                 (UV)trie->uniquecharcount
13916             )
13917         );
13918         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
13919             int i;
13920             int rangestart = -1;
13921             U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
13922             sv_catpvs(sv, "[");
13923             for (i = 0; i <= 256; i++) {
13924                 if (i < 256 && BITMAP_TEST(bitmap,i)) {
13925                     if (rangestart == -1)
13926                         rangestart = i;
13927                 } else if (rangestart != -1) {
13928                     if (i <= rangestart + 3)
13929                         for (; rangestart < i; rangestart++)
13930                             put_byte(sv, rangestart);
13931                     else {
13932                         put_byte(sv, rangestart);
13933                         sv_catpvs(sv, "-");
13934                         put_byte(sv, i - 1);
13935                     }
13936                     rangestart = -1;
13937                 }
13938             }
13939             sv_catpvs(sv, "]");
13940         } 
13941          
13942     } else if (k == CURLY) {
13943         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
13944             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
13945         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
13946     }
13947     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
13948         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
13949     else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
13950         Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
13951         if ( RXp_PAREN_NAMES(prog) ) {
13952             if ( k != REF || (OP(o) < NREF)) {
13953                 AV *list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
13954                 SV **name= av_fetch(list, ARG(o), 0 );
13955                 if (name)
13956                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
13957             }       
13958             else {
13959                 AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]);
13960                 SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]);
13961                 I32 *nums=(I32*)SvPVX(sv_dat);
13962                 SV **name= av_fetch(list, nums[0], 0 );
13963                 I32 n;
13964                 if (name) {
13965                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
13966                         Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
13967                                     (n ? "," : ""), (IV)nums[n]);
13968                     }
13969                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
13970                 }
13971             }
13972         }            
13973     } else if (k == GOSUB) 
13974         Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
13975     else if (k == VERB) {
13976         if (!o->flags) 
13977             Perl_sv_catpvf(aTHX_ sv, ":%"SVf, 
13978                            SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
13979     } else if (k == LOGICAL)
13980         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);     /* 2: embedded, otherwise 1 */
13981     else if (k == ANYOF) {
13982         int i, rangestart = -1;
13983         const U8 flags = ANYOF_FLAGS(o);
13984         int do_sep = 0;
13985
13986
13987         if (flags & ANYOF_LOCALE)
13988             sv_catpvs(sv, "{loc}");
13989         if (flags & ANYOF_LOC_FOLD)
13990             sv_catpvs(sv, "{i}");
13991         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
13992         if (flags & ANYOF_INVERT)
13993             sv_catpvs(sv, "^");
13994
13995         /* output what the standard cp 0-255 bitmap matches */
13996         for (i = 0; i <= 256; i++) {
13997             if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
13998                 if (rangestart == -1)
13999                     rangestart = i;
14000             } else if (rangestart != -1) {
14001                 if (i <= rangestart + 3)
14002                     for (; rangestart < i; rangestart++)
14003                         put_byte(sv, rangestart);
14004                 else {
14005                     put_byte(sv, rangestart);
14006                     sv_catpvs(sv, "-");
14007                     put_byte(sv, i - 1);
14008                 }
14009                 do_sep = 1;
14010                 rangestart = -1;
14011             }
14012         }
14013         
14014         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
14015         /* output any special charclass tests (used entirely under use locale) */
14016         if (ANYOF_CLASS_TEST_ANY_SET(o))
14017             for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
14018                 if (ANYOF_CLASS_TEST(o,i)) {
14019                     sv_catpv(sv, anyofs[i]);
14020                     do_sep = 1;
14021                 }
14022         
14023         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
14024         
14025         if (flags & ANYOF_NON_UTF8_LATIN1_ALL) {
14026             sv_catpvs(sv, "{non-utf8-latin1-all}");
14027         }
14028
14029         /* output information about the unicode matching */
14030         if (flags & ANYOF_UNICODE_ALL)
14031             sv_catpvs(sv, "{unicode_all}");
14032         else if (ANYOF_NONBITMAP(o))
14033             sv_catpvs(sv, "{unicode}");
14034         if (flags & ANYOF_NONBITMAP_NON_UTF8)
14035             sv_catpvs(sv, "{outside bitmap}");
14036
14037         if (ANYOF_NONBITMAP(o)) {
14038             SV *lv; /* Set if there is something outside the bit map */
14039             SV * const sw = regclass_swash(prog, o, FALSE, &lv, NULL);
14040             bool byte_output = FALSE;   /* If something in the bitmap has been
14041                                            output */
14042
14043             if (lv && lv != &PL_sv_undef) {
14044                 if (sw) {
14045                     U8 s[UTF8_MAXBYTES_CASE+1];
14046
14047                     for (i = 0; i <= 256; i++) { /* Look at chars in bitmap */
14048                         uvchr_to_utf8(s, i);
14049
14050                         if (i < 256
14051                             && ! ANYOF_BITMAP_TEST(o, i)    /* Don't duplicate
14052                                                                things already
14053                                                                output as part
14054                                                                of the bitmap */
14055                             && swash_fetch(sw, s, TRUE))
14056                         {
14057                             if (rangestart == -1)
14058                                 rangestart = i;
14059                         } else if (rangestart != -1) {
14060                             byte_output = TRUE;
14061                             if (i <= rangestart + 3)
14062                                 for (; rangestart < i; rangestart++) {
14063                                     put_byte(sv, rangestart);
14064                                 }
14065                             else {
14066                                 put_byte(sv, rangestart);
14067                                 sv_catpvs(sv, "-");
14068                                 put_byte(sv, i-1);
14069                             }
14070                             rangestart = -1;
14071                         }
14072                     }
14073                 }
14074
14075                 {
14076                     char *s = savesvpv(lv);
14077                     char * const origs = s;
14078
14079                     while (*s && *s != '\n')
14080                         s++;
14081
14082                     if (*s == '\n') {
14083                         const char * const t = ++s;
14084
14085                         if (byte_output) {
14086                             sv_catpvs(sv, " ");
14087                         }
14088
14089                         while (*s) {
14090                             if (*s == '\n') {
14091
14092                                 /* Truncate very long output */
14093                                 if (s - origs > 256) {
14094                                     Perl_sv_catpvf(aTHX_ sv,
14095                                                    "%.*s...",
14096                                                    (int) (s - origs - 1),
14097                                                    t);
14098                                     goto out_dump;
14099                                 }
14100                                 *s = ' ';
14101                             }
14102                             else if (*s == '\t') {
14103                                 *s = '-';
14104                             }
14105                             s++;
14106                         }
14107                         if (s[-1] == ' ')
14108                             s[-1] = 0;
14109
14110                         sv_catpv(sv, t);
14111                     }
14112
14113                 out_dump:
14114
14115                     Safefree(origs);
14116                 }
14117                 SvREFCNT_dec(lv);
14118             }
14119         }
14120
14121         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
14122     }
14123     else if (k == POSIXD || k == NPOSIXD) {
14124         U8 index = FLAGS(o) * 2;
14125         if (index > (sizeof(anyofs) / sizeof(anyofs[0]))) {
14126             Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
14127         }
14128         else {
14129             sv_catpv(sv, anyofs[index]);
14130         }
14131     }
14132     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
14133         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
14134 #else
14135     PERL_UNUSED_CONTEXT;
14136     PERL_UNUSED_ARG(sv);
14137     PERL_UNUSED_ARG(o);
14138     PERL_UNUSED_ARG(prog);
14139 #endif  /* DEBUGGING */
14140 }
14141
14142 SV *
14143 Perl_re_intuit_string(pTHX_ REGEXP * const r)
14144 {                               /* Assume that RE_INTUIT is set */
14145     dVAR;
14146     struct regexp *const prog = ReANY(r);
14147     GET_RE_DEBUG_FLAGS_DECL;
14148
14149     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
14150     PERL_UNUSED_CONTEXT;
14151
14152     DEBUG_COMPILE_r(
14153         {
14154             const char * const s = SvPV_nolen_const(prog->check_substr
14155                       ? prog->check_substr : prog->check_utf8);
14156
14157             if (!PL_colorset) reginitcolors();
14158             PerlIO_printf(Perl_debug_log,
14159                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
14160                       PL_colors[4],
14161                       prog->check_substr ? "" : "utf8 ",
14162                       PL_colors[5],PL_colors[0],
14163                       s,
14164                       PL_colors[1],
14165                       (strlen(s) > 60 ? "..." : ""));
14166         } );
14167
14168     return prog->check_substr ? prog->check_substr : prog->check_utf8;
14169 }
14170
14171 /* 
14172    pregfree() 
14173    
14174    handles refcounting and freeing the perl core regexp structure. When 
14175    it is necessary to actually free the structure the first thing it 
14176    does is call the 'free' method of the regexp_engine associated to
14177    the regexp, allowing the handling of the void *pprivate; member 
14178    first. (This routine is not overridable by extensions, which is why 
14179    the extensions free is called first.)
14180    
14181    See regdupe and regdupe_internal if you change anything here. 
14182 */
14183 #ifndef PERL_IN_XSUB_RE
14184 void
14185 Perl_pregfree(pTHX_ REGEXP *r)
14186 {
14187     SvREFCNT_dec(r);
14188 }
14189
14190 void
14191 Perl_pregfree2(pTHX_ REGEXP *rx)
14192 {
14193     dVAR;
14194     struct regexp *const r = ReANY(rx);
14195     GET_RE_DEBUG_FLAGS_DECL;
14196
14197     PERL_ARGS_ASSERT_PREGFREE2;
14198
14199     if (r->mother_re) {
14200         ReREFCNT_dec(r->mother_re);
14201     } else {
14202         CALLREGFREE_PVT(rx); /* free the private data */
14203         SvREFCNT_dec(RXp_PAREN_NAMES(r));
14204         Safefree(r->xpv_len_u.xpvlenu_pv);
14205     }        
14206     if (r->substrs) {
14207         SvREFCNT_dec(r->anchored_substr);
14208         SvREFCNT_dec(r->anchored_utf8);
14209         SvREFCNT_dec(r->float_substr);
14210         SvREFCNT_dec(r->float_utf8);
14211         Safefree(r->substrs);
14212     }
14213     RX_MATCH_COPY_FREE(rx);
14214 #ifdef PERL_ANY_COW
14215     SvREFCNT_dec(r->saved_copy);
14216 #endif
14217     Safefree(r->offs);
14218     SvREFCNT_dec(r->qr_anoncv);
14219     rx->sv_u.svu_rx = 0;
14220 }
14221
14222 /*  reg_temp_copy()
14223     
14224     This is a hacky workaround to the structural issue of match results
14225     being stored in the regexp structure which is in turn stored in
14226     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
14227     could be PL_curpm in multiple contexts, and could require multiple
14228     result sets being associated with the pattern simultaneously, such
14229     as when doing a recursive match with (??{$qr})
14230     
14231     The solution is to make a lightweight copy of the regexp structure 
14232     when a qr// is returned from the code executed by (??{$qr}) this
14233     lightweight copy doesn't actually own any of its data except for
14234     the starp/end and the actual regexp structure itself. 
14235     
14236 */    
14237     
14238     
14239 REGEXP *
14240 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
14241 {
14242     struct regexp *ret;
14243     struct regexp *const r = ReANY(rx);
14244     const bool islv = ret_x && SvTYPE(ret_x) == SVt_PVLV;
14245
14246     PERL_ARGS_ASSERT_REG_TEMP_COPY;
14247
14248     if (!ret_x)
14249         ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
14250     else {
14251         SvOK_off((SV *)ret_x);
14252         if (islv) {
14253             /* For PVLVs, SvANY points to the xpvlv body while sv_u points
14254                to the regexp.  (For SVt_REGEXPs, sv_upgrade has already
14255                made both spots point to the same regexp body.) */
14256             REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
14257             assert(!SvPVX(ret_x));
14258             ret_x->sv_u.svu_rx = temp->sv_any;
14259             temp->sv_any = NULL;
14260             SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
14261             SvREFCNT_dec(temp);
14262             /* SvCUR still resides in the xpvlv struct, so the regexp copy-
14263                ing below will not set it. */
14264             SvCUR_set(ret_x, SvCUR(rx));
14265         }
14266     }
14267     /* This ensures that SvTHINKFIRST(sv) is true, and hence that
14268        sv_force_normal(sv) is called.  */
14269     SvFAKE_on(ret_x);
14270     ret = ReANY(ret_x);
14271     
14272     SvFLAGS(ret_x) |= SvUTF8(rx);
14273     /* We share the same string buffer as the original regexp, on which we
14274        hold a reference count, incremented when mother_re is set below.
14275        The string pointer is copied here, being part of the regexp struct.
14276      */
14277     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
14278            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
14279     if (r->offs) {
14280         const I32 npar = r->nparens+1;
14281         Newx(ret->offs, npar, regexp_paren_pair);
14282         Copy(r->offs, ret->offs, npar, regexp_paren_pair);
14283     }
14284     if (r->substrs) {
14285         Newx(ret->substrs, 1, struct reg_substr_data);
14286         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
14287
14288         SvREFCNT_inc_void(ret->anchored_substr);
14289         SvREFCNT_inc_void(ret->anchored_utf8);
14290         SvREFCNT_inc_void(ret->float_substr);
14291         SvREFCNT_inc_void(ret->float_utf8);
14292
14293         /* check_substr and check_utf8, if non-NULL, point to either their
14294            anchored or float namesakes, and don't hold a second reference.  */
14295     }
14296     RX_MATCH_COPIED_off(ret_x);
14297 #ifdef PERL_ANY_COW
14298     ret->saved_copy = NULL;
14299 #endif
14300     ret->mother_re = ReREFCNT_inc(r->mother_re ? r->mother_re : rx);
14301     SvREFCNT_inc_void(ret->qr_anoncv);
14302     
14303     return ret_x;
14304 }
14305 #endif
14306
14307 /* regfree_internal() 
14308
14309    Free the private data in a regexp. This is overloadable by 
14310    extensions. Perl takes care of the regexp structure in pregfree(), 
14311    this covers the *pprivate pointer which technically perl doesn't 
14312    know about, however of course we have to handle the 
14313    regexp_internal structure when no extension is in use. 
14314    
14315    Note this is called before freeing anything in the regexp 
14316    structure. 
14317  */
14318  
14319 void
14320 Perl_regfree_internal(pTHX_ REGEXP * const rx)
14321 {
14322     dVAR;
14323     struct regexp *const r = ReANY(rx);
14324     RXi_GET_DECL(r,ri);
14325     GET_RE_DEBUG_FLAGS_DECL;
14326
14327     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
14328
14329     DEBUG_COMPILE_r({
14330         if (!PL_colorset)
14331             reginitcolors();
14332         {
14333             SV *dsv= sv_newmortal();
14334             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
14335                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
14336             PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n", 
14337                 PL_colors[4],PL_colors[5],s);
14338         }
14339     });
14340 #ifdef RE_TRACK_PATTERN_OFFSETS
14341     if (ri->u.offsets)
14342         Safefree(ri->u.offsets);             /* 20010421 MJD */
14343 #endif
14344     if (ri->code_blocks) {
14345         int n;
14346         for (n = 0; n < ri->num_code_blocks; n++)
14347             SvREFCNT_dec(ri->code_blocks[n].src_regex);
14348         Safefree(ri->code_blocks);
14349     }
14350
14351     if (ri->data) {
14352         int n = ri->data->count;
14353
14354         while (--n >= 0) {
14355           /* If you add a ->what type here, update the comment in regcomp.h */
14356             switch (ri->data->what[n]) {
14357             case 'a':
14358             case 'r':
14359             case 's':
14360             case 'S':
14361             case 'u':
14362                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
14363                 break;
14364             case 'f':
14365                 Safefree(ri->data->data[n]);
14366                 break;
14367             case 'l':
14368             case 'L':
14369                 break;
14370             case 'T':           
14371                 { /* Aho Corasick add-on structure for a trie node.
14372                      Used in stclass optimization only */
14373                     U32 refcount;
14374                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
14375                     OP_REFCNT_LOCK;
14376                     refcount = --aho->refcount;
14377                     OP_REFCNT_UNLOCK;
14378                     if ( !refcount ) {
14379                         PerlMemShared_free(aho->states);
14380                         PerlMemShared_free(aho->fail);
14381                          /* do this last!!!! */
14382                         PerlMemShared_free(ri->data->data[n]);
14383                         PerlMemShared_free(ri->regstclass);
14384                     }
14385                 }
14386                 break;
14387             case 't':
14388                 {
14389                     /* trie structure. */
14390                     U32 refcount;
14391                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
14392                     OP_REFCNT_LOCK;
14393                     refcount = --trie->refcount;
14394                     OP_REFCNT_UNLOCK;
14395                     if ( !refcount ) {
14396                         PerlMemShared_free(trie->charmap);
14397                         PerlMemShared_free(trie->states);
14398                         PerlMemShared_free(trie->trans);
14399                         if (trie->bitmap)
14400                             PerlMemShared_free(trie->bitmap);
14401                         if (trie->jump)
14402                             PerlMemShared_free(trie->jump);
14403                         PerlMemShared_free(trie->wordinfo);
14404                         /* do this last!!!! */
14405                         PerlMemShared_free(ri->data->data[n]);
14406                     }
14407                 }
14408                 break;
14409             default:
14410                 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
14411             }
14412         }
14413         Safefree(ri->data->what);
14414         Safefree(ri->data);
14415     }
14416
14417     Safefree(ri);
14418 }
14419
14420 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
14421 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
14422 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
14423
14424 /* 
14425    re_dup - duplicate a regexp. 
14426    
14427    This routine is expected to clone a given regexp structure. It is only
14428    compiled under USE_ITHREADS.
14429
14430    After all of the core data stored in struct regexp is duplicated
14431    the regexp_engine.dupe method is used to copy any private data
14432    stored in the *pprivate pointer. This allows extensions to handle
14433    any duplication it needs to do.
14434
14435    See pregfree() and regfree_internal() if you change anything here. 
14436 */
14437 #if defined(USE_ITHREADS)
14438 #ifndef PERL_IN_XSUB_RE
14439 void
14440 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
14441 {
14442     dVAR;
14443     I32 npar;
14444     const struct regexp *r = ReANY(sstr);
14445     struct regexp *ret = ReANY(dstr);
14446     
14447     PERL_ARGS_ASSERT_RE_DUP_GUTS;
14448
14449     npar = r->nparens+1;
14450     Newx(ret->offs, npar, regexp_paren_pair);
14451     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
14452     if(ret->swap) {
14453         /* no need to copy these */
14454         Newx(ret->swap, npar, regexp_paren_pair);
14455     }
14456
14457     if (ret->substrs) {
14458         /* Do it this way to avoid reading from *r after the StructCopy().
14459            That way, if any of the sv_dup_inc()s dislodge *r from the L1
14460            cache, it doesn't matter.  */
14461         const bool anchored = r->check_substr
14462             ? r->check_substr == r->anchored_substr
14463             : r->check_utf8 == r->anchored_utf8;
14464         Newx(ret->substrs, 1, struct reg_substr_data);
14465         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
14466
14467         ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
14468         ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
14469         ret->float_substr = sv_dup_inc(ret->float_substr, param);
14470         ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
14471
14472         /* check_substr and check_utf8, if non-NULL, point to either their
14473            anchored or float namesakes, and don't hold a second reference.  */
14474
14475         if (ret->check_substr) {
14476             if (anchored) {
14477                 assert(r->check_utf8 == r->anchored_utf8);
14478                 ret->check_substr = ret->anchored_substr;
14479                 ret->check_utf8 = ret->anchored_utf8;
14480             } else {
14481                 assert(r->check_substr == r->float_substr);
14482                 assert(r->check_utf8 == r->float_utf8);
14483                 ret->check_substr = ret->float_substr;
14484                 ret->check_utf8 = ret->float_utf8;
14485             }
14486         } else if (ret->check_utf8) {
14487             if (anchored) {
14488                 ret->check_utf8 = ret->anchored_utf8;
14489             } else {
14490                 ret->check_utf8 = ret->float_utf8;
14491             }
14492         }
14493     }
14494
14495     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
14496     ret->qr_anoncv = MUTABLE_CV(sv_dup_inc((const SV *)ret->qr_anoncv, param));
14497
14498     if (ret->pprivate)
14499         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
14500
14501     if (RX_MATCH_COPIED(dstr))
14502         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
14503     else
14504         ret->subbeg = NULL;
14505 #ifdef PERL_ANY_COW
14506     ret->saved_copy = NULL;
14507 #endif
14508
14509     /* Whether mother_re be set or no, we need to copy the string.  We
14510        cannot refrain from copying it when the storage points directly to
14511        our mother regexp, because that's
14512                1: a buffer in a different thread
14513                2: something we no longer hold a reference on
14514                so we need to copy it locally.  */
14515     RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED(sstr), SvCUR(sstr)+1);
14516     ret->mother_re   = NULL;
14517     ret->gofs = 0;
14518 }
14519 #endif /* PERL_IN_XSUB_RE */
14520
14521 /*
14522    regdupe_internal()
14523    
14524    This is the internal complement to regdupe() which is used to copy
14525    the structure pointed to by the *pprivate pointer in the regexp.
14526    This is the core version of the extension overridable cloning hook.
14527    The regexp structure being duplicated will be copied by perl prior
14528    to this and will be provided as the regexp *r argument, however 
14529    with the /old/ structures pprivate pointer value. Thus this routine
14530    may override any copying normally done by perl.
14531    
14532    It returns a pointer to the new regexp_internal structure.
14533 */
14534
14535 void *
14536 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
14537 {
14538     dVAR;
14539     struct regexp *const r = ReANY(rx);
14540     regexp_internal *reti;
14541     int len;
14542     RXi_GET_DECL(r,ri);
14543
14544     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
14545     
14546     len = ProgLen(ri);
14547     
14548     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), char, regexp_internal);
14549     Copy(ri->program, reti->program, len+1, regnode);
14550
14551     reti->num_code_blocks = ri->num_code_blocks;
14552     if (ri->code_blocks) {
14553         int n;
14554         Newxc(reti->code_blocks, ri->num_code_blocks, struct reg_code_block,
14555                 struct reg_code_block);
14556         Copy(ri->code_blocks, reti->code_blocks, ri->num_code_blocks,
14557                 struct reg_code_block);
14558         for (n = 0; n < ri->num_code_blocks; n++)
14559              reti->code_blocks[n].src_regex = (REGEXP*)
14560                     sv_dup_inc((SV*)(ri->code_blocks[n].src_regex), param);
14561     }
14562     else
14563         reti->code_blocks = NULL;
14564
14565     reti->regstclass = NULL;
14566
14567     if (ri->data) {
14568         struct reg_data *d;
14569         const int count = ri->data->count;
14570         int i;
14571
14572         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
14573                 char, struct reg_data);
14574         Newx(d->what, count, U8);
14575
14576         d->count = count;
14577         for (i = 0; i < count; i++) {
14578             d->what[i] = ri->data->what[i];
14579             switch (d->what[i]) {
14580                 /* see also regcomp.h and regfree_internal() */
14581             case 'a': /* actually an AV, but the dup function is identical.  */
14582             case 'r':
14583             case 's':
14584             case 'S':
14585             case 'u': /* actually an HV, but the dup function is identical.  */
14586                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
14587                 break;
14588             case 'f':
14589                 /* This is cheating. */
14590                 Newx(d->data[i], 1, struct regnode_charclass_class);
14591                 StructCopy(ri->data->data[i], d->data[i],
14592                             struct regnode_charclass_class);
14593                 reti->regstclass = (regnode*)d->data[i];
14594                 break;
14595             case 'T':
14596                 /* Trie stclasses are readonly and can thus be shared
14597                  * without duplication. We free the stclass in pregfree
14598                  * when the corresponding reg_ac_data struct is freed.
14599                  */
14600                 reti->regstclass= ri->regstclass;
14601                 /* Fall through */
14602             case 't':
14603                 OP_REFCNT_LOCK;
14604                 ((reg_trie_data*)ri->data->data[i])->refcount++;
14605                 OP_REFCNT_UNLOCK;
14606                 /* Fall through */
14607             case 'l':
14608             case 'L':
14609                 d->data[i] = ri->data->data[i];
14610                 break;
14611             default:
14612                 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
14613             }
14614         }
14615
14616         reti->data = d;
14617     }
14618     else
14619         reti->data = NULL;
14620
14621     reti->name_list_idx = ri->name_list_idx;
14622
14623 #ifdef RE_TRACK_PATTERN_OFFSETS
14624     if (ri->u.offsets) {
14625         Newx(reti->u.offsets, 2*len+1, U32);
14626         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
14627     }
14628 #else
14629     SetProgLen(reti,len);
14630 #endif
14631
14632     return (void*)reti;
14633 }
14634
14635 #endif    /* USE_ITHREADS */
14636
14637 #ifndef PERL_IN_XSUB_RE
14638
14639 /*
14640  - regnext - dig the "next" pointer out of a node
14641  */
14642 regnode *
14643 Perl_regnext(pTHX_ regnode *p)
14644 {
14645     dVAR;
14646     I32 offset;
14647
14648     if (!p)
14649         return(NULL);
14650
14651     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
14652         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(p), (int)REGNODE_MAX);
14653     }
14654
14655     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
14656     if (offset == 0)
14657         return(NULL);
14658
14659     return(p+offset);
14660 }
14661 #endif
14662
14663 STATIC void
14664 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
14665 {
14666     va_list args;
14667     STRLEN l1 = strlen(pat1);
14668     STRLEN l2 = strlen(pat2);
14669     char buf[512];
14670     SV *msv;
14671     const char *message;
14672
14673     PERL_ARGS_ASSERT_RE_CROAK2;
14674
14675     if (l1 > 510)
14676         l1 = 510;
14677     if (l1 + l2 > 510)
14678         l2 = 510 - l1;
14679     Copy(pat1, buf, l1 , char);
14680     Copy(pat2, buf + l1, l2 , char);
14681     buf[l1 + l2] = '\n';
14682     buf[l1 + l2 + 1] = '\0';
14683 #ifdef I_STDARG
14684     /* ANSI variant takes additional second argument */
14685     va_start(args, pat2);
14686 #else
14687     va_start(args);
14688 #endif
14689     msv = vmess(buf, &args);
14690     va_end(args);
14691     message = SvPV_const(msv,l1);
14692     if (l1 > 512)
14693         l1 = 512;
14694     Copy(message, buf, l1 , char);
14695     buf[l1-1] = '\0';                   /* Overwrite \n */
14696     Perl_croak(aTHX_ "%s", buf);
14697 }
14698
14699 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
14700
14701 #ifndef PERL_IN_XSUB_RE
14702 void
14703 Perl_save_re_context(pTHX)
14704 {
14705     dVAR;
14706
14707     struct re_save_state *state;
14708
14709     SAVEVPTR(PL_curcop);
14710     SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
14711
14712     state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
14713     PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
14714     SSPUSHUV(SAVEt_RE_STATE);
14715
14716     Copy(&PL_reg_state, state, 1, struct re_save_state);
14717
14718     PL_reg_oldsaved = NULL;
14719     PL_reg_oldsavedlen = 0;
14720     PL_reg_oldsavedoffset = 0;
14721     PL_reg_oldsavedcoffset = 0;
14722     PL_reg_maxiter = 0;
14723     PL_reg_leftiter = 0;
14724     PL_reg_poscache = NULL;
14725     PL_reg_poscache_size = 0;
14726 #ifdef PERL_ANY_COW
14727     PL_nrs = NULL;
14728 #endif
14729
14730     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
14731     if (PL_curpm) {
14732         const REGEXP * const rx = PM_GETRE(PL_curpm);
14733         if (rx) {
14734             U32 i;
14735             for (i = 1; i <= RX_NPARENS(rx); i++) {
14736                 char digits[TYPE_CHARS(long)];
14737                 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
14738                 GV *const *const gvp
14739                     = (GV**)hv_fetch(PL_defstash, digits, len, 0);
14740
14741                 if (gvp) {
14742                     GV * const gv = *gvp;
14743                     if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
14744                         save_scalar(gv);
14745                 }
14746             }
14747         }
14748     }
14749 }
14750 #endif
14751
14752 #ifdef DEBUGGING
14753
14754 STATIC void
14755 S_put_byte(pTHX_ SV *sv, int c)
14756 {
14757     PERL_ARGS_ASSERT_PUT_BYTE;
14758
14759     /* Our definition of isPRINT() ignores locales, so only bytes that are
14760        not part of UTF-8 are considered printable. I assume that the same
14761        holds for UTF-EBCDIC.
14762        Also, code point 255 is not printable in either (it's E0 in EBCDIC,
14763        which Wikipedia says:
14764
14765        EO, or Eight Ones, is an 8-bit EBCDIC character code represented as all
14766        ones (binary 1111 1111, hexadecimal FF). It is similar, but not
14767        identical, to the ASCII delete (DEL) or rubout control character.
14768        ) So the old condition can be simplified to !isPRINT(c)  */
14769     if (!isPRINT(c)) {
14770         if (c < 256) {
14771             Perl_sv_catpvf(aTHX_ sv, "\\x%02x", c);
14772         }
14773         else {
14774             Perl_sv_catpvf(aTHX_ sv, "\\x{%x}", c);
14775         }
14776     }
14777     else {
14778         const char string = c;
14779         if (c == '-' || c == ']' || c == '\\' || c == '^')
14780             sv_catpvs(sv, "\\");
14781         sv_catpvn(sv, &string, 1);
14782     }
14783 }
14784
14785
14786 #define CLEAR_OPTSTART \
14787     if (optstart) STMT_START { \
14788             DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
14789             optstart=NULL; \
14790     } STMT_END
14791
14792 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
14793
14794 STATIC const regnode *
14795 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
14796             const regnode *last, const regnode *plast, 
14797             SV* sv, I32 indent, U32 depth)
14798 {
14799     dVAR;
14800     U8 op = PSEUDO;     /* Arbitrary non-END op. */
14801     const regnode *next;
14802     const regnode *optstart= NULL;
14803     
14804     RXi_GET_DECL(r,ri);
14805     GET_RE_DEBUG_FLAGS_DECL;
14806
14807     PERL_ARGS_ASSERT_DUMPUNTIL;
14808
14809 #ifdef DEBUG_DUMPUNTIL
14810     PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
14811         last ? last-start : 0,plast ? plast-start : 0);
14812 #endif
14813             
14814     if (plast && plast < last) 
14815         last= plast;
14816
14817     while (PL_regkind[op] != END && (!last || node < last)) {
14818         /* While that wasn't END last time... */
14819         NODE_ALIGN(node);
14820         op = OP(node);
14821         if (op == CLOSE || op == WHILEM)
14822             indent--;
14823         next = regnext((regnode *)node);
14824
14825         /* Where, what. */
14826         if (OP(node) == OPTIMIZED) {
14827             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
14828                 optstart = node;
14829             else
14830                 goto after_print;
14831         } else
14832             CLEAR_OPTSTART;
14833
14834         regprop(r, sv, node);
14835         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
14836                       (int)(2*indent + 1), "", SvPVX_const(sv));
14837         
14838         if (OP(node) != OPTIMIZED) {                  
14839             if (next == NULL)           /* Next ptr. */
14840                 PerlIO_printf(Perl_debug_log, " (0)");
14841             else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
14842                 PerlIO_printf(Perl_debug_log, " (FAIL)");
14843             else 
14844                 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
14845             (void)PerlIO_putc(Perl_debug_log, '\n'); 
14846         }
14847         
14848       after_print:
14849         if (PL_regkind[(U8)op] == BRANCHJ) {
14850             assert(next);
14851             {
14852                 const regnode *nnode = (OP(next) == LONGJMP
14853                                        ? regnext((regnode *)next)
14854                                        : next);
14855                 if (last && nnode > last)
14856                     nnode = last;
14857                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
14858             }
14859         }
14860         else if (PL_regkind[(U8)op] == BRANCH) {
14861             assert(next);
14862             DUMPUNTIL(NEXTOPER(node), next);
14863         }
14864         else if ( PL_regkind[(U8)op]  == TRIE ) {
14865             const regnode *this_trie = node;
14866             const char op = OP(node);
14867             const U32 n = ARG(node);
14868             const reg_ac_data * const ac = op>=AHOCORASICK ?
14869                (reg_ac_data *)ri->data->data[n] :
14870                NULL;
14871             const reg_trie_data * const trie =
14872                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
14873 #ifdef DEBUGGING
14874             AV *const trie_words = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
14875 #endif
14876             const regnode *nextbranch= NULL;
14877             I32 word_idx;
14878             sv_setpvs(sv, "");
14879             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
14880                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
14881
14882                 PerlIO_printf(Perl_debug_log, "%*s%s ",
14883                    (int)(2*(indent+3)), "",
14884                     elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
14885                             PL_colors[0], PL_colors[1],
14886                             (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
14887                             PERL_PV_PRETTY_ELLIPSES    |
14888                             PERL_PV_PRETTY_LTGT
14889                             )
14890                             : "???"
14891                 );
14892                 if (trie->jump) {
14893                     U16 dist= trie->jump[word_idx+1];
14894                     PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
14895                                   (UV)((dist ? this_trie + dist : next) - start));
14896                     if (dist) {
14897                         if (!nextbranch)
14898                             nextbranch= this_trie + trie->jump[0];    
14899                         DUMPUNTIL(this_trie + dist, nextbranch);
14900                     }
14901                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
14902                         nextbranch= regnext((regnode *)nextbranch);
14903                 } else {
14904                     PerlIO_printf(Perl_debug_log, "\n");
14905                 }
14906             }
14907             if (last && next > last)
14908                 node= last;
14909             else
14910                 node= next;
14911         }
14912         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
14913             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
14914                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
14915         }
14916         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
14917             assert(next);
14918             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
14919         }
14920         else if ( op == PLUS || op == STAR) {
14921             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
14922         }
14923         else if (PL_regkind[(U8)op] == ANYOF) {
14924             /* arglen 1 + class block */
14925             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_CLASS)
14926                     ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
14927             node = NEXTOPER(node);
14928         }
14929         else if (PL_regkind[(U8)op] == EXACT) {
14930             /* Literal string, where present. */
14931             node += NODE_SZ_STR(node) - 1;
14932             node = NEXTOPER(node);
14933         }
14934         else {
14935             node = NEXTOPER(node);
14936             node += regarglen[(U8)op];
14937         }
14938         if (op == CURLYX || op == OPEN)
14939             indent++;
14940     }
14941     CLEAR_OPTSTART;
14942 #ifdef DEBUG_DUMPUNTIL    
14943     PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
14944 #endif
14945     return node;
14946 }
14947
14948 #endif  /* DEBUGGING */
14949
14950 /*
14951  * Local variables:
14952  * c-indentation-style: bsd
14953  * c-basic-offset: 4
14954  * indent-tabs-mode: nil
14955  * End:
14956  *
14957  * ex: set ts=8 sts=4 sw=4 et:
14958  */