]> git.vpit.fr Git - perl/modules/re-engine-Hooks.git/blob - src/5013010/regcomp.c
Remove the 5.11 development branch
[perl/modules/re-engine-Hooks.git] / src / 5013010 / 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 #else
85 #  include "regcomp.h"
86 #endif
87
88 #include "dquote_static.c"
89
90 #ifdef op
91 #undef op
92 #endif /* op */
93
94 #ifdef MSDOS
95 #  if defined(BUGGY_MSC6)
96  /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
97 #    pragma optimize("a",off)
98  /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
99 #    pragma optimize("w",on )
100 #  endif /* BUGGY_MSC6 */
101 #endif /* MSDOS */
102
103 #ifndef STATIC
104 #define STATIC  static
105 #endif
106
107 typedef struct RExC_state_t {
108     U32         flags;                  /* are we folding, multilining? */
109     char        *precomp;               /* uncompiled string. */
110     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
111     regexp      *rx;                    /* perl core regexp structure */
112     regexp_internal     *rxi;           /* internal data for regexp object pprivate field */        
113     char        *start;                 /* Start of input for compile */
114     char        *end;                   /* End of input for compile */
115     char        *parse;                 /* Input-scan pointer. */
116     I32         whilem_seen;            /* number of WHILEM in this expr */
117     regnode     *emit_start;            /* Start of emitted-code area */
118     regnode     *emit_bound;            /* First regnode outside of the allocated space */
119     regnode     *emit;                  /* Code-emit pointer; &regdummy = don't = compiling */
120     I32         naughty;                /* How bad is this pattern? */
121     I32         sawback;                /* Did we see \1, ...? */
122     U32         seen;
123     I32         size;                   /* Code size. */
124     I32         npar;                   /* Capture buffer count, (OPEN). */
125     I32         cpar;                   /* Capture buffer count, (CLOSE). */
126     I32         nestroot;               /* root parens we are in - used by accept */
127     I32         extralen;
128     I32         seen_zerolen;
129     I32         seen_evals;
130     regnode     **open_parens;          /* pointers to open parens */
131     regnode     **close_parens;         /* pointers to close parens */
132     regnode     *opend;                 /* END node in program */
133     I32         utf8;           /* whether the pattern is utf8 or not */
134     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
135                                 /* XXX use this for future optimisation of case
136                                  * where pattern must be upgraded to utf8. */
137     I32         uni_semantics;  /* If a d charset modifier should use unicode
138                                    rules, even if the pattern is not in
139                                    utf8 */
140     HV          *paren_names;           /* Paren names */
141     
142     regnode     **recurse;              /* Recurse regops */
143     I32         recurse_count;          /* Number of recurse regops */
144     I32         in_lookbehind;
145 #if ADD_TO_REGEXEC
146     char        *starttry;              /* -Dr: where regtry was called. */
147 #define RExC_starttry   (pRExC_state->starttry)
148 #endif
149 #ifdef DEBUGGING
150     const char  *lastparse;
151     I32         lastnum;
152     AV          *paren_name_list;       /* idx -> name */
153 #define RExC_lastparse  (pRExC_state->lastparse)
154 #define RExC_lastnum    (pRExC_state->lastnum)
155 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
156 #endif
157 } RExC_state_t;
158
159 #define RExC_flags      (pRExC_state->flags)
160 #define RExC_precomp    (pRExC_state->precomp)
161 #define RExC_rx_sv      (pRExC_state->rx_sv)
162 #define RExC_rx         (pRExC_state->rx)
163 #define RExC_rxi        (pRExC_state->rxi)
164 #define RExC_start      (pRExC_state->start)
165 #define RExC_end        (pRExC_state->end)
166 #define RExC_parse      (pRExC_state->parse)
167 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
168 #ifdef RE_TRACK_PATTERN_OFFSETS
169 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the others */
170 #endif
171 #define RExC_emit       (pRExC_state->emit)
172 #define RExC_emit_start (pRExC_state->emit_start)
173 #define RExC_emit_bound (pRExC_state->emit_bound)
174 #define RExC_naughty    (pRExC_state->naughty)
175 #define RExC_sawback    (pRExC_state->sawback)
176 #define RExC_seen       (pRExC_state->seen)
177 #define RExC_size       (pRExC_state->size)
178 #define RExC_npar       (pRExC_state->npar)
179 #define RExC_nestroot   (pRExC_state->nestroot)
180 #define RExC_extralen   (pRExC_state->extralen)
181 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
182 #define RExC_seen_evals (pRExC_state->seen_evals)
183 #define RExC_utf8       (pRExC_state->utf8)
184 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
185 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
186 #define RExC_open_parens        (pRExC_state->open_parens)
187 #define RExC_close_parens       (pRExC_state->close_parens)
188 #define RExC_opend      (pRExC_state->opend)
189 #define RExC_paren_names        (pRExC_state->paren_names)
190 #define RExC_recurse    (pRExC_state->recurse)
191 #define RExC_recurse_count      (pRExC_state->recurse_count)
192 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
193
194
195 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
196 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
197         ((*s) == '{' && regcurly(s)))
198
199 #ifdef SPSTART
200 #undef SPSTART          /* dratted cpp namespace... */
201 #endif
202 /*
203  * Flags to be passed up and down.
204  */
205 #define WORST           0       /* Worst case. */
206 #define HASWIDTH        0x01    /* Known to match non-null strings. */
207
208 /* Simple enough to be STAR/PLUS operand, in an EXACT node must be a single
209  * character, and if utf8, must be invariant.  Note that this is not the same thing as REGNODE_SIMPLE */
210 #define SIMPLE          0x02
211 #define SPSTART         0x04    /* Starts with * or +. */
212 #define TRYAGAIN        0x08    /* Weeded out a declaration. */
213 #define POSTPONED       0x10    /* (?1),(?&name), (??{...}) or similar */
214
215 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
216
217 /* whether trie related optimizations are enabled */
218 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
219 #define TRIE_STUDY_OPT
220 #define FULL_TRIE_STUDY
221 #define TRIE_STCLASS
222 #endif
223
224
225
226 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
227 #define PBITVAL(paren) (1 << ((paren) & 7))
228 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
229 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
230 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
231
232 /* If not already in utf8, do a longjmp back to the beginning */
233 #define UTF8_LONGJMP 42 /* Choose a value not likely to ever conflict */
234 #define REQUIRE_UTF8    STMT_START {                                       \
235                                      if (! UTF) JMPENV_JUMP(UTF8_LONGJMP); \
236                         } STMT_END
237
238 /* About scan_data_t.
239
240   During optimisation we recurse through the regexp program performing
241   various inplace (keyhole style) optimisations. In addition study_chunk
242   and scan_commit populate this data structure with information about
243   what strings MUST appear in the pattern. We look for the longest 
244   string that must appear at a fixed location, and we look for the
245   longest string that may appear at a floating location. So for instance
246   in the pattern:
247   
248     /FOO[xX]A.*B[xX]BAR/
249     
250   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
251   strings (because they follow a .* construct). study_chunk will identify
252   both FOO and BAR as being the longest fixed and floating strings respectively.
253   
254   The strings can be composites, for instance
255   
256      /(f)(o)(o)/
257      
258   will result in a composite fixed substring 'foo'.
259   
260   For each string some basic information is maintained:
261   
262   - offset or min_offset
263     This is the position the string must appear at, or not before.
264     It also implicitly (when combined with minlenp) tells us how many
265     characters must match before the string we are searching for.
266     Likewise when combined with minlenp and the length of the string it
267     tells us how many characters must appear after the string we have 
268     found.
269   
270   - max_offset
271     Only used for floating strings. This is the rightmost point that
272     the string can appear at. If set to I32 max it indicates that the
273     string can occur infinitely far to the right.
274   
275   - minlenp
276     A pointer to the minimum length of the pattern that the string 
277     was found inside. This is important as in the case of positive 
278     lookahead or positive lookbehind we can have multiple patterns 
279     involved. Consider
280     
281     /(?=FOO).*F/
282     
283     The minimum length of the pattern overall is 3, the minimum length
284     of the lookahead part is 3, but the minimum length of the part that
285     will actually match is 1. So 'FOO's minimum length is 3, but the 
286     minimum length for the F is 1. This is important as the minimum length
287     is used to determine offsets in front of and behind the string being 
288     looked for.  Since strings can be composites this is the length of the
289     pattern at the time it was committed with a scan_commit. Note that
290     the length is calculated by study_chunk, so that the minimum lengths
291     are not known until the full pattern has been compiled, thus the 
292     pointer to the value.
293   
294   - lookbehind
295   
296     In the case of lookbehind the string being searched for can be
297     offset past the start point of the final matching string. 
298     If this value was just blithely removed from the min_offset it would
299     invalidate some of the calculations for how many chars must match
300     before or after (as they are derived from min_offset and minlen and
301     the length of the string being searched for). 
302     When the final pattern is compiled and the data is moved from the
303     scan_data_t structure into the regexp structure the information
304     about lookbehind is factored in, with the information that would 
305     have been lost precalculated in the end_shift field for the 
306     associated string.
307
308   The fields pos_min and pos_delta are used to store the minimum offset
309   and the delta to the maximum offset at the current point in the pattern.    
310
311 */
312
313 typedef struct scan_data_t {
314     /*I32 len_min;      unused */
315     /*I32 len_delta;    unused */
316     I32 pos_min;
317     I32 pos_delta;
318     SV *last_found;
319     I32 last_end;           /* min value, <0 unless valid. */
320     I32 last_start_min;
321     I32 last_start_max;
322     SV **longest;           /* Either &l_fixed, or &l_float. */
323     SV *longest_fixed;      /* longest fixed string found in pattern */
324     I32 offset_fixed;       /* offset where it starts */
325     I32 *minlen_fixed;      /* pointer to the minlen relevant to the string */
326     I32 lookbehind_fixed;   /* is the position of the string modfied by LB */
327     SV *longest_float;      /* longest floating string found in pattern */
328     I32 offset_float_min;   /* earliest point in string it can appear */
329     I32 offset_float_max;   /* latest point in string it can appear */
330     I32 *minlen_float;      /* pointer to the minlen relevant to the string */
331     I32 lookbehind_float;   /* is the position of the string modified by LB */
332     I32 flags;
333     I32 whilem_c;
334     I32 *last_closep;
335     struct regnode_charclass_class *start_class;
336 } scan_data_t;
337
338 /*
339  * Forward declarations for pregcomp()'s friends.
340  */
341
342 static const scan_data_t zero_scan_data =
343   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
344
345 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
346 #define SF_BEFORE_SEOL          0x0001
347 #define SF_BEFORE_MEOL          0x0002
348 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
349 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
350
351 #ifdef NO_UNARY_PLUS
352 #  define SF_FIX_SHIFT_EOL      (0+2)
353 #  define SF_FL_SHIFT_EOL               (0+4)
354 #else
355 #  define SF_FIX_SHIFT_EOL      (+2)
356 #  define SF_FL_SHIFT_EOL               (+4)
357 #endif
358
359 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
360 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
361
362 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
363 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
364 #define SF_IS_INF               0x0040
365 #define SF_HAS_PAR              0x0080
366 #define SF_IN_PAR               0x0100
367 #define SF_HAS_EVAL             0x0200
368 #define SCF_DO_SUBSTR           0x0400
369 #define SCF_DO_STCLASS_AND      0x0800
370 #define SCF_DO_STCLASS_OR       0x1000
371 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
372 #define SCF_WHILEM_VISITED_POS  0x2000
373
374 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
375 #define SCF_SEEN_ACCEPT         0x8000 
376
377 #define UTF cBOOL(RExC_utf8)
378 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
379 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
380 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_DEPENDS_CHARSET)
381 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags) >= REGEX_UNICODE_CHARSET)
382 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_RESTRICTED_CHARSET)
383 #define MORE_ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
384 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags) >= REGEX_ASCII_RESTRICTED_CHARSET)
385
386 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
387
388 #define OOB_UNICODE             12345678
389 #define OOB_NAMEDCLASS          -1
390
391 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
392 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
393
394
395 /* length of regex to show in messages that don't mark a position within */
396 #define RegexLengthToShowInErrorMessages 127
397
398 /*
399  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
400  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
401  * op/pragma/warn/regcomp.
402  */
403 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
404 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
405
406 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
407
408 /*
409  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
410  * arg. Show regex, up to a maximum length. If it's too long, chop and add
411  * "...".
412  */
413 #define _FAIL(code) STMT_START {                                        \
414     const char *ellipses = "";                                          \
415     IV len = RExC_end - RExC_precomp;                                   \
416                                                                         \
417     if (!SIZE_ONLY)                                                     \
418         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);                   \
419     if (len > RegexLengthToShowInErrorMessages) {                       \
420         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
421         len = RegexLengthToShowInErrorMessages - 10;                    \
422         ellipses = "...";                                               \
423     }                                                                   \
424     code;                                                               \
425 } STMT_END
426
427 #define FAIL(msg) _FAIL(                            \
428     Perl_croak(aTHX_ "%s in regex m/%.*s%s/",       \
429             msg, (int)len, RExC_precomp, ellipses))
430
431 #define FAIL2(msg,arg) _FAIL(                       \
432     Perl_croak(aTHX_ msg " in regex m/%.*s%s/",     \
433             arg, (int)len, RExC_precomp, ellipses))
434
435 /*
436  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
437  */
438 #define Simple_vFAIL(m) STMT_START {                                    \
439     const IV offset = RExC_parse - RExC_precomp;                        \
440     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
441             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
442 } STMT_END
443
444 /*
445  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
446  */
447 #define vFAIL(m) STMT_START {                           \
448     if (!SIZE_ONLY)                                     \
449         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);   \
450     Simple_vFAIL(m);                                    \
451 } STMT_END
452
453 /*
454  * Like Simple_vFAIL(), but accepts two arguments.
455  */
456 #define Simple_vFAIL2(m,a1) STMT_START {                        \
457     const IV offset = RExC_parse - RExC_precomp;                        \
458     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1,                   \
459             (int)offset, RExC_precomp, RExC_precomp + offset);  \
460 } STMT_END
461
462 /*
463  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
464  */
465 #define vFAIL2(m,a1) STMT_START {                       \
466     if (!SIZE_ONLY)                                     \
467         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);   \
468     Simple_vFAIL2(m, a1);                               \
469 } STMT_END
470
471
472 /*
473  * Like Simple_vFAIL(), but accepts three arguments.
474  */
475 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
476     const IV offset = RExC_parse - RExC_precomp;                \
477     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2,               \
478             (int)offset, RExC_precomp, RExC_precomp + offset);  \
479 } STMT_END
480
481 /*
482  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
483  */
484 #define vFAIL3(m,a1,a2) STMT_START {                    \
485     if (!SIZE_ONLY)                                     \
486         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);   \
487     Simple_vFAIL3(m, a1, a2);                           \
488 } STMT_END
489
490 /*
491  * Like Simple_vFAIL(), but accepts four arguments.
492  */
493 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
494     const IV offset = RExC_parse - RExC_precomp;                \
495     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3,           \
496             (int)offset, RExC_precomp, RExC_precomp + offset);  \
497 } STMT_END
498
499 #define ckWARNreg(loc,m) STMT_START {                                   \
500     const IV offset = loc - RExC_precomp;                               \
501     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
502             (int)offset, RExC_precomp, RExC_precomp + offset);          \
503 } STMT_END
504
505 #define ckWARNregdep(loc,m) STMT_START {                                \
506     const IV offset = loc - RExC_precomp;                               \
507     Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),     \
508             m REPORT_LOCATION,                                          \
509             (int)offset, RExC_precomp, RExC_precomp + offset);          \
510 } STMT_END
511
512 #define ckWARN2reg(loc, m, a1) STMT_START {                             \
513     const IV offset = loc - RExC_precomp;                               \
514     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
515             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
516 } STMT_END
517
518 #define vWARN3(loc, m, a1, a2) STMT_START {                             \
519     const IV offset = loc - RExC_precomp;                               \
520     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
521             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
522 } STMT_END
523
524 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                         \
525     const IV offset = loc - RExC_precomp;                               \
526     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
527             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
528 } STMT_END
529
530 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
531     const IV offset = loc - RExC_precomp;                               \
532     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
533             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
534 } STMT_END
535
536 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
537     const IV offset = loc - RExC_precomp;                               \
538     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
539             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
540 } STMT_END
541
542 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
543     const IV offset = loc - RExC_precomp;                               \
544     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
545             a1, a2, a3, a4, (int)offset, RExC_precomp, RExC_precomp + offset); \
546 } STMT_END
547
548
549 /* Allow for side effects in s */
550 #define REGC(c,s) STMT_START {                  \
551     if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
552 } STMT_END
553
554 /* Macros for recording node offsets.   20001227 mjd@plover.com 
555  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
556  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
557  * Element 0 holds the number n.
558  * Position is 1 indexed.
559  */
560 #ifndef RE_TRACK_PATTERN_OFFSETS
561 #define Set_Node_Offset_To_R(node,byte)
562 #define Set_Node_Offset(node,byte)
563 #define Set_Cur_Node_Offset
564 #define Set_Node_Length_To_R(node,len)
565 #define Set_Node_Length(node,len)
566 #define Set_Node_Cur_Length(node)
567 #define Node_Offset(n) 
568 #define Node_Length(n) 
569 #define Set_Node_Offset_Length(node,offset,len)
570 #define ProgLen(ri) ri->u.proglen
571 #define SetProgLen(ri,x) ri->u.proglen = x
572 #else
573 #define ProgLen(ri) ri->u.offsets[0]
574 #define SetProgLen(ri,x) ri->u.offsets[0] = x
575 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
576     if (! SIZE_ONLY) {                                                  \
577         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
578                     __LINE__, (int)(node), (int)(byte)));               \
579         if((node) < 0) {                                                \
580             Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \
581         } else {                                                        \
582             RExC_offsets[2*(node)-1] = (byte);                          \
583         }                                                               \
584     }                                                                   \
585 } STMT_END
586
587 #define Set_Node_Offset(node,byte) \
588     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
589 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
590
591 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
592     if (! SIZE_ONLY) {                                                  \
593         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
594                 __LINE__, (int)(node), (int)(len)));                    \
595         if((node) < 0) {                                                \
596             Perl_croak(aTHX_ "value of node is %d in Length macro", (int)(node)); \
597         } else {                                                        \
598             RExC_offsets[2*(node)] = (len);                             \
599         }                                                               \
600     }                                                                   \
601 } STMT_END
602
603 #define Set_Node_Length(node,len) \
604     Set_Node_Length_To_R((node)-RExC_emit_start, len)
605 #define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
606 #define Set_Node_Cur_Length(node) \
607     Set_Node_Length(node, RExC_parse - parse_start)
608
609 /* Get offsets and lengths */
610 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
611 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
612
613 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
614     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
615     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
616 } STMT_END
617 #endif
618
619 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
620 #define EXPERIMENTAL_INPLACESCAN
621 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
622
623 #define DEBUG_STUDYDATA(str,data,depth)                              \
624 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
625     PerlIO_printf(Perl_debug_log,                                    \
626         "%*s" str "Pos:%"IVdf"/%"IVdf                                \
627         " Flags: 0x%"UVXf" Whilem_c: %"IVdf" Lcp: %"IVdf" %s",       \
628         (int)(depth)*2, "",                                          \
629         (IV)((data)->pos_min),                                       \
630         (IV)((data)->pos_delta),                                     \
631         (UV)((data)->flags),                                         \
632         (IV)((data)->whilem_c),                                      \
633         (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
634         is_inf ? "INF " : ""                                         \
635     );                                                               \
636     if ((data)->last_found)                                          \
637         PerlIO_printf(Perl_debug_log,                                \
638             "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
639             " %sFloat: '%s' @ %"IVdf"/%"IVdf"",                      \
640             SvPVX_const((data)->last_found),                         \
641             (IV)((data)->last_end),                                  \
642             (IV)((data)->last_start_min),                            \
643             (IV)((data)->last_start_max),                            \
644             ((data)->longest &&                                      \
645              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
646             SvPVX_const((data)->longest_fixed),                      \
647             (IV)((data)->offset_fixed),                              \
648             ((data)->longest &&                                      \
649              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
650             SvPVX_const((data)->longest_float),                      \
651             (IV)((data)->offset_float_min),                          \
652             (IV)((data)->offset_float_max)                           \
653         );                                                           \
654     PerlIO_printf(Perl_debug_log,"\n");                              \
655 });
656
657 static void clear_re(pTHX_ void *r);
658
659 /* Mark that we cannot extend a found fixed substring at this point.
660    Update the longest found anchored substring and the longest found
661    floating substrings if needed. */
662
663 STATIC void
664 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp, int is_inf)
665 {
666     const STRLEN l = CHR_SVLEN(data->last_found);
667     const STRLEN old_l = CHR_SVLEN(*data->longest);
668     GET_RE_DEBUG_FLAGS_DECL;
669
670     PERL_ARGS_ASSERT_SCAN_COMMIT;
671
672     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
673         SvSetMagicSV(*data->longest, data->last_found);
674         if (*data->longest == data->longest_fixed) {
675             data->offset_fixed = l ? data->last_start_min : data->pos_min;
676             if (data->flags & SF_BEFORE_EOL)
677                 data->flags
678                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
679             else
680                 data->flags &= ~SF_FIX_BEFORE_EOL;
681             data->minlen_fixed=minlenp; 
682             data->lookbehind_fixed=0;
683         }
684         else { /* *data->longest == data->longest_float */
685             data->offset_float_min = l ? data->last_start_min : data->pos_min;
686             data->offset_float_max = (l
687                                       ? data->last_start_max
688                                       : data->pos_min + data->pos_delta);
689             if (is_inf || (U32)data->offset_float_max > (U32)I32_MAX)
690                 data->offset_float_max = I32_MAX;
691             if (data->flags & SF_BEFORE_EOL)
692                 data->flags
693                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
694             else
695                 data->flags &= ~SF_FL_BEFORE_EOL;
696             data->minlen_float=minlenp;
697             data->lookbehind_float=0;
698         }
699     }
700     SvCUR_set(data->last_found, 0);
701     {
702         SV * const sv = data->last_found;
703         if (SvUTF8(sv) && SvMAGICAL(sv)) {
704             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
705             if (mg)
706                 mg->mg_len = 0;
707         }
708     }
709     data->last_end = -1;
710     data->flags &= ~SF_BEFORE_EOL;
711     DEBUG_STUDYDATA("commit: ",data,0);
712 }
713
714 /* Can match anything (initialization) */
715 STATIC void
716 S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
717 {
718     PERL_ARGS_ASSERT_CL_ANYTHING;
719
720     ANYOF_CLASS_ZERO(cl);
721     ANYOF_BITMAP_SETALL(cl);
722     cl->flags = ANYOF_EOS|ANYOF_UNICODE_ALL|ANYOF_LOC_NONBITMAP_FOLD|ANYOF_NON_UTF8_LATIN1_ALL;
723     if (LOC)
724         cl->flags |= ANYOF_LOCALE;
725 }
726
727 /* Can match anything (initialization) */
728 STATIC int
729 S_cl_is_anything(const struct regnode_charclass_class *cl)
730 {
731     int value;
732
733     PERL_ARGS_ASSERT_CL_IS_ANYTHING;
734
735     for (value = 0; value <= ANYOF_MAX; value += 2)
736         if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
737             return 1;
738     if (!(cl->flags & ANYOF_UNICODE_ALL))
739         return 0;
740     if (!ANYOF_BITMAP_TESTALLSET((const void*)cl))
741         return 0;
742     return 1;
743 }
744
745 /* Can match anything (initialization) */
746 STATIC void
747 S_cl_init(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
748 {
749     PERL_ARGS_ASSERT_CL_INIT;
750
751     Zero(cl, 1, struct regnode_charclass_class);
752     cl->type = ANYOF;
753     cl_anything(pRExC_state, cl);
754 }
755
756 STATIC void
757 S_cl_init_zero(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
758 {
759     PERL_ARGS_ASSERT_CL_INIT_ZERO;
760
761     Zero(cl, 1, struct regnode_charclass_class);
762     cl->type = ANYOF;
763     cl_anything(pRExC_state, cl);
764     if (LOC)
765         cl->flags |= ANYOF_LOCALE;
766 }
767
768 /* 'And' a given class with another one.  Can create false positives */
769 /* We assume that cl is not inverted */
770 STATIC void
771 S_cl_and(struct regnode_charclass_class *cl,
772         const struct regnode_charclass_class *and_with)
773 {
774     PERL_ARGS_ASSERT_CL_AND;
775
776     assert(and_with->type == ANYOF);
777
778     if (!(ANYOF_CLASS_TEST_ANY_SET(and_with))
779         && !(ANYOF_CLASS_TEST_ANY_SET(cl))
780         && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
781         && !(and_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
782         && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) {
783         int i;
784
785         if (and_with->flags & ANYOF_INVERT)
786             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
787                 cl->bitmap[i] &= ~and_with->bitmap[i];
788         else
789             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
790                 cl->bitmap[i] &= and_with->bitmap[i];
791     } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
792     if (!(and_with->flags & ANYOF_EOS))
793         cl->flags &= ~ANYOF_EOS;
794
795     if (!(and_with->flags & ANYOF_LOC_NONBITMAP_FOLD))
796         cl->flags &= ~ANYOF_LOC_NONBITMAP_FOLD;
797     if (!(and_with->flags & ANYOF_NON_UTF8_LATIN1_ALL))
798         cl->flags &= ~ANYOF_NON_UTF8_LATIN1_ALL;
799
800     if (cl->flags & ANYOF_UNICODE_ALL
801         && and_with->flags & ANYOF_NONBITMAP
802         && !(and_with->flags & ANYOF_INVERT))
803     {
804         if (! (and_with->flags & ANYOF_UNICODE_ALL)) {
805             cl->flags &= ~ANYOF_UNICODE_ALL;
806         }
807         cl->flags |= and_with->flags & ANYOF_NONBITMAP; /* field is 2 bits; use
808                                                            only the one(s)
809                                                            actually set */
810         ARG_SET(cl, ARG(and_with));
811     }
812     if (!(and_with->flags & ANYOF_UNICODE_ALL) &&
813         !(and_with->flags & ANYOF_INVERT))
814         cl->flags &= ~ANYOF_UNICODE_ALL;
815     if (!(and_with->flags & (ANYOF_NONBITMAP|ANYOF_UNICODE_ALL)) &&
816         !(and_with->flags & ANYOF_INVERT))
817         cl->flags &= ~ANYOF_NONBITMAP;
818 }
819
820 /* 'OR' a given class with another one.  Can create false positives */
821 /* We assume that cl is not inverted */
822 STATIC void
823 S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
824 {
825     PERL_ARGS_ASSERT_CL_OR;
826
827     if (or_with->flags & ANYOF_INVERT) {
828         /* We do not use
829          * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
830          *   <= (B1 | !B2) | (CL1 | !CL2)
831          * which is wasteful if CL2 is small, but we ignore CL2:
832          *   (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
833          * XXXX Can we handle case-fold?  Unclear:
834          *   (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
835          *   (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
836          */
837         if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
838              && !(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
839              && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD) ) {
840             int i;
841
842             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
843                 cl->bitmap[i] |= ~or_with->bitmap[i];
844         } /* XXXX: logic is complicated otherwise */
845         else {
846             cl_anything(pRExC_state, cl);
847         }
848     } else {
849         /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
850         if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
851              && (!(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
852                  || (cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) ) {
853             int i;
854
855             /* OR char bitmap and class bitmap separately */
856             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
857                 cl->bitmap[i] |= or_with->bitmap[i];
858             if (ANYOF_CLASS_TEST_ANY_SET(or_with)) {
859                 for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++)
860                     cl->classflags[i] |= or_with->classflags[i];
861                 cl->flags |= ANYOF_CLASS;
862             }
863         }
864         else { /* XXXX: logic is complicated, leave it along for a moment. */
865             cl_anything(pRExC_state, cl);
866         }
867     }
868     if (or_with->flags & ANYOF_EOS)
869         cl->flags |= ANYOF_EOS;
870     if (!(or_with->flags & ANYOF_NON_UTF8_LATIN1_ALL))
871         cl->flags |= ANYOF_NON_UTF8_LATIN1_ALL;
872
873     if (or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
874         cl->flags |= ANYOF_LOC_NONBITMAP_FOLD;
875
876     /* If both nodes match something outside the bitmap, but what they match
877      * outside is not the same pointer, and hence not easily compared, give up
878      * and allow the start class to match everything outside the bitmap */
879     if (cl->flags & ANYOF_NONBITMAP && or_with->flags & ANYOF_NONBITMAP &&
880         ARG(cl) != ARG(or_with)) {
881         cl->flags |= ANYOF_UNICODE_ALL;
882     }
883
884     if (or_with->flags & ANYOF_UNICODE_ALL) {
885         cl->flags |= ANYOF_UNICODE_ALL;
886     }
887 }
888
889 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
890 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
891 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
892 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list ? (TRIE_LIST_CUR( idx ) - 1) : 0 )
893
894
895 #ifdef DEBUGGING
896 /*
897    dump_trie(trie,widecharmap,revcharmap)
898    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
899    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
900
901    These routines dump out a trie in a somewhat readable format.
902    The _interim_ variants are used for debugging the interim
903    tables that are used to generate the final compressed
904    representation which is what dump_trie expects.
905
906    Part of the reason for their existence is to provide a form
907    of documentation as to how the different representations function.
908
909 */
910
911 /*
912   Dumps the final compressed table form of the trie to Perl_debug_log.
913   Used for debugging make_trie().
914 */
915
916 STATIC void
917 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
918             AV *revcharmap, U32 depth)
919 {
920     U32 state;
921     SV *sv=sv_newmortal();
922     int colwidth= widecharmap ? 6 : 4;
923     U16 word;
924     GET_RE_DEBUG_FLAGS_DECL;
925
926     PERL_ARGS_ASSERT_DUMP_TRIE;
927
928     PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
929         (int)depth * 2 + 2,"",
930         "Match","Base","Ofs" );
931
932     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
933         SV ** const tmp = av_fetch( revcharmap, state, 0);
934         if ( tmp ) {
935             PerlIO_printf( Perl_debug_log, "%*s", 
936                 colwidth,
937                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
938                             PL_colors[0], PL_colors[1],
939                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
940                             PERL_PV_ESCAPE_FIRSTCHAR 
941                 ) 
942             );
943         }
944     }
945     PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
946         (int)depth * 2 + 2,"");
947
948     for( state = 0 ; state < trie->uniquecharcount ; state++ )
949         PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
950     PerlIO_printf( Perl_debug_log, "\n");
951
952     for( state = 1 ; state < trie->statecount ; state++ ) {
953         const U32 base = trie->states[ state ].trans.base;
954
955         PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state);
956
957         if ( trie->states[ state ].wordnum ) {
958             PerlIO_printf( Perl_debug_log, " W%4X", trie->states[ state ].wordnum );
959         } else {
960             PerlIO_printf( Perl_debug_log, "%6s", "" );
961         }
962
963         PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
964
965         if ( base ) {
966             U32 ofs = 0;
967
968             while( ( base + ofs  < trie->uniquecharcount ) ||
969                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
970                      && trie->trans[ base + ofs - trie->uniquecharcount ].check != state))
971                     ofs++;
972
973             PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
974
975             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
976                 if ( ( base + ofs >= trie->uniquecharcount ) &&
977                      ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
978                      trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
979                 {
980                    PerlIO_printf( Perl_debug_log, "%*"UVXf,
981                     colwidth,
982                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
983                 } else {
984                     PerlIO_printf( Perl_debug_log, "%*s",colwidth,"   ." );
985                 }
986             }
987
988             PerlIO_printf( Perl_debug_log, "]");
989
990         }
991         PerlIO_printf( Perl_debug_log, "\n" );
992     }
993     PerlIO_printf(Perl_debug_log, "%*sword_info N:(prev,len)=", (int)depth*2, "");
994     for (word=1; word <= trie->wordcount; word++) {
995         PerlIO_printf(Perl_debug_log, " %d:(%d,%d)",
996             (int)word, (int)(trie->wordinfo[word].prev),
997             (int)(trie->wordinfo[word].len));
998     }
999     PerlIO_printf(Perl_debug_log, "\n" );
1000 }    
1001 /*
1002   Dumps a fully constructed but uncompressed trie in list form.
1003   List tries normally only are used for construction when the number of 
1004   possible chars (trie->uniquecharcount) is very high.
1005   Used for debugging make_trie().
1006 */
1007 STATIC void
1008 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
1009                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
1010                          U32 depth)
1011 {
1012     U32 state;
1013     SV *sv=sv_newmortal();
1014     int colwidth= widecharmap ? 6 : 4;
1015     GET_RE_DEBUG_FLAGS_DECL;
1016
1017     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
1018
1019     /* print out the table precompression.  */
1020     PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
1021         (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
1022         "------:-----+-----------------\n" );
1023     
1024     for( state=1 ; state < next_alloc ; state ++ ) {
1025         U16 charid;
1026     
1027         PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
1028             (int)depth * 2 + 2,"", (UV)state  );
1029         if ( ! trie->states[ state ].wordnum ) {
1030             PerlIO_printf( Perl_debug_log, "%5s| ","");
1031         } else {
1032             PerlIO_printf( Perl_debug_log, "W%4x| ",
1033                 trie->states[ state ].wordnum
1034             );
1035         }
1036         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
1037             SV ** const tmp = av_fetch( revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
1038             if ( tmp ) {
1039                 PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
1040                     colwidth,
1041                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1042                             PL_colors[0], PL_colors[1],
1043                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1044                             PERL_PV_ESCAPE_FIRSTCHAR 
1045                     ) ,
1046                     TRIE_LIST_ITEM(state,charid).forid,
1047                     (UV)TRIE_LIST_ITEM(state,charid).newstate
1048                 );
1049                 if (!(charid % 10)) 
1050                     PerlIO_printf(Perl_debug_log, "\n%*s| ",
1051                         (int)((depth * 2) + 14), "");
1052             }
1053         }
1054         PerlIO_printf( Perl_debug_log, "\n");
1055     }
1056 }    
1057
1058 /*
1059   Dumps a fully constructed but uncompressed trie in table form.
1060   This is the normal DFA style state transition table, with a few 
1061   twists to facilitate compression later. 
1062   Used for debugging make_trie().
1063 */
1064 STATIC void
1065 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
1066                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
1067                           U32 depth)
1068 {
1069     U32 state;
1070     U16 charid;
1071     SV *sv=sv_newmortal();
1072     int colwidth= widecharmap ? 6 : 4;
1073     GET_RE_DEBUG_FLAGS_DECL;
1074
1075     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
1076     
1077     /*
1078        print out the table precompression so that we can do a visual check
1079        that they are identical.
1080      */
1081     
1082     PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
1083
1084     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1085         SV ** const tmp = av_fetch( revcharmap, charid, 0);
1086         if ( tmp ) {
1087             PerlIO_printf( Perl_debug_log, "%*s", 
1088                 colwidth,
1089                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1090                             PL_colors[0], PL_colors[1],
1091                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1092                             PERL_PV_ESCAPE_FIRSTCHAR 
1093                 ) 
1094             );
1095         }
1096     }
1097
1098     PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
1099
1100     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
1101         PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
1102     }
1103
1104     PerlIO_printf( Perl_debug_log, "\n" );
1105
1106     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
1107
1108         PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ", 
1109             (int)depth * 2 + 2,"",
1110             (UV)TRIE_NODENUM( state ) );
1111
1112         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1113             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
1114             if (v)
1115                 PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
1116             else
1117                 PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
1118         }
1119         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1120             PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check );
1121         } else {
1122             PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n", (UV)trie->trans[ state ].check,
1123             trie->states[ TRIE_NODENUM( state ) ].wordnum );
1124         }
1125     }
1126 }
1127
1128 #endif
1129
1130
1131 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
1132   startbranch: the first branch in the whole branch sequence
1133   first      : start branch of sequence of branch-exact nodes.
1134                May be the same as startbranch
1135   last       : Thing following the last branch.
1136                May be the same as tail.
1137   tail       : item following the branch sequence
1138   count      : words in the sequence
1139   flags      : currently the OP() type we will be building one of /EXACT(|F|Fl)/
1140   depth      : indent depth
1141
1142 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
1143
1144 A trie is an N'ary tree where the branches are determined by digital
1145 decomposition of the key. IE, at the root node you look up the 1st character and
1146 follow that branch repeat until you find the end of the branches. Nodes can be
1147 marked as "accepting" meaning they represent a complete word. Eg:
1148
1149   /he|she|his|hers/
1150
1151 would convert into the following structure. Numbers represent states, letters
1152 following numbers represent valid transitions on the letter from that state, if
1153 the number is in square brackets it represents an accepting state, otherwise it
1154 will be in parenthesis.
1155
1156       +-h->+-e->[3]-+-r->(8)-+-s->[9]
1157       |    |
1158       |   (2)
1159       |    |
1160      (1)   +-i->(6)-+-s->[7]
1161       |
1162       +-s->(3)-+-h->(4)-+-e->[5]
1163
1164       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
1165
1166 This shows that when matching against the string 'hers' we will begin at state 1
1167 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
1168 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
1169 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
1170 single traverse. We store a mapping from accepting to state to which word was
1171 matched, and then when we have multiple possibilities we try to complete the
1172 rest of the regex in the order in which they occured in the alternation.
1173
1174 The only prior NFA like behaviour that would be changed by the TRIE support is
1175 the silent ignoring of duplicate alternations which are of the form:
1176
1177  / (DUPE|DUPE) X? (?{ ... }) Y /x
1178
1179 Thus EVAL blocks following a trie may be called a different number of times with
1180 and without the optimisation. With the optimisations dupes will be silently
1181 ignored. This inconsistent behaviour of EVAL type nodes is well established as
1182 the following demonstrates:
1183
1184  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
1185
1186 which prints out 'word' three times, but
1187
1188  'words'=~/(word|word|word)(?{ print $1 })S/
1189
1190 which doesnt print it out at all. This is due to other optimisations kicking in.
1191
1192 Example of what happens on a structural level:
1193
1194 The regexp /(ac|ad|ab)+/ will produce the following debug output:
1195
1196    1: CURLYM[1] {1,32767}(18)
1197    5:   BRANCH(8)
1198    6:     EXACT <ac>(16)
1199    8:   BRANCH(11)
1200    9:     EXACT <ad>(16)
1201   11:   BRANCH(14)
1202   12:     EXACT <ab>(16)
1203   16:   SUCCEED(0)
1204   17:   NOTHING(18)
1205   18: END(0)
1206
1207 This would be optimizable with startbranch=5, first=5, last=16, tail=16
1208 and should turn into:
1209
1210    1: CURLYM[1] {1,32767}(18)
1211    5:   TRIE(16)
1212         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
1213           <ac>
1214           <ad>
1215           <ab>
1216   16:   SUCCEED(0)
1217   17:   NOTHING(18)
1218   18: END(0)
1219
1220 Cases where tail != last would be like /(?foo|bar)baz/:
1221
1222    1: BRANCH(4)
1223    2:   EXACT <foo>(8)
1224    4: BRANCH(7)
1225    5:   EXACT <bar>(8)
1226    7: TAIL(8)
1227    8: EXACT <baz>(10)
1228   10: END(0)
1229
1230 which would be optimizable with startbranch=1, first=1, last=7, tail=8
1231 and would end up looking like:
1232
1233     1: TRIE(8)
1234       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
1235         <foo>
1236         <bar>
1237    7: TAIL(8)
1238    8: EXACT <baz>(10)
1239   10: END(0)
1240
1241     d = uvuni_to_utf8_flags(d, uv, 0);
1242
1243 is the recommended Unicode-aware way of saying
1244
1245     *(d++) = uv;
1246 */
1247
1248 #define TRIE_STORE_REVCHAR                                                 \
1249     STMT_START {                                                           \
1250         if (UTF) {                                                         \
1251             SV *zlopp = newSV(2);                                          \
1252             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
1253             unsigned const char *const kapow = uvuni_to_utf8(flrbbbbb, uvc & 0xFF); \
1254             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
1255             SvPOK_on(zlopp);                                               \
1256             SvUTF8_on(zlopp);                                              \
1257             av_push(revcharmap, zlopp);                                    \
1258         } else {                                                           \
1259             char ooooff = (char)uvc;                                               \
1260             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
1261         }                                                                  \
1262         } STMT_END
1263
1264 #define TRIE_READ_CHAR STMT_START {                                           \
1265     wordlen++;                                                                \
1266     if ( UTF ) {                                                              \
1267         if ( folder ) {                                                       \
1268             if ( foldlen > 0 ) {                                              \
1269                uvc = utf8n_to_uvuni( scan, UTF8_MAXLEN, &len, uniflags );     \
1270                foldlen -= len;                                                \
1271                scan += len;                                                   \
1272                len = 0;                                                       \
1273             } else {                                                          \
1274                 uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
1275                 uvc = to_uni_fold( uvc, foldbuf, &foldlen );                  \
1276                 foldlen -= UNISKIP( uvc );                                    \
1277                 scan = foldbuf + UNISKIP( uvc );                              \
1278             }                                                                 \
1279         } else {                                                              \
1280             uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
1281         }                                                                     \
1282     } else {                                                                  \
1283         uvc = (U32)*uc;                                                       \
1284         len = 1;                                                              \
1285     }                                                                         \
1286 } STMT_END
1287
1288
1289
1290 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
1291     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
1292         U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
1293         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
1294     }                                                           \
1295     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
1296     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
1297     TRIE_LIST_CUR( state )++;                                   \
1298 } STMT_END
1299
1300 #define TRIE_LIST_NEW(state) STMT_START {                       \
1301     Newxz( trie->states[ state ].trans.list,               \
1302         4, reg_trie_trans_le );                                 \
1303      TRIE_LIST_CUR( state ) = 1;                                \
1304      TRIE_LIST_LEN( state ) = 4;                                \
1305 } STMT_END
1306
1307 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
1308     U16 dupe= trie->states[ state ].wordnum;                    \
1309     regnode * const noper_next = regnext( noper );              \
1310                                                                 \
1311     DEBUG_r({                                                   \
1312         /* store the word for dumping */                        \
1313         SV* tmp;                                                \
1314         if (OP(noper) != NOTHING)                               \
1315             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
1316         else                                                    \
1317             tmp = newSVpvn_utf8( "", 0, UTF );                  \
1318         av_push( trie_words, tmp );                             \
1319     });                                                         \
1320                                                                 \
1321     curword++;                                                  \
1322     trie->wordinfo[curword].prev   = 0;                         \
1323     trie->wordinfo[curword].len    = wordlen;                   \
1324     trie->wordinfo[curword].accept = state;                     \
1325                                                                 \
1326     if ( noper_next < tail ) {                                  \
1327         if (!trie->jump)                                        \
1328             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, sizeof(U16) ); \
1329         trie->jump[curword] = (U16)(noper_next - convert);      \
1330         if (!jumper)                                            \
1331             jumper = noper_next;                                \
1332         if (!nextbranch)                                        \
1333             nextbranch= regnext(cur);                           \
1334     }                                                           \
1335                                                                 \
1336     if ( dupe ) {                                               \
1337         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
1338         /* chain, so that when the bits of chain are later    */\
1339         /* linked together, the dups appear in the chain      */\
1340         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
1341         trie->wordinfo[dupe].prev = curword;                    \
1342     } else {                                                    \
1343         /* we haven't inserted this word yet.                */ \
1344         trie->states[ state ].wordnum = curword;                \
1345     }                                                           \
1346 } STMT_END
1347
1348
1349 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
1350      ( ( base + charid >=  ucharcount                                   \
1351          && base + charid < ubound                                      \
1352          && state == trie->trans[ base - ucharcount + charid ].check    \
1353          && trie->trans[ base - ucharcount + charid ].next )            \
1354            ? trie->trans[ base - ucharcount + charid ].next             \
1355            : ( state==1 ? special : 0 )                                 \
1356       )
1357
1358 #define MADE_TRIE       1
1359 #define MADE_JUMP_TRIE  2
1360 #define MADE_EXACT_TRIE 4
1361
1362 STATIC I32
1363 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth)
1364 {
1365     dVAR;
1366     /* first pass, loop through and scan words */
1367     reg_trie_data *trie;
1368     HV *widecharmap = NULL;
1369     AV *revcharmap = newAV();
1370     regnode *cur;
1371     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1372     STRLEN len = 0;
1373     UV uvc = 0;
1374     U16 curword = 0;
1375     U32 next_alloc = 0;
1376     regnode *jumper = NULL;
1377     regnode *nextbranch = NULL;
1378     regnode *convert = NULL;
1379     U32 *prev_states; /* temp array mapping each state to previous one */
1380     /* we just use folder as a flag in utf8 */
1381     const U8 * folder = NULL;
1382
1383 #ifdef DEBUGGING
1384     const U32 data_slot = add_data( pRExC_state, 4, "tuuu" );
1385     AV *trie_words = NULL;
1386     /* along with revcharmap, this only used during construction but both are
1387      * useful during debugging so we store them in the struct when debugging.
1388      */
1389 #else
1390     const U32 data_slot = add_data( pRExC_state, 2, "tu" );
1391     STRLEN trie_charcount=0;
1392 #endif
1393     SV *re_trie_maxbuff;
1394     GET_RE_DEBUG_FLAGS_DECL;
1395
1396     PERL_ARGS_ASSERT_MAKE_TRIE;
1397 #ifndef DEBUGGING
1398     PERL_UNUSED_ARG(depth);
1399 #endif
1400
1401     switch (flags) {
1402         case EXACTFA:
1403         case EXACTFU: folder = PL_fold_latin1; break;
1404         case EXACTF:  folder = PL_fold; break;
1405         case EXACTFL: folder = PL_fold_locale; break;
1406     }
1407
1408     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
1409     trie->refcount = 1;
1410     trie->startstate = 1;
1411     trie->wordcount = word_count;
1412     RExC_rxi->data->data[ data_slot ] = (void*)trie;
1413     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
1414     if (!(UTF && folder))
1415         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
1416     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
1417                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
1418
1419     DEBUG_r({
1420         trie_words = newAV();
1421     });
1422
1423     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
1424     if (!SvIOK(re_trie_maxbuff)) {
1425         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
1426     }
1427     DEBUG_OPTIMISE_r({
1428                 PerlIO_printf( Perl_debug_log,
1429                   "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
1430                   (int)depth * 2 + 2, "", 
1431                   REG_NODE_NUM(startbranch),REG_NODE_NUM(first), 
1432                   REG_NODE_NUM(last), REG_NODE_NUM(tail),
1433                   (int)depth);
1434     });
1435    
1436    /* Find the node we are going to overwrite */
1437     if ( first == startbranch && OP( last ) != BRANCH ) {
1438         /* whole branch chain */
1439         convert = first;
1440     } else {
1441         /* branch sub-chain */
1442         convert = NEXTOPER( first );
1443     }
1444         
1445     /*  -- First loop and Setup --
1446
1447        We first traverse the branches and scan each word to determine if it
1448        contains widechars, and how many unique chars there are, this is
1449        important as we have to build a table with at least as many columns as we
1450        have unique chars.
1451
1452        We use an array of integers to represent the character codes 0..255
1453        (trie->charmap) and we use a an HV* to store Unicode characters. We use the
1454        native representation of the character value as the key and IV's for the
1455        coded index.
1456
1457        *TODO* If we keep track of how many times each character is used we can
1458        remap the columns so that the table compression later on is more
1459        efficient in terms of memory by ensuring the most common value is in the
1460        middle and the least common are on the outside.  IMO this would be better
1461        than a most to least common mapping as theres a decent chance the most
1462        common letter will share a node with the least common, meaning the node
1463        will not be compressible. With a middle is most common approach the worst
1464        case is when we have the least common nodes twice.
1465
1466      */
1467
1468     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1469         regnode * const noper = NEXTOPER( cur );
1470         const U8 *uc = (U8*)STRING( noper );
1471         const U8 * const e  = uc + STR_LEN( noper );
1472         STRLEN foldlen = 0;
1473         U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1474         const U8 *scan = (U8*)NULL;
1475         U32 wordlen      = 0;         /* required init */
1476         STRLEN chars = 0;
1477         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the bitmap?*/
1478
1479         if (OP(noper) == NOTHING) {
1480             trie->minlen= 0;
1481             continue;
1482         }
1483         if ( set_bit ) /* bitmap only alloced when !(UTF&&Folding) */
1484             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
1485                                           regardless of encoding */
1486
1487         for ( ; uc < e ; uc += len ) {
1488             TRIE_CHARCOUNT(trie)++;
1489             TRIE_READ_CHAR;
1490             chars++;
1491             if ( uvc < 256 ) {
1492                 if ( !trie->charmap[ uvc ] ) {
1493                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
1494                     if ( folder )
1495                         trie->charmap[ folder[ uvc ] ] = trie->charmap[ uvc ];
1496                     TRIE_STORE_REVCHAR;
1497                 }
1498                 if ( set_bit ) {
1499                     /* store the codepoint in the bitmap, and its folded
1500                      * equivalent. */
1501                     TRIE_BITMAP_SET(trie,uvc);
1502
1503                     /* store the folded codepoint */
1504                     if ( folder ) TRIE_BITMAP_SET(trie,folder[ uvc ]);
1505
1506                     if ( !UTF ) {
1507                         /* store first byte of utf8 representation of
1508                            variant codepoints */
1509                         if (! UNI_IS_INVARIANT(uvc)) {
1510                             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));
1511                         }
1512                     }
1513                     set_bit = 0; /* We've done our bit :-) */
1514                 }
1515             } else {
1516                 SV** svpp;
1517                 if ( !widecharmap )
1518                     widecharmap = newHV();
1519
1520                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
1521
1522                 if ( !svpp )
1523                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
1524
1525                 if ( !SvTRUE( *svpp ) ) {
1526                     sv_setiv( *svpp, ++trie->uniquecharcount );
1527                     TRIE_STORE_REVCHAR;
1528                 }
1529             }
1530         }
1531         if( cur == first ) {
1532             trie->minlen=chars;
1533             trie->maxlen=chars;
1534         } else if (chars < trie->minlen) {
1535             trie->minlen=chars;
1536         } else if (chars > trie->maxlen) {
1537             trie->maxlen=chars;
1538         }
1539
1540     } /* end first pass */
1541     DEBUG_TRIE_COMPILE_r(
1542         PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
1543                 (int)depth * 2 + 2,"",
1544                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
1545                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
1546                 (int)trie->minlen, (int)trie->maxlen )
1547     );
1548
1549     /*
1550         We now know what we are dealing with in terms of unique chars and
1551         string sizes so we can calculate how much memory a naive
1552         representation using a flat table  will take. If it's over a reasonable
1553         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
1554         conservative but potentially much slower representation using an array
1555         of lists.
1556
1557         At the end we convert both representations into the same compressed
1558         form that will be used in regexec.c for matching with. The latter
1559         is a form that cannot be used to construct with but has memory
1560         properties similar to the list form and access properties similar
1561         to the table form making it both suitable for fast searches and
1562         small enough that its feasable to store for the duration of a program.
1563
1564         See the comment in the code where the compressed table is produced
1565         inplace from the flat tabe representation for an explanation of how
1566         the compression works.
1567
1568     */
1569
1570
1571     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
1572     prev_states[1] = 0;
1573
1574     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1) > SvIV(re_trie_maxbuff) ) {
1575         /*
1576             Second Pass -- Array Of Lists Representation
1577
1578             Each state will be represented by a list of charid:state records
1579             (reg_trie_trans_le) the first such element holds the CUR and LEN
1580             points of the allocated array. (See defines above).
1581
1582             We build the initial structure using the lists, and then convert
1583             it into the compressed table form which allows faster lookups
1584             (but cant be modified once converted).
1585         */
1586
1587         STRLEN transcount = 1;
1588
1589         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
1590             "%*sCompiling trie using list compiler\n",
1591             (int)depth * 2 + 2, ""));
1592         
1593         trie->states = (reg_trie_state *)
1594             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1595                                   sizeof(reg_trie_state) );
1596         TRIE_LIST_NEW(1);
1597         next_alloc = 2;
1598
1599         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1600
1601             regnode * const noper = NEXTOPER( cur );
1602             U8 *uc           = (U8*)STRING( noper );
1603             const U8 * const e = uc + STR_LEN( noper );
1604             U32 state        = 1;         /* required init */
1605             U16 charid       = 0;         /* sanity init */
1606             U8 *scan         = (U8*)NULL; /* sanity init */
1607             STRLEN foldlen   = 0;         /* required init */
1608             U32 wordlen      = 0;         /* required init */
1609             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1610
1611             if (OP(noper) != NOTHING) {
1612                 for ( ; uc < e ; uc += len ) {
1613
1614                     TRIE_READ_CHAR;
1615
1616                     if ( uvc < 256 ) {
1617                         charid = trie->charmap[ uvc ];
1618                     } else {
1619                         SV** const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1620                         if ( !svpp ) {
1621                             charid = 0;
1622                         } else {
1623                             charid=(U16)SvIV( *svpp );
1624                         }
1625                     }
1626                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
1627                     if ( charid ) {
1628
1629                         U16 check;
1630                         U32 newstate = 0;
1631
1632                         charid--;
1633                         if ( !trie->states[ state ].trans.list ) {
1634                             TRIE_LIST_NEW( state );
1635                         }
1636                         for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) {
1637                             if ( TRIE_LIST_ITEM( state, check ).forid == charid ) {
1638                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
1639                                 break;
1640                             }
1641                         }
1642                         if ( ! newstate ) {
1643                             newstate = next_alloc++;
1644                             prev_states[newstate] = state;
1645                             TRIE_LIST_PUSH( state, charid, newstate );
1646                             transcount++;
1647                         }
1648                         state = newstate;
1649                     } else {
1650                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1651                     }
1652                 }
1653             }
1654             TRIE_HANDLE_WORD(state);
1655
1656         } /* end second pass */
1657
1658         /* next alloc is the NEXT state to be allocated */
1659         trie->statecount = next_alloc; 
1660         trie->states = (reg_trie_state *)
1661             PerlMemShared_realloc( trie->states,
1662                                    next_alloc
1663                                    * sizeof(reg_trie_state) );
1664
1665         /* and now dump it out before we compress it */
1666         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
1667                                                          revcharmap, next_alloc,
1668                                                          depth+1)
1669         );
1670
1671         trie->trans = (reg_trie_trans *)
1672             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
1673         {
1674             U32 state;
1675             U32 tp = 0;
1676             U32 zp = 0;
1677
1678
1679             for( state=1 ; state < next_alloc ; state ++ ) {
1680                 U32 base=0;
1681
1682                 /*
1683                 DEBUG_TRIE_COMPILE_MORE_r(
1684                     PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
1685                 );
1686                 */
1687
1688                 if (trie->states[state].trans.list) {
1689                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
1690                     U16 maxid=minid;
1691                     U16 idx;
1692
1693                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1694                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
1695                         if ( forid < minid ) {
1696                             minid=forid;
1697                         } else if ( forid > maxid ) {
1698                             maxid=forid;
1699                         }
1700                     }
1701                     if ( transcount < tp + maxid - minid + 1) {
1702                         transcount *= 2;
1703                         trie->trans = (reg_trie_trans *)
1704                             PerlMemShared_realloc( trie->trans,
1705                                                      transcount
1706                                                      * sizeof(reg_trie_trans) );
1707                         Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans );
1708                     }
1709                     base = trie->uniquecharcount + tp - minid;
1710                     if ( maxid == minid ) {
1711                         U32 set = 0;
1712                         for ( ; zp < tp ; zp++ ) {
1713                             if ( ! trie->trans[ zp ].next ) {
1714                                 base = trie->uniquecharcount + zp - minid;
1715                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1716                                 trie->trans[ zp ].check = state;
1717                                 set = 1;
1718                                 break;
1719                             }
1720                         }
1721                         if ( !set ) {
1722                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1723                             trie->trans[ tp ].check = state;
1724                             tp++;
1725                             zp = tp;
1726                         }
1727                     } else {
1728                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1729                             const U32 tid = base -  trie->uniquecharcount + TRIE_LIST_ITEM( state, idx ).forid;
1730                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state, idx ).newstate;
1731                             trie->trans[ tid ].check = state;
1732                         }
1733                         tp += ( maxid - minid + 1 );
1734                     }
1735                     Safefree(trie->states[ state ].trans.list);
1736                 }
1737                 /*
1738                 DEBUG_TRIE_COMPILE_MORE_r(
1739                     PerlIO_printf( Perl_debug_log, " base: %d\n",base);
1740                 );
1741                 */
1742                 trie->states[ state ].trans.base=base;
1743             }
1744             trie->lasttrans = tp + 1;
1745         }
1746     } else {
1747         /*
1748            Second Pass -- Flat Table Representation.
1749
1750            we dont use the 0 slot of either trans[] or states[] so we add 1 to each.
1751            We know that we will need Charcount+1 trans at most to store the data
1752            (one row per char at worst case) So we preallocate both structures
1753            assuming worst case.
1754
1755            We then construct the trie using only the .next slots of the entry
1756            structs.
1757
1758            We use the .check field of the first entry of the node temporarily to
1759            make compression both faster and easier by keeping track of how many non
1760            zero fields are in the node.
1761
1762            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
1763            transition.
1764
1765            There are two terms at use here: state as a TRIE_NODEIDX() which is a
1766            number representing the first entry of the node, and state as a
1767            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1) and
1768            TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3) if there
1769            are 2 entrys per node. eg:
1770
1771              A B       A B
1772           1. 2 4    1. 3 7
1773           2. 0 3    3. 0 5
1774           3. 0 0    5. 0 0
1775           4. 0 0    7. 0 0
1776
1777            The table is internally in the right hand, idx form. However as we also
1778            have to deal with the states array which is indexed by nodenum we have to
1779            use TRIE_NODENUM() to convert.
1780
1781         */
1782         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
1783             "%*sCompiling trie using table compiler\n",
1784             (int)depth * 2 + 2, ""));
1785
1786         trie->trans = (reg_trie_trans *)
1787             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
1788                                   * trie->uniquecharcount + 1,
1789                                   sizeof(reg_trie_trans) );
1790         trie->states = (reg_trie_state *)
1791             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1792                                   sizeof(reg_trie_state) );
1793         next_alloc = trie->uniquecharcount + 1;
1794
1795
1796         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1797
1798             regnode * const noper   = NEXTOPER( cur );
1799             const U8 *uc     = (U8*)STRING( noper );
1800             const U8 * const e = uc + STR_LEN( noper );
1801
1802             U32 state        = 1;         /* required init */
1803
1804             U16 charid       = 0;         /* sanity init */
1805             U32 accept_state = 0;         /* sanity init */
1806             U8 *scan         = (U8*)NULL; /* sanity init */
1807
1808             STRLEN foldlen   = 0;         /* required init */
1809             U32 wordlen      = 0;         /* required init */
1810             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1811
1812             if ( OP(noper) != NOTHING ) {
1813                 for ( ; uc < e ; uc += len ) {
1814
1815                     TRIE_READ_CHAR;
1816
1817                     if ( uvc < 256 ) {
1818                         charid = trie->charmap[ uvc ];
1819                     } else {
1820                         SV* const * const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1821                         charid = svpp ? (U16)SvIV(*svpp) : 0;
1822                     }
1823                     if ( charid ) {
1824                         charid--;
1825                         if ( !trie->trans[ state + charid ].next ) {
1826                             trie->trans[ state + charid ].next = next_alloc;
1827                             trie->trans[ state ].check++;
1828                             prev_states[TRIE_NODENUM(next_alloc)]
1829                                     = TRIE_NODENUM(state);
1830                             next_alloc += trie->uniquecharcount;
1831                         }
1832                         state = trie->trans[ state + charid ].next;
1833                     } else {
1834                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1835                     }
1836                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
1837                 }
1838             }
1839             accept_state = TRIE_NODENUM( state );
1840             TRIE_HANDLE_WORD(accept_state);
1841
1842         } /* end second pass */
1843
1844         /* and now dump it out before we compress it */
1845         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
1846                                                           revcharmap,
1847                                                           next_alloc, depth+1));
1848
1849         {
1850         /*
1851            * Inplace compress the table.*
1852
1853            For sparse data sets the table constructed by the trie algorithm will
1854            be mostly 0/FAIL transitions or to put it another way mostly empty.
1855            (Note that leaf nodes will not contain any transitions.)
1856
1857            This algorithm compresses the tables by eliminating most such
1858            transitions, at the cost of a modest bit of extra work during lookup:
1859
1860            - Each states[] entry contains a .base field which indicates the
1861            index in the state[] array wheres its transition data is stored.
1862
1863            - If .base is 0 there are no valid transitions from that node.
1864
1865            - If .base is nonzero then charid is added to it to find an entry in
1866            the trans array.
1867
1868            -If trans[states[state].base+charid].check!=state then the
1869            transition is taken to be a 0/Fail transition. Thus if there are fail
1870            transitions at the front of the node then the .base offset will point
1871            somewhere inside the previous nodes data (or maybe even into a node
1872            even earlier), but the .check field determines if the transition is
1873            valid.
1874
1875            XXX - wrong maybe?
1876            The following process inplace converts the table to the compressed
1877            table: We first do not compress the root node 1,and mark all its
1878            .check pointers as 1 and set its .base pointer as 1 as well. This
1879            allows us to do a DFA construction from the compressed table later,
1880            and ensures that any .base pointers we calculate later are greater
1881            than 0.
1882
1883            - We set 'pos' to indicate the first entry of the second node.
1884
1885            - We then iterate over the columns of the node, finding the first and
1886            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
1887            and set the .check pointers accordingly, and advance pos
1888            appropriately and repreat for the next node. Note that when we copy
1889            the next pointers we have to convert them from the original
1890            NODEIDX form to NODENUM form as the former is not valid post
1891            compression.
1892
1893            - If a node has no transitions used we mark its base as 0 and do not
1894            advance the pos pointer.
1895
1896            - If a node only has one transition we use a second pointer into the
1897            structure to fill in allocated fail transitions from other states.
1898            This pointer is independent of the main pointer and scans forward
1899            looking for null transitions that are allocated to a state. When it
1900            finds one it writes the single transition into the "hole".  If the
1901            pointer doesnt find one the single transition is appended as normal.
1902
1903            - Once compressed we can Renew/realloc the structures to release the
1904            excess space.
1905
1906            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
1907            specifically Fig 3.47 and the associated pseudocode.
1908
1909            demq
1910         */
1911         const U32 laststate = TRIE_NODENUM( next_alloc );
1912         U32 state, charid;
1913         U32 pos = 0, zp=0;
1914         trie->statecount = laststate;
1915
1916         for ( state = 1 ; state < laststate ; state++ ) {
1917             U8 flag = 0;
1918             const U32 stateidx = TRIE_NODEIDX( state );
1919             const U32 o_used = trie->trans[ stateidx ].check;
1920             U32 used = trie->trans[ stateidx ].check;
1921             trie->trans[ stateidx ].check = 0;
1922
1923             for ( charid = 0 ; used && charid < trie->uniquecharcount ; charid++ ) {
1924                 if ( flag || trie->trans[ stateidx + charid ].next ) {
1925                     if ( trie->trans[ stateidx + charid ].next ) {
1926                         if (o_used == 1) {
1927                             for ( ; zp < pos ; zp++ ) {
1928                                 if ( ! trie->trans[ zp ].next ) {
1929                                     break;
1930                                 }
1931                             }
1932                             trie->states[ state ].trans.base = zp + trie->uniquecharcount - charid ;
1933                             trie->trans[ zp ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
1934                             trie->trans[ zp ].check = state;
1935                             if ( ++zp > pos ) pos = zp;
1936                             break;
1937                         }
1938                         used--;
1939                     }
1940                     if ( !flag ) {
1941                         flag = 1;
1942                         trie->states[ state ].trans.base = pos + trie->uniquecharcount - charid ;
1943                     }
1944                     trie->trans[ pos ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
1945                     trie->trans[ pos ].check = state;
1946                     pos++;
1947                 }
1948             }
1949         }
1950         trie->lasttrans = pos + 1;
1951         trie->states = (reg_trie_state *)
1952             PerlMemShared_realloc( trie->states, laststate
1953                                    * sizeof(reg_trie_state) );
1954         DEBUG_TRIE_COMPILE_MORE_r(
1955                 PerlIO_printf( Perl_debug_log,
1956                     "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
1957                     (int)depth * 2 + 2,"",
1958                     (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1 ),
1959                     (IV)next_alloc,
1960                     (IV)pos,
1961                     ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
1962             );
1963
1964         } /* end table compress */
1965     }
1966     DEBUG_TRIE_COMPILE_MORE_r(
1967             PerlIO_printf(Perl_debug_log, "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
1968                 (int)depth * 2 + 2, "",
1969                 (UV)trie->statecount,
1970                 (UV)trie->lasttrans)
1971     );
1972     /* resize the trans array to remove unused space */
1973     trie->trans = (reg_trie_trans *)
1974         PerlMemShared_realloc( trie->trans, trie->lasttrans
1975                                * sizeof(reg_trie_trans) );
1976
1977     {   /* Modify the program and insert the new TRIE node */ 
1978         U8 nodetype =(U8)(flags & 0xFF);
1979         char *str=NULL;
1980         
1981 #ifdef DEBUGGING
1982         regnode *optimize = NULL;
1983 #ifdef RE_TRACK_PATTERN_OFFSETS
1984
1985         U32 mjd_offset = 0;
1986         U32 mjd_nodelen = 0;
1987 #endif /* RE_TRACK_PATTERN_OFFSETS */
1988 #endif /* DEBUGGING */
1989         /*
1990            This means we convert either the first branch or the first Exact,
1991            depending on whether the thing following (in 'last') is a branch
1992            or not and whther first is the startbranch (ie is it a sub part of
1993            the alternation or is it the whole thing.)
1994            Assuming its a sub part we convert the EXACT otherwise we convert
1995            the whole branch sequence, including the first.
1996          */
1997         /* Find the node we are going to overwrite */
1998         if ( first != startbranch || OP( last ) == BRANCH ) {
1999             /* branch sub-chain */
2000             NEXT_OFF( first ) = (U16)(last - first);
2001 #ifdef RE_TRACK_PATTERN_OFFSETS
2002             DEBUG_r({
2003                 mjd_offset= Node_Offset((convert));
2004                 mjd_nodelen= Node_Length((convert));
2005             });
2006 #endif
2007             /* whole branch chain */
2008         }
2009 #ifdef RE_TRACK_PATTERN_OFFSETS
2010         else {
2011             DEBUG_r({
2012                 const  regnode *nop = NEXTOPER( convert );
2013                 mjd_offset= Node_Offset((nop));
2014                 mjd_nodelen= Node_Length((nop));
2015             });
2016         }
2017         DEBUG_OPTIMISE_r(
2018             PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
2019                 (int)depth * 2 + 2, "",
2020                 (UV)mjd_offset, (UV)mjd_nodelen)
2021         );
2022 #endif
2023         /* But first we check to see if there is a common prefix we can 
2024            split out as an EXACT and put in front of the TRIE node.  */
2025         trie->startstate= 1;
2026         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
2027             U32 state;
2028             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
2029                 U32 ofs = 0;
2030                 I32 idx = -1;
2031                 U32 count = 0;
2032                 const U32 base = trie->states[ state ].trans.base;
2033
2034                 if ( trie->states[state].wordnum )
2035                         count = 1;
2036
2037                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2038                     if ( ( base + ofs >= trie->uniquecharcount ) &&
2039                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
2040                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
2041                     {
2042                         if ( ++count > 1 ) {
2043                             SV **tmp = av_fetch( revcharmap, ofs, 0);
2044                             const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
2045                             if ( state == 1 ) break;
2046                             if ( count == 2 ) {
2047                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
2048                                 DEBUG_OPTIMISE_r(
2049                                     PerlIO_printf(Perl_debug_log,
2050                                         "%*sNew Start State=%"UVuf" Class: [",
2051                                         (int)depth * 2 + 2, "",
2052                                         (UV)state));
2053                                 if (idx >= 0) {
2054                                     SV ** const tmp = av_fetch( revcharmap, idx, 0);
2055                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
2056
2057                                     TRIE_BITMAP_SET(trie,*ch);
2058                                     if ( folder )
2059                                         TRIE_BITMAP_SET(trie, folder[ *ch ]);
2060                                     DEBUG_OPTIMISE_r(
2061                                         PerlIO_printf(Perl_debug_log, "%s", (char*)ch)
2062                                     );
2063                                 }
2064                             }
2065                             TRIE_BITMAP_SET(trie,*ch);
2066                             if ( folder )
2067                                 TRIE_BITMAP_SET(trie,folder[ *ch ]);
2068                             DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
2069                         }
2070                         idx = ofs;
2071                     }
2072                 }
2073                 if ( count == 1 ) {
2074                     SV **tmp = av_fetch( revcharmap, idx, 0);
2075                     STRLEN len;
2076                     char *ch = SvPV( *tmp, len );
2077                     DEBUG_OPTIMISE_r({
2078                         SV *sv=sv_newmortal();
2079                         PerlIO_printf( Perl_debug_log,
2080                             "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
2081                             (int)depth * 2 + 2, "",
2082                             (UV)state, (UV)idx, 
2083                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6, 
2084                                 PL_colors[0], PL_colors[1],
2085                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2086                                 PERL_PV_ESCAPE_FIRSTCHAR 
2087                             )
2088                         );
2089                     });
2090                     if ( state==1 ) {
2091                         OP( convert ) = nodetype;
2092                         str=STRING(convert);
2093                         STR_LEN(convert)=0;
2094                     }
2095                     STR_LEN(convert) += len;
2096                     while (len--)
2097                         *str++ = *ch++;
2098                 } else {
2099 #ifdef DEBUGGING            
2100                     if (state>1)
2101                         DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
2102 #endif
2103                     break;
2104                 }
2105             }
2106             trie->prefixlen = (state-1);
2107             if (str) {
2108                 regnode *n = convert+NODE_SZ_STR(convert);
2109                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
2110                 trie->startstate = state;
2111                 trie->minlen -= (state - 1);
2112                 trie->maxlen -= (state - 1);
2113 #ifdef DEBUGGING
2114                /* At least the UNICOS C compiler choked on this
2115                 * being argument to DEBUG_r(), so let's just have
2116                 * it right here. */
2117                if (
2118 #ifdef PERL_EXT_RE_BUILD
2119                    1
2120 #else
2121                    DEBUG_r_TEST
2122 #endif
2123                    ) {
2124                    regnode *fix = convert;
2125                    U32 word = trie->wordcount;
2126                    mjd_nodelen++;
2127                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
2128                    while( ++fix < n ) {
2129                        Set_Node_Offset_Length(fix, 0, 0);
2130                    }
2131                    while (word--) {
2132                        SV ** const tmp = av_fetch( trie_words, word, 0 );
2133                        if (tmp) {
2134                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
2135                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
2136                            else
2137                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
2138                        }
2139                    }
2140                }
2141 #endif
2142                 if (trie->maxlen) {
2143                     convert = n;
2144                 } else {
2145                     NEXT_OFF(convert) = (U16)(tail - convert);
2146                     DEBUG_r(optimize= n);
2147                 }
2148             }
2149         }
2150         if (!jumper) 
2151             jumper = last; 
2152         if ( trie->maxlen ) {
2153             NEXT_OFF( convert ) = (U16)(tail - convert);
2154             ARG_SET( convert, data_slot );
2155             /* Store the offset to the first unabsorbed branch in 
2156                jump[0], which is otherwise unused by the jump logic. 
2157                We use this when dumping a trie and during optimisation. */
2158             if (trie->jump) 
2159                 trie->jump[0] = (U16)(nextbranch - convert);
2160             
2161             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
2162              *   and there is a bitmap
2163              *   and the first "jump target" node we found leaves enough room
2164              * then convert the TRIE node into a TRIEC node, with the bitmap
2165              * embedded inline in the opcode - this is hypothetically faster.
2166              */
2167             if ( !trie->states[trie->startstate].wordnum
2168                  && trie->bitmap
2169                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
2170             {
2171                 OP( convert ) = TRIEC;
2172                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
2173                 PerlMemShared_free(trie->bitmap);
2174                 trie->bitmap= NULL;
2175             } else 
2176                 OP( convert ) = TRIE;
2177
2178             /* store the type in the flags */
2179             convert->flags = nodetype;
2180             DEBUG_r({
2181             optimize = convert 
2182                       + NODE_STEP_REGNODE 
2183                       + regarglen[ OP( convert ) ];
2184             });
2185             /* XXX We really should free up the resource in trie now, 
2186                    as we won't use them - (which resources?) dmq */
2187         }
2188         /* needed for dumping*/
2189         DEBUG_r(if (optimize) {
2190             regnode *opt = convert;
2191
2192             while ( ++opt < optimize) {
2193                 Set_Node_Offset_Length(opt,0,0);
2194             }
2195             /* 
2196                 Try to clean up some of the debris left after the 
2197                 optimisation.
2198              */
2199             while( optimize < jumper ) {
2200                 mjd_nodelen += Node_Length((optimize));
2201                 OP( optimize ) = OPTIMIZED;
2202                 Set_Node_Offset_Length(optimize,0,0);
2203                 optimize++;
2204             }
2205             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
2206         });
2207     } /* end node insert */
2208     REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, convert);
2209
2210     /*  Finish populating the prev field of the wordinfo array.  Walk back
2211      *  from each accept state until we find another accept state, and if
2212      *  so, point the first word's .prev field at the second word. If the
2213      *  second already has a .prev field set, stop now. This will be the
2214      *  case either if we've already processed that word's accept state,
2215      *  or that state had multiple words, and the overspill words were
2216      *  already linked up earlier.
2217      */
2218     {
2219         U16 word;
2220         U32 state;
2221         U16 prev;
2222
2223         for (word=1; word <= trie->wordcount; word++) {
2224             prev = 0;
2225             if (trie->wordinfo[word].prev)
2226                 continue;
2227             state = trie->wordinfo[word].accept;
2228             while (state) {
2229                 state = prev_states[state];
2230                 if (!state)
2231                     break;
2232                 prev = trie->states[state].wordnum;
2233                 if (prev)
2234                     break;
2235             }
2236             trie->wordinfo[word].prev = prev;
2237         }
2238         Safefree(prev_states);
2239     }
2240
2241
2242     /* and now dump out the compressed format */
2243     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
2244
2245     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
2246 #ifdef DEBUGGING
2247     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
2248     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
2249 #else
2250     SvREFCNT_dec(revcharmap);
2251 #endif
2252     return trie->jump 
2253            ? MADE_JUMP_TRIE 
2254            : trie->startstate>1 
2255              ? MADE_EXACT_TRIE 
2256              : MADE_TRIE;
2257 }
2258
2259 STATIC void
2260 S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source,  regnode *stclass, U32 depth)
2261 {
2262 /* The Trie is constructed and compressed now so we can build a fail array if it's needed
2263
2264    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
2265    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
2266    ISBN 0-201-10088-6
2267
2268    We find the fail state for each state in the trie, this state is the longest proper
2269    suffix of the current state's 'word' that is also a proper prefix of another word in our
2270    trie. State 1 represents the word '' and is thus the default fail state. This allows
2271    the DFA not to have to restart after its tried and failed a word at a given point, it
2272    simply continues as though it had been matching the other word in the first place.
2273    Consider
2274       'abcdgu'=~/abcdefg|cdgu/
2275    When we get to 'd' we are still matching the first word, we would encounter 'g' which would
2276    fail, which would bring us to the state representing 'd' in the second word where we would
2277    try 'g' and succeed, proceeding to match 'cdgu'.
2278  */
2279  /* add a fail transition */
2280     const U32 trie_offset = ARG(source);
2281     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
2282     U32 *q;
2283     const U32 ucharcount = trie->uniquecharcount;
2284     const U32 numstates = trie->statecount;
2285     const U32 ubound = trie->lasttrans + ucharcount;
2286     U32 q_read = 0;
2287     U32 q_write = 0;
2288     U32 charid;
2289     U32 base = trie->states[ 1 ].trans.base;
2290     U32 *fail;
2291     reg_ac_data *aho;
2292     const U32 data_slot = add_data( pRExC_state, 1, "T" );
2293     GET_RE_DEBUG_FLAGS_DECL;
2294
2295     PERL_ARGS_ASSERT_MAKE_TRIE_FAILTABLE;
2296 #ifndef DEBUGGING
2297     PERL_UNUSED_ARG(depth);
2298 #endif
2299
2300
2301     ARG_SET( stclass, data_slot );
2302     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
2303     RExC_rxi->data->data[ data_slot ] = (void*)aho;
2304     aho->trie=trie_offset;
2305     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
2306     Copy( trie->states, aho->states, numstates, reg_trie_state );
2307     Newxz( q, numstates, U32);
2308     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
2309     aho->refcount = 1;
2310     fail = aho->fail;
2311     /* initialize fail[0..1] to be 1 so that we always have
2312        a valid final fail state */
2313     fail[ 0 ] = fail[ 1 ] = 1;
2314
2315     for ( charid = 0; charid < ucharcount ; charid++ ) {
2316         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
2317         if ( newstate ) {
2318             q[ q_write ] = newstate;
2319             /* set to point at the root */
2320             fail[ q[ q_write++ ] ]=1;
2321         }
2322     }
2323     while ( q_read < q_write) {
2324         const U32 cur = q[ q_read++ % numstates ];
2325         base = trie->states[ cur ].trans.base;
2326
2327         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
2328             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
2329             if (ch_state) {
2330                 U32 fail_state = cur;
2331                 U32 fail_base;
2332                 do {
2333                     fail_state = fail[ fail_state ];
2334                     fail_base = aho->states[ fail_state ].trans.base;
2335                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
2336
2337                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
2338                 fail[ ch_state ] = fail_state;
2339                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
2340                 {
2341                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
2342                 }
2343                 q[ q_write++ % numstates] = ch_state;
2344             }
2345         }
2346     }
2347     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
2348        when we fail in state 1, this allows us to use the
2349        charclass scan to find a valid start char. This is based on the principle
2350        that theres a good chance the string being searched contains lots of stuff
2351        that cant be a start char.
2352      */
2353     fail[ 0 ] = fail[ 1 ] = 0;
2354     DEBUG_TRIE_COMPILE_r({
2355         PerlIO_printf(Perl_debug_log,
2356                       "%*sStclass Failtable (%"UVuf" states): 0", 
2357                       (int)(depth * 2), "", (UV)numstates
2358         );
2359         for( q_read=1; q_read<numstates; q_read++ ) {
2360             PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
2361         }
2362         PerlIO_printf(Perl_debug_log, "\n");
2363     });
2364     Safefree(q);
2365     /*RExC_seen |= REG_SEEN_TRIEDFA;*/
2366 }
2367
2368
2369 /*
2370  * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2371  * These need to be revisited when a newer toolchain becomes available.
2372  */
2373 #if defined(__sparc64__) && defined(__GNUC__)
2374 #   if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2375 #       undef  SPARC64_GCC_WORKAROUND
2376 #       define SPARC64_GCC_WORKAROUND 1
2377 #   endif
2378 #endif
2379
2380 #define DEBUG_PEEP(str,scan,depth) \
2381     DEBUG_OPTIMISE_r({if (scan){ \
2382        SV * const mysv=sv_newmortal(); \
2383        regnode *Next = regnext(scan); \
2384        regprop(RExC_rx, mysv, scan); \
2385        PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
2386        (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
2387        Next ? (REG_NODE_NUM(Next)) : 0 ); \
2388    }});
2389
2390
2391
2392
2393
2394 #define JOIN_EXACT(scan,min,flags) \
2395     if (PL_regkind[OP(scan)] == EXACT) \
2396         join_exact(pRExC_state,(scan),(min),(flags),NULL,depth+1)
2397
2398 STATIC U32
2399 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, I32 *min, U32 flags,regnode *val, U32 depth) {
2400     /* Merge several consecutive EXACTish nodes into one. */
2401     regnode *n = regnext(scan);
2402     U32 stringok = 1;
2403     regnode *next = scan + NODE_SZ_STR(scan);
2404     U32 merged = 0;
2405     U32 stopnow = 0;
2406 #ifdef DEBUGGING
2407     regnode *stop = scan;
2408     GET_RE_DEBUG_FLAGS_DECL;
2409 #else
2410     PERL_UNUSED_ARG(depth);
2411 #endif
2412
2413     PERL_ARGS_ASSERT_JOIN_EXACT;
2414 #ifndef EXPERIMENTAL_INPLACESCAN
2415     PERL_UNUSED_ARG(flags);
2416     PERL_UNUSED_ARG(val);
2417 #endif
2418     DEBUG_PEEP("join",scan,depth);
2419     
2420     /* Skip NOTHING, merge EXACT*. */
2421     while (n &&
2422            ( PL_regkind[OP(n)] == NOTHING ||
2423              (stringok && (OP(n) == OP(scan))))
2424            && NEXT_OFF(n)
2425            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
2426         
2427         if (OP(n) == TAIL || n > next)
2428             stringok = 0;
2429         if (PL_regkind[OP(n)] == NOTHING) {
2430             DEBUG_PEEP("skip:",n,depth);
2431             NEXT_OFF(scan) += NEXT_OFF(n);
2432             next = n + NODE_STEP_REGNODE;
2433 #ifdef DEBUGGING
2434             if (stringok)
2435                 stop = n;
2436 #endif
2437             n = regnext(n);
2438         }
2439         else if (stringok) {
2440             const unsigned int oldl = STR_LEN(scan);
2441             regnode * const nnext = regnext(n);
2442             
2443             DEBUG_PEEP("merg",n,depth);
2444             
2445             merged++;
2446             if (oldl + STR_LEN(n) > U8_MAX)
2447                 break;
2448             NEXT_OFF(scan) += NEXT_OFF(n);
2449             STR_LEN(scan) += STR_LEN(n);
2450             next = n + NODE_SZ_STR(n);
2451             /* Now we can overwrite *n : */
2452             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
2453 #ifdef DEBUGGING
2454             stop = next - 1;
2455 #endif
2456             n = nnext;
2457             if (stopnow) break;
2458         }
2459
2460 #ifdef EXPERIMENTAL_INPLACESCAN
2461         if (flags && !NEXT_OFF(n)) {
2462             DEBUG_PEEP("atch", val, depth);
2463             if (reg_off_by_arg[OP(n)]) {
2464                 ARG_SET(n, val - n);
2465             }
2466             else {
2467                 NEXT_OFF(n) = val - n;
2468             }
2469             stopnow = 1;
2470         }
2471 #endif
2472     }
2473 #define GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS   0x0390
2474 #define IOTA_D_T        GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS
2475 #define GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS     0x03B0
2476 #define UPSILON_D_T     GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS
2477
2478     if (UTF
2479         && ( OP(scan) == EXACTF || OP(scan) == EXACTFU || OP(scan) == EXACTFA)
2480         && ( STR_LEN(scan) >= 6 ) )
2481     {
2482     /*
2483     Two problematic code points in Unicode casefolding of EXACT nodes:
2484     
2485     U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
2486     U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
2487     
2488     which casefold to
2489     
2490     Unicode                      UTF-8
2491     
2492     U+03B9 U+0308 U+0301         0xCE 0xB9 0xCC 0x88 0xCC 0x81
2493     U+03C5 U+0308 U+0301         0xCF 0x85 0xCC 0x88 0xCC 0x81
2494     
2495     This means that in case-insensitive matching (or "loose matching",
2496     as Unicode calls it), an EXACTF of length six (the UTF-8 encoded byte
2497     length of the above casefolded versions) can match a target string
2498     of length two (the byte length of UTF-8 encoded U+0390 or U+03B0).
2499     This would rather mess up the minimum length computation.
2500     
2501     What we'll do is to look for the tail four bytes, and then peek
2502     at the preceding two bytes to see whether we need to decrease
2503     the minimum length by four (six minus two).
2504     
2505     Thanks to the design of UTF-8, there cannot be false matches:
2506     A sequence of valid UTF-8 bytes cannot be a subsequence of
2507     another valid sequence of UTF-8 bytes.
2508     
2509     */
2510          char * const s0 = STRING(scan), *s, *t;
2511          char * const s1 = s0 + STR_LEN(scan) - 1;
2512          char * const s2 = s1 - 4;
2513 #ifdef EBCDIC /* RD tunifold greek 0390 and 03B0 */
2514          const char t0[] = "\xaf\x49\xaf\x42";
2515 #else
2516          const char t0[] = "\xcc\x88\xcc\x81";
2517 #endif
2518          const char * const t1 = t0 + 3;
2519     
2520          for (s = s0 + 2;
2521               s < s2 && (t = ninstr(s, s1, t0, t1));
2522               s = t + 4) {
2523 #ifdef EBCDIC
2524               if (((U8)t[-1] == 0x68 && (U8)t[-2] == 0xB4) ||
2525                   ((U8)t[-1] == 0x46 && (U8)t[-2] == 0xB5))
2526 #else
2527               if (((U8)t[-1] == 0xB9 && (U8)t[-2] == 0xCE) ||
2528                   ((U8)t[-1] == 0x85 && (U8)t[-2] == 0xCF))
2529 #endif
2530                    *min -= 4;
2531          }
2532     }
2533     
2534 #ifdef DEBUGGING
2535     /* Allow dumping */
2536     n = scan + NODE_SZ_STR(scan);
2537     while (n <= stop) {
2538         if (PL_regkind[OP(n)] != NOTHING || OP(n) == NOTHING) {
2539             OP(n) = OPTIMIZED;
2540             NEXT_OFF(n) = 0;
2541         }
2542         n++;
2543     }
2544 #endif
2545     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
2546     return stopnow;
2547 }
2548
2549 /* REx optimizer.  Converts nodes into quicker variants "in place".
2550    Finds fixed substrings.  */
2551
2552 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
2553    to the position after last scanned or to NULL. */
2554
2555 #define INIT_AND_WITHP \
2556     assert(!and_withp); \
2557     Newx(and_withp,1,struct regnode_charclass_class); \
2558     SAVEFREEPV(and_withp)
2559
2560 /* this is a chain of data about sub patterns we are processing that
2561    need to be handled separately/specially in study_chunk. Its so
2562    we can simulate recursion without losing state.  */
2563 struct scan_frame;
2564 typedef struct scan_frame {
2565     regnode *last;  /* last node to process in this frame */
2566     regnode *next;  /* next node to process when last is reached */
2567     struct scan_frame *prev; /*previous frame*/
2568     I32 stop; /* what stopparen do we use */
2569 } scan_frame;
2570
2571
2572 #define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf)
2573
2574 #define CASE_SYNST_FNC(nAmE)                                       \
2575 case nAmE:                                                         \
2576     if (flags & SCF_DO_STCLASS_AND) {                              \
2577             for (value = 0; value < 256; value++)                  \
2578                 if (!is_ ## nAmE ## _cp(value))                       \
2579                     ANYOF_BITMAP_CLEAR(data->start_class, value);  \
2580     }                                                              \
2581     else {                                                         \
2582             for (value = 0; value < 256; value++)                  \
2583                 if (is_ ## nAmE ## _cp(value))                        \
2584                     ANYOF_BITMAP_SET(data->start_class, value);    \
2585     }                                                              \
2586     break;                                                         \
2587 case N ## nAmE:                                                    \
2588     if (flags & SCF_DO_STCLASS_AND) {                              \
2589             for (value = 0; value < 256; value++)                   \
2590                 if (is_ ## nAmE ## _cp(value))                         \
2591                     ANYOF_BITMAP_CLEAR(data->start_class, value);   \
2592     }                                                               \
2593     else {                                                          \
2594             for (value = 0; value < 256; value++)                   \
2595                 if (!is_ ## nAmE ## _cp(value))                        \
2596                     ANYOF_BITMAP_SET(data->start_class, value);     \
2597     }                                                               \
2598     break
2599
2600
2601
2602 STATIC I32
2603 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
2604                         I32 *minlenp, I32 *deltap,
2605                         regnode *last,
2606                         scan_data_t *data,
2607                         I32 stopparen,
2608                         U8* recursed,
2609                         struct regnode_charclass_class *and_withp,
2610                         U32 flags, U32 depth)
2611                         /* scanp: Start here (read-write). */
2612                         /* deltap: Write maxlen-minlen here. */
2613                         /* last: Stop before this one. */
2614                         /* data: string data about the pattern */
2615                         /* stopparen: treat close N as END */
2616                         /* recursed: which subroutines have we recursed into */
2617                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
2618 {
2619     dVAR;
2620     I32 min = 0, pars = 0, code;
2621     regnode *scan = *scanp, *next;
2622     I32 delta = 0;
2623     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
2624     int is_inf_internal = 0;            /* The studied chunk is infinite */
2625     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
2626     scan_data_t data_fake;
2627     SV *re_trie_maxbuff = NULL;
2628     regnode *first_non_open = scan;
2629     I32 stopmin = I32_MAX;
2630     scan_frame *frame = NULL;
2631     GET_RE_DEBUG_FLAGS_DECL;
2632
2633     PERL_ARGS_ASSERT_STUDY_CHUNK;
2634
2635 #ifdef DEBUGGING
2636     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
2637 #endif
2638
2639     if ( depth == 0 ) {
2640         while (first_non_open && OP(first_non_open) == OPEN)
2641             first_non_open=regnext(first_non_open);
2642     }
2643
2644
2645   fake_study_recurse:
2646     while ( scan && OP(scan) != END && scan < last ){
2647         /* Peephole optimizer: */
2648         DEBUG_STUDYDATA("Peep:", data,depth);
2649         DEBUG_PEEP("Peep",scan,depth);
2650         JOIN_EXACT(scan,&min,0);
2651
2652         /* Follow the next-chain of the current node and optimize
2653            away all the NOTHINGs from it.  */
2654         if (OP(scan) != CURLYX) {
2655             const int max = (reg_off_by_arg[OP(scan)]
2656                        ? I32_MAX
2657                        /* I32 may be smaller than U16 on CRAYs! */
2658                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
2659             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
2660             int noff;
2661             regnode *n = scan;
2662         
2663             /* Skip NOTHING and LONGJMP. */
2664             while ((n = regnext(n))
2665                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
2666                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
2667                    && off + noff < max)
2668                 off += noff;
2669             if (reg_off_by_arg[OP(scan)])
2670                 ARG(scan) = off;
2671             else
2672                 NEXT_OFF(scan) = off;
2673         }
2674
2675
2676
2677         /* The principal pseudo-switch.  Cannot be a switch, since we
2678            look into several different things.  */
2679         if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
2680                    || OP(scan) == IFTHEN) {
2681             next = regnext(scan);
2682             code = OP(scan);
2683             /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
2684         
2685             if (OP(next) == code || code == IFTHEN) {
2686                 /* NOTE - There is similar code to this block below for handling
2687                    TRIE nodes on a re-study.  If you change stuff here check there
2688                    too. */
2689                 I32 max1 = 0, min1 = I32_MAX, num = 0;
2690                 struct regnode_charclass_class accum;
2691                 regnode * const startbranch=scan;
2692                 
2693                 if (flags & SCF_DO_SUBSTR)
2694                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
2695                 if (flags & SCF_DO_STCLASS)
2696                     cl_init_zero(pRExC_state, &accum);
2697
2698                 while (OP(scan) == code) {
2699                     I32 deltanext, minnext, f = 0, fake;
2700                     struct regnode_charclass_class this_class;
2701
2702                     num++;
2703                     data_fake.flags = 0;
2704                     if (data) {
2705                         data_fake.whilem_c = data->whilem_c;
2706                         data_fake.last_closep = data->last_closep;
2707                     }
2708                     else
2709                         data_fake.last_closep = &fake;
2710
2711                     data_fake.pos_delta = delta;
2712                     next = regnext(scan);
2713                     scan = NEXTOPER(scan);
2714                     if (code != BRANCH)
2715                         scan = NEXTOPER(scan);
2716                     if (flags & SCF_DO_STCLASS) {
2717                         cl_init(pRExC_state, &this_class);
2718                         data_fake.start_class = &this_class;
2719                         f = SCF_DO_STCLASS_AND;
2720                     }
2721                     if (flags & SCF_WHILEM_VISITED_POS)
2722                         f |= SCF_WHILEM_VISITED_POS;
2723
2724                     /* we suppose the run is continuous, last=next...*/
2725                     minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
2726                                           next, &data_fake,
2727                                           stopparen, recursed, NULL, f,depth+1);
2728                     if (min1 > minnext)
2729                         min1 = minnext;
2730                     if (max1 < minnext + deltanext)
2731                         max1 = minnext + deltanext;
2732                     if (deltanext == I32_MAX)
2733                         is_inf = is_inf_internal = 1;
2734                     scan = next;
2735                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
2736                         pars++;
2737                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
2738                         if ( stopmin > minnext) 
2739                             stopmin = min + min1;
2740                         flags &= ~SCF_DO_SUBSTR;
2741                         if (data)
2742                             data->flags |= SCF_SEEN_ACCEPT;
2743                     }
2744                     if (data) {
2745                         if (data_fake.flags & SF_HAS_EVAL)
2746                             data->flags |= SF_HAS_EVAL;
2747                         data->whilem_c = data_fake.whilem_c;
2748                     }
2749                     if (flags & SCF_DO_STCLASS)
2750                         cl_or(pRExC_state, &accum, &this_class);
2751                 }
2752                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
2753                     min1 = 0;
2754                 if (flags & SCF_DO_SUBSTR) {
2755                     data->pos_min += min1;
2756                     data->pos_delta += max1 - min1;
2757                     if (max1 != min1 || is_inf)
2758                         data->longest = &(data->longest_float);
2759                 }
2760                 min += min1;
2761                 delta += max1 - min1;
2762                 if (flags & SCF_DO_STCLASS_OR) {
2763                     cl_or(pRExC_state, data->start_class, &accum);
2764                     if (min1) {
2765                         cl_and(data->start_class, and_withp);
2766                         flags &= ~SCF_DO_STCLASS;
2767                     }
2768                 }
2769                 else if (flags & SCF_DO_STCLASS_AND) {
2770                     if (min1) {
2771                         cl_and(data->start_class, &accum);
2772                         flags &= ~SCF_DO_STCLASS;
2773                     }
2774                     else {
2775                         /* Switch to OR mode: cache the old value of
2776                          * data->start_class */
2777                         INIT_AND_WITHP;
2778                         StructCopy(data->start_class, and_withp,
2779                                    struct regnode_charclass_class);
2780                         flags &= ~SCF_DO_STCLASS_AND;
2781                         StructCopy(&accum, data->start_class,
2782                                    struct regnode_charclass_class);
2783                         flags |= SCF_DO_STCLASS_OR;
2784                         data->start_class->flags |= ANYOF_EOS;
2785                     }
2786                 }
2787
2788                 if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) == BRANCH ) {
2789                 /* demq.
2790
2791                    Assuming this was/is a branch we are dealing with: 'scan' now
2792                    points at the item that follows the branch sequence, whatever
2793                    it is. We now start at the beginning of the sequence and look
2794                    for subsequences of
2795
2796                    BRANCH->EXACT=>x1
2797                    BRANCH->EXACT=>x2
2798                    tail
2799
2800                    which would be constructed from a pattern like /A|LIST|OF|WORDS/
2801
2802                    If we can find such a subsequence we need to turn the first
2803                    element into a trie and then add the subsequent branch exact
2804                    strings to the trie.
2805
2806                    We have two cases
2807
2808                      1. patterns where the whole set of branches can be converted. 
2809
2810                      2. patterns where only a subset can be converted.
2811
2812                    In case 1 we can replace the whole set with a single regop
2813                    for the trie. In case 2 we need to keep the start and end
2814                    branches so
2815
2816                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
2817                      becomes BRANCH TRIE; BRANCH X;
2818
2819                   There is an additional case, that being where there is a 
2820                   common prefix, which gets split out into an EXACT like node
2821                   preceding the TRIE node.
2822
2823                   If x(1..n)==tail then we can do a simple trie, if not we make
2824                   a "jump" trie, such that when we match the appropriate word
2825                   we "jump" to the appropriate tail node. Essentially we turn
2826                   a nested if into a case structure of sorts.
2827
2828                 */
2829                 
2830                     int made=0;
2831                     if (!re_trie_maxbuff) {
2832                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2833                         if (!SvIOK(re_trie_maxbuff))
2834                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2835                     }
2836                     if ( SvIV(re_trie_maxbuff)>=0  ) {
2837                         regnode *cur;
2838                         regnode *first = (regnode *)NULL;
2839                         regnode *last = (regnode *)NULL;
2840                         regnode *tail = scan;
2841                         U8 optype = 0;
2842                         U32 count=0;
2843
2844 #ifdef DEBUGGING
2845                         SV * const mysv = sv_newmortal();       /* for dumping */
2846 #endif
2847                         /* var tail is used because there may be a TAIL
2848                            regop in the way. Ie, the exacts will point to the
2849                            thing following the TAIL, but the last branch will
2850                            point at the TAIL. So we advance tail. If we
2851                            have nested (?:) we may have to move through several
2852                            tails.
2853                          */
2854
2855                         while ( OP( tail ) == TAIL ) {
2856                             /* this is the TAIL generated by (?:) */
2857                             tail = regnext( tail );
2858                         }
2859
2860                         
2861                         DEBUG_OPTIMISE_r({
2862                             regprop(RExC_rx, mysv, tail );
2863                             PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
2864                                 (int)depth * 2 + 2, "", 
2865                                 "Looking for TRIE'able sequences. Tail node is: ", 
2866                                 SvPV_nolen_const( mysv )
2867                             );
2868                         });
2869                         
2870                         /*
2871
2872                            step through the branches, cur represents each
2873                            branch, noper is the first thing to be matched
2874                            as part of that branch and noper_next is the
2875                            regnext() of that node. if noper is an EXACT
2876                            and noper_next is the same as scan (our current
2877                            position in the regex) then the EXACT branch is
2878                            a possible optimization target. Once we have
2879                            two or more consecutive such branches we can
2880                            create a trie of the EXACT's contents and stich
2881                            it in place. If the sequence represents all of
2882                            the branches we eliminate the whole thing and
2883                            replace it with a single TRIE. If it is a
2884                            subsequence then we need to stitch it in. This
2885                            means the first branch has to remain, and needs
2886                            to be repointed at the item on the branch chain
2887                            following the last branch optimized. This could
2888                            be either a BRANCH, in which case the
2889                            subsequence is internal, or it could be the
2890                            item following the branch sequence in which
2891                            case the subsequence is at the end.
2892
2893                         */
2894
2895                         /* dont use tail as the end marker for this traverse */
2896                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
2897                             regnode * const noper = NEXTOPER( cur );
2898 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
2899                             regnode * const noper_next = regnext( noper );
2900 #endif
2901
2902                             DEBUG_OPTIMISE_r({
2903                                 regprop(RExC_rx, mysv, cur);
2904                                 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
2905                                    (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
2906
2907                                 regprop(RExC_rx, mysv, noper);
2908                                 PerlIO_printf( Perl_debug_log, " -> %s",
2909                                     SvPV_nolen_const(mysv));
2910
2911                                 if ( noper_next ) {
2912                                   regprop(RExC_rx, mysv, noper_next );
2913                                   PerlIO_printf( Perl_debug_log,"\t=> %s\t",
2914                                     SvPV_nolen_const(mysv));
2915                                 }
2916                                 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d)\n",
2917                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur) );
2918                             });
2919                             if ( (((first && optype!=NOTHING) ? OP( noper ) == optype
2920                                          : PL_regkind[ OP( noper ) ] == EXACT )
2921                                   || OP(noper) == NOTHING )
2922 #ifdef NOJUMPTRIE
2923                                   && noper_next == tail
2924 #endif
2925                                   && count < U16_MAX)
2926                             {
2927                                 count++;
2928                                 if ( !first || optype == NOTHING ) {
2929                                     if (!first) first = cur;
2930                                     optype = OP( noper );
2931                                 } else {
2932                                     last = cur;
2933                                 }
2934                             } else {
2935 /* 
2936     Currently we do not believe that the trie logic can
2937     handle case insensitive matching properly when the
2938     pattern is not unicode (thus forcing unicode semantics).
2939
2940     If/when this is fixed the following define can be swapped
2941     in below to fully enable trie logic.
2942
2943 #define TRIE_TYPE_IS_SAFE 1
2944
2945 */
2946 #define TRIE_TYPE_IS_SAFE (UTF || optype==EXACT)
2947
2948                                 if ( last && TRIE_TYPE_IS_SAFE ) {
2949                                     make_trie( pRExC_state, 
2950                                             startbranch, first, cur, tail, count, 
2951                                             optype, depth+1 );
2952                                 }
2953                                 if ( PL_regkind[ OP( noper ) ] == EXACT
2954 #ifdef NOJUMPTRIE
2955                                      && noper_next == tail
2956 #endif
2957                                 ){
2958                                     count = 1;
2959                                     first = cur;
2960                                     optype = OP( noper );
2961                                 } else {
2962                                     count = 0;
2963                                     first = NULL;
2964                                     optype = 0;
2965                                 }
2966                                 last = NULL;
2967                             }
2968                         }
2969                         DEBUG_OPTIMISE_r({
2970                             regprop(RExC_rx, mysv, cur);
2971                             PerlIO_printf( Perl_debug_log,
2972                               "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
2973                               "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
2974
2975                         });
2976                         
2977                         if ( last && TRIE_TYPE_IS_SAFE ) {
2978                             made= make_trie( pRExC_state, startbranch, first, scan, tail, count, optype, depth+1 );
2979 #ifdef TRIE_STUDY_OPT   
2980                             if ( ((made == MADE_EXACT_TRIE && 
2981                                  startbranch == first) 
2982                                  || ( first_non_open == first )) && 
2983                                  depth==0 ) {
2984                                 flags |= SCF_TRIE_RESTUDY;
2985                                 if ( startbranch == first 
2986                                      && scan == tail ) 
2987                                 {
2988                                     RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
2989                                 }
2990                             }
2991 #endif
2992                         }
2993                     }
2994                     
2995                 } /* do trie */
2996                 
2997             }
2998             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
2999                 scan = NEXTOPER(NEXTOPER(scan));
3000             } else                      /* single branch is optimized. */
3001                 scan = NEXTOPER(scan);
3002             continue;
3003         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
3004             scan_frame *newframe = NULL;
3005             I32 paren;
3006             regnode *start;
3007             regnode *end;
3008
3009             if (OP(scan) != SUSPEND) {
3010             /* set the pointer */
3011                 if (OP(scan) == GOSUB) {
3012                     paren = ARG(scan);
3013                     RExC_recurse[ARG2L(scan)] = scan;
3014                     start = RExC_open_parens[paren-1];
3015                     end   = RExC_close_parens[paren-1];
3016                 } else {
3017                     paren = 0;
3018                     start = RExC_rxi->program + 1;
3019                     end   = RExC_opend;
3020                 }
3021                 if (!recursed) {
3022                     Newxz(recursed, (((RExC_npar)>>3) +1), U8);
3023                     SAVEFREEPV(recursed);
3024                 }
3025                 if (!PAREN_TEST(recursed,paren+1)) {
3026                     PAREN_SET(recursed,paren+1);
3027                     Newx(newframe,1,scan_frame);
3028                 } else {
3029                     if (flags & SCF_DO_SUBSTR) {
3030                         SCAN_COMMIT(pRExC_state,data,minlenp);
3031                         data->longest = &(data->longest_float);
3032                     }
3033                     is_inf = is_inf_internal = 1;
3034                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3035                         cl_anything(pRExC_state, data->start_class);
3036                     flags &= ~SCF_DO_STCLASS;
3037                 }
3038             } else {
3039                 Newx(newframe,1,scan_frame);
3040                 paren = stopparen;
3041                 start = scan+2;
3042                 end = regnext(scan);
3043             }
3044             if (newframe) {
3045                 assert(start);
3046                 assert(end);
3047                 SAVEFREEPV(newframe);
3048                 newframe->next = regnext(scan);
3049                 newframe->last = last;
3050                 newframe->stop = stopparen;
3051                 newframe->prev = frame;
3052
3053                 frame = newframe;
3054                 scan =  start;
3055                 stopparen = paren;
3056                 last = end;
3057
3058                 continue;
3059             }
3060         }
3061         else if (OP(scan) == EXACT) {
3062             I32 l = STR_LEN(scan);
3063             UV uc;
3064             if (UTF) {
3065                 const U8 * const s = (U8*)STRING(scan);
3066                 l = utf8_length(s, s + l);
3067                 uc = utf8_to_uvchr(s, NULL);
3068             } else {
3069                 uc = *((U8*)STRING(scan));
3070             }
3071             min += l;
3072             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
3073                 /* The code below prefers earlier match for fixed
3074                    offset, later match for variable offset.  */
3075                 if (data->last_end == -1) { /* Update the start info. */
3076                     data->last_start_min = data->pos_min;
3077                     data->last_start_max = is_inf
3078                         ? I32_MAX : data->pos_min + data->pos_delta;
3079                 }
3080                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
3081                 if (UTF)
3082                     SvUTF8_on(data->last_found);
3083                 {
3084                     SV * const sv = data->last_found;
3085                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3086                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
3087                     if (mg && mg->mg_len >= 0)
3088                         mg->mg_len += utf8_length((U8*)STRING(scan),
3089                                                   (U8*)STRING(scan)+STR_LEN(scan));
3090                 }
3091                 data->last_end = data->pos_min + l;
3092                 data->pos_min += l; /* As in the first entry. */
3093                 data->flags &= ~SF_BEFORE_EOL;
3094             }
3095             if (flags & SCF_DO_STCLASS_AND) {
3096                 /* Check whether it is compatible with what we know already! */
3097                 int compat = 1;
3098
3099
3100                 /* If compatible, we or it in below.  It is compatible if is
3101                  * in the bitmp and either 1) its bit or its fold is set, or 2)
3102                  * it's for a locale.  Even if there isn't unicode semantics
3103                  * here, at runtime there may be because of matching against a
3104                  * utf8 string, so accept a possible false positive for
3105                  * latin1-range folds */
3106                 if (uc >= 0x100 ||
3107                     (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3108                     && !ANYOF_BITMAP_TEST(data->start_class, uc)
3109                     && (!(data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD)
3110                         || !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3111                     )
3112                 {
3113                     compat = 0;
3114                 }
3115                 ANYOF_CLASS_ZERO(data->start_class);
3116                 ANYOF_BITMAP_ZERO(data->start_class);
3117                 if (compat)
3118                     ANYOF_BITMAP_SET(data->start_class, uc);
3119                 else if (uc >= 0x100) {
3120                     int i;
3121
3122                     /* Some Unicode code points fold to the Latin1 range; as
3123                      * XXX temporary code, instead of figuring out if this is
3124                      * one, just assume it is and set all the start class bits
3125                      * that could be some such above 255 code point's fold
3126                      * which will generate fals positives.  As the code
3127                      * elsewhere that does compute the fold settles down, it
3128                      * can be extracted out and re-used here */
3129                     for (i = 0; i < 256; i++){
3130                         if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3131                             ANYOF_BITMAP_SET(data->start_class, i);
3132                         }
3133                     }
3134                 }
3135                 data->start_class->flags &= ~ANYOF_EOS;
3136                 if (uc < 0x100)
3137                   data->start_class->flags &= ~ANYOF_UNICODE_ALL;
3138             }
3139             else if (flags & SCF_DO_STCLASS_OR) {
3140                 /* false positive possible if the class is case-folded */
3141                 if (uc < 0x100)
3142                     ANYOF_BITMAP_SET(data->start_class, uc);
3143                 else
3144                     data->start_class->flags |= ANYOF_UNICODE_ALL;
3145                 data->start_class->flags &= ~ANYOF_EOS;
3146                 cl_and(data->start_class, and_withp);
3147             }
3148             flags &= ~SCF_DO_STCLASS;
3149         }
3150         else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
3151             I32 l = STR_LEN(scan);
3152             UV uc = *((U8*)STRING(scan));
3153
3154             /* Search for fixed substrings supports EXACT only. */
3155             if (flags & SCF_DO_SUBSTR) {
3156                 assert(data);
3157                 SCAN_COMMIT(pRExC_state, data, minlenp);
3158             }
3159             if (UTF) {
3160                 const U8 * const s = (U8 *)STRING(scan);
3161                 l = utf8_length(s, s + l);
3162                 uc = utf8_to_uvchr(s, NULL);
3163             }
3164             min += l;
3165             if (flags & SCF_DO_SUBSTR)
3166                 data->pos_min += l;
3167             if (flags & SCF_DO_STCLASS_AND) {
3168                 /* Check whether it is compatible with what we know already! */
3169                 int compat = 1;
3170                 if (uc >= 0x100 ||
3171                  (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3172                   && !ANYOF_BITMAP_TEST(data->start_class, uc)
3173                   && !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3174                 {
3175                     compat = 0;
3176                 }
3177                 ANYOF_CLASS_ZERO(data->start_class);
3178                 ANYOF_BITMAP_ZERO(data->start_class);
3179                 if (compat) {
3180                     ANYOF_BITMAP_SET(data->start_class, uc);
3181                     data->start_class->flags &= ~ANYOF_EOS;
3182                     data->start_class->flags |= ANYOF_LOC_NONBITMAP_FOLD;
3183                     if (OP(scan) == EXACTFL) {
3184                         data->start_class->flags |= ANYOF_LOCALE;
3185                     }
3186                     else {
3187
3188                         /* Also set the other member of the fold pair.  In case
3189                          * that unicode semantics is called for at runtime, use
3190                          * the full latin1 fold.  (Can't do this for locale,
3191                          * because not known until runtime */
3192                         ANYOF_BITMAP_SET(data->start_class, PL_fold_latin1[uc]);
3193                     }
3194                 }
3195                 else if (uc >= 0x100) {
3196                     int i;
3197                     for (i = 0; i < 256; i++){
3198                         if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3199                             ANYOF_BITMAP_SET(data->start_class, i);
3200                         }
3201                     }
3202                 }
3203             }
3204             else if (flags & SCF_DO_STCLASS_OR) {
3205                 if (data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD) {
3206                     /* false positive possible if the class is case-folded.
3207                        Assume that the locale settings are the same... */
3208                     if (uc < 0x100) {
3209                         ANYOF_BITMAP_SET(data->start_class, uc);
3210                         if (OP(scan) != EXACTFL) {
3211
3212                             /* And set the other member of the fold pair, but
3213                              * can't do that in locale because not known until
3214                              * run-time */
3215                             ANYOF_BITMAP_SET(data->start_class,
3216                                              PL_fold_latin1[uc]);
3217                         }
3218                     }
3219                     data->start_class->flags &= ~ANYOF_EOS;
3220                 }
3221                 cl_and(data->start_class, and_withp);
3222             }
3223             flags &= ~SCF_DO_STCLASS;
3224         }
3225         else if (REGNODE_VARIES(OP(scan))) {
3226             I32 mincount, maxcount, minnext, deltanext, fl = 0;
3227             I32 f = flags, pos_before = 0;
3228             regnode * const oscan = scan;
3229             struct regnode_charclass_class this_class;
3230             struct regnode_charclass_class *oclass = NULL;
3231             I32 next_is_eval = 0;
3232
3233             switch (PL_regkind[OP(scan)]) {
3234             case WHILEM:                /* End of (?:...)* . */
3235                 scan = NEXTOPER(scan);
3236                 goto finish;
3237             case PLUS:
3238                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
3239                     next = NEXTOPER(scan);
3240                     if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
3241                         mincount = 1;
3242                         maxcount = REG_INFTY;
3243                         next = regnext(scan);
3244                         scan = NEXTOPER(scan);
3245                         goto do_curly;
3246                     }
3247                 }
3248                 if (flags & SCF_DO_SUBSTR)
3249                     data->pos_min++;
3250                 min++;
3251                 /* Fall through. */
3252             case STAR:
3253                 if (flags & SCF_DO_STCLASS) {
3254                     mincount = 0;
3255                     maxcount = REG_INFTY;
3256                     next = regnext(scan);
3257                     scan = NEXTOPER(scan);
3258                     goto do_curly;
3259                 }
3260                 is_inf = is_inf_internal = 1;
3261                 scan = regnext(scan);
3262                 if (flags & SCF_DO_SUBSTR) {
3263                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
3264                     data->longest = &(data->longest_float);
3265                 }
3266                 goto optimize_curly_tail;
3267             case CURLY:
3268                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
3269                     && (scan->flags == stopparen))
3270                 {
3271                     mincount = 1;
3272                     maxcount = 1;
3273                 } else {
3274                     mincount = ARG1(scan);
3275                     maxcount = ARG2(scan);
3276                 }
3277                 next = regnext(scan);
3278                 if (OP(scan) == CURLYX) {
3279                     I32 lp = (data ? *(data->last_closep) : 0);
3280                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
3281                 }
3282                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3283                 next_is_eval = (OP(scan) == EVAL);
3284               do_curly:
3285                 if (flags & SCF_DO_SUBSTR) {
3286                     if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
3287                     pos_before = data->pos_min;
3288                 }
3289                 if (data) {
3290                     fl = data->flags;
3291                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
3292                     if (is_inf)
3293                         data->flags |= SF_IS_INF;
3294                 }
3295                 if (flags & SCF_DO_STCLASS) {
3296                     cl_init(pRExC_state, &this_class);
3297                     oclass = data->start_class;
3298                     data->start_class = &this_class;
3299                     f |= SCF_DO_STCLASS_AND;
3300                     f &= ~SCF_DO_STCLASS_OR;
3301                 }
3302                 /* Exclude from super-linear cache processing any {n,m}
3303                    regops for which the combination of input pos and regex
3304                    pos is not enough information to determine if a match
3305                    will be possible.
3306
3307                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
3308                    regex pos at the \s*, the prospects for a match depend not
3309                    only on the input position but also on how many (bar\s*)
3310                    repeats into the {4,8} we are. */
3311                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
3312                     f &= ~SCF_WHILEM_VISITED_POS;
3313
3314                 /* This will finish on WHILEM, setting scan, or on NULL: */
3315                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, 
3316                                       last, data, stopparen, recursed, NULL,
3317                                       (mincount == 0
3318                                         ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
3319
3320                 if (flags & SCF_DO_STCLASS)
3321                     data->start_class = oclass;
3322                 if (mincount == 0 || minnext == 0) {
3323                     if (flags & SCF_DO_STCLASS_OR) {
3324                         cl_or(pRExC_state, data->start_class, &this_class);
3325                     }
3326                     else if (flags & SCF_DO_STCLASS_AND) {
3327                         /* Switch to OR mode: cache the old value of
3328                          * data->start_class */
3329                         INIT_AND_WITHP;
3330                         StructCopy(data->start_class, and_withp,
3331                                    struct regnode_charclass_class);
3332                         flags &= ~SCF_DO_STCLASS_AND;
3333                         StructCopy(&this_class, data->start_class,
3334                                    struct regnode_charclass_class);
3335                         flags |= SCF_DO_STCLASS_OR;
3336                         data->start_class->flags |= ANYOF_EOS;
3337                     }
3338                 } else {                /* Non-zero len */
3339                     if (flags & SCF_DO_STCLASS_OR) {
3340                         cl_or(pRExC_state, data->start_class, &this_class);
3341                         cl_and(data->start_class, and_withp);
3342                     }
3343                     else if (flags & SCF_DO_STCLASS_AND)
3344                         cl_and(data->start_class, &this_class);
3345                     flags &= ~SCF_DO_STCLASS;
3346                 }
3347                 if (!scan)              /* It was not CURLYX, but CURLY. */
3348                     scan = next;
3349                 if ( /* ? quantifier ok, except for (?{ ... }) */
3350                     (next_is_eval || !(mincount == 0 && maxcount == 1))
3351                     && (minnext == 0) && (deltanext == 0)
3352                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
3353                     && maxcount <= REG_INFTY/3) /* Complement check for big count */
3354                 {
3355                     ckWARNreg(RExC_parse,
3356                               "Quantifier unexpected on zero-length expression");
3357                 }
3358
3359                 min += minnext * mincount;
3360                 is_inf_internal |= ((maxcount == REG_INFTY
3361                                      && (minnext + deltanext) > 0)
3362                                     || deltanext == I32_MAX);
3363                 is_inf |= is_inf_internal;
3364                 delta += (minnext + deltanext) * maxcount - minnext * mincount;
3365
3366                 /* Try powerful optimization CURLYX => CURLYN. */
3367                 if (  OP(oscan) == CURLYX && data
3368                       && data->flags & SF_IN_PAR
3369                       && !(data->flags & SF_HAS_EVAL)
3370                       && !deltanext && minnext == 1 ) {
3371                     /* Try to optimize to CURLYN.  */
3372                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
3373                     regnode * const nxt1 = nxt;
3374 #ifdef DEBUGGING
3375                     regnode *nxt2;
3376 #endif
3377
3378                     /* Skip open. */
3379                     nxt = regnext(nxt);
3380                     if (!REGNODE_SIMPLE(OP(nxt))
3381                         && !(PL_regkind[OP(nxt)] == EXACT
3382                              && STR_LEN(nxt) == 1))
3383                         goto nogo;
3384 #ifdef DEBUGGING
3385                     nxt2 = nxt;
3386 #endif
3387                     nxt = regnext(nxt);
3388                     if (OP(nxt) != CLOSE)
3389                         goto nogo;
3390                     if (RExC_open_parens) {
3391                         RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3392                         RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
3393                     }
3394                     /* Now we know that nxt2 is the only contents: */
3395                     oscan->flags = (U8)ARG(nxt);
3396                     OP(oscan) = CURLYN;
3397                     OP(nxt1) = NOTHING; /* was OPEN. */
3398
3399 #ifdef DEBUGGING
3400                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3401                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
3402                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
3403                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
3404                     OP(nxt + 1) = OPTIMIZED; /* was count. */
3405                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
3406 #endif
3407                 }
3408               nogo:
3409
3410                 /* Try optimization CURLYX => CURLYM. */
3411                 if (  OP(oscan) == CURLYX && data
3412                       && !(data->flags & SF_HAS_PAR)
3413                       && !(data->flags & SF_HAS_EVAL)
3414                       && !deltanext     /* atom is fixed width */
3415                       && minnext != 0   /* CURLYM can't handle zero width */
3416                 ) {
3417                     /* XXXX How to optimize if data == 0? */
3418                     /* Optimize to a simpler form.  */
3419                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
3420                     regnode *nxt2;
3421
3422                     OP(oscan) = CURLYM;
3423                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
3424                             && (OP(nxt2) != WHILEM))
3425                         nxt = nxt2;
3426                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
3427                     /* Need to optimize away parenths. */
3428                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
3429                         /* Set the parenth number.  */
3430                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
3431
3432                         oscan->flags = (U8)ARG(nxt);
3433                         if (RExC_open_parens) {
3434                             RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3435                             RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
3436                         }
3437                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
3438                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
3439
3440 #ifdef DEBUGGING
3441                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3442                         OP(nxt + 1) = OPTIMIZED; /* was count. */
3443                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
3444                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
3445 #endif
3446 #if 0
3447                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
3448                             regnode *nnxt = regnext(nxt1);
3449                             if (nnxt == nxt) {
3450                                 if (reg_off_by_arg[OP(nxt1)])
3451                                     ARG_SET(nxt1, nxt2 - nxt1);
3452                                 else if (nxt2 - nxt1 < U16_MAX)
3453                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
3454                                 else
3455                                     OP(nxt) = NOTHING;  /* Cannot beautify */
3456                             }
3457                             nxt1 = nnxt;
3458                         }
3459 #endif
3460                         /* Optimize again: */
3461                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
3462                                     NULL, stopparen, recursed, NULL, 0,depth+1);
3463                     }
3464                     else
3465                         oscan->flags = 0;
3466                 }
3467                 else if ((OP(oscan) == CURLYX)
3468                          && (flags & SCF_WHILEM_VISITED_POS)
3469                          /* See the comment on a similar expression above.
3470                             However, this time it's not a subexpression
3471                             we care about, but the expression itself. */
3472                          && (maxcount == REG_INFTY)
3473                          && data && ++data->whilem_c < 16) {
3474                     /* This stays as CURLYX, we can put the count/of pair. */
3475                     /* Find WHILEM (as in regexec.c) */
3476                     regnode *nxt = oscan + NEXT_OFF(oscan);
3477
3478                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
3479                         nxt += ARG(nxt);
3480                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
3481                         | (RExC_whilem_seen << 4)); /* On WHILEM */
3482                 }
3483                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
3484                     pars++;
3485                 if (flags & SCF_DO_SUBSTR) {
3486                     SV *last_str = NULL;
3487                     int counted = mincount != 0;
3488
3489                     if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
3490 #if defined(SPARC64_GCC_WORKAROUND)
3491                         I32 b = 0;
3492                         STRLEN l = 0;
3493                         const char *s = NULL;
3494                         I32 old = 0;
3495
3496                         if (pos_before >= data->last_start_min)
3497                             b = pos_before;
3498                         else
3499                             b = data->last_start_min;
3500
3501                         l = 0;
3502                         s = SvPV_const(data->last_found, l);
3503                         old = b - data->last_start_min;
3504
3505 #else
3506                         I32 b = pos_before >= data->last_start_min
3507                             ? pos_before : data->last_start_min;
3508                         STRLEN l;
3509                         const char * const s = SvPV_const(data->last_found, l);
3510                         I32 old = b - data->last_start_min;
3511 #endif
3512
3513                         if (UTF)
3514                             old = utf8_hop((U8*)s, old) - (U8*)s;
3515                         l -= old;
3516                         /* Get the added string: */
3517                         last_str = newSVpvn_utf8(s  + old, l, UTF);
3518                         if (deltanext == 0 && pos_before == b) {
3519                             /* What was added is a constant string */
3520                             if (mincount > 1) {
3521                                 SvGROW(last_str, (mincount * l) + 1);
3522                                 repeatcpy(SvPVX(last_str) + l,
3523                                           SvPVX_const(last_str), l, mincount - 1);
3524                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
3525                                 /* Add additional parts. */
3526                                 SvCUR_set(data->last_found,
3527                                           SvCUR(data->last_found) - l);
3528                                 sv_catsv(data->last_found, last_str);
3529                                 {
3530                                     SV * sv = data->last_found;
3531                                     MAGIC *mg =
3532                                         SvUTF8(sv) && SvMAGICAL(sv) ?
3533                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
3534                                     if (mg && mg->mg_len >= 0)
3535                                         mg->mg_len += CHR_SVLEN(last_str) - l;
3536                                 }
3537                                 data->last_end += l * (mincount - 1);
3538                             }
3539                         } else {
3540                             /* start offset must point into the last copy */
3541                             data->last_start_min += minnext * (mincount - 1);
3542                             data->last_start_max += is_inf ? I32_MAX
3543                                 : (maxcount - 1) * (minnext + data->pos_delta);
3544                         }
3545                     }
3546                     /* It is counted once already... */
3547                     data->pos_min += minnext * (mincount - counted);
3548                     data->pos_delta += - counted * deltanext +
3549                         (minnext + deltanext) * maxcount - minnext * mincount;
3550                     if (mincount != maxcount) {
3551                          /* Cannot extend fixed substrings found inside
3552                             the group.  */
3553                         SCAN_COMMIT(pRExC_state,data,minlenp);
3554                         if (mincount && last_str) {
3555                             SV * const sv = data->last_found;
3556                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3557                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
3558
3559                             if (mg)
3560                                 mg->mg_len = -1;
3561                             sv_setsv(sv, last_str);
3562                             data->last_end = data->pos_min;
3563                             data->last_start_min =
3564                                 data->pos_min - CHR_SVLEN(last_str);
3565                             data->last_start_max = is_inf
3566                                 ? I32_MAX
3567                                 : data->pos_min + data->pos_delta
3568                                 - CHR_SVLEN(last_str);
3569                         }
3570                         data->longest = &(data->longest_float);
3571                     }
3572                     SvREFCNT_dec(last_str);
3573                 }
3574                 if (data && (fl & SF_HAS_EVAL))
3575                     data->flags |= SF_HAS_EVAL;
3576               optimize_curly_tail:
3577                 if (OP(oscan) != CURLYX) {
3578                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
3579                            && NEXT_OFF(next))
3580                         NEXT_OFF(oscan) += NEXT_OFF(next);
3581                 }
3582                 continue;
3583             default:                    /* REF, ANYOFV, and CLUMP only? */
3584                 if (flags & SCF_DO_SUBSTR) {
3585                     SCAN_COMMIT(pRExC_state,data,minlenp);      /* Cannot expect anything... */
3586                     data->longest = &(data->longest_float);
3587                 }
3588                 is_inf = is_inf_internal = 1;
3589                 if (flags & SCF_DO_STCLASS_OR)
3590                     cl_anything(pRExC_state, data->start_class);
3591                 flags &= ~SCF_DO_STCLASS;
3592                 break;
3593             }
3594         }
3595         else if (OP(scan) == LNBREAK) {
3596             if (flags & SCF_DO_STCLASS) {
3597                 int value = 0;
3598                 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
3599                 if (flags & SCF_DO_STCLASS_AND) {
3600                     for (value = 0; value < 256; value++)
3601                         if (!is_VERTWS_cp(value))
3602                             ANYOF_BITMAP_CLEAR(data->start_class, value);
3603                 }
3604                 else {
3605                     for (value = 0; value < 256; value++)
3606                         if (is_VERTWS_cp(value))
3607                             ANYOF_BITMAP_SET(data->start_class, value);
3608                 }
3609                 if (flags & SCF_DO_STCLASS_OR)
3610                     cl_and(data->start_class, and_withp);
3611                 flags &= ~SCF_DO_STCLASS;
3612             }
3613             min += 1;
3614             delta += 1;
3615             if (flags & SCF_DO_SUBSTR) {
3616                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
3617                 data->pos_min += 1;
3618                 data->pos_delta += 1;
3619                 data->longest = &(data->longest_float);
3620             }
3621         }
3622         else if (OP(scan) == FOLDCHAR) {
3623             int d = ARG(scan) == LATIN_SMALL_LETTER_SHARP_S ? 1 : 2;
3624             flags &= ~SCF_DO_STCLASS;
3625             min += 1;
3626             delta += d;
3627             if (flags & SCF_DO_SUBSTR) {
3628                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
3629                 data->pos_min += 1;
3630                 data->pos_delta += d;
3631                 data->longest = &(data->longest_float);
3632             }
3633         }
3634         else if (REGNODE_SIMPLE(OP(scan))) {
3635             int value = 0;
3636
3637             if (flags & SCF_DO_SUBSTR) {
3638                 SCAN_COMMIT(pRExC_state,data,minlenp);
3639                 data->pos_min++;
3640             }
3641             min++;
3642             if (flags & SCF_DO_STCLASS) {
3643                 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
3644
3645                 /* Some of the logic below assumes that switching
3646                    locale on will only add false positives. */
3647                 switch (PL_regkind[OP(scan)]) {
3648                 case SANY:
3649                 default:
3650                   do_default:
3651                     /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
3652                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3653                         cl_anything(pRExC_state, data->start_class);
3654                     break;
3655                 case REG_ANY:
3656                     if (OP(scan) == SANY)
3657                         goto do_default;
3658                     if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
3659                         value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
3660                                  || ANYOF_CLASS_TEST_ANY_SET(data->start_class));
3661                         cl_anything(pRExC_state, data->start_class);
3662                     }
3663                     if (flags & SCF_DO_STCLASS_AND || !value)
3664                         ANYOF_BITMAP_CLEAR(data->start_class,'\n');
3665                     break;
3666                 case ANYOF:
3667                     if (flags & SCF_DO_STCLASS_AND)
3668                         cl_and(data->start_class,
3669                                (struct regnode_charclass_class*)scan);
3670                     else
3671                         cl_or(pRExC_state, data->start_class,
3672                               (struct regnode_charclass_class*)scan);
3673                     break;
3674                 case ALNUM:
3675                     if (flags & SCF_DO_STCLASS_AND) {
3676                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3677                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
3678                             if (OP(scan) == ALNUMU) {
3679                                 for (value = 0; value < 256; value++) {
3680                                     if (!isWORDCHAR_L1(value)) {
3681                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3682                                     }
3683                                 }
3684                             } else {
3685                                 for (value = 0; value < 256; value++) {
3686                                     if (!isALNUM(value)) {
3687                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3688                                     }
3689                                 }
3690                             }
3691                         }
3692                     }
3693                     else {
3694                         if (data->start_class->flags & ANYOF_LOCALE)
3695                             ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
3696                         else if (OP(scan) == ALNUMU) {
3697                             for (value = 0; value < 256; value++) {
3698                                 if (isWORDCHAR_L1(value)) {
3699                                     ANYOF_BITMAP_SET(data->start_class, value);
3700                                 }
3701                             }
3702                         } else {
3703                             for (value = 0; value < 256; value++) {
3704                                 if (isALNUM(value)) {
3705                                     ANYOF_BITMAP_SET(data->start_class, value);
3706                                 }
3707                             }
3708                         }
3709                     }
3710                     break;
3711                 case NALNUM:
3712                     if (flags & SCF_DO_STCLASS_AND) {
3713                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3714                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
3715                             if (OP(scan) == NALNUMU) {
3716                                 for (value = 0; value < 256; value++) {
3717                                     if (isWORDCHAR_L1(value)) {
3718                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3719                                     }
3720                                 }
3721                             } else {
3722                                 for (value = 0; value < 256; value++) {
3723                                     if (isALNUM(value)) {
3724                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3725                                     }
3726                                 }
3727                             }
3728                         }
3729                     }
3730                     else {
3731                         if (data->start_class->flags & ANYOF_LOCALE)
3732                             ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
3733                         else {
3734                             if (OP(scan) == NALNUMU) {
3735                                 for (value = 0; value < 256; value++) {
3736                                     if (! isWORDCHAR_L1(value)) {
3737                                         ANYOF_BITMAP_SET(data->start_class, value);
3738                                     }
3739                                 }
3740                             } else {
3741                                 for (value = 0; value < 256; value++) {
3742                                     if (! isALNUM(value)) {
3743                                         ANYOF_BITMAP_SET(data->start_class, value);
3744                                     }
3745                                 }
3746                             }
3747                         }
3748                     }
3749                     break;
3750                 case SPACE:
3751                     if (flags & SCF_DO_STCLASS_AND) {
3752                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3753                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
3754                             if (OP(scan) == SPACEU) {
3755                                 for (value = 0; value < 256; value++) {
3756                                     if (!isSPACE_L1(value)) {
3757                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3758                                     }
3759                                 }
3760                             } else {
3761                                 for (value = 0; value < 256; value++) {
3762                                     if (!isSPACE(value)) {
3763                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3764                                     }
3765                                 }
3766                             }
3767                         }
3768                     }
3769                     else {
3770                         if (data->start_class->flags & ANYOF_LOCALE) {
3771                             ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
3772                         }
3773                         else if (OP(scan) == SPACEU) {
3774                             for (value = 0; value < 256; value++) {
3775                                 if (isSPACE_L1(value)) {
3776                                     ANYOF_BITMAP_SET(data->start_class, value);
3777                                 }
3778                             }
3779                         } else {
3780                             for (value = 0; value < 256; value++) {
3781                                 if (isSPACE(value)) {
3782                                     ANYOF_BITMAP_SET(data->start_class, value);
3783                                 }
3784                             }
3785                         }
3786                     }
3787                     break;
3788                 case NSPACE:
3789                     if (flags & SCF_DO_STCLASS_AND) {
3790                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3791                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
3792                             if (OP(scan) == NSPACEU) {
3793                                 for (value = 0; value < 256; value++) {
3794                                     if (isSPACE_L1(value)) {
3795                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3796                                     }
3797                                 }
3798                             } else {
3799                                 for (value = 0; value < 256; value++) {
3800                                     if (isSPACE(value)) {
3801                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3802                                     }
3803                                 }
3804                             }
3805                         }
3806                     }
3807                     else {
3808                         if (data->start_class->flags & ANYOF_LOCALE)
3809                             ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
3810                         else if (OP(scan) == NSPACEU) {
3811                             for (value = 0; value < 256; value++) {
3812                                 if (!isSPACE_L1(value)) {
3813                                     ANYOF_BITMAP_SET(data->start_class, value);
3814                                 }
3815                             }
3816                         }
3817                         else {
3818                             for (value = 0; value < 256; value++) {
3819                                 if (!isSPACE(value)) {
3820                                     ANYOF_BITMAP_SET(data->start_class, value);
3821                                 }
3822                             }
3823                         }
3824                     }
3825                     break;
3826                 case DIGIT:
3827                     if (flags & SCF_DO_STCLASS_AND) {
3828                         ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
3829                         for (value = 0; value < 256; value++)
3830                             if (!isDIGIT(value))
3831                                 ANYOF_BITMAP_CLEAR(data->start_class, value);
3832                     }
3833                     else {
3834                         if (data->start_class->flags & ANYOF_LOCALE)
3835                             ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
3836                         else {
3837                             for (value = 0; value < 256; value++)
3838                                 if (isDIGIT(value))
3839                                     ANYOF_BITMAP_SET(data->start_class, value);
3840                         }
3841                     }
3842                     break;
3843                 case NDIGIT:
3844                     if (flags & SCF_DO_STCLASS_AND) {
3845                         ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
3846                         for (value = 0; value < 256; value++)
3847                             if (isDIGIT(value))
3848                                 ANYOF_BITMAP_CLEAR(data->start_class, value);
3849                     }
3850                     else {
3851                         if (data->start_class->flags & ANYOF_LOCALE)
3852                             ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
3853                         else {
3854                             for (value = 0; value < 256; value++)
3855                                 if (!isDIGIT(value))
3856                                     ANYOF_BITMAP_SET(data->start_class, value);
3857                         }
3858                     }
3859                     break;
3860                 CASE_SYNST_FNC(VERTWS);
3861                 CASE_SYNST_FNC(HORIZWS);
3862                 
3863                 }
3864                 if (flags & SCF_DO_STCLASS_OR)
3865                     cl_and(data->start_class, and_withp);
3866                 flags &= ~SCF_DO_STCLASS;
3867             }
3868         }
3869         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
3870             data->flags |= (OP(scan) == MEOL
3871                             ? SF_BEFORE_MEOL
3872                             : SF_BEFORE_SEOL);
3873         }
3874         else if (  PL_regkind[OP(scan)] == BRANCHJ
3875                  /* Lookbehind, or need to calculate parens/evals/stclass: */
3876                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
3877                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
3878             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY 
3879                 || OP(scan) == UNLESSM )
3880             {
3881                 /* Negative Lookahead/lookbehind
3882                    In this case we can't do fixed string optimisation.
3883                 */
3884
3885                 I32 deltanext, minnext, fake = 0;
3886                 regnode *nscan;
3887                 struct regnode_charclass_class intrnl;
3888                 int f = 0;
3889
3890                 data_fake.flags = 0;
3891                 if (data) {
3892                     data_fake.whilem_c = data->whilem_c;
3893                     data_fake.last_closep = data->last_closep;
3894                 }
3895                 else
3896                     data_fake.last_closep = &fake;
3897                 data_fake.pos_delta = delta;
3898                 if ( flags & SCF_DO_STCLASS && !scan->flags
3899                      && OP(scan) == IFMATCH ) { /* Lookahead */
3900                     cl_init(pRExC_state, &intrnl);
3901                     data_fake.start_class = &intrnl;
3902                     f |= SCF_DO_STCLASS_AND;
3903                 }
3904                 if (flags & SCF_WHILEM_VISITED_POS)
3905                     f |= SCF_WHILEM_VISITED_POS;
3906                 next = regnext(scan);
3907                 nscan = NEXTOPER(NEXTOPER(scan));
3908                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext, 
3909                     last, &data_fake, stopparen, recursed, NULL, f, depth+1);
3910                 if (scan->flags) {
3911                     if (deltanext) {
3912                         FAIL("Variable length lookbehind not implemented");
3913                     }
3914                     else if (minnext > (I32)U8_MAX) {
3915                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
3916                     }
3917                     scan->flags = (U8)minnext;
3918                 }
3919                 if (data) {
3920                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3921                         pars++;
3922                     if (data_fake.flags & SF_HAS_EVAL)
3923                         data->flags |= SF_HAS_EVAL;
3924                     data->whilem_c = data_fake.whilem_c;
3925                 }
3926                 if (f & SCF_DO_STCLASS_AND) {
3927                     if (flags & SCF_DO_STCLASS_OR) {
3928                         /* OR before, AND after: ideally we would recurse with
3929                          * data_fake to get the AND applied by study of the
3930                          * remainder of the pattern, and then derecurse;
3931                          * *** HACK *** for now just treat as "no information".
3932                          * See [perl #56690].
3933                          */
3934                         cl_init(pRExC_state, data->start_class);
3935                     }  else {
3936                         /* AND before and after: combine and continue */
3937                         const int was = (data->start_class->flags & ANYOF_EOS);
3938
3939                         cl_and(data->start_class, &intrnl);
3940                         if (was)
3941                             data->start_class->flags |= ANYOF_EOS;
3942                     }
3943                 }
3944             }
3945 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
3946             else {
3947                 /* Positive Lookahead/lookbehind
3948                    In this case we can do fixed string optimisation,
3949                    but we must be careful about it. Note in the case of
3950                    lookbehind the positions will be offset by the minimum
3951                    length of the pattern, something we won't know about
3952                    until after the recurse.
3953                 */
3954                 I32 deltanext, fake = 0;
3955                 regnode *nscan;
3956                 struct regnode_charclass_class intrnl;
3957                 int f = 0;
3958                 /* We use SAVEFREEPV so that when the full compile 
3959                     is finished perl will clean up the allocated 
3960                     minlens when it's all done. This way we don't
3961                     have to worry about freeing them when we know
3962                     they wont be used, which would be a pain.
3963                  */
3964                 I32 *minnextp;
3965                 Newx( minnextp, 1, I32 );
3966                 SAVEFREEPV(minnextp);
3967
3968                 if (data) {
3969                     StructCopy(data, &data_fake, scan_data_t);
3970                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
3971                         f |= SCF_DO_SUBSTR;
3972                         if (scan->flags) 
3973                             SCAN_COMMIT(pRExC_state, &data_fake,minlenp);
3974                         data_fake.last_found=newSVsv(data->last_found);
3975                     }
3976                 }
3977                 else
3978                     data_fake.last_closep = &fake;
3979                 data_fake.flags = 0;
3980                 data_fake.pos_delta = delta;
3981                 if (is_inf)
3982                     data_fake.flags |= SF_IS_INF;
3983                 if ( flags & SCF_DO_STCLASS && !scan->flags
3984                      && OP(scan) == IFMATCH ) { /* Lookahead */
3985                     cl_init(pRExC_state, &intrnl);
3986                     data_fake.start_class = &intrnl;
3987                     f |= SCF_DO_STCLASS_AND;
3988                 }
3989                 if (flags & SCF_WHILEM_VISITED_POS)
3990                     f |= SCF_WHILEM_VISITED_POS;
3991                 next = regnext(scan);
3992                 nscan = NEXTOPER(NEXTOPER(scan));
3993
3994                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext, 
3995                     last, &data_fake, stopparen, recursed, NULL, f,depth+1);
3996                 if (scan->flags) {
3997                     if (deltanext) {
3998                         FAIL("Variable length lookbehind not implemented");
3999                     }
4000                     else if (*minnextp > (I32)U8_MAX) {
4001                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4002                     }
4003                     scan->flags = (U8)*minnextp;
4004                 }
4005
4006                 *minnextp += min;
4007
4008                 if (f & SCF_DO_STCLASS_AND) {
4009                     const int was = (data->start_class->flags & ANYOF_EOS);
4010
4011                     cl_and(data->start_class, &intrnl);
4012                     if (was)
4013                         data->start_class->flags |= ANYOF_EOS;
4014                 }
4015                 if (data) {
4016                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4017                         pars++;
4018                     if (data_fake.flags & SF_HAS_EVAL)
4019                         data->flags |= SF_HAS_EVAL;
4020                     data->whilem_c = data_fake.whilem_c;
4021                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
4022                         if (RExC_rx->minlen<*minnextp)
4023                             RExC_rx->minlen=*minnextp;
4024                         SCAN_COMMIT(pRExC_state, &data_fake, minnextp);
4025                         SvREFCNT_dec(data_fake.last_found);
4026                         
4027                         if ( data_fake.minlen_fixed != minlenp ) 
4028                         {
4029                             data->offset_fixed= data_fake.offset_fixed;
4030                             data->minlen_fixed= data_fake.minlen_fixed;
4031                             data->lookbehind_fixed+= scan->flags;
4032                         }
4033                         if ( data_fake.minlen_float != minlenp )
4034                         {
4035                             data->minlen_float= data_fake.minlen_float;
4036                             data->offset_float_min=data_fake.offset_float_min;
4037                             data->offset_float_max=data_fake.offset_float_max;
4038                             data->lookbehind_float+= scan->flags;
4039                         }
4040                     }
4041                 }
4042
4043
4044             }
4045 #endif
4046         }
4047         else if (OP(scan) == OPEN) {
4048             if (stopparen != (I32)ARG(scan))
4049                 pars++;
4050         }
4051         else if (OP(scan) == CLOSE) {
4052             if (stopparen == (I32)ARG(scan)) {
4053                 break;
4054             }
4055             if ((I32)ARG(scan) == is_par) {
4056                 next = regnext(scan);
4057
4058                 if ( next && (OP(next) != WHILEM) && next < last)
4059                     is_par = 0;         /* Disable optimization */
4060             }
4061             if (data)
4062                 *(data->last_closep) = ARG(scan);
4063         }
4064         else if (OP(scan) == EVAL) {
4065                 if (data)
4066                     data->flags |= SF_HAS_EVAL;
4067         }
4068         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
4069             if (flags & SCF_DO_SUBSTR) {
4070                 SCAN_COMMIT(pRExC_state,data,minlenp);
4071                 flags &= ~SCF_DO_SUBSTR;
4072             }
4073             if (data && OP(scan)==ACCEPT) {
4074                 data->flags |= SCF_SEEN_ACCEPT;
4075                 if (stopmin > min)
4076                     stopmin = min;
4077             }
4078         }
4079         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
4080         {
4081                 if (flags & SCF_DO_SUBSTR) {
4082                     SCAN_COMMIT(pRExC_state,data,minlenp);
4083                     data->longest = &(data->longest_float);
4084                 }
4085                 is_inf = is_inf_internal = 1;
4086                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4087                     cl_anything(pRExC_state, data->start_class);
4088                 flags &= ~SCF_DO_STCLASS;
4089         }
4090         else if (OP(scan) == GPOS) {
4091             if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) &&
4092                 !(delta || is_inf || (data && data->pos_delta))) 
4093             {
4094                 if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR))
4095                     RExC_rx->extflags |= RXf_ANCH_GPOS;
4096                 if (RExC_rx->gofs < (U32)min)
4097                     RExC_rx->gofs = min;
4098             } else {
4099                 RExC_rx->extflags |= RXf_GPOS_FLOAT;
4100                 RExC_rx->gofs = 0;
4101             }       
4102         }
4103 #ifdef TRIE_STUDY_OPT
4104 #ifdef FULL_TRIE_STUDY
4105         else if (PL_regkind[OP(scan)] == TRIE) {
4106             /* NOTE - There is similar code to this block above for handling
4107                BRANCH nodes on the initial study.  If you change stuff here
4108                check there too. */
4109             regnode *trie_node= scan;
4110             regnode *tail= regnext(scan);
4111             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4112             I32 max1 = 0, min1 = I32_MAX;
4113             struct regnode_charclass_class accum;
4114
4115             if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
4116                 SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
4117             if (flags & SCF_DO_STCLASS)
4118                 cl_init_zero(pRExC_state, &accum);
4119                 
4120             if (!trie->jump) {
4121                 min1= trie->minlen;
4122                 max1= trie->maxlen;
4123             } else {
4124                 const regnode *nextbranch= NULL;
4125                 U32 word;
4126                 
4127                 for ( word=1 ; word <= trie->wordcount ; word++) 
4128                 {
4129                     I32 deltanext=0, minnext=0, f = 0, fake;
4130                     struct regnode_charclass_class this_class;
4131                     
4132                     data_fake.flags = 0;
4133                     if (data) {
4134                         data_fake.whilem_c = data->whilem_c;
4135                         data_fake.last_closep = data->last_closep;
4136                     }
4137                     else
4138                         data_fake.last_closep = &fake;
4139                     data_fake.pos_delta = delta;
4140                     if (flags & SCF_DO_STCLASS) {
4141                         cl_init(pRExC_state, &this_class);
4142                         data_fake.start_class = &this_class;
4143                         f = SCF_DO_STCLASS_AND;
4144                     }
4145                     if (flags & SCF_WHILEM_VISITED_POS)
4146                         f |= SCF_WHILEM_VISITED_POS;
4147     
4148                     if (trie->jump[word]) {
4149                         if (!nextbranch)
4150                             nextbranch = trie_node + trie->jump[0];
4151                         scan= trie_node + trie->jump[word];
4152                         /* We go from the jump point to the branch that follows
4153                            it. Note this means we need the vestigal unused branches
4154                            even though they arent otherwise used.
4155                          */
4156                         minnext = study_chunk(pRExC_state, &scan, minlenp, 
4157                             &deltanext, (regnode *)nextbranch, &data_fake, 
4158                             stopparen, recursed, NULL, f,depth+1);
4159                     }
4160                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
4161                         nextbranch= regnext((regnode*)nextbranch);
4162                     
4163                     if (min1 > (I32)(minnext + trie->minlen))
4164                         min1 = minnext + trie->minlen;
4165                     if (max1 < (I32)(minnext + deltanext + trie->maxlen))
4166                         max1 = minnext + deltanext + trie->maxlen;
4167                     if (deltanext == I32_MAX)
4168                         is_inf = is_inf_internal = 1;
4169                     
4170                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4171                         pars++;
4172                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4173                         if ( stopmin > min + min1) 
4174                             stopmin = min + min1;
4175                         flags &= ~SCF_DO_SUBSTR;
4176                         if (data)
4177                             data->flags |= SCF_SEEN_ACCEPT;
4178                     }
4179                     if (data) {
4180                         if (data_fake.flags & SF_HAS_EVAL)
4181                             data->flags |= SF_HAS_EVAL;
4182                         data->whilem_c = data_fake.whilem_c;
4183                     }
4184                     if (flags & SCF_DO_STCLASS)
4185                         cl_or(pRExC_state, &accum, &this_class);
4186                 }
4187             }
4188             if (flags & SCF_DO_SUBSTR) {
4189                 data->pos_min += min1;
4190                 data->pos_delta += max1 - min1;
4191                 if (max1 != min1 || is_inf)
4192                     data->longest = &(data->longest_float);
4193             }
4194             min += min1;
4195             delta += max1 - min1;
4196             if (flags & SCF_DO_STCLASS_OR) {
4197                 cl_or(pRExC_state, data->start_class, &accum);
4198                 if (min1) {
4199                     cl_and(data->start_class, and_withp);
4200                     flags &= ~SCF_DO_STCLASS;
4201                 }
4202             }
4203             else if (flags & SCF_DO_STCLASS_AND) {
4204                 if (min1) {
4205                     cl_and(data->start_class, &accum);
4206                     flags &= ~SCF_DO_STCLASS;
4207                 }
4208                 else {
4209                     /* Switch to OR mode: cache the old value of
4210                      * data->start_class */
4211                     INIT_AND_WITHP;
4212                     StructCopy(data->start_class, and_withp,
4213                                struct regnode_charclass_class);
4214                     flags &= ~SCF_DO_STCLASS_AND;
4215                     StructCopy(&accum, data->start_class,
4216                                struct regnode_charclass_class);
4217                     flags |= SCF_DO_STCLASS_OR;
4218                     data->start_class->flags |= ANYOF_EOS;
4219                 }
4220             }
4221             scan= tail;
4222             continue;
4223         }
4224 #else
4225         else if (PL_regkind[OP(scan)] == TRIE) {
4226             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4227             U8*bang=NULL;
4228             
4229             min += trie->minlen;
4230             delta += (trie->maxlen - trie->minlen);
4231             flags &= ~SCF_DO_STCLASS; /* xxx */
4232             if (flags & SCF_DO_SUBSTR) {
4233                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
4234                 data->pos_min += trie->minlen;
4235                 data->pos_delta += (trie->maxlen - trie->minlen);
4236                 if (trie->maxlen != trie->minlen)
4237                     data->longest = &(data->longest_float);
4238             }
4239             if (trie->jump) /* no more substrings -- for now /grr*/
4240                 flags &= ~SCF_DO_SUBSTR; 
4241         }
4242 #endif /* old or new */
4243 #endif /* TRIE_STUDY_OPT */     
4244
4245         /* Else: zero-length, ignore. */
4246         scan = regnext(scan);
4247     }
4248     if (frame) {
4249         last = frame->last;
4250         scan = frame->next;
4251         stopparen = frame->stop;
4252         frame = frame->prev;
4253         goto fake_study_recurse;
4254     }
4255
4256   finish:
4257     assert(!frame);
4258     DEBUG_STUDYDATA("pre-fin:",data,depth);
4259
4260     *scanp = scan;
4261     *deltap = is_inf_internal ? I32_MAX : delta;
4262     if (flags & SCF_DO_SUBSTR && is_inf)
4263         data->pos_delta = I32_MAX - data->pos_min;
4264     if (is_par > (I32)U8_MAX)
4265         is_par = 0;
4266     if (is_par && pars==1 && data) {
4267         data->flags |= SF_IN_PAR;
4268         data->flags &= ~SF_HAS_PAR;
4269     }
4270     else if (pars && data) {
4271         data->flags |= SF_HAS_PAR;
4272         data->flags &= ~SF_IN_PAR;
4273     }
4274     if (flags & SCF_DO_STCLASS_OR)
4275         cl_and(data->start_class, and_withp);
4276     if (flags & SCF_TRIE_RESTUDY)
4277         data->flags |=  SCF_TRIE_RESTUDY;
4278     
4279     DEBUG_STUDYDATA("post-fin:",data,depth);
4280     
4281     return min < stopmin ? min : stopmin;
4282 }
4283
4284 STATIC U32
4285 S_add_data(RExC_state_t *pRExC_state, U32 n, const char *s)
4286 {
4287     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
4288
4289     PERL_ARGS_ASSERT_ADD_DATA;
4290
4291     Renewc(RExC_rxi->data,
4292            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
4293            char, struct reg_data);
4294     if(count)
4295         Renew(RExC_rxi->data->what, count + n, U8);
4296     else
4297         Newx(RExC_rxi->data->what, n, U8);
4298     RExC_rxi->data->count = count + n;
4299     Copy(s, RExC_rxi->data->what + count, n, U8);
4300     return count;
4301 }
4302
4303 /*XXX: todo make this not included in a non debugging perl */
4304 #ifndef PERL_IN_XSUB_RE
4305 void
4306 Perl_reginitcolors(pTHX)
4307 {
4308     dVAR;
4309     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
4310     if (s) {
4311         char *t = savepv(s);
4312         int i = 0;
4313         PL_colors[0] = t;
4314         while (++i < 6) {
4315             t = strchr(t, '\t');
4316             if (t) {
4317                 *t = '\0';
4318                 PL_colors[i] = ++t;
4319             }
4320             else
4321                 PL_colors[i] = t = (char *)"";
4322         }
4323     } else {
4324         int i = 0;
4325         while (i < 6)
4326             PL_colors[i++] = (char *)"";
4327     }
4328     PL_colorset = 1;
4329 }
4330 #endif
4331
4332
4333 #ifdef TRIE_STUDY_OPT
4334 #define CHECK_RESTUDY_GOTO                                  \
4335         if (                                                \
4336               (data.flags & SCF_TRIE_RESTUDY)               \
4337               && ! restudied++                              \
4338         )     goto reStudy
4339 #else
4340 #define CHECK_RESTUDY_GOTO
4341 #endif        
4342
4343 /*
4344  - pregcomp - compile a regular expression into internal code
4345  *
4346  * We can't allocate space until we know how big the compiled form will be,
4347  * but we can't compile it (and thus know how big it is) until we've got a
4348  * place to put the code.  So we cheat:  we compile it twice, once with code
4349  * generation turned off and size counting turned on, and once "for real".
4350  * This also means that we don't allocate space until we are sure that the
4351  * thing really will compile successfully, and we never have to move the
4352  * code and thus invalidate pointers into it.  (Note that it has to be in
4353  * one piece because free() must be able to free it all.) [NB: not true in perl]
4354  *
4355  * Beware that the optimization-preparation code in here knows about some
4356  * of the structure of the compiled regexp.  [I'll say.]
4357  */
4358
4359
4360
4361 #ifndef PERL_IN_XSUB_RE
4362 #define RE_ENGINE_PTR &reh_regexp_engine
4363 #else
4364 extern const struct regexp_engine my_reg_engine;
4365 #define RE_ENGINE_PTR &my_reg_engine
4366 #endif
4367
4368 #ifndef PERL_IN_XSUB_RE 
4369 REGEXP *
4370 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
4371 {
4372     dVAR;
4373     HV * const table = GvHV(PL_hintgv);
4374
4375     PERL_ARGS_ASSERT_PREGCOMP;
4376
4377     /* Dispatch a request to compile a regexp to correct 
4378        regexp engine. */
4379     if (table) {
4380         SV **ptr= hv_fetchs(table, "regcomp", FALSE);
4381         GET_RE_DEBUG_FLAGS_DECL;
4382         if (ptr && SvIOK(*ptr) && SvIV(*ptr)) {
4383             const regexp_engine *eng=INT2PTR(regexp_engine*,SvIV(*ptr));
4384             DEBUG_COMPILE_r({
4385                 PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
4386                     SvIV(*ptr));
4387             });            
4388             return CALLREGCOMP_ENG(eng, pattern, flags);
4389         } 
4390     }
4391     return Perl_re_compile(aTHX_ pattern, flags);
4392 }
4393 #endif
4394
4395 REGEXP *
4396 Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags)
4397 {
4398     dVAR;
4399     REGEXP *rx;
4400     struct regexp *r;
4401     register regexp_internal *ri;
4402     STRLEN plen;
4403     char  *exp;
4404     char* xend;
4405     regnode *scan;
4406     I32 flags;
4407     I32 minlen = 0;
4408     U32 pm_flags;
4409
4410     /* these are all flags - maybe they should be turned
4411      * into a single int with different bit masks */
4412     I32 sawlookahead = 0;
4413     I32 sawplus = 0;
4414     I32 sawopen = 0;
4415     bool used_setjump = FALSE;
4416
4417     U8 jump_ret = 0;
4418     dJMPENV;
4419     scan_data_t data;
4420     RExC_state_t RExC_state;
4421     RExC_state_t * const pRExC_state = &RExC_state;
4422 #ifdef TRIE_STUDY_OPT    
4423     int restudied;
4424     RExC_state_t copyRExC_state;
4425 #endif    
4426     GET_RE_DEBUG_FLAGS_DECL;
4427
4428     PERL_ARGS_ASSERT_RE_COMPILE;
4429
4430     DEBUG_r(if (!PL_colorset) reginitcolors());
4431
4432     RExC_utf8 = RExC_orig_utf8 = SvUTF8(pattern);
4433     RExC_uni_semantics = 0;
4434
4435     /****************** LONG JUMP TARGET HERE***********************/
4436     /* Longjmp back to here if have to switch in midstream to utf8 */
4437     if (! RExC_orig_utf8) {
4438         JMPENV_PUSH(jump_ret);
4439         used_setjump = TRUE;
4440     }
4441
4442     if (jump_ret == 0) {    /* First time through */
4443         exp = SvPV(pattern, plen);
4444         xend = exp + plen;
4445         /* ignore the utf8ness if the pattern is 0 length */
4446         if (plen == 0) {
4447             RExC_utf8 = RExC_orig_utf8 = 0;
4448         }
4449
4450         DEBUG_COMPILE_r({
4451             SV *dsv= sv_newmortal();
4452             RE_PV_QUOTED_DECL(s, RExC_utf8,
4453                 dsv, exp, plen, 60);
4454             PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
4455                            PL_colors[4],PL_colors[5],s);
4456         });
4457     }
4458     else {  /* longjumped back */
4459         STRLEN len = plen;
4460
4461         /* If the cause for the longjmp was other than changing to utf8, pop
4462          * our own setjmp, and longjmp to the correct handler */
4463         if (jump_ret != UTF8_LONGJMP) {
4464             JMPENV_POP;
4465             JMPENV_JUMP(jump_ret);
4466         }
4467
4468         GET_RE_DEBUG_FLAGS;
4469
4470         /* It's possible to write a regexp in ascii that represents Unicode
4471         codepoints outside of the byte range, such as via \x{100}. If we
4472         detect such a sequence we have to convert the entire pattern to utf8
4473         and then recompile, as our sizing calculation will have been based
4474         on 1 byte == 1 character, but we will need to use utf8 to encode
4475         at least some part of the pattern, and therefore must convert the whole
4476         thing.
4477         -- dmq */
4478         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
4479             "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
4480         exp = (char*)Perl_bytes_to_utf8(aTHX_ (U8*)SvPV(pattern, plen), &len);
4481         xend = exp + len;
4482         RExC_orig_utf8 = RExC_utf8 = 1;
4483         SAVEFREEPV(exp);
4484     }
4485
4486 #ifdef TRIE_STUDY_OPT
4487     restudied = 0;
4488 #endif
4489
4490     /* Set to use unicode semantics if the pattern is in utf8 and has the
4491      * 'depends' charset specified, as it means unicode when utf8  */
4492     pm_flags = orig_pm_flags;
4493
4494     if (RExC_utf8 && get_regex_charset(pm_flags) == REGEX_DEPENDS_CHARSET) {
4495         set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
4496     }
4497
4498     RExC_precomp = exp;
4499     RExC_flags = pm_flags;
4500     RExC_sawback = 0;
4501
4502     RExC_seen = 0;
4503     RExC_in_lookbehind = 0;
4504     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
4505     RExC_seen_evals = 0;
4506     RExC_extralen = 0;
4507
4508     /* First pass: determine size, legality. */
4509     RExC_parse = exp;
4510     RExC_start = exp;
4511     RExC_end = xend;
4512     RExC_naughty = 0;
4513     RExC_npar = 1;
4514     RExC_nestroot = 0;
4515     RExC_size = 0L;
4516     RExC_emit = &PL_regdummy;
4517     RExC_whilem_seen = 0;
4518     RExC_open_parens = NULL;
4519     RExC_close_parens = NULL;
4520     RExC_opend = NULL;
4521     RExC_paren_names = NULL;
4522 #ifdef DEBUGGING
4523     RExC_paren_name_list = NULL;
4524 #endif
4525     RExC_recurse = NULL;
4526     RExC_recurse_count = 0;
4527
4528 #if 0 /* REGC() is (currently) a NOP at the first pass.
4529        * Clever compilers notice this and complain. --jhi */
4530     REGC((U8)REG_MAGIC, (char*)RExC_emit);
4531 #endif
4532     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n"));
4533     if (reg(pRExC_state, 0, &flags,1) == NULL) {
4534         RExC_precomp = NULL;
4535         return(NULL);
4536     }
4537
4538     /* Here, finished first pass.  Get rid of any added setjmp */
4539     if (used_setjump) {
4540         JMPENV_POP;
4541     }
4542
4543     DEBUG_PARSE_r({
4544         PerlIO_printf(Perl_debug_log, 
4545             "Required size %"IVdf" nodes\n"
4546             "Starting second pass (creation)\n", 
4547             (IV)RExC_size);
4548         RExC_lastnum=0; 
4549         RExC_lastparse=NULL; 
4550     });
4551
4552     /* The first pass could have found things that force Unicode semantics */
4553     if ((RExC_utf8 || RExC_uni_semantics)
4554          && get_regex_charset(pm_flags) == REGEX_DEPENDS_CHARSET)
4555     {
4556         set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
4557     }
4558
4559     /* Small enough for pointer-storage convention?
4560        If extralen==0, this means that we will not need long jumps. */
4561     if (RExC_size >= 0x10000L && RExC_extralen)
4562         RExC_size += RExC_extralen;
4563     else
4564         RExC_extralen = 0;
4565     if (RExC_whilem_seen > 15)
4566         RExC_whilem_seen = 15;
4567
4568     /* Allocate space and zero-initialize. Note, the two step process 
4569        of zeroing when in debug mode, thus anything assigned has to 
4570        happen after that */
4571     rx = (REGEXP*) newSV_type(SVt_REGEXP);
4572     r = (struct regexp*)SvANY(rx);
4573     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
4574          char, regexp_internal);
4575     if ( r == NULL || ri == NULL )
4576         FAIL("Regexp out of space");
4577 #ifdef DEBUGGING
4578     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
4579     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char);
4580 #else 
4581     /* bulk initialize base fields with 0. */
4582     Zero(ri, sizeof(regexp_internal), char);        
4583 #endif
4584
4585     /* non-zero initialization begins here */
4586     RXi_SET( r, ri );
4587     r->engine= RE_ENGINE_PTR;
4588     r->extflags = pm_flags;
4589     {
4590         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
4591         bool has_charset = (get_regex_charset(r->extflags) != REGEX_DEPENDS_CHARSET);
4592
4593         /* The caret is output if there are any defaults: if not all the STD
4594          * flags are set, or if no character set specifier is needed */
4595         bool has_default =
4596                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
4597                     || ! has_charset);
4598         bool has_runon = ((RExC_seen & REG_SEEN_RUN_ON_COMMENT)==REG_SEEN_RUN_ON_COMMENT);
4599         U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD)
4600                             >> RXf_PMf_STD_PMMOD_SHIFT);
4601         const char *fptr = STD_PAT_MODS;        /*"msix"*/
4602         char *p;
4603         /* Allocate for the worst case, which is all the std flags are turned
4604          * on.  If more precision is desired, we could do a population count of
4605          * the flags set.  This could be done with a small lookup table, or by
4606          * shifting, masking and adding, or even, when available, assembly
4607          * language for a machine-language population count.
4608          * We never output a minus, as all those are defaults, so are
4609          * covered by the caret */
4610         const STRLEN wraplen = plen + has_p + has_runon
4611             + has_default       /* If needs a caret */
4612
4613                 /* If needs a character set specifier */
4614             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
4615             + (sizeof(STD_PAT_MODS) - 1)
4616             + (sizeof("(?:)") - 1);
4617
4618         p = sv_grow(MUTABLE_SV(rx), wraplen + 1); /* +1 for the ending NUL */
4619         SvPOK_on(rx);
4620         SvFLAGS(rx) |= SvUTF8(pattern);
4621         *p++='('; *p++='?';
4622
4623         /* If a default, cover it using the caret */
4624         if (has_default) {
4625             *p++= DEFAULT_PAT_MOD;
4626         }
4627         if (has_charset) {
4628             STRLEN len;
4629             const char* const name = get_regex_charset_name(r->extflags, &len);
4630             Copy(name, p, len, char);
4631             p += len;
4632         }
4633         if (has_p)
4634             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
4635         {
4636             char ch;
4637             while((ch = *fptr++)) {
4638                 if(reganch & 1)
4639                     *p++ = ch;
4640                 reganch >>= 1;
4641             }
4642         }
4643
4644         *p++ = ':';
4645         Copy(RExC_precomp, p, plen, char);
4646         assert ((RX_WRAPPED(rx) - p) < 16);
4647         r->pre_prefix = p - RX_WRAPPED(rx);
4648         p += plen;
4649         if (has_runon)
4650             *p++ = '\n';
4651         *p++ = ')';
4652         *p = 0;
4653         SvCUR_set(rx, p - SvPVX_const(rx));
4654     }
4655
4656     r->intflags = 0;
4657     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
4658     
4659     if (RExC_seen & REG_SEEN_RECURSE) {
4660         Newxz(RExC_open_parens, RExC_npar,regnode *);
4661         SAVEFREEPV(RExC_open_parens);
4662         Newxz(RExC_close_parens,RExC_npar,regnode *);
4663         SAVEFREEPV(RExC_close_parens);
4664     }
4665
4666     /* Useful during FAIL. */
4667 #ifdef RE_TRACK_PATTERN_OFFSETS
4668     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
4669     DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
4670                           "%s %"UVuf" bytes for offset annotations.\n",
4671                           ri->u.offsets ? "Got" : "Couldn't get",
4672                           (UV)((2*RExC_size+1) * sizeof(U32))));
4673 #endif
4674     SetProgLen(ri,RExC_size);
4675     RExC_rx_sv = rx;
4676     RExC_rx = r;
4677     RExC_rxi = ri;
4678     REH_CALL_COMP_BEGIN_HOOK(pRExC_state->rx);
4679
4680     /* Second pass: emit code. */
4681     RExC_flags = pm_flags;      /* don't let top level (?i) bleed */
4682     RExC_parse = exp;
4683     RExC_end = xend;
4684     RExC_naughty = 0;
4685     RExC_npar = 1;
4686     RExC_emit_start = ri->program;
4687     RExC_emit = ri->program;
4688     RExC_emit_bound = ri->program + RExC_size + 1;
4689
4690     /* Store the count of eval-groups for security checks: */
4691     RExC_rx->seen_evals = RExC_seen_evals;
4692     REGC((U8)REG_MAGIC, (char*) RExC_emit++);
4693     if (reg(pRExC_state, 0, &flags,1) == NULL) {
4694         ReREFCNT_dec(rx);   
4695         return(NULL);
4696     }
4697     /* XXXX To minimize changes to RE engine we always allocate
4698        3-units-long substrs field. */
4699     Newx(r->substrs, 1, struct reg_substr_data);
4700     if (RExC_recurse_count) {
4701         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
4702         SAVEFREEPV(RExC_recurse);
4703     }
4704
4705 reStudy:
4706     r->minlen = minlen = sawlookahead = sawplus = sawopen = 0;
4707     Zero(r->substrs, 1, struct reg_substr_data);
4708
4709 #ifdef TRIE_STUDY_OPT
4710     if (!restudied) {
4711         StructCopy(&zero_scan_data, &data, scan_data_t);
4712         copyRExC_state = RExC_state;
4713     } else {
4714         U32 seen=RExC_seen;
4715         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
4716         
4717         RExC_state = copyRExC_state;
4718         if (seen & REG_TOP_LEVEL_BRANCHES) 
4719             RExC_seen |= REG_TOP_LEVEL_BRANCHES;
4720         else
4721             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES;
4722         if (data.last_found) {
4723             SvREFCNT_dec(data.longest_fixed);
4724             SvREFCNT_dec(data.longest_float);
4725             SvREFCNT_dec(data.last_found);
4726         }
4727         StructCopy(&zero_scan_data, &data, scan_data_t);
4728     }
4729 #else
4730     StructCopy(&zero_scan_data, &data, scan_data_t);
4731 #endif    
4732
4733     /* Dig out information for optimizations. */
4734     r->extflags = RExC_flags; /* was pm_op */
4735     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
4736  
4737     if (UTF)
4738         SvUTF8_on(rx);  /* Unicode in it? */
4739     ri->regstclass = NULL;
4740     if (RExC_naughty >= 10)     /* Probably an expensive pattern. */
4741         r->intflags |= PREGf_NAUGHTY;
4742     scan = ri->program + 1;             /* First BRANCH. */
4743
4744     /* testing for BRANCH here tells us whether there is "must appear"
4745        data in the pattern. If there is then we can use it for optimisations */
4746     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /*  Only one top-level choice. */
4747         I32 fake;
4748         STRLEN longest_float_length, longest_fixed_length;
4749         struct regnode_charclass_class ch_class; /* pointed to by data */
4750         int stclass_flag;
4751         I32 last_close = 0; /* pointed to by data */
4752         regnode *first= scan;
4753         regnode *first_next= regnext(first);
4754         /*
4755          * Skip introductions and multiplicators >= 1
4756          * so that we can extract the 'meat' of the pattern that must 
4757          * match in the large if() sequence following.
4758          * NOTE that EXACT is NOT covered here, as it is normally
4759          * picked up by the optimiser separately. 
4760          *
4761          * This is unfortunate as the optimiser isnt handling lookahead
4762          * properly currently.
4763          *
4764          */
4765         while ((OP(first) == OPEN && (sawopen = 1)) ||
4766                /* An OR of *one* alternative - should not happen now. */
4767             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
4768             /* for now we can't handle lookbehind IFMATCH*/
4769             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
4770             (OP(first) == PLUS) ||
4771             (OP(first) == MINMOD) ||
4772                /* An {n,m} with n>0 */
4773             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
4774             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
4775         {
4776                 /* 
4777                  * the only op that could be a regnode is PLUS, all the rest
4778                  * will be regnode_1 or regnode_2.
4779                  *
4780                  */
4781                 if (OP(first) == PLUS)
4782                     sawplus = 1;
4783                 else
4784                     first += regarglen[OP(first)];
4785                 
4786                 first = NEXTOPER(first);
4787                 first_next= regnext(first);
4788         }
4789
4790         /* Starting-point info. */
4791       again:
4792         DEBUG_PEEP("first:",first,0);
4793         /* Ignore EXACT as we deal with it later. */
4794         if (PL_regkind[OP(first)] == EXACT) {
4795             if (OP(first) == EXACT)
4796                 NOOP;   /* Empty, get anchored substr later. */
4797             else
4798                 ri->regstclass = first;
4799         }
4800 #ifdef TRIE_STCLASS     
4801         else if (PL_regkind[OP(first)] == TRIE &&
4802                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0) 
4803         {
4804             regnode *trie_op;
4805             /* this can happen only on restudy */
4806             if ( OP(first) == TRIE ) {
4807                 struct regnode_1 *trieop = (struct regnode_1 *)
4808                     PerlMemShared_calloc(1, sizeof(struct regnode_1));
4809                 StructCopy(first,trieop,struct regnode_1);
4810                 trie_op=(regnode *)trieop;
4811             } else {
4812                 struct regnode_charclass *trieop = (struct regnode_charclass *)
4813                     PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
4814                 StructCopy(first,trieop,struct regnode_charclass);
4815                 trie_op=(regnode *)trieop;
4816             }
4817             OP(trie_op)+=2;
4818             make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
4819             ri->regstclass = trie_op;
4820         }
4821 #endif  
4822         else if (REGNODE_SIMPLE(OP(first)))
4823             ri->regstclass = first;
4824         else if (PL_regkind[OP(first)] == BOUND ||
4825                  PL_regkind[OP(first)] == NBOUND)
4826             ri->regstclass = first;
4827         else if (PL_regkind[OP(first)] == BOL) {
4828             r->extflags |= (OP(first) == MBOL
4829                            ? RXf_ANCH_MBOL
4830                            : (OP(first) == SBOL
4831                               ? RXf_ANCH_SBOL
4832                               : RXf_ANCH_BOL));
4833             first = NEXTOPER(first);
4834             goto again;
4835         }
4836         else if (OP(first) == GPOS) {
4837             r->extflags |= RXf_ANCH_GPOS;
4838             first = NEXTOPER(first);
4839             goto again;
4840         }
4841         else if ((!sawopen || !RExC_sawback) &&
4842             (OP(first) == STAR &&
4843             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
4844             !(r->extflags & RXf_ANCH) && !(RExC_seen & REG_SEEN_EVAL))
4845         {
4846             /* turn .* into ^.* with an implied $*=1 */
4847             const int type =
4848                 (OP(NEXTOPER(first)) == REG_ANY)
4849                     ? RXf_ANCH_MBOL
4850                     : RXf_ANCH_SBOL;
4851             r->extflags |= type;
4852             r->intflags |= PREGf_IMPLICIT;
4853             first = NEXTOPER(first);
4854             goto again;
4855         }
4856         if (sawplus && !sawlookahead && (!sawopen || !RExC_sawback)
4857             && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
4858             /* x+ must match at the 1st pos of run of x's */
4859             r->intflags |= PREGf_SKIP;
4860
4861         /* Scan is after the zeroth branch, first is atomic matcher. */
4862 #ifdef TRIE_STUDY_OPT
4863         DEBUG_PARSE_r(
4864             if (!restudied)
4865                 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
4866                               (IV)(first - scan + 1))
4867         );
4868 #else
4869         DEBUG_PARSE_r(
4870             PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
4871                 (IV)(first - scan + 1))
4872         );
4873 #endif
4874
4875
4876         /*
4877         * If there's something expensive in the r.e., find the
4878         * longest literal string that must appear and make it the
4879         * regmust.  Resolve ties in favor of later strings, since
4880         * the regstart check works with the beginning of the r.e.
4881         * and avoiding duplication strengthens checking.  Not a
4882         * strong reason, but sufficient in the absence of others.
4883         * [Now we resolve ties in favor of the earlier string if
4884         * it happens that c_offset_min has been invalidated, since the
4885         * earlier string may buy us something the later one won't.]
4886         */
4887         
4888         data.longest_fixed = newSVpvs("");
4889         data.longest_float = newSVpvs("");
4890         data.last_found = newSVpvs("");
4891         data.longest = &(data.longest_fixed);
4892         first = scan;
4893         if (!ri->regstclass) {
4894             cl_init(pRExC_state, &ch_class);
4895             data.start_class = &ch_class;
4896             stclass_flag = SCF_DO_STCLASS_AND;
4897         } else                          /* XXXX Check for BOUND? */
4898             stclass_flag = 0;
4899         data.last_closep = &last_close;
4900         
4901         minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */
4902             &data, -1, NULL, NULL,
4903             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
4904
4905         
4906         CHECK_RESTUDY_GOTO;
4907
4908
4909         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
4910              && data.last_start_min == 0 && data.last_end > 0
4911              && !RExC_seen_zerolen
4912              && !(RExC_seen & REG_SEEN_VERBARG)
4913              && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
4914             r->extflags |= RXf_CHECK_ALL;
4915         scan_commit(pRExC_state, &data,&minlen,0);
4916         SvREFCNT_dec(data.last_found);
4917
4918         /* Note that code very similar to this but for anchored string 
4919            follows immediately below, changes may need to be made to both. 
4920            Be careful. 
4921          */
4922         longest_float_length = CHR_SVLEN(data.longest_float);
4923         if (longest_float_length
4924             || (data.flags & SF_FL_BEFORE_EOL
4925                 && (!(data.flags & SF_FL_BEFORE_MEOL)
4926                     || (RExC_flags & RXf_PMf_MULTILINE)))) 
4927         {
4928             I32 t,ml;
4929
4930             if (SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
4931                 && data.offset_fixed == data.offset_float_min
4932                 && SvCUR(data.longest_fixed) == SvCUR(data.longest_float))
4933                     goto remove_float;          /* As in (a)+. */
4934
4935             /* copy the information about the longest float from the reg_scan_data
4936                over to the program. */
4937             if (SvUTF8(data.longest_float)) {
4938                 r->float_utf8 = data.longest_float;
4939                 r->float_substr = NULL;
4940             } else {
4941                 r->float_substr = data.longest_float;
4942                 r->float_utf8 = NULL;
4943             }
4944             /* float_end_shift is how many chars that must be matched that 
4945                follow this item. We calculate it ahead of time as once the
4946                lookbehind offset is added in we lose the ability to correctly
4947                calculate it.*/
4948             ml = data.minlen_float ? *(data.minlen_float) 
4949                                    : (I32)longest_float_length;
4950             r->float_end_shift = ml - data.offset_float_min
4951                 - longest_float_length + (SvTAIL(data.longest_float) != 0)
4952                 + data.lookbehind_float;
4953             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
4954             r->float_max_offset = data.offset_float_max;
4955             if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
4956                 r->float_max_offset -= data.lookbehind_float;
4957             
4958             t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
4959                        && (!(data.flags & SF_FL_BEFORE_MEOL)
4960                            || (RExC_flags & RXf_PMf_MULTILINE)));
4961             fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0);
4962         }
4963         else {
4964           remove_float:
4965             r->float_substr = r->float_utf8 = NULL;
4966             SvREFCNT_dec(data.longest_float);
4967             longest_float_length = 0;
4968         }
4969
4970         /* Note that code very similar to this but for floating string 
4971            is immediately above, changes may need to be made to both. 
4972            Be careful. 
4973          */
4974         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
4975         if (longest_fixed_length
4976             || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
4977                 && (!(data.flags & SF_FIX_BEFORE_MEOL)
4978                     || (RExC_flags & RXf_PMf_MULTILINE)))) 
4979         {
4980             I32 t,ml;
4981
4982             /* copy the information about the longest fixed 
4983                from the reg_scan_data over to the program. */
4984             if (SvUTF8(data.longest_fixed)) {
4985                 r->anchored_utf8 = data.longest_fixed;
4986                 r->anchored_substr = NULL;
4987             } else {
4988                 r->anchored_substr = data.longest_fixed;
4989                 r->anchored_utf8 = NULL;
4990             }
4991             /* fixed_end_shift is how many chars that must be matched that 
4992                follow this item. We calculate it ahead of time as once the
4993                lookbehind offset is added in we lose the ability to correctly
4994                calculate it.*/
4995             ml = data.minlen_fixed ? *(data.minlen_fixed) 
4996                                    : (I32)longest_fixed_length;
4997             r->anchored_end_shift = ml - data.offset_fixed
4998                 - longest_fixed_length + (SvTAIL(data.longest_fixed) != 0)
4999                 + data.lookbehind_fixed;
5000             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
5001
5002             t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
5003                  && (!(data.flags & SF_FIX_BEFORE_MEOL)
5004                      || (RExC_flags & RXf_PMf_MULTILINE)));
5005             fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0);
5006         }
5007         else {
5008             r->anchored_substr = r->anchored_utf8 = NULL;
5009             SvREFCNT_dec(data.longest_fixed);
5010             longest_fixed_length = 0;
5011         }
5012         if (ri->regstclass
5013             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
5014             ri->regstclass = NULL;
5015
5016         /* If the synthetic start class were to ever be used when EOS is set,
5017          * that bit would have to be cleared, as it is shared with another */
5018         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
5019             && stclass_flag
5020             && !(data.start_class->flags & ANYOF_EOS)
5021             && !cl_is_anything(data.start_class))
5022         {
5023             const U32 n = add_data(pRExC_state, 1, "f");
5024
5025             Newx(RExC_rxi->data->data[n], 1,
5026                 struct regnode_charclass_class);
5027             StructCopy(data.start_class,
5028                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
5029                        struct regnode_charclass_class);
5030             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5031             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5032             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
5033                       regprop(r, sv, (regnode*)data.start_class);
5034                       PerlIO_printf(Perl_debug_log,
5035                                     "synthetic stclass \"%s\".\n",
5036                                     SvPVX_const(sv));});
5037         }
5038
5039         /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
5040         if (longest_fixed_length > longest_float_length) {
5041             r->check_end_shift = r->anchored_end_shift;
5042             r->check_substr = r->anchored_substr;
5043             r->check_utf8 = r->anchored_utf8;
5044             r->check_offset_min = r->check_offset_max = r->anchored_offset;
5045             if (r->extflags & RXf_ANCH_SINGLE)
5046                 r->extflags |= RXf_NOSCAN;
5047         }
5048         else {
5049             r->check_end_shift = r->float_end_shift;
5050             r->check_substr = r->float_substr;
5051             r->check_utf8 = r->float_utf8;
5052             r->check_offset_min = r->float_min_offset;
5053             r->check_offset_max = r->float_max_offset;
5054         }
5055         /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
5056            This should be changed ASAP!  */
5057         if ((r->check_substr || r->check_utf8) && !(r->extflags & RXf_ANCH_GPOS)) {
5058             r->extflags |= RXf_USE_INTUIT;
5059             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
5060                 r->extflags |= RXf_INTUIT_TAIL;
5061         }
5062         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
5063         if ( (STRLEN)minlen < longest_float_length )
5064             minlen= longest_float_length;
5065         if ( (STRLEN)minlen < longest_fixed_length )
5066             minlen= longest_fixed_length;     
5067         */
5068     }
5069     else {
5070         /* Several toplevels. Best we can is to set minlen. */
5071         I32 fake;
5072         struct regnode_charclass_class ch_class;
5073         I32 last_close = 0;
5074         
5075         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
5076
5077         scan = ri->program + 1;
5078         cl_init(pRExC_state, &ch_class);
5079         data.start_class = &ch_class;
5080         data.last_closep = &last_close;
5081
5082         
5083         minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
5084             &data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
5085         
5086         CHECK_RESTUDY_GOTO;
5087
5088         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
5089                 = r->float_substr = r->float_utf8 = NULL;
5090
5091         /* If the synthetic start class were to ever be used when EOS is set,
5092          * that bit would have to be cleared, as it is shared with another */
5093         if (!(data.start_class->flags & ANYOF_EOS)
5094             && !cl_is_anything(data.start_class))
5095         {
5096             const U32 n = add_data(pRExC_state, 1, "f");
5097
5098             Newx(RExC_rxi->data->data[n], 1,
5099                 struct regnode_charclass_class);
5100             StructCopy(data.start_class,
5101                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
5102                        struct regnode_charclass_class);
5103             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5104             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5105             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
5106                       regprop(r, sv, (regnode*)data.start_class);
5107                       PerlIO_printf(Perl_debug_log,
5108                                     "synthetic stclass \"%s\".\n",
5109                                     SvPVX_const(sv));});
5110         }
5111     }
5112
5113     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
5114        the "real" pattern. */
5115     DEBUG_OPTIMISE_r({
5116         PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n",
5117                       (IV)minlen, (IV)r->minlen);
5118     });
5119     r->minlenret = minlen;
5120     if (r->minlen < minlen) 
5121         r->minlen = minlen;
5122     
5123     if (RExC_seen & REG_SEEN_GPOS)
5124         r->extflags |= RXf_GPOS_SEEN;
5125     if (RExC_seen & REG_SEEN_LOOKBEHIND)
5126         r->extflags |= RXf_LOOKBEHIND_SEEN;
5127     if (RExC_seen & REG_SEEN_EVAL)
5128         r->extflags |= RXf_EVAL_SEEN;
5129     if (RExC_seen & REG_SEEN_CANY)
5130         r->extflags |= RXf_CANY_SEEN;
5131     if (RExC_seen & REG_SEEN_VERBARG)
5132         r->intflags |= PREGf_VERBARG_SEEN;
5133     if (RExC_seen & REG_SEEN_CUTGROUP)
5134         r->intflags |= PREGf_CUTGROUP_SEEN;
5135     if (RExC_paren_names)
5136         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
5137     else
5138         RXp_PAREN_NAMES(r) = NULL;
5139
5140 #ifdef STUPID_PATTERN_CHECKS            
5141     if (RX_PRELEN(rx) == 0)
5142         r->extflags |= RXf_NULL;
5143     if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5144         /* XXX: this should happen BEFORE we compile */
5145         r->extflags |= (RXf_SKIPWHITE|RXf_WHITE); 
5146     else if (RX_PRELEN(rx) == 3 && memEQ("\\s+", RX_PRECOMP(rx), 3))
5147         r->extflags |= RXf_WHITE;
5148     else if (RX_PRELEN(rx) == 1 && RXp_PRECOMP(rx)[0] == '^')
5149         r->extflags |= RXf_START_ONLY;
5150 #else
5151     if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5152             /* XXX: this should happen BEFORE we compile */
5153             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE); 
5154     else {
5155         regnode *first = ri->program + 1;
5156         U8 fop = OP(first);
5157
5158         if (PL_regkind[fop] == NOTHING && OP(NEXTOPER(first)) == END)
5159             r->extflags |= RXf_NULL;
5160         else if (PL_regkind[fop] == BOL && OP(NEXTOPER(first)) == END)
5161             r->extflags |= RXf_START_ONLY;
5162         else if (fop == PLUS && OP(NEXTOPER(first)) == SPACE
5163                              && OP(regnext(first)) == END)
5164             r->extflags |= RXf_WHITE;    
5165     }
5166 #endif
5167 #ifdef DEBUGGING
5168     if (RExC_paren_names) {
5169         ri->name_list_idx = add_data( pRExC_state, 1, "a" );
5170         ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list);
5171     } else
5172 #endif
5173         ri->name_list_idx = 0;
5174
5175     if (RExC_recurse_count) {
5176         for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
5177             const regnode *scan = RExC_recurse[RExC_recurse_count-1];
5178             ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
5179         }
5180     }
5181     Newxz(r->offs, RExC_npar, regexp_paren_pair);
5182     /* assume we don't need to swap parens around before we match */
5183
5184     DEBUG_DUMP_r({
5185         PerlIO_printf(Perl_debug_log,"Final program:\n");
5186         regdump(r);
5187     });
5188 #ifdef RE_TRACK_PATTERN_OFFSETS
5189     DEBUG_OFFSETS_r(if (ri->u.offsets) {
5190         const U32 len = ri->u.offsets[0];
5191         U32 i;
5192         GET_RE_DEBUG_FLAGS_DECL;
5193         PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
5194         for (i = 1; i <= len; i++) {
5195             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
5196                 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
5197                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
5198             }
5199         PerlIO_printf(Perl_debug_log, "\n");
5200     });
5201 #endif
5202     return rx;
5203 }
5204
5205 #undef RE_ENGINE_PTR
5206
5207
5208 SV*
5209 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
5210                     const U32 flags)
5211 {
5212     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
5213
5214     PERL_UNUSED_ARG(value);
5215
5216     if (flags & RXapif_FETCH) {
5217         return reg_named_buff_fetch(rx, key, flags);
5218     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
5219         Perl_croak_no_modify(aTHX);
5220         return NULL;
5221     } else if (flags & RXapif_EXISTS) {
5222         return reg_named_buff_exists(rx, key, flags)
5223             ? &PL_sv_yes
5224             : &PL_sv_no;
5225     } else if (flags & RXapif_REGNAMES) {
5226         return reg_named_buff_all(rx, flags);
5227     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
5228         return reg_named_buff_scalar(rx, flags);
5229     } else {
5230         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
5231         return NULL;
5232     }
5233 }
5234
5235 SV*
5236 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
5237                          const U32 flags)
5238 {
5239     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
5240     PERL_UNUSED_ARG(lastkey);
5241
5242     if (flags & RXapif_FIRSTKEY)
5243         return reg_named_buff_firstkey(rx, flags);
5244     else if (flags & RXapif_NEXTKEY)
5245         return reg_named_buff_nextkey(rx, flags);
5246     else {
5247         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter", (int)flags);
5248         return NULL;
5249     }
5250 }
5251
5252 SV*
5253 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
5254                           const U32 flags)
5255 {
5256     AV *retarray = NULL;
5257     SV *ret;
5258     struct regexp *const rx = (struct regexp *)SvANY(r);
5259
5260     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
5261
5262     if (flags & RXapif_ALL)
5263         retarray=newAV();
5264
5265     if (rx && RXp_PAREN_NAMES(rx)) {
5266         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
5267         if (he_str) {
5268             IV i;
5269             SV* sv_dat=HeVAL(he_str);
5270             I32 *nums=(I32*)SvPVX(sv_dat);
5271             for ( i=0; i<SvIVX(sv_dat); i++ ) {
5272                 if ((I32)(rx->nparens) >= nums[i]
5273                     && rx->offs[nums[i]].start != -1
5274                     && rx->offs[nums[i]].end != -1)
5275                 {
5276                     ret = newSVpvs("");
5277                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
5278                     if (!retarray)
5279                         return ret;
5280                 } else {
5281                     ret = newSVsv(&PL_sv_undef);
5282                 }
5283                 if (retarray)
5284                     av_push(retarray, ret);
5285             }
5286             if (retarray)
5287                 return newRV_noinc(MUTABLE_SV(retarray));
5288         }
5289     }
5290     return NULL;
5291 }
5292
5293 bool
5294 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
5295                            const U32 flags)
5296 {
5297     struct regexp *const rx = (struct regexp *)SvANY(r);
5298
5299     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
5300
5301     if (rx && RXp_PAREN_NAMES(rx)) {
5302         if (flags & RXapif_ALL) {
5303             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
5304         } else {
5305             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
5306             if (sv) {
5307                 SvREFCNT_dec(sv);
5308                 return TRUE;
5309             } else {
5310                 return FALSE;
5311             }
5312         }
5313     } else {
5314         return FALSE;
5315     }
5316 }
5317
5318 SV*
5319 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
5320 {
5321     struct regexp *const rx = (struct regexp *)SvANY(r);
5322
5323     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
5324
5325     if ( rx && RXp_PAREN_NAMES(rx) ) {
5326         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
5327
5328         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
5329     } else {
5330         return FALSE;
5331     }
5332 }
5333
5334 SV*
5335 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
5336 {
5337     struct regexp *const rx = (struct regexp *)SvANY(r);
5338     GET_RE_DEBUG_FLAGS_DECL;
5339
5340     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
5341
5342     if (rx && RXp_PAREN_NAMES(rx)) {
5343         HV *hv = RXp_PAREN_NAMES(rx);
5344         HE *temphe;
5345         while ( (temphe = hv_iternext_flags(hv,0)) ) {
5346             IV i;
5347             IV parno = 0;
5348             SV* sv_dat = HeVAL(temphe);
5349             I32 *nums = (I32*)SvPVX(sv_dat);
5350             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5351                 if ((I32)(rx->lastparen) >= nums[i] &&
5352                     rx->offs[nums[i]].start != -1 &&
5353                     rx->offs[nums[i]].end != -1)
5354                 {
5355                     parno = nums[i];
5356                     break;
5357                 }
5358             }
5359             if (parno || flags & RXapif_ALL) {
5360                 return newSVhek(HeKEY_hek(temphe));
5361             }
5362         }
5363     }
5364     return NULL;
5365 }
5366
5367 SV*
5368 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
5369 {
5370     SV *ret;
5371     AV *av;
5372     I32 length;
5373     struct regexp *const rx = (struct regexp *)SvANY(r);
5374
5375     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
5376
5377     if (rx && RXp_PAREN_NAMES(rx)) {
5378         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
5379             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
5380         } else if (flags & RXapif_ONE) {
5381             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
5382             av = MUTABLE_AV(SvRV(ret));
5383             length = av_len(av);
5384             SvREFCNT_dec(ret);
5385             return newSViv(length + 1);
5386         } else {
5387             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", (int)flags);
5388             return NULL;
5389         }
5390     }
5391     return &PL_sv_undef;
5392 }
5393
5394 SV*
5395 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
5396 {
5397     struct regexp *const rx = (struct regexp *)SvANY(r);
5398     AV *av = newAV();
5399
5400     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
5401
5402     if (rx && RXp_PAREN_NAMES(rx)) {
5403         HV *hv= RXp_PAREN_NAMES(rx);
5404         HE *temphe;
5405         (void)hv_iterinit(hv);
5406         while ( (temphe = hv_iternext_flags(hv,0)) ) {
5407             IV i;
5408             IV parno = 0;
5409             SV* sv_dat = HeVAL(temphe);
5410             I32 *nums = (I32*)SvPVX(sv_dat);
5411             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5412                 if ((I32)(rx->lastparen) >= nums[i] &&
5413                     rx->offs[nums[i]].start != -1 &&
5414                     rx->offs[nums[i]].end != -1)
5415                 {
5416                     parno = nums[i];
5417                     break;
5418                 }
5419             }
5420             if (parno || flags & RXapif_ALL) {
5421                 av_push(av, newSVhek(HeKEY_hek(temphe)));
5422             }
5423         }
5424     }
5425
5426     return newRV_noinc(MUTABLE_SV(av));
5427 }
5428
5429 void
5430 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
5431                              SV * const sv)
5432 {
5433     struct regexp *const rx = (struct regexp *)SvANY(r);
5434     char *s = NULL;
5435     I32 i = 0;
5436     I32 s1, t1;
5437
5438     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
5439         
5440     if (!rx->subbeg) {
5441         sv_setsv(sv,&PL_sv_undef);
5442         return;
5443     } 
5444     else               
5445     if (paren == RX_BUFF_IDX_PREMATCH && rx->offs[0].start != -1) {
5446         /* $` */
5447         i = rx->offs[0].start;
5448         s = rx->subbeg;
5449     }
5450     else 
5451     if (paren == RX_BUFF_IDX_POSTMATCH && rx->offs[0].end != -1) {
5452         /* $' */
5453         s = rx->subbeg + rx->offs[0].end;
5454         i = rx->sublen - rx->offs[0].end;
5455     } 
5456     else
5457     if ( 0 <= paren && paren <= (I32)rx->nparens &&
5458         (s1 = rx->offs[paren].start) != -1 &&
5459         (t1 = rx->offs[paren].end) != -1)
5460     {
5461         /* $& $1 ... */
5462         i = t1 - s1;
5463         s = rx->subbeg + s1;
5464     } else {
5465         sv_setsv(sv,&PL_sv_undef);
5466         return;
5467     }          
5468     assert(rx->sublen >= (s - rx->subbeg) + i );
5469     if (i >= 0) {
5470         const int oldtainted = PL_tainted;
5471         TAINT_NOT;
5472         sv_setpvn(sv, s, i);
5473         PL_tainted = oldtainted;
5474         if ( (rx->extflags & RXf_CANY_SEEN)
5475             ? (RXp_MATCH_UTF8(rx)
5476                         && (!i || is_utf8_string((U8*)s, i)))
5477             : (RXp_MATCH_UTF8(rx)) )
5478         {
5479             SvUTF8_on(sv);
5480         }
5481         else
5482             SvUTF8_off(sv);
5483         if (PL_tainting) {
5484             if (RXp_MATCH_TAINTED(rx)) {
5485                 if (SvTYPE(sv) >= SVt_PVMG) {
5486                     MAGIC* const mg = SvMAGIC(sv);
5487                     MAGIC* mgt;
5488                     PL_tainted = 1;
5489                     SvMAGIC_set(sv, mg->mg_moremagic);
5490                     SvTAINT(sv);
5491                     if ((mgt = SvMAGIC(sv))) {
5492                         mg->mg_moremagic = mgt;
5493                         SvMAGIC_set(sv, mg);
5494                     }
5495                 } else {
5496                     PL_tainted = 1;
5497                     SvTAINT(sv);
5498                 }
5499             } else 
5500                 SvTAINTED_off(sv);
5501         }
5502     } else {
5503         sv_setsv(sv,&PL_sv_undef);
5504         return;
5505     }
5506 }
5507
5508 void
5509 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
5510                                                          SV const * const value)
5511 {
5512     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
5513
5514     PERL_UNUSED_ARG(rx);
5515     PERL_UNUSED_ARG(paren);
5516     PERL_UNUSED_ARG(value);
5517
5518     if (!PL_localizing)
5519         Perl_croak_no_modify(aTHX);
5520 }
5521
5522 I32
5523 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
5524                               const I32 paren)
5525 {
5526     struct regexp *const rx = (struct regexp *)SvANY(r);
5527     I32 i;
5528     I32 s1, t1;
5529
5530     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
5531
5532     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
5533         switch (paren) {
5534       /* $` / ${^PREMATCH} */
5535       case RX_BUFF_IDX_PREMATCH:
5536         if (rx->offs[0].start != -1) {
5537                         i = rx->offs[0].start;
5538                         if (i > 0) {
5539                                 s1 = 0;
5540                                 t1 = i;
5541                                 goto getlen;
5542                         }
5543             }
5544         return 0;
5545       /* $' / ${^POSTMATCH} */
5546       case RX_BUFF_IDX_POSTMATCH:
5547             if (rx->offs[0].end != -1) {
5548                         i = rx->sublen - rx->offs[0].end;
5549                         if (i > 0) {
5550                                 s1 = rx->offs[0].end;
5551                                 t1 = rx->sublen;
5552                                 goto getlen;
5553                         }
5554             }
5555         return 0;
5556       /* $& / ${^MATCH}, $1, $2, ... */
5557       default:
5558             if (paren <= (I32)rx->nparens &&
5559             (s1 = rx->offs[paren].start) != -1 &&
5560             (t1 = rx->offs[paren].end) != -1)
5561             {
5562             i = t1 - s1;
5563             goto getlen;
5564         } else {
5565             if (ckWARN(WARN_UNINITIALIZED))
5566                 report_uninit((const SV *)sv);
5567             return 0;
5568         }
5569     }
5570   getlen:
5571     if (i > 0 && RXp_MATCH_UTF8(rx)) {
5572         const char * const s = rx->subbeg + s1;
5573         const U8 *ep;
5574         STRLEN el;
5575
5576         i = t1 - s1;
5577         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
5578                         i = el;
5579     }
5580     return i;
5581 }
5582
5583 SV*
5584 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
5585 {
5586     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
5587         PERL_UNUSED_ARG(rx);
5588         if (0)
5589             return NULL;
5590         else
5591             return newSVpvs("Regexp");
5592 }
5593
5594 /* Scans the name of a named buffer from the pattern.
5595  * If flags is REG_RSN_RETURN_NULL returns null.
5596  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
5597  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
5598  * to the parsed name as looked up in the RExC_paren_names hash.
5599  * If there is an error throws a vFAIL().. type exception.
5600  */
5601
5602 #define REG_RSN_RETURN_NULL    0
5603 #define REG_RSN_RETURN_NAME    1
5604 #define REG_RSN_RETURN_DATA    2
5605
5606 STATIC SV*
5607 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
5608 {
5609     char *name_start = RExC_parse;
5610
5611     PERL_ARGS_ASSERT_REG_SCAN_NAME;
5612
5613     if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
5614          /* skip IDFIRST by using do...while */
5615         if (UTF)
5616             do {
5617                 RExC_parse += UTF8SKIP(RExC_parse);
5618             } while (isALNUM_utf8((U8*)RExC_parse));
5619         else
5620             do {
5621                 RExC_parse++;
5622             } while (isALNUM(*RExC_parse));
5623     }
5624
5625     if ( flags ) {
5626         SV* sv_name
5627             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
5628                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
5629         if ( flags == REG_RSN_RETURN_NAME)
5630             return sv_name;
5631         else if (flags==REG_RSN_RETURN_DATA) {
5632             HE *he_str = NULL;
5633             SV *sv_dat = NULL;
5634             if ( ! sv_name )      /* should not happen*/
5635                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
5636             if (RExC_paren_names)
5637                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
5638             if ( he_str )
5639                 sv_dat = HeVAL(he_str);
5640             if ( ! sv_dat )
5641                 vFAIL("Reference to nonexistent named group");
5642             return sv_dat;
5643         }
5644         else {
5645             Perl_croak(aTHX_ "panic: bad flag in reg_scan_name");
5646         }
5647         /* NOT REACHED */
5648     }
5649     return NULL;
5650 }
5651
5652 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
5653     int rem=(int)(RExC_end - RExC_parse);                       \
5654     int cut;                                                    \
5655     int num;                                                    \
5656     int iscut=0;                                                \
5657     if (rem>10) {                                               \
5658         rem=10;                                                 \
5659         iscut=1;                                                \
5660     }                                                           \
5661     cut=10-rem;                                                 \
5662     if (RExC_lastparse!=RExC_parse)                             \
5663         PerlIO_printf(Perl_debug_log," >%.*s%-*s",              \
5664             rem, RExC_parse,                                    \
5665             cut + 4,                                            \
5666             iscut ? "..." : "<"                                 \
5667         );                                                      \
5668     else                                                        \
5669         PerlIO_printf(Perl_debug_log,"%16s","");                \
5670                                                                 \
5671     if (SIZE_ONLY)                                              \
5672        num = RExC_size + 1;                                     \
5673     else                                                        \
5674        num=REG_NODE_NUM(RExC_emit);                             \
5675     if (RExC_lastnum!=num)                                      \
5676        PerlIO_printf(Perl_debug_log,"|%4d",num);                \
5677     else                                                        \
5678        PerlIO_printf(Perl_debug_log,"|%4s","");                 \
5679     PerlIO_printf(Perl_debug_log,"|%*s%-4s",                    \
5680         (int)((depth*2)), "",                                   \
5681         (funcname)                                              \
5682     );                                                          \
5683     RExC_lastnum=num;                                           \
5684     RExC_lastparse=RExC_parse;                                  \
5685 })
5686
5687
5688
5689 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
5690     DEBUG_PARSE_MSG((funcname));                            \
5691     PerlIO_printf(Perl_debug_log,"%4s","\n");               \
5692 })
5693 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({           \
5694     DEBUG_PARSE_MSG((funcname));                            \
5695     PerlIO_printf(Perl_debug_log,fmt "\n",args);               \
5696 })
5697
5698 /* This section of code defines the inversion list object and its methods.  The
5699  * interfaces are highly subject to change, so as much as possible is static to
5700  * this file.  An inversion list is here implemented as a malloc'd C array with
5701  * some added info.  More will be coming when functionality is added later.
5702  *
5703  * Some of the methods should always be private to the implementation, and some
5704  * should eventually be made public */
5705
5706 #define INVLIST_INITIAL_LEN 10
5707 #define INVLIST_ARRAY_KEY "array"
5708 #define INVLIST_MAX_KEY "max"
5709 #define INVLIST_LEN_KEY "len"
5710
5711 PERL_STATIC_INLINE UV*
5712 S_invlist_array(pTHX_ HV* const invlist)
5713 {
5714     /* Returns the pointer to the inversion list's array.  Every time the
5715      * length changes, this needs to be called in case malloc or realloc moved
5716      * it */
5717
5718     SV** list_ptr = hv_fetchs(invlist, INVLIST_ARRAY_KEY, FALSE);
5719
5720     PERL_ARGS_ASSERT_INVLIST_ARRAY;
5721
5722     if (list_ptr == NULL) {
5723         Perl_croak(aTHX_ "panic: inversion list without a '%s' element",
5724                                                             INVLIST_ARRAY_KEY);
5725     }
5726
5727     return INT2PTR(UV *, SvUV(*list_ptr));
5728 }
5729
5730 PERL_STATIC_INLINE void
5731 S_invlist_set_array(pTHX_ HV* const invlist, const UV* const array)
5732 {
5733     PERL_ARGS_ASSERT_INVLIST_SET_ARRAY;
5734
5735     /* Sets the array stored in the inversion list to the memory beginning with
5736      * the parameter */
5737
5738     if (hv_stores(invlist, INVLIST_ARRAY_KEY, newSVuv(PTR2UV(array))) == NULL) {
5739         Perl_croak(aTHX_ "panic: can't store '%s' entry in inversion list",
5740                                                             INVLIST_ARRAY_KEY);
5741     }
5742 }
5743
5744 PERL_STATIC_INLINE UV
5745 S_invlist_len(pTHX_ HV* const invlist)
5746 {
5747     /* Returns the current number of elements in the inversion list's array */
5748
5749     SV** len_ptr = hv_fetchs(invlist, INVLIST_LEN_KEY, FALSE);
5750
5751     PERL_ARGS_ASSERT_INVLIST_LEN;
5752
5753     if (len_ptr == NULL) {
5754         Perl_croak(aTHX_ "panic: inversion list without a '%s' element",
5755                                                             INVLIST_LEN_KEY);
5756     }
5757
5758     return SvUV(*len_ptr);
5759 }
5760
5761 PERL_STATIC_INLINE UV
5762 S_invlist_max(pTHX_ HV* const invlist)
5763 {
5764     /* Returns the maximum number of elements storable in the inversion list's
5765      * array, without having to realloc() */
5766
5767     SV** max_ptr = hv_fetchs(invlist, INVLIST_MAX_KEY, FALSE);
5768
5769     PERL_ARGS_ASSERT_INVLIST_MAX;
5770
5771     if (max_ptr == NULL) {
5772         Perl_croak(aTHX_ "panic: inversion list without a '%s' element",
5773                                                             INVLIST_MAX_KEY);
5774     }
5775
5776     return SvUV(*max_ptr);
5777 }
5778
5779 PERL_STATIC_INLINE void
5780 S_invlist_set_len(pTHX_ HV* const invlist, const UV len)
5781 {
5782     /* Sets the current number of elements stored in the inversion list */
5783
5784     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
5785
5786     if (len != 0 && len > invlist_max(invlist)) {
5787         Perl_croak(aTHX_ "panic: Can't make '%s=%"UVuf"' more than %s=%"UVuf" in inversion list", INVLIST_LEN_KEY, len, INVLIST_MAX_KEY, invlist_max(invlist));
5788     }
5789
5790     if (hv_stores(invlist, INVLIST_LEN_KEY, newSVuv(len)) == NULL) {
5791         Perl_croak(aTHX_ "panic: can't store '%s' entry in inversion list",
5792                                                             INVLIST_LEN_KEY);
5793     }
5794 }
5795
5796 PERL_STATIC_INLINE void
5797 S_invlist_set_max(pTHX_ HV* const invlist, const UV max)
5798 {
5799
5800     /* Sets the maximum number of elements storable in the inversion list
5801      * without having to realloc() */
5802
5803     PERL_ARGS_ASSERT_INVLIST_SET_MAX;
5804
5805     if (max < invlist_len(invlist)) {
5806         Perl_croak(aTHX_ "panic: Can't make '%s=%"UVuf"' less than %s=%"UVuf" in inversion list", INVLIST_MAX_KEY, invlist_len(invlist), INVLIST_LEN_KEY, invlist_max(invlist));
5807     }
5808
5809     if (hv_stores(invlist, INVLIST_MAX_KEY, newSVuv(max)) == NULL) {
5810         Perl_croak(aTHX_ "panic: can't store '%s' entry in inversion list",
5811                                                             INVLIST_LEN_KEY);
5812     }
5813 }
5814
5815 #ifndef PERL_IN_XSUB_RE
5816 HV*
5817 Perl__new_invlist(pTHX_ IV initial_size)
5818 {
5819
5820     /* Return a pointer to a newly constructed inversion list, with enough
5821      * space to store 'initial_size' elements.  If that number is negative, a
5822      * system default is used instead */
5823
5824     HV* invlist = newHV();
5825     UV* list;
5826
5827     if (initial_size < 0) {
5828         initial_size = INVLIST_INITIAL_LEN;
5829     }
5830
5831     /* Allocate the initial space */
5832     Newx(list, initial_size, UV);
5833     invlist_set_array(invlist, list);
5834
5835     /* set_len has to come before set_max, as the latter inspects the len */
5836     invlist_set_len(invlist, 0);
5837     invlist_set_max(invlist, initial_size);
5838
5839     return invlist;
5840 }
5841 #endif
5842
5843 PERL_STATIC_INLINE void
5844 S_invlist_destroy(pTHX_ HV* const invlist)
5845 {
5846    /* Inversion list destructor */
5847
5848     SV** list_ptr = hv_fetchs(invlist, INVLIST_ARRAY_KEY, FALSE);
5849
5850     PERL_ARGS_ASSERT_INVLIST_DESTROY;
5851
5852     if (list_ptr != NULL) {
5853         UV *list = INT2PTR(UV *, SvUV(*list_ptr)); /* PERL_POISON needs lvalue */
5854         Safefree(list);
5855     }
5856 }
5857
5858 STATIC void
5859 S_invlist_extend(pTHX_ HV* const invlist, const UV new_max)
5860 {
5861     /* Change the maximum size of an inversion list (up or down) */
5862
5863     UV* orig_array;
5864     UV* array;
5865     const UV old_max = invlist_max(invlist);
5866
5867     PERL_ARGS_ASSERT_INVLIST_EXTEND;
5868
5869     if (old_max == new_max) {   /* If a no-op */
5870         return;
5871     }
5872
5873     array = orig_array = invlist_array(invlist);
5874     Renew(array, new_max, UV);
5875
5876     /* If the size change moved the list in memory, set the new one */
5877     if (array != orig_array) {
5878         invlist_set_array(invlist, array);
5879     }
5880
5881     invlist_set_max(invlist, new_max);
5882
5883 }
5884
5885 PERL_STATIC_INLINE void
5886 S_invlist_trim(pTHX_ HV* const invlist)
5887 {
5888     PERL_ARGS_ASSERT_INVLIST_TRIM;
5889
5890     /* Change the length of the inversion list to how many entries it currently
5891      * has */
5892
5893     invlist_extend(invlist, invlist_len(invlist));
5894 }
5895
5896 /* An element is in an inversion list iff its index is even numbered: 0, 2, 4,
5897  * etc */
5898
5899 #define ELEMENT_IN_INVLIST_SET(i) (! ((i) & 1))
5900
5901 #ifndef PERL_IN_XSUB_RE
5902 void
5903 Perl__append_range_to_invlist(pTHX_ HV* const invlist, const UV start, const UV end)
5904 {
5905    /* Subject to change or removal.  Append the range from 'start' to 'end' at
5906     * the end of the inversion list.  The range must be above any existing
5907     * ones. */
5908
5909     UV* array = invlist_array(invlist);
5910     UV max = invlist_max(invlist);
5911     UV len = invlist_len(invlist);
5912
5913     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
5914
5915     if (len > 0) {
5916
5917         /* Here, the existing list is non-empty. The current max entry in the
5918          * list is generally the first value not in the set, except when the
5919          * set extends to the end of permissible values, in which case it is
5920          * the first entry in that final set, and so this call is an attempt to
5921          * append out-of-order */
5922
5923         UV final_element = len - 1;
5924         if (array[final_element] > start
5925             || ELEMENT_IN_INVLIST_SET(final_element))
5926         {
5927             Perl_croak(aTHX_ "panic: attempting to append to an inversion list, but wasn't at the end of the list");
5928         }
5929
5930         /* Here, it is a legal append.  If the new range begins with the first
5931          * value not in the set, it is extending the set, so the new first
5932          * value not in the set is one greater than the newly extended range.
5933          * */
5934         if (array[final_element] == start) {
5935             if (end != UV_MAX) {
5936                 array[final_element] = end + 1;
5937             }
5938             else {
5939                 /* But if the end is the maximum representable on the machine,
5940                  * just let the range that this would extend have no end */
5941                 invlist_set_len(invlist, len - 1);
5942             }
5943             return;
5944         }
5945     }
5946
5947     /* Here the new range doesn't extend any existing set.  Add it */
5948
5949     len += 2;   /* Includes an element each for the start and end of range */
5950
5951     /* If overflows the existing space, extend, which may cause the array to be
5952      * moved */
5953     if (max < len) {
5954         invlist_extend(invlist, len);
5955         array = invlist_array(invlist);
5956     }
5957
5958     invlist_set_len(invlist, len);
5959
5960     /* The next item on the list starts the range, the one after that is
5961      * one past the new range.  */
5962     array[len - 2] = start;
5963     if (end != UV_MAX) {
5964         array[len - 1] = end + 1;
5965     }
5966     else {
5967         /* But if the end is the maximum representable on the machine, just let
5968          * the range have no end */
5969         invlist_set_len(invlist, len - 1);
5970     }
5971 }
5972 #endif
5973
5974 PERL_STATIC_INLINE HV*
5975 S_invlist_union(pTHX_ HV* const a, HV* const b)
5976 {
5977     /* Return a new inversion list which is the union of two inversion lists.
5978      * The basis for this comes from "Unicode Demystified" Chapter 13 by
5979      * Richard Gillam, published by Addison-Wesley, and explained at some
5980      * length there.  The preface says to incorporate its examples into your
5981      * code at your own risk.
5982      *
5983      * The algorithm is like a merge sort.
5984      *
5985      * XXX A potential performance improvement is to keep track as we go along
5986      * if only one of the inputs contributes to the result, meaning the other
5987      * is a subset of that one.  In that case, we can skip the final copy and
5988      * return the larger of the input lists */
5989
5990     UV* array_a = invlist_array(a);   /* a's array */
5991     UV* array_b = invlist_array(b);
5992     UV len_a = invlist_len(a);  /* length of a's array */
5993     UV len_b = invlist_len(b);
5994
5995     HV* u;                      /* the resulting union */
5996     UV* array_u;
5997     UV len_u;
5998
5999     UV i_a = 0;             /* current index into a's array */
6000     UV i_b = 0;
6001     UV i_u = 0;
6002
6003     /* running count, as explained in the algorithm source book; items are
6004      * stopped accumulating and are output when the count changes to/from 0.
6005      * The count is incremented when we start a range that's in the set, and
6006      * decremented when we start a range that's not in the set.  So its range
6007      * is 0 to 2.  Only when the count is zero is something not in the set.
6008      */
6009     UV count = 0;
6010
6011     PERL_ARGS_ASSERT_INVLIST_UNION;
6012
6013     /* Size the union for the worst case: that the sets are completely
6014      * disjoint */
6015     u = _new_invlist(len_a + len_b);
6016     array_u = invlist_array(u);
6017
6018     /* Go through each list item by item, stopping when exhausted one of
6019      * them */
6020     while (i_a < len_a && i_b < len_b) {
6021         UV cp;      /* The element to potentially add to the union's array */
6022         bool cp_in_set;   /* is it in the the input list's set or not */
6023
6024         /* We need to take one or the other of the two inputs for the union.
6025          * Since we are merging two sorted lists, we take the smaller of the
6026          * next items.  In case of a tie, we take the one that is in its set
6027          * first.  If we took one not in the set first, it would decrement the
6028          * count, possibly to 0 which would cause it to be output as ending the
6029          * range, and the next time through we would take the same number, and
6030          * output it again as beginning the next range.  By doing it the
6031          * opposite way, there is no possibility that the count will be
6032          * momentarily decremented to 0, and thus the two adjoining ranges will
6033          * be seamlessly merged.  (In a tie and both are in the set or both not
6034          * in the set, it doesn't matter which we take first.) */
6035         if (array_a[i_a] < array_b[i_b]
6036             || (array_a[i_a] == array_b[i_b] && ELEMENT_IN_INVLIST_SET(i_a)))
6037         {
6038             cp_in_set = ELEMENT_IN_INVLIST_SET(i_a);
6039             cp= array_a[i_a++];
6040         }
6041         else {
6042             cp_in_set = ELEMENT_IN_INVLIST_SET(i_b);
6043             cp= array_b[i_b++];
6044         }
6045
6046         /* Here, have chosen which of the two inputs to look at.  Only output
6047          * if the running count changes to/from 0, which marks the
6048          * beginning/end of a range in that's in the set */
6049         if (cp_in_set) {
6050             if (count == 0) {
6051                 array_u[i_u++] = cp;
6052             }
6053             count++;
6054         }
6055         else {
6056             count--;
6057             if (count == 0) {
6058                 array_u[i_u++] = cp;
6059             }
6060         }
6061     }
6062
6063     /* Here, we are finished going through at least one of the lists, which
6064      * means there is something remaining in at most one.  We check if the list
6065      * that hasn't been exhausted is positioned such that we are in the middle
6066      * of a range in its set or not.  (We are in the set if the next item in
6067      * the array marks the beginning of something not in the set)   If in the
6068      * set, we decrement 'count'; if 0, there is potentially more to output.
6069      * There are four cases:
6070      *  1) Both weren't in their sets, count is 0, and remains 0.  What's left
6071      *     in the union is entirely from the non-exhausted set.
6072      *  2) Both were in their sets, count is 2.  Nothing further should
6073      *     be output, as everything that remains will be in the exhausted
6074      *     list's set, hence in the union; decrementing to 1 but not 0 insures
6075      *     that
6076      *  3) the exhausted was in its set, non-exhausted isn't, count is 1.
6077      *     Nothing further should be output because the union includes
6078      *     everything from the exhausted set.  Not decrementing insures that.
6079      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1;
6080      *     decrementing to 0 insures that we look at the remainder of the
6081      *     non-exhausted set */
6082     if ((i_a != len_a && ! ELEMENT_IN_INVLIST_SET(i_a))
6083         || (i_b != len_b && ! ELEMENT_IN_INVLIST_SET(i_b)))
6084     {
6085         count--;
6086     }
6087
6088     /* The final length is what we've output so far, plus what else is about to
6089      * be output.  (If 'count' is non-zero, then the input list we exhausted
6090      * has everything remaining up to the machine's limit in its set, and hence
6091      * in the union, so there will be no further output. */
6092     len_u = i_u;
6093     if (count == 0) {
6094         /* At most one of the subexpressions will be non-zero */
6095         len_u += (len_a - i_a) + (len_b - i_b);
6096     }
6097
6098     /* Set result to final length, which can change the pointer to array_u, so
6099      * re-find it */
6100     if (len_u != invlist_len(u)) {
6101         invlist_set_len(u, len_u);
6102         invlist_trim(u);
6103         array_u = invlist_array(u);
6104     }
6105
6106     /* When 'count' is 0, the list that was exhausted (if one was shorter than
6107      * the other) ended with everything above it not in its set.  That means
6108      * that the remaining part of the union is precisely the same as the
6109      * non-exhausted list, so can just copy it unchanged.  (If both list were
6110      * exhausted at the same time, then the operations below will be both 0.)
6111      */
6112     if (count == 0) {
6113         IV copy_count; /* At most one will have a non-zero copy count */
6114         if ((copy_count = len_a - i_a) > 0) {
6115             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
6116         }
6117         else if ((copy_count = len_b - i_b) > 0) {
6118             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
6119         }
6120     }
6121
6122     return u;
6123 }
6124
6125 PERL_STATIC_INLINE HV*
6126 S_invlist_intersection(pTHX_ HV* const a, HV* const b)
6127 {
6128     /* Return the intersection of two inversion lists.  The basis for this
6129      * comes from "Unicode Demystified" Chapter 13 by Richard Gillam, published
6130      * by Addison-Wesley, and explained at some length there.  The preface says
6131      * to incorporate its examples into your code at your own risk.
6132      *
6133      * The algorithm is like a merge sort, and is essentially the same as the
6134      * union above
6135      */
6136
6137     UV* array_a = invlist_array(a);   /* a's array */
6138     UV* array_b = invlist_array(b);
6139     UV len_a = invlist_len(a);  /* length of a's array */
6140     UV len_b = invlist_len(b);
6141
6142     HV* r;                   /* the resulting intersection */
6143     UV* array_r;
6144     UV len_r;
6145
6146     UV i_a = 0;             /* current index into a's array */
6147     UV i_b = 0;
6148     UV i_r = 0;
6149
6150     /* running count, as explained in the algorithm source book; items are
6151      * stopped accumulating and are output when the count changes to/from 2.
6152      * The count is incremented when we start a range that's in the set, and
6153      * decremented when we start a range that's not in the set.  So its range
6154      * is 0 to 2.  Only when the count is 2 is something in the intersection.
6155      */
6156     UV count = 0;
6157
6158     PERL_ARGS_ASSERT_INVLIST_INTERSECTION;
6159
6160     /* Size the intersection for the worst case: that the intersection ends up
6161      * fragmenting everything to be completely disjoint */
6162     r= _new_invlist(len_a + len_b);
6163     array_r = invlist_array(r);
6164
6165     /* Go through each list item by item, stopping when exhausted one of
6166      * them */
6167     while (i_a < len_a && i_b < len_b) {
6168         UV cp;      /* The element to potentially add to the intersection's
6169                        array */
6170         bool cp_in_set; /* Is it in the input list's set or not */
6171
6172         /* We need to take one or the other of the two inputs for the union.
6173          * Since we are merging two sorted lists, we take the smaller of the
6174          * next items.  In case of a tie, we take the one that is not in its
6175          * set first (a difference from the union algorithm).  If we took one
6176          * in the set first, it would increment the count, possibly to 2 which
6177          * would cause it to be output as starting a range in the intersection,
6178          * and the next time through we would take that same number, and output
6179          * it again as ending the set.  By doing it the opposite of this, we
6180          * there is no possibility that the count will be momentarily
6181          * incremented to 2.  (In a tie and both are in the set or both not in
6182          * the set, it doesn't matter which we take first.) */
6183         if (array_a[i_a] < array_b[i_b]
6184             || (array_a[i_a] == array_b[i_b] && ! ELEMENT_IN_INVLIST_SET(i_a)))
6185         {
6186             cp_in_set = ELEMENT_IN_INVLIST_SET(i_a);
6187             cp= array_a[i_a++];
6188         }
6189         else {
6190             cp_in_set = ELEMENT_IN_INVLIST_SET(i_b);
6191             cp= array_b[i_b++];
6192         }
6193
6194         /* Here, have chosen which of the two inputs to look at.  Only output
6195          * if the running count changes to/from 2, which marks the
6196          * beginning/end of a range that's in the intersection */
6197         if (cp_in_set) {
6198             count++;
6199             if (count == 2) {
6200                 array_r[i_r++] = cp;
6201             }
6202         }
6203         else {
6204             if (count == 2) {
6205                 array_r[i_r++] = cp;
6206             }
6207             count--;
6208         }
6209     }
6210
6211     /* Here, we are finished going through at least one of the sets, which
6212      * means there is something remaining in at most one.  See the comments in
6213      * the union code */
6214     if ((i_a != len_a && ! ELEMENT_IN_INVLIST_SET(i_a))
6215         || (i_b != len_b && ! ELEMENT_IN_INVLIST_SET(i_b)))
6216     {
6217         count--;
6218     }
6219
6220     /* The final length is what we've output so far plus what else is in the
6221      * intersection.  Only one of the subexpressions below will be non-zero */
6222     len_r = i_r;
6223     if (count == 2) {
6224         len_r += (len_a - i_a) + (len_b - i_b);
6225     }
6226
6227     /* Set result to final length, which can change the pointer to array_r, so
6228      * re-find it */
6229     if (len_r != invlist_len(r)) {
6230         invlist_set_len(r, len_r);
6231         invlist_trim(r);
6232         array_r = invlist_array(r);
6233     }
6234
6235     /* Finish outputting any remaining */
6236     if (count == 2) { /* Only one of will have a non-zero copy count */
6237         IV copy_count;
6238         if ((copy_count = len_a - i_a) > 0) {
6239             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
6240         }
6241         else if ((copy_count = len_b - i_b) > 0) {
6242             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
6243         }
6244     }
6245
6246     return r;
6247 }
6248
6249 STATIC HV*
6250 S_add_range_to_invlist(pTHX_ HV* const invlist, const UV start, const UV end)
6251 {
6252     /* Add the range from 'start' to 'end' inclusive to the inversion list's
6253      * set.  A pointer to the inversion list is returned.  This may actually be
6254      * a new list, in which case the passed in one has been destroyed */
6255
6256     HV* range_invlist;
6257     HV* added_invlist;
6258
6259     UV len = invlist_len(invlist);
6260
6261     PERL_ARGS_ASSERT_ADD_RANGE_TO_INVLIST;
6262
6263     /* If comes after the final entry, can just append it to the end */
6264     if (len == 0
6265         || start >= invlist_array(invlist)
6266                                     [invlist_len(invlist) - 1])
6267     {
6268         _append_range_to_invlist(invlist, start, end);
6269         return invlist;
6270     }
6271
6272     /* Here, can't just append things, create and return a new inversion list
6273      * which is the union of this range and the existing inversion list */
6274     range_invlist = _new_invlist(2);
6275     _append_range_to_invlist(range_invlist, start, end);
6276
6277     added_invlist = invlist_union(invlist, range_invlist);
6278
6279     /* The passed in list can be freed, as well as our temporary */
6280     invlist_destroy(range_invlist);
6281     if (invlist != added_invlist) {
6282         invlist_destroy(invlist);
6283     }
6284
6285     return added_invlist;
6286 }
6287
6288 /* End of inversion list object */
6289
6290 /*
6291  - reg - regular expression, i.e. main body or parenthesized thing
6292  *
6293  * Caller must absorb opening parenthesis.
6294  *
6295  * Combining parenthesis handling with the base level of regular expression
6296  * is a trifle forced, but the need to tie the tails of the branches to what
6297  * follows makes it hard to avoid.
6298  */
6299 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
6300 #ifdef DEBUGGING
6301 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
6302 #else
6303 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
6304 #endif
6305
6306 STATIC regnode *
6307 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
6308     /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
6309 {
6310     dVAR;
6311     register regnode *ret;              /* Will be the head of the group. */
6312     register regnode *br;
6313     register regnode *lastbr;
6314     register regnode *ender = NULL;
6315     register I32 parno = 0;
6316     I32 flags;
6317     U32 oregflags = RExC_flags;
6318     bool have_branch = 0;
6319     bool is_open = 0;
6320     I32 freeze_paren = 0;
6321     I32 after_freeze = 0;
6322
6323     /* for (?g), (?gc), and (?o) warnings; warning
6324        about (?c) will warn about (?g) -- japhy    */
6325
6326 #define WASTED_O  0x01
6327 #define WASTED_G  0x02
6328 #define WASTED_C  0x04
6329 #define WASTED_GC (0x02|0x04)
6330     I32 wastedflags = 0x00;
6331
6332     char * parse_start = RExC_parse; /* MJD */
6333     char * const oregcomp_parse = RExC_parse;
6334
6335     GET_RE_DEBUG_FLAGS_DECL;
6336
6337     PERL_ARGS_ASSERT_REG;
6338     DEBUG_PARSE("reg ");
6339
6340     *flagp = 0;                         /* Tentatively. */
6341
6342
6343     /* Make an OPEN node, if parenthesized. */
6344     if (paren) {
6345         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
6346             char *start_verb = RExC_parse;
6347             STRLEN verb_len = 0;
6348             char *start_arg = NULL;
6349             unsigned char op = 0;
6350             int argok = 1;
6351             int internal_argval = 0; /* internal_argval is only useful if !argok */
6352             while ( *RExC_parse && *RExC_parse != ')' ) {
6353                 if ( *RExC_parse == ':' ) {
6354                     start_arg = RExC_parse + 1;
6355                     break;
6356                 }
6357                 RExC_parse++;
6358             }
6359             ++start_verb;
6360             verb_len = RExC_parse - start_verb;
6361             if ( start_arg ) {
6362                 RExC_parse++;
6363                 while ( *RExC_parse && *RExC_parse != ')' ) 
6364                     RExC_parse++;
6365                 if ( *RExC_parse != ')' ) 
6366                     vFAIL("Unterminated verb pattern argument");
6367                 if ( RExC_parse == start_arg )
6368                     start_arg = NULL;
6369             } else {
6370                 if ( *RExC_parse != ')' )
6371                     vFAIL("Unterminated verb pattern");
6372             }
6373             
6374             switch ( *start_verb ) {
6375             case 'A':  /* (*ACCEPT) */
6376                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
6377                     op = ACCEPT;
6378                     internal_argval = RExC_nestroot;
6379                 }
6380                 break;
6381             case 'C':  /* (*COMMIT) */
6382                 if ( memEQs(start_verb,verb_len,"COMMIT") )
6383                     op = COMMIT;
6384                 break;
6385             case 'F':  /* (*FAIL) */
6386                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
6387                     op = OPFAIL;
6388                     argok = 0;
6389                 }
6390                 break;
6391             case ':':  /* (*:NAME) */
6392             case 'M':  /* (*MARK:NAME) */
6393                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
6394                     op = MARKPOINT;
6395                     argok = -1;
6396                 }
6397                 break;
6398             case 'P':  /* (*PRUNE) */
6399                 if ( memEQs(start_verb,verb_len,"PRUNE") )
6400                     op = PRUNE;
6401                 break;
6402             case 'S':   /* (*SKIP) */  
6403                 if ( memEQs(start_verb,verb_len,"SKIP") ) 
6404                     op = SKIP;
6405                 break;
6406             case 'T':  /* (*THEN) */
6407                 /* [19:06] <TimToady> :: is then */
6408                 if ( memEQs(start_verb,verb_len,"THEN") ) {
6409                     op = CUTGROUP;
6410                     RExC_seen |= REG_SEEN_CUTGROUP;
6411                 }
6412                 break;
6413             }
6414             if ( ! op ) {
6415                 RExC_parse++;
6416                 vFAIL3("Unknown verb pattern '%.*s'",
6417                     verb_len, start_verb);
6418             }
6419             if ( argok ) {
6420                 if ( start_arg && internal_argval ) {
6421                     vFAIL3("Verb pattern '%.*s' may not have an argument",
6422                         verb_len, start_verb); 
6423                 } else if ( argok < 0 && !start_arg ) {
6424                     vFAIL3("Verb pattern '%.*s' has a mandatory argument",
6425                         verb_len, start_verb);    
6426                 } else {
6427                     ret = reganode(pRExC_state, op, internal_argval);
6428                     if ( ! internal_argval && ! SIZE_ONLY ) {
6429                         if (start_arg) {
6430                             SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
6431                             ARG(ret) = add_data( pRExC_state, 1, "S" );
6432                             RExC_rxi->data->data[ARG(ret)]=(void*)sv;
6433                             ret->flags = 0;
6434                         } else {
6435                             ret->flags = 1; 
6436                         }
6437                     }               
6438                 }
6439                 if (!internal_argval)
6440                     RExC_seen |= REG_SEEN_VERBARG;
6441             } else if ( start_arg ) {
6442                 vFAIL3("Verb pattern '%.*s' may not have an argument",
6443                         verb_len, start_verb);    
6444             } else {
6445                 ret = reg_node(pRExC_state, op);
6446             }
6447             nextchar(pRExC_state);
6448             return ret;
6449         } else 
6450         if (*RExC_parse == '?') { /* (?...) */
6451             bool is_logical = 0;
6452             const char * const seqstart = RExC_parse;
6453             bool has_use_defaults = FALSE;
6454
6455             RExC_parse++;
6456             paren = *RExC_parse++;
6457             ret = NULL;                 /* For look-ahead/behind. */
6458             switch (paren) {
6459
6460             case 'P':   /* (?P...) variants for those used to PCRE/Python */
6461                 paren = *RExC_parse++;
6462                 if ( paren == '<')         /* (?P<...>) named capture */
6463                     goto named_capture;
6464                 else if (paren == '>') {   /* (?P>name) named recursion */
6465                     goto named_recursion;
6466                 }
6467                 else if (paren == '=') {   /* (?P=...)  named backref */
6468                     /* this pretty much dupes the code for \k<NAME> in regatom(), if
6469                        you change this make sure you change that */
6470                     char* name_start = RExC_parse;
6471                     U32 num = 0;
6472                     SV *sv_dat = reg_scan_name(pRExC_state,
6473                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6474                     if (RExC_parse == name_start || *RExC_parse != ')')
6475                         vFAIL2("Sequence %.3s... not terminated",parse_start);
6476
6477                     if (!SIZE_ONLY) {
6478                         num = add_data( pRExC_state, 1, "S" );
6479                         RExC_rxi->data->data[num]=(void*)sv_dat;
6480                         SvREFCNT_inc_simple_void(sv_dat);
6481                     }
6482                     RExC_sawback = 1;
6483                     ret = reganode(pRExC_state,
6484                                    ((! FOLD)
6485                                      ? NREF
6486                                      : (MORE_ASCII_RESTRICTED)
6487                                        ? NREFFA
6488                                        : (AT_LEAST_UNI_SEMANTICS)
6489                                          ? NREFFU
6490                                          : (LOC)
6491                                            ? NREFFL
6492                                            : NREFF),
6493                                     num);
6494                     *flagp |= HASWIDTH;
6495
6496                     Set_Node_Offset(ret, parse_start+1);
6497                     Set_Node_Cur_Length(ret); /* MJD */
6498
6499                     nextchar(pRExC_state);
6500                     return ret;
6501                 }
6502                 RExC_parse++;
6503                 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
6504                 /*NOTREACHED*/
6505             case '<':           /* (?<...) */
6506                 if (*RExC_parse == '!')
6507                     paren = ',';
6508                 else if (*RExC_parse != '=') 
6509               named_capture:
6510                 {               /* (?<...>) */
6511                     char *name_start;
6512                     SV *svname;
6513                     paren= '>';
6514             case '\'':          /* (?'...') */
6515                     name_start= RExC_parse;
6516                     svname = reg_scan_name(pRExC_state,
6517                         SIZE_ONLY ?  /* reverse test from the others */
6518                         REG_RSN_RETURN_NAME : 
6519                         REG_RSN_RETURN_NULL);
6520                     if (RExC_parse == name_start) {
6521                         RExC_parse++;
6522                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
6523                         /*NOTREACHED*/
6524                     }
6525                     if (*RExC_parse != paren)
6526                         vFAIL2("Sequence (?%c... not terminated",
6527                             paren=='>' ? '<' : paren);
6528                     if (SIZE_ONLY) {
6529                         HE *he_str;
6530                         SV *sv_dat = NULL;
6531                         if (!svname) /* shouldn't happen */
6532                             Perl_croak(aTHX_
6533                                 "panic: reg_scan_name returned NULL");
6534                         if (!RExC_paren_names) {
6535                             RExC_paren_names= newHV();
6536                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
6537 #ifdef DEBUGGING
6538                             RExC_paren_name_list= newAV();
6539                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
6540 #endif
6541                         }
6542                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
6543                         if ( he_str )
6544                             sv_dat = HeVAL(he_str);
6545                         if ( ! sv_dat ) {
6546                             /* croak baby croak */
6547                             Perl_croak(aTHX_
6548                                 "panic: paren_name hash element allocation failed");
6549                         } else if ( SvPOK(sv_dat) ) {
6550                             /* (?|...) can mean we have dupes so scan to check
6551                                its already been stored. Maybe a flag indicating
6552                                we are inside such a construct would be useful,
6553                                but the arrays are likely to be quite small, so
6554                                for now we punt -- dmq */
6555                             IV count = SvIV(sv_dat);
6556                             I32 *pv = (I32*)SvPVX(sv_dat);
6557                             IV i;
6558                             for ( i = 0 ; i < count ; i++ ) {
6559                                 if ( pv[i] == RExC_npar ) {
6560                                     count = 0;
6561                                     break;
6562                                 }
6563                             }
6564                             if ( count ) {
6565                                 pv = (I32*)SvGROW(sv_dat, SvCUR(sv_dat) + sizeof(I32)+1);
6566                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
6567                                 pv[count] = RExC_npar;
6568                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
6569                             }
6570                         } else {
6571                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
6572                             sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
6573                             SvIOK_on(sv_dat);
6574                             SvIV_set(sv_dat, 1);
6575                         }
6576 #ifdef DEBUGGING
6577                         if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
6578                             SvREFCNT_dec(svname);
6579 #endif
6580
6581                         /*sv_dump(sv_dat);*/
6582                     }
6583                     nextchar(pRExC_state);
6584                     paren = 1;
6585                     goto capturing_parens;
6586                 }
6587                 RExC_seen |= REG_SEEN_LOOKBEHIND;
6588                 RExC_in_lookbehind++;
6589                 RExC_parse++;
6590             case '=':           /* (?=...) */
6591                 RExC_seen_zerolen++;
6592                 break;
6593             case '!':           /* (?!...) */
6594                 RExC_seen_zerolen++;
6595                 if (*RExC_parse == ')') {
6596                     ret=reg_node(pRExC_state, OPFAIL);
6597                     nextchar(pRExC_state);
6598                     return ret;
6599                 }
6600                 break;
6601             case '|':           /* (?|...) */
6602                 /* branch reset, behave like a (?:...) except that
6603                    buffers in alternations share the same numbers */
6604                 paren = ':'; 
6605                 after_freeze = freeze_paren = RExC_npar;
6606                 break;
6607             case ':':           /* (?:...) */
6608             case '>':           /* (?>...) */
6609                 break;
6610             case '$':           /* (?$...) */
6611             case '@':           /* (?@...) */
6612                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
6613                 break;
6614             case '#':           /* (?#...) */
6615                 while (*RExC_parse && *RExC_parse != ')')
6616                     RExC_parse++;
6617                 if (*RExC_parse != ')')
6618                     FAIL("Sequence (?#... not terminated");
6619                 nextchar(pRExC_state);
6620                 *flagp = TRYAGAIN;
6621                 return NULL;
6622             case '0' :           /* (?0) */
6623             case 'R' :           /* (?R) */
6624                 if (*RExC_parse != ')')
6625                     FAIL("Sequence (?R) not terminated");
6626                 ret = reg_node(pRExC_state, GOSTART);
6627                 *flagp |= POSTPONED;
6628                 nextchar(pRExC_state);
6629                 return ret;
6630                 /*notreached*/
6631             { /* named and numeric backreferences */
6632                 I32 num;
6633             case '&':            /* (?&NAME) */
6634                 parse_start = RExC_parse - 1;
6635               named_recursion:
6636                 {
6637                     SV *sv_dat = reg_scan_name(pRExC_state,
6638                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6639                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
6640                 }
6641                 goto gen_recurse_regop;
6642                 /* NOT REACHED */
6643             case '+':
6644                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
6645                     RExC_parse++;
6646                     vFAIL("Illegal pattern");
6647                 }
6648                 goto parse_recursion;
6649                 /* NOT REACHED*/
6650             case '-': /* (?-1) */
6651                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
6652                     RExC_parse--; /* rewind to let it be handled later */
6653                     goto parse_flags;
6654                 } 
6655                 /*FALLTHROUGH */
6656             case '1': case '2': case '3': case '4': /* (?1) */
6657             case '5': case '6': case '7': case '8': case '9':
6658                 RExC_parse--;
6659               parse_recursion:
6660                 num = atoi(RExC_parse);
6661                 parse_start = RExC_parse - 1; /* MJD */
6662                 if (*RExC_parse == '-')
6663                     RExC_parse++;
6664                 while (isDIGIT(*RExC_parse))
6665                         RExC_parse++;
6666                 if (*RExC_parse!=')') 
6667                     vFAIL("Expecting close bracket");
6668                         
6669               gen_recurse_regop:
6670                 if ( paren == '-' ) {
6671                     /*
6672                     Diagram of capture buffer numbering.
6673                     Top line is the normal capture buffer numbers
6674                     Bottom line is the negative indexing as from
6675                     the X (the (?-2))
6676
6677                     +   1 2    3 4 5 X          6 7
6678                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
6679                     -   5 4    3 2 1 X          x x
6680
6681                     */
6682                     num = RExC_npar + num;
6683                     if (num < 1)  {
6684                         RExC_parse++;
6685                         vFAIL("Reference to nonexistent group");
6686                     }
6687                 } else if ( paren == '+' ) {
6688                     num = RExC_npar + num - 1;
6689                 }
6690
6691                 ret = reganode(pRExC_state, GOSUB, num);
6692                 if (!SIZE_ONLY) {
6693                     if (num > (I32)RExC_rx->nparens) {
6694                         RExC_parse++;
6695                         vFAIL("Reference to nonexistent group");
6696                     }
6697                     ARG2L_SET( ret, RExC_recurse_count++);
6698                     RExC_emit++;
6699                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
6700                         "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
6701                 } else {
6702                     RExC_size++;
6703                 }
6704                 RExC_seen |= REG_SEEN_RECURSE;
6705                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
6706                 Set_Node_Offset(ret, parse_start); /* MJD */
6707
6708                 *flagp |= POSTPONED;
6709                 nextchar(pRExC_state);
6710                 return ret;
6711             } /* named and numeric backreferences */
6712             /* NOT REACHED */
6713
6714             case '?':           /* (??...) */
6715                 is_logical = 1;
6716                 if (*RExC_parse != '{') {
6717                     RExC_parse++;
6718                     vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
6719                     /*NOTREACHED*/
6720                 }
6721                 *flagp |= POSTPONED;
6722                 paren = *RExC_parse++;
6723                 /* FALL THROUGH */
6724             case '{':           /* (?{...}) */
6725             {
6726                 I32 count = 1;
6727                 U32 n = 0;
6728                 char c;
6729                 char *s = RExC_parse;
6730
6731                 RExC_seen_zerolen++;
6732                 RExC_seen |= REG_SEEN_EVAL;
6733                 while (count && (c = *RExC_parse)) {
6734                     if (c == '\\') {
6735                         if (RExC_parse[1])
6736                             RExC_parse++;
6737                     }
6738                     else if (c == '{')
6739                         count++;
6740                     else if (c == '}')
6741                         count--;
6742                     RExC_parse++;
6743                 }
6744                 if (*RExC_parse != ')') {
6745                     RExC_parse = s;             
6746                     vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
6747                 }
6748                 if (!SIZE_ONLY) {
6749                     PAD *pad;
6750                     OP_4tree *sop, *rop;
6751                     SV * const sv = newSVpvn(s, RExC_parse - 1 - s);
6752
6753                     ENTER;
6754                     Perl_save_re_context(aTHX);
6755                     rop = Perl_sv_compile_2op_is_broken(aTHX_ sv, &sop, "re", &pad);
6756                     sop->op_private |= OPpREFCOUNTED;
6757                     /* re_dup will OpREFCNT_inc */
6758                     OpREFCNT_set(sop, 1);
6759                     LEAVE;
6760
6761                     n = add_data(pRExC_state, 3, "nop");
6762                     RExC_rxi->data->data[n] = (void*)rop;
6763                     RExC_rxi->data->data[n+1] = (void*)sop;
6764                     RExC_rxi->data->data[n+2] = (void*)pad;
6765                     SvREFCNT_dec(sv);
6766                 }
6767                 else {                                          /* First pass */
6768                     if (PL_reginterp_cnt < ++RExC_seen_evals
6769                         && IN_PERL_RUNTIME)
6770                         /* No compiled RE interpolated, has runtime
6771                            components ===> unsafe.  */
6772                         FAIL("Eval-group not allowed at runtime, use re 'eval'");
6773                     if (PL_tainting && PL_tainted)
6774                         FAIL("Eval-group in insecure regular expression");
6775 #if PERL_VERSION > 8
6776                     if (IN_PERL_COMPILETIME)
6777                         PL_cv_has_eval = 1;
6778 #endif
6779                 }
6780
6781                 nextchar(pRExC_state);
6782                 if (is_logical) {
6783                     ret = reg_node(pRExC_state, LOGICAL);
6784                     if (!SIZE_ONLY)
6785                         ret->flags = 2;
6786                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
6787                     /* deal with the length of this later - MJD */
6788                     return ret;
6789                 }
6790                 ret = reganode(pRExC_state, EVAL, n);
6791                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
6792                 Set_Node_Offset(ret, parse_start);
6793                 return ret;
6794             }
6795             case '(':           /* (?(?{...})...) and (?(?=...)...) */
6796             {
6797                 int is_define= 0;
6798                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
6799                     if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
6800                         || RExC_parse[1] == '<'
6801                         || RExC_parse[1] == '{') { /* Lookahead or eval. */
6802                         I32 flag;
6803                         
6804                         ret = reg_node(pRExC_state, LOGICAL);
6805                         if (!SIZE_ONLY)
6806                             ret->flags = 1;
6807                         REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
6808                         goto insert_if;
6809                     }
6810                 }
6811                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
6812                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
6813                 {
6814                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
6815                     char *name_start= RExC_parse++;
6816                     U32 num = 0;
6817                     SV *sv_dat=reg_scan_name(pRExC_state,
6818                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6819                     if (RExC_parse == name_start || *RExC_parse != ch)
6820                         vFAIL2("Sequence (?(%c... not terminated",
6821                             (ch == '>' ? '<' : ch));
6822                     RExC_parse++;
6823                     if (!SIZE_ONLY) {
6824                         num = add_data( pRExC_state, 1, "S" );
6825                         RExC_rxi->data->data[num]=(void*)sv_dat;
6826                         SvREFCNT_inc_simple_void(sv_dat);
6827                     }
6828                     ret = reganode(pRExC_state,NGROUPP,num);
6829                     goto insert_if_check_paren;
6830                 }
6831                 else if (RExC_parse[0] == 'D' &&
6832                          RExC_parse[1] == 'E' &&
6833                          RExC_parse[2] == 'F' &&
6834                          RExC_parse[3] == 'I' &&
6835                          RExC_parse[4] == 'N' &&
6836                          RExC_parse[5] == 'E')
6837                 {
6838                     ret = reganode(pRExC_state,DEFINEP,0);
6839                     RExC_parse +=6 ;
6840                     is_define = 1;
6841                     goto insert_if_check_paren;
6842                 }
6843                 else if (RExC_parse[0] == 'R') {
6844                     RExC_parse++;
6845                     parno = 0;
6846                     if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
6847                         parno = atoi(RExC_parse++);
6848                         while (isDIGIT(*RExC_parse))
6849                             RExC_parse++;
6850                     } else if (RExC_parse[0] == '&') {
6851                         SV *sv_dat;
6852                         RExC_parse++;
6853                         sv_dat = reg_scan_name(pRExC_state,
6854                             SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6855                         parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
6856                     }
6857                     ret = reganode(pRExC_state,INSUBP,parno); 
6858                     goto insert_if_check_paren;
6859                 }
6860                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
6861                     /* (?(1)...) */
6862                     char c;
6863                     parno = atoi(RExC_parse++);
6864
6865                     while (isDIGIT(*RExC_parse))
6866                         RExC_parse++;
6867                     ret = reganode(pRExC_state, GROUPP, parno);
6868
6869                  insert_if_check_paren:
6870                     if ((c = *nextchar(pRExC_state)) != ')')
6871                         vFAIL("Switch condition not recognized");
6872                   insert_if:
6873                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
6874                     br = regbranch(pRExC_state, &flags, 1,depth+1);
6875                     if (br == NULL)
6876                         br = reganode(pRExC_state, LONGJMP, 0);
6877                     else
6878                         REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
6879                     c = *nextchar(pRExC_state);
6880                     if (flags&HASWIDTH)
6881                         *flagp |= HASWIDTH;
6882                     if (c == '|') {
6883                         if (is_define) 
6884                             vFAIL("(?(DEFINE)....) does not allow branches");
6885                         lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
6886                         regbranch(pRExC_state, &flags, 1,depth+1);
6887                         REGTAIL(pRExC_state, ret, lastbr);
6888                         if (flags&HASWIDTH)
6889                             *flagp |= HASWIDTH;
6890                         c = *nextchar(pRExC_state);
6891                     }
6892                     else
6893                         lastbr = NULL;
6894                     if (c != ')')
6895                         vFAIL("Switch (?(condition)... contains too many branches");
6896                     ender = reg_node(pRExC_state, TAIL);
6897                     REGTAIL(pRExC_state, br, ender);
6898                     if (lastbr) {
6899                         REGTAIL(pRExC_state, lastbr, ender);
6900                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
6901                     }
6902                     else
6903                         REGTAIL(pRExC_state, ret, ender);
6904                     RExC_size++; /* XXX WHY do we need this?!!
6905                                     For large programs it seems to be required
6906                                     but I can't figure out why. -- dmq*/
6907                     return ret;
6908                 }
6909                 else {
6910                     vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
6911                 }
6912             }
6913             case 0:
6914                 RExC_parse--; /* for vFAIL to print correctly */
6915                 vFAIL("Sequence (? incomplete");
6916                 break;
6917             case DEFAULT_PAT_MOD:   /* Use default flags with the exceptions
6918                                        that follow */
6919                 has_use_defaults = TRUE;
6920                 STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
6921                 set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
6922                                                 ? REGEX_UNICODE_CHARSET
6923                                                 : REGEX_DEPENDS_CHARSET);
6924                 goto parse_flags;
6925             default:
6926                 --RExC_parse;
6927                 parse_flags:      /* (?i) */  
6928             {
6929                 U32 posflags = 0, negflags = 0;
6930                 U32 *flagsp = &posflags;
6931                 bool has_charset_modifier = 0;
6932                 regex_charset cs = REGEX_DEPENDS_CHARSET;
6933
6934                 while (*RExC_parse) {
6935                     /* && strchr("iogcmsx", *RExC_parse) */
6936                     /* (?g), (?gc) and (?o) are useless here
6937                        and must be globally applied -- japhy */
6938                     switch (*RExC_parse) {
6939                     CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
6940                     case LOCALE_PAT_MOD:
6941                         if (has_charset_modifier || flagsp == &negflags) {
6942                             goto fail_modifiers;
6943                         }
6944                         cs = REGEX_LOCALE_CHARSET;
6945                         has_charset_modifier = 1;
6946                         break;
6947                     case UNICODE_PAT_MOD:
6948                         if (has_charset_modifier || flagsp == &negflags) {
6949                             goto fail_modifiers;
6950                         }
6951                         cs = REGEX_UNICODE_CHARSET;
6952                         has_charset_modifier = 1;
6953                         break;
6954                     case ASCII_RESTRICT_PAT_MOD:
6955                         if (has_charset_modifier || flagsp == &negflags) {
6956                             goto fail_modifiers;
6957                         }
6958                         if (*(RExC_parse + 1) == ASCII_RESTRICT_PAT_MOD) {
6959                             /* Doubled modifier implies more restricted */
6960                             cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
6961                             RExC_parse++;
6962                         }
6963                         else {
6964                             cs = REGEX_ASCII_RESTRICTED_CHARSET;
6965                         }
6966                         has_charset_modifier = 1;
6967                         break;
6968                     case DEPENDS_PAT_MOD:
6969                         if (has_use_defaults
6970                             || has_charset_modifier
6971                             || flagsp == &negflags)
6972                         {
6973                             goto fail_modifiers;
6974                         }
6975
6976                         /* The dual charset means unicode semantics if the
6977                          * pattern (or target, not known until runtime) are
6978                          * utf8, or something in the pattern indicates unicode
6979                          * semantics */
6980                         cs = (RExC_utf8 || RExC_uni_semantics)
6981                              ? REGEX_UNICODE_CHARSET
6982                              : REGEX_DEPENDS_CHARSET;
6983                         has_charset_modifier = 1;
6984                         break;
6985                     case ONCE_PAT_MOD: /* 'o' */
6986                     case GLOBAL_PAT_MOD: /* 'g' */
6987                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
6988                             const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
6989                             if (! (wastedflags & wflagbit) ) {
6990                                 wastedflags |= wflagbit;
6991                                 vWARN5(
6992                                     RExC_parse + 1,
6993                                     "Useless (%s%c) - %suse /%c modifier",
6994                                     flagsp == &negflags ? "?-" : "?",
6995                                     *RExC_parse,
6996                                     flagsp == &negflags ? "don't " : "",
6997                                     *RExC_parse
6998                                 );
6999                             }
7000                         }
7001                         break;
7002                         
7003                     case CONTINUE_PAT_MOD: /* 'c' */
7004                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
7005                             if (! (wastedflags & WASTED_C) ) {
7006                                 wastedflags |= WASTED_GC;
7007                                 vWARN3(
7008                                     RExC_parse + 1,
7009                                     "Useless (%sc) - %suse /gc modifier",
7010                                     flagsp == &negflags ? "?-" : "?",
7011                                     flagsp == &negflags ? "don't " : ""
7012                                 );
7013                             }
7014                         }
7015                         break;
7016                     case KEEPCOPY_PAT_MOD: /* 'p' */
7017                         if (flagsp == &negflags) {
7018                             if (SIZE_ONLY)
7019                                 ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
7020                         } else {
7021                             *flagsp |= RXf_PMf_KEEPCOPY;
7022                         }
7023                         break;
7024                     case '-':
7025                         /* A flag is a default iff it is following a minus, so
7026                          * if there is a minus, it means will be trying to
7027                          * re-specify a default which is an error */
7028                         if (has_use_defaults || flagsp == &negflags) {
7029             fail_modifiers:
7030                             RExC_parse++;
7031                             vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7032                             /*NOTREACHED*/
7033                         }
7034                         flagsp = &negflags;
7035                         wastedflags = 0;  /* reset so (?g-c) warns twice */
7036                         break;
7037                     case ':':
7038                         paren = ':';
7039                         /*FALLTHROUGH*/
7040                     case ')':
7041                         RExC_flags |= posflags;
7042                         RExC_flags &= ~negflags;
7043                         set_regex_charset(&RExC_flags, cs);
7044                         if (paren != ':') {
7045                             oregflags |= posflags;
7046                             oregflags &= ~negflags;
7047                             set_regex_charset(&oregflags, cs);
7048                         }
7049                         nextchar(pRExC_state);
7050                         if (paren != ':') {
7051                             *flagp = TRYAGAIN;
7052                             return NULL;
7053                         } else {
7054                             ret = NULL;
7055                             goto parse_rest;
7056                         }
7057                         /*NOTREACHED*/
7058                     default:
7059                         RExC_parse++;
7060                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7061                         /*NOTREACHED*/
7062                     }                           
7063                     ++RExC_parse;
7064                 }
7065             }} /* one for the default block, one for the switch */
7066         }
7067         else {                  /* (...) */
7068           capturing_parens:
7069             parno = RExC_npar;
7070             RExC_npar++;
7071             
7072             ret = reganode(pRExC_state, OPEN, parno);
7073             if (!SIZE_ONLY ){
7074                 if (!RExC_nestroot) 
7075                     RExC_nestroot = parno;
7076                 if (RExC_seen & REG_SEEN_RECURSE
7077                     && !RExC_open_parens[parno-1])
7078                 {
7079                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
7080                         "Setting open paren #%"IVdf" to %d\n", 
7081                         (IV)parno, REG_NODE_NUM(ret)));
7082                     RExC_open_parens[parno-1]= ret;
7083                 }
7084             }
7085             Set_Node_Length(ret, 1); /* MJD */
7086             Set_Node_Offset(ret, RExC_parse); /* MJD */
7087             is_open = 1;
7088         }
7089     }
7090     else                        /* ! paren */
7091         ret = NULL;
7092    
7093    parse_rest:
7094     /* Pick up the branches, linking them together. */
7095     parse_start = RExC_parse;   /* MJD */
7096     br = regbranch(pRExC_state, &flags, 1,depth+1);
7097
7098     if (freeze_paren) {
7099         if (RExC_npar > after_freeze)
7100             after_freeze = RExC_npar;
7101         RExC_npar = freeze_paren;
7102     }
7103
7104     /*     branch_len = (paren != 0); */
7105
7106     if (br == NULL)
7107         return(NULL);
7108     if (*RExC_parse == '|') {
7109         if (!SIZE_ONLY && RExC_extralen) {
7110             reginsert(pRExC_state, BRANCHJ, br, depth+1);
7111         }
7112         else {                  /* MJD */
7113             reginsert(pRExC_state, BRANCH, br, depth+1);
7114             Set_Node_Length(br, paren != 0);
7115             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
7116         }
7117         have_branch = 1;
7118         if (SIZE_ONLY)
7119             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
7120     }
7121     else if (paren == ':') {
7122         *flagp |= flags&SIMPLE;
7123     }
7124     if (is_open) {                              /* Starts with OPEN. */
7125         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
7126     }
7127     else if (paren != '?')              /* Not Conditional */
7128         ret = br;
7129     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
7130     lastbr = br;
7131     while (*RExC_parse == '|') {
7132         if (!SIZE_ONLY && RExC_extralen) {
7133             ender = reganode(pRExC_state, LONGJMP,0);
7134             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
7135         }
7136         if (SIZE_ONLY)
7137             RExC_extralen += 2;         /* Account for LONGJMP. */
7138         nextchar(pRExC_state);
7139         if (freeze_paren) {
7140             if (RExC_npar > after_freeze)
7141                 after_freeze = RExC_npar;
7142             RExC_npar = freeze_paren;       
7143         }
7144         br = regbranch(pRExC_state, &flags, 0, depth+1);
7145
7146         if (br == NULL)
7147             return(NULL);
7148         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
7149         lastbr = br;
7150         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
7151     }
7152
7153     if (have_branch || paren != ':') {
7154         /* Make a closing node, and hook it on the end. */
7155         switch (paren) {
7156         case ':':
7157             ender = reg_node(pRExC_state, TAIL);
7158             break;
7159         case 1:
7160             ender = reganode(pRExC_state, CLOSE, parno);
7161             if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
7162                 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
7163                         "Setting close paren #%"IVdf" to %d\n", 
7164                         (IV)parno, REG_NODE_NUM(ender)));
7165                 RExC_close_parens[parno-1]= ender;
7166                 if (RExC_nestroot == parno) 
7167                     RExC_nestroot = 0;
7168             }       
7169             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
7170             Set_Node_Length(ender,1); /* MJD */
7171             break;
7172         case '<':
7173         case ',':
7174         case '=':
7175         case '!':
7176             *flagp &= ~HASWIDTH;
7177             /* FALL THROUGH */
7178         case '>':
7179             ender = reg_node(pRExC_state, SUCCEED);
7180             break;
7181         case 0:
7182             ender = reg_node(pRExC_state, END);
7183             if (!SIZE_ONLY) {
7184                 assert(!RExC_opend); /* there can only be one! */
7185                 RExC_opend = ender;
7186             }
7187             break;
7188         }
7189         REGTAIL(pRExC_state, lastbr, ender);
7190
7191         if (have_branch && !SIZE_ONLY) {
7192             if (depth==1)
7193                 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
7194
7195             /* Hook the tails of the branches to the closing node. */
7196             for (br = ret; br; br = regnext(br)) {
7197                 const U8 op = PL_regkind[OP(br)];
7198                 if (op == BRANCH) {
7199                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
7200                 }
7201                 else if (op == BRANCHJ) {
7202                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
7203                 }
7204             }
7205         }
7206     }
7207
7208     {
7209         const char *p;
7210         static const char parens[] = "=!<,>";
7211
7212         if (paren && (p = strchr(parens, paren))) {
7213             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
7214             int flag = (p - parens) > 1;
7215
7216             if (paren == '>')
7217                 node = SUSPEND, flag = 0;
7218             reginsert(pRExC_state, node,ret, depth+1);
7219             Set_Node_Cur_Length(ret);
7220             Set_Node_Offset(ret, parse_start + 1);
7221             ret->flags = flag;
7222             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
7223         }
7224     }
7225
7226     /* Check for proper termination. */
7227     if (paren) {
7228         RExC_flags = oregflags;
7229         if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
7230             RExC_parse = oregcomp_parse;
7231             vFAIL("Unmatched (");
7232         }
7233     }
7234     else if (!paren && RExC_parse < RExC_end) {
7235         if (*RExC_parse == ')') {
7236             RExC_parse++;
7237             vFAIL("Unmatched )");
7238         }
7239         else
7240             FAIL("Junk on end of regexp");      /* "Can't happen". */
7241         /* NOTREACHED */
7242     }
7243
7244     if (RExC_in_lookbehind) {
7245         RExC_in_lookbehind--;
7246     }
7247     if (after_freeze)
7248         RExC_npar = after_freeze;
7249     return(ret);
7250 }
7251
7252 /*
7253  - regbranch - one alternative of an | operator
7254  *
7255  * Implements the concatenation operator.
7256  */
7257 STATIC regnode *
7258 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
7259 {
7260     dVAR;
7261     register regnode *ret;
7262     register regnode *chain = NULL;
7263     register regnode *latest;
7264     I32 flags = 0, c = 0;
7265     GET_RE_DEBUG_FLAGS_DECL;
7266
7267     PERL_ARGS_ASSERT_REGBRANCH;
7268
7269     DEBUG_PARSE("brnc");
7270
7271     if (first)
7272         ret = NULL;
7273     else {
7274         if (!SIZE_ONLY && RExC_extralen)
7275             ret = reganode(pRExC_state, BRANCHJ,0);
7276         else {
7277             ret = reg_node(pRExC_state, BRANCH);
7278             Set_Node_Length(ret, 1);
7279         }
7280     }
7281         
7282     if (!first && SIZE_ONLY)
7283         RExC_extralen += 1;                     /* BRANCHJ */
7284
7285     *flagp = WORST;                     /* Tentatively. */
7286
7287     RExC_parse--;
7288     nextchar(pRExC_state);
7289     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
7290         flags &= ~TRYAGAIN;
7291         latest = regpiece(pRExC_state, &flags,depth+1);
7292         if (latest == NULL) {
7293             if (flags & TRYAGAIN)
7294                 continue;
7295             return(NULL);
7296         }
7297         else if (ret == NULL)
7298             ret = latest;
7299         *flagp |= flags&(HASWIDTH|POSTPONED);
7300         if (chain == NULL)      /* First piece. */
7301             *flagp |= flags&SPSTART;
7302         else {
7303             RExC_naughty++;
7304             REGTAIL(pRExC_state, chain, latest);
7305         }
7306         chain = latest;
7307         c++;
7308     }
7309     if (chain == NULL) {        /* Loop ran zero times. */
7310         chain = reg_node(pRExC_state, NOTHING);
7311         if (ret == NULL)
7312             ret = chain;
7313     }
7314     if (c == 1) {
7315         *flagp |= flags&SIMPLE;
7316     }
7317
7318     return ret;
7319 }
7320
7321 /*
7322  - regpiece - something followed by possible [*+?]
7323  *
7324  * Note that the branching code sequences used for ? and the general cases
7325  * of * and + are somewhat optimized:  they use the same NOTHING node as
7326  * both the endmarker for their branch list and the body of the last branch.
7327  * It might seem that this node could be dispensed with entirely, but the
7328  * endmarker role is not redundant.
7329  */
7330 STATIC regnode *
7331 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
7332 {
7333     dVAR;
7334     register regnode *ret;
7335     register char op;
7336     register char *next;
7337     I32 flags;
7338     const char * const origparse = RExC_parse;
7339     I32 min;
7340     I32 max = REG_INFTY;
7341     char *parse_start;
7342     const char *maxpos = NULL;
7343     GET_RE_DEBUG_FLAGS_DECL;
7344
7345     PERL_ARGS_ASSERT_REGPIECE;
7346
7347     DEBUG_PARSE("piec");
7348
7349     ret = regatom(pRExC_state, &flags,depth+1);
7350     if (ret == NULL) {
7351         if (flags & TRYAGAIN)
7352             *flagp |= TRYAGAIN;
7353         return(NULL);
7354     }
7355
7356     op = *RExC_parse;
7357
7358     if (op == '{' && regcurly(RExC_parse)) {
7359         maxpos = NULL;
7360         parse_start = RExC_parse; /* MJD */
7361         next = RExC_parse + 1;
7362         while (isDIGIT(*next) || *next == ',') {
7363             if (*next == ',') {
7364                 if (maxpos)
7365                     break;
7366                 else
7367                     maxpos = next;
7368             }
7369             next++;
7370         }
7371         if (*next == '}') {             /* got one */
7372             if (!maxpos)
7373                 maxpos = next;
7374             RExC_parse++;
7375             min = atoi(RExC_parse);
7376             if (*maxpos == ',')
7377                 maxpos++;
7378             else
7379                 maxpos = RExC_parse;
7380             max = atoi(maxpos);
7381             if (!max && *maxpos != '0')
7382                 max = REG_INFTY;                /* meaning "infinity" */
7383             else if (max >= REG_INFTY)
7384                 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
7385             RExC_parse = next;
7386             nextchar(pRExC_state);
7387
7388         do_curly:
7389             if ((flags&SIMPLE)) {
7390                 RExC_naughty += 2 + RExC_naughty / 2;
7391                 reginsert(pRExC_state, CURLY, ret, depth+1);
7392                 Set_Node_Offset(ret, parse_start+1); /* MJD */
7393                 Set_Node_Cur_Length(ret);
7394             }
7395             else {
7396                 regnode * const w = reg_node(pRExC_state, WHILEM);
7397
7398                 w->flags = 0;
7399                 REGTAIL(pRExC_state, ret, w);
7400                 if (!SIZE_ONLY && RExC_extralen) {
7401                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
7402                     reginsert(pRExC_state, NOTHING,ret, depth+1);
7403                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
7404                 }
7405                 reginsert(pRExC_state, CURLYX,ret, depth+1);
7406                                 /* MJD hk */
7407                 Set_Node_Offset(ret, parse_start+1);
7408                 Set_Node_Length(ret,
7409                                 op == '{' ? (RExC_parse - parse_start) : 1);
7410
7411                 if (!SIZE_ONLY && RExC_extralen)
7412                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
7413                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
7414                 if (SIZE_ONLY)
7415                     RExC_whilem_seen++, RExC_extralen += 3;
7416                 RExC_naughty += 4 + RExC_naughty;       /* compound interest */
7417             }
7418             ret->flags = 0;
7419
7420             if (min > 0)
7421                 *flagp = WORST;
7422             if (max > 0)
7423                 *flagp |= HASWIDTH;
7424             if (max < min)
7425                 vFAIL("Can't do {n,m} with n > m");
7426             if (!SIZE_ONLY) {
7427                 ARG1_SET(ret, (U16)min);
7428                 ARG2_SET(ret, (U16)max);
7429             }
7430
7431             goto nest_check;
7432         }
7433     }
7434
7435     if (!ISMULT1(op)) {
7436         *flagp = flags;
7437         return(ret);
7438     }
7439
7440 #if 0                           /* Now runtime fix should be reliable. */
7441
7442     /* if this is reinstated, don't forget to put this back into perldiag:
7443
7444             =item Regexp *+ operand could be empty at {#} in regex m/%s/
7445
7446            (F) The part of the regexp subject to either the * or + quantifier
7447            could match an empty string. The {#} shows in the regular
7448            expression about where the problem was discovered.
7449
7450     */
7451
7452     if (!(flags&HASWIDTH) && op != '?')
7453       vFAIL("Regexp *+ operand could be empty");
7454 #endif
7455
7456     parse_start = RExC_parse;
7457     nextchar(pRExC_state);
7458
7459     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
7460
7461     if (op == '*' && (flags&SIMPLE)) {
7462         reginsert(pRExC_state, STAR, ret, depth+1);
7463         ret->flags = 0;
7464         RExC_naughty += 4;
7465     }
7466     else if (op == '*') {
7467         min = 0;
7468         goto do_curly;
7469     }
7470     else if (op == '+' && (flags&SIMPLE)) {
7471         reginsert(pRExC_state, PLUS, ret, depth+1);
7472         ret->flags = 0;
7473         RExC_naughty += 3;
7474     }
7475     else if (op == '+') {
7476         min = 1;
7477         goto do_curly;
7478     }
7479     else if (op == '?') {
7480         min = 0; max = 1;
7481         goto do_curly;
7482     }
7483   nest_check:
7484     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
7485         ckWARN3reg(RExC_parse,
7486                    "%.*s matches null string many times",
7487                    (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
7488                    origparse);
7489     }
7490
7491     if (RExC_parse < RExC_end && *RExC_parse == '?') {
7492         nextchar(pRExC_state);
7493         reginsert(pRExC_state, MINMOD, ret, depth+1);
7494         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
7495     }
7496 #ifndef REG_ALLOW_MINMOD_SUSPEND
7497     else
7498 #endif
7499     if (RExC_parse < RExC_end && *RExC_parse == '+') {
7500         regnode *ender;
7501         nextchar(pRExC_state);
7502         ender = reg_node(pRExC_state, SUCCEED);
7503         REGTAIL(pRExC_state, ret, ender);
7504         reginsert(pRExC_state, SUSPEND, ret, depth+1);
7505         ret->flags = 0;
7506         ender = reg_node(pRExC_state, TAIL);
7507         REGTAIL(pRExC_state, ret, ender);
7508         /*ret= ender;*/
7509     }
7510
7511     if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
7512         RExC_parse++;
7513         vFAIL("Nested quantifiers");
7514     }
7515
7516     return(ret);
7517 }
7518
7519
7520 /* reg_namedseq(pRExC_state,UVp)
7521    
7522    This is expected to be called by a parser routine that has 
7523    recognized '\N' and needs to handle the rest. RExC_parse is
7524    expected to point at the first char following the N at the time
7525    of the call.
7526
7527    The \N may be inside (indicated by valuep not being NULL) or outside a
7528    character class.
7529
7530    \N may begin either a named sequence, or if outside a character class, mean
7531    to match a non-newline.  For non single-quoted regexes, the tokenizer has
7532    attempted to decide which, and in the case of a named sequence converted it
7533    into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...},
7534    where c1... are the characters in the sequence.  For single-quoted regexes,
7535    the tokenizer passes the \N sequence through unchanged; this code will not
7536    attempt to determine this nor expand those.  The net effect is that if the
7537    beginning of the passed-in pattern isn't '{U+' or there is no '}', it
7538    signals that this \N occurrence means to match a non-newline.
7539    
7540    Only the \N{U+...} form should occur in a character class, for the same
7541    reason that '.' inside a character class means to just match a period: it
7542    just doesn't make sense.
7543    
7544    If valuep is non-null then it is assumed that we are parsing inside 
7545    of a charclass definition and the first codepoint in the resolved
7546    string is returned via *valuep and the routine will return NULL. 
7547    In this mode if a multichar string is returned from the charnames 
7548    handler, a warning will be issued, and only the first char in the 
7549    sequence will be examined. If the string returned is zero length
7550    then the value of *valuep is undefined and NON-NULL will 
7551    be returned to indicate failure. (This will NOT be a valid pointer 
7552    to a regnode.)
7553    
7554    If valuep is null then it is assumed that we are parsing normal text and a
7555    new EXACT node is inserted into the program containing the resolved string,
7556    and a pointer to the new node is returned.  But if the string is zero length
7557    a NOTHING node is emitted instead.
7558
7559    On success RExC_parse is set to the char following the endbrace.
7560    Parsing failures will generate a fatal error via vFAIL(...)
7561  */
7562 STATIC regnode *
7563 S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep, I32 *flagp)
7564 {
7565     char * endbrace;    /* '}' following the name */
7566     regnode *ret = NULL;
7567 #ifdef DEBUGGING
7568     char* parse_start = RExC_parse - 2;     /* points to the '\N' */
7569 #endif
7570     char* p;
7571
7572     GET_RE_DEBUG_FLAGS_DECL;
7573  
7574     PERL_ARGS_ASSERT_REG_NAMEDSEQ;
7575
7576     GET_RE_DEBUG_FLAGS;
7577
7578     /* The [^\n] meaning of \N ignores spaces and comments under the /x
7579      * modifier.  The other meaning does not */
7580     p = (RExC_flags & RXf_PMf_EXTENDED)
7581         ? regwhite( pRExC_state, RExC_parse )
7582         : RExC_parse;
7583    
7584     /* Disambiguate between \N meaning a named character versus \N meaning
7585      * [^\n].  The former is assumed when it can't be the latter. */
7586     if (*p != '{' || regcurly(p)) {
7587         RExC_parse = p;
7588         if (valuep) {
7589             /* no bare \N in a charclass */
7590             vFAIL("\\N in a character class must be a named character: \\N{...}");
7591         }
7592         nextchar(pRExC_state);
7593         ret = reg_node(pRExC_state, REG_ANY);
7594         *flagp |= HASWIDTH|SIMPLE;
7595         RExC_naughty++;
7596         RExC_parse--;
7597         Set_Node_Length(ret, 1); /* MJD */
7598         return ret;
7599     }
7600
7601     /* Here, we have decided it should be a named sequence */
7602
7603     /* The test above made sure that the next real character is a '{', but
7604      * under the /x modifier, it could be separated by space (or a comment and
7605      * \n) and this is not allowed (for consistency with \x{...} and the
7606      * tokenizer handling of \N{NAME}). */
7607     if (*RExC_parse != '{') {
7608         vFAIL("Missing braces on \\N{}");
7609     }
7610
7611     RExC_parse++;       /* Skip past the '{' */
7612
7613     if (! (endbrace = strchr(RExC_parse, '}')) /* no trailing brace */
7614         || ! (endbrace == RExC_parse            /* nothing between the {} */
7615               || (endbrace - RExC_parse >= 2    /* U+ (bad hex is checked below */
7616                   && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg) */
7617     {
7618         if (endbrace) RExC_parse = endbrace;    /* position msg's '<--HERE' */
7619         vFAIL("\\N{NAME} must be resolved by the lexer");
7620     }
7621
7622     if (endbrace == RExC_parse) {   /* empty: \N{} */
7623         if (! valuep) {
7624             RExC_parse = endbrace + 1;  
7625             return reg_node(pRExC_state,NOTHING);
7626         }
7627
7628         if (SIZE_ONLY) {
7629             ckWARNreg(RExC_parse,
7630                     "Ignoring zero length \\N{} in character class"
7631             );
7632             RExC_parse = endbrace + 1;  
7633         }
7634         *valuep = 0;
7635         return (regnode *) &RExC_parse; /* Invalid regnode pointer */
7636     }
7637
7638     REQUIRE_UTF8;       /* named sequences imply Unicode semantics */
7639     RExC_parse += 2;    /* Skip past the 'U+' */
7640
7641     if (valuep) {   /* In a bracketed char class */
7642         /* We only pay attention to the first char of 
7643         multichar strings being returned. I kinda wonder
7644         if this makes sense as it does change the behaviour
7645         from earlier versions, OTOH that behaviour was broken
7646         as well. XXX Solution is to recharacterize as
7647         [rest-of-class]|multi1|multi2... */
7648
7649         STRLEN length_of_hex;
7650         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
7651             | PERL_SCAN_DISALLOW_PREFIX
7652             | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
7653     
7654         char * endchar = RExC_parse + strcspn(RExC_parse, ".}");
7655         if (endchar < endbrace) {
7656             ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
7657         }
7658
7659         length_of_hex = (STRLEN)(endchar - RExC_parse);
7660         *valuep = grok_hex(RExC_parse, &length_of_hex, &flags, NULL);
7661
7662         /* The tokenizer should have guaranteed validity, but it's possible to
7663          * bypass it by using single quoting, so check */
7664         if (length_of_hex == 0
7665             || length_of_hex != (STRLEN)(endchar - RExC_parse) )
7666         {
7667             RExC_parse += length_of_hex;        /* Includes all the valid */
7668             RExC_parse += (RExC_orig_utf8)      /* point to after 1st invalid */
7669                             ? UTF8SKIP(RExC_parse)
7670                             : 1;
7671             /* Guard against malformed utf8 */
7672             if (RExC_parse >= endchar) RExC_parse = endchar;
7673             vFAIL("Invalid hexadecimal number in \\N{U+...}");
7674         }    
7675
7676         RExC_parse = endbrace + 1;
7677         if (endchar == endbrace) return NULL;
7678
7679         ret = (regnode *) &RExC_parse;  /* Invalid regnode pointer */
7680     }
7681     else {      /* Not a char class */
7682         char *s;            /* String to put in generated EXACT node */
7683         STRLEN len = 0;     /* Its current byte length */
7684         char *endchar;      /* Points to '.' or '}' ending cur char in the input
7685                                stream */
7686         ret = reg_node(pRExC_state,
7687                            (U8) ((! FOLD) ? EXACT
7688                                           : (LOC)
7689                                              ? EXACTFL
7690                                              : (MORE_ASCII_RESTRICTED)
7691                                                ? EXACTFA
7692                                                : (AT_LEAST_UNI_SEMANTICS)
7693                                                  ? EXACTFU
7694                                                  : EXACTF));
7695         s= STRING(ret);
7696
7697         /* Exact nodes can hold only a U8 length's of text = 255.  Loop through
7698          * the input which is of the form now 'c1.c2.c3...}' until find the
7699          * ending brace or exceed length 255.  The characters that exceed this
7700          * limit are dropped.  The limit could be relaxed should it become
7701          * desirable by reparsing this as (?:\N{NAME}), so could generate
7702          * multiple EXACT nodes, as is done for just regular input.  But this
7703          * is primarily a named character, and not intended to be a huge long
7704          * string, so 255 bytes should be good enough */
7705         while (1) {
7706             STRLEN length_of_hex;
7707             I32 grok_flags = PERL_SCAN_ALLOW_UNDERSCORES
7708                             | PERL_SCAN_DISALLOW_PREFIX
7709                             | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
7710             UV cp;  /* Ord of current character */
7711             bool use_this_char_fold = FOLD;
7712
7713             /* Code points are separated by dots.  If none, there is only one
7714              * code point, and is terminated by the brace */
7715             endchar = RExC_parse + strcspn(RExC_parse, ".}");
7716
7717             /* The values are Unicode even on EBCDIC machines */
7718             length_of_hex = (STRLEN)(endchar - RExC_parse);
7719             cp = grok_hex(RExC_parse, &length_of_hex, &grok_flags, NULL);
7720             if ( length_of_hex == 0 
7721                 || length_of_hex != (STRLEN)(endchar - RExC_parse) )
7722             {
7723                 RExC_parse += length_of_hex;        /* Includes all the valid */
7724                 RExC_parse += (RExC_orig_utf8)  /* point to after 1st invalid */
7725                                 ? UTF8SKIP(RExC_parse)
7726                                 : 1;
7727                 /* Guard against malformed utf8 */
7728                 if (RExC_parse >= endchar) RExC_parse = endchar;
7729                 vFAIL("Invalid hexadecimal number in \\N{U+...}");
7730             }    
7731
7732             /* XXX ? Change to ANYOF node
7733             if (FOLD
7734                 && (cp > 255 || (! MORE_ASCII_RESTRICTED && ! LOC))
7735                 && is_TRICKYFOLD_cp(cp))
7736             {
7737             }
7738             */
7739
7740             /* Under /aa, we can't mix ASCII with non- in a fold.  If we are
7741              * folding, and the source isn't ASCII, look through all the
7742              * characters it folds to.  If any one of them is ASCII, forbid
7743              * this fold.  (cp is uni, so the 127 below is correct even for
7744              * EBCDIC).  Similarly under locale rules, we don't mix under 256
7745              * with above 255.  XXX It really doesn't make sense to have \N{}
7746              * which means a Unicode rules under locale.  I (khw) think this
7747              * should be warned about, but the counter argument is that people
7748              * who have programmed around Perl's earlier lack of specifying the
7749              * rules and used \N{} to force Unicode things in a local
7750              * environment shouldn't get suddenly a warning */
7751             if (use_this_char_fold) {
7752                 if (LOC && cp < 256) {  /* Fold not known until run-time */
7753                     use_this_char_fold = FALSE;
7754                 }
7755                 else if ((cp > 127 && MORE_ASCII_RESTRICTED)
7756                          || (cp > 255 && LOC))
7757                 {
7758                 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
7759                 U8* s = tmpbuf;
7760                 U8* e;
7761                 STRLEN foldlen;
7762
7763                 (void) toFOLD_uni(cp, tmpbuf, &foldlen);
7764                 e = s + foldlen;
7765
7766                 while (s < e) {
7767                     if (isASCII(*s)
7768                         || (LOC && (UTF8_IS_INVARIANT(*s)
7769                                     || UTF8_IS_DOWNGRADEABLE_START(*s))))
7770                     {
7771                         use_this_char_fold = FALSE;
7772                         break;
7773                     }
7774                     s += UTF8SKIP(s);
7775                 }
7776                 }
7777             }
7778
7779             if (! use_this_char_fold) { /* Not folding, just append to the
7780                                            string */
7781                 STRLEN unilen;
7782
7783                 /* Quit before adding this character if would exceed limit */
7784                 if (len + UNISKIP(cp) > U8_MAX) break;
7785
7786                 unilen = reguni(pRExC_state, cp, s);
7787                 if (unilen > 0) {
7788                     s   += unilen;
7789                     len += unilen;
7790                 }
7791             } else {    /* Folding, output the folded equivalent */
7792                 STRLEN foldlen,numlen;
7793                 U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
7794                 cp = toFOLD_uni(cp, tmpbuf, &foldlen);
7795
7796                 /* Quit before exceeding size limit */
7797                 if (len + foldlen > U8_MAX) break;
7798                 
7799                 for (foldbuf = tmpbuf;
7800                     foldlen;
7801                     foldlen -= numlen) 
7802                 {
7803                     cp = utf8_to_uvchr(foldbuf, &numlen);
7804                     if (numlen > 0) {
7805                         const STRLEN unilen = reguni(pRExC_state, cp, s);
7806                         s       += unilen;
7807                         len     += unilen;
7808                         /* In EBCDIC the numlen and unilen can differ. */
7809                         foldbuf += numlen;
7810                         if (numlen >= foldlen)
7811                             break;
7812                     }
7813                     else
7814                         break; /* "Can't happen." */
7815                 }                          
7816             }
7817
7818             /* Point to the beginning of the next character in the sequence. */
7819             RExC_parse = endchar + 1;
7820
7821             /* Quit if no more characters */
7822             if (RExC_parse >= endbrace) break;
7823         }
7824
7825
7826         if (SIZE_ONLY) {
7827             if (RExC_parse < endbrace) {
7828                 ckWARNreg(RExC_parse - 1,
7829                           "Using just the first characters returned by \\N{}");
7830             }
7831
7832             RExC_size += STR_SZ(len);
7833         } else {
7834             STR_LEN(ret) = len;
7835             RExC_emit += STR_SZ(len);
7836         }
7837
7838         RExC_parse = endbrace + 1;
7839
7840         *flagp |= HASWIDTH; /* Not SIMPLE, as that causes the engine to fail
7841                                with malformed in t/re/pat_advanced.t */
7842         RExC_parse --;
7843         Set_Node_Cur_Length(ret); /* MJD */
7844         nextchar(pRExC_state);
7845     }
7846
7847     return ret;
7848 }
7849
7850
7851 /*
7852  * reg_recode
7853  *
7854  * It returns the code point in utf8 for the value in *encp.
7855  *    value: a code value in the source encoding
7856  *    encp:  a pointer to an Encode object
7857  *
7858  * If the result from Encode is not a single character,
7859  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
7860  */
7861 STATIC UV
7862 S_reg_recode(pTHX_ const char value, SV **encp)
7863 {
7864     STRLEN numlen = 1;
7865     SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP);
7866     const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
7867     const STRLEN newlen = SvCUR(sv);
7868     UV uv = UNICODE_REPLACEMENT;
7869
7870     PERL_ARGS_ASSERT_REG_RECODE;
7871
7872     if (newlen)
7873         uv = SvUTF8(sv)
7874              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
7875              : *(U8*)s;
7876
7877     if (!newlen || numlen != newlen) {
7878         uv = UNICODE_REPLACEMENT;
7879         *encp = NULL;
7880     }
7881     return uv;
7882 }
7883
7884
7885 /*
7886  - regatom - the lowest level
7887
7888    Try to identify anything special at the start of the pattern. If there
7889    is, then handle it as required. This may involve generating a single regop,
7890    such as for an assertion; or it may involve recursing, such as to
7891    handle a () structure.
7892
7893    If the string doesn't start with something special then we gobble up
7894    as much literal text as we can.
7895
7896    Once we have been able to handle whatever type of thing started the
7897    sequence, we return.
7898
7899    Note: we have to be careful with escapes, as they can be both literal
7900    and special, and in the case of \10 and friends can either, depending
7901    on context. Specifically there are two separate switches for handling
7902    escape sequences, with the one for handling literal escapes requiring
7903    a dummy entry for all of the special escapes that are actually handled
7904    by the other.
7905 */
7906
7907 STATIC regnode *
7908 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
7909 {
7910     dVAR;
7911     register regnode *ret = NULL;
7912     I32 flags;
7913     char *parse_start = RExC_parse;
7914     U8 op;
7915     GET_RE_DEBUG_FLAGS_DECL;
7916     DEBUG_PARSE("atom");
7917     *flagp = WORST;             /* Tentatively. */
7918
7919     PERL_ARGS_ASSERT_REGATOM;
7920
7921 tryagain:
7922     switch ((U8)*RExC_parse) {
7923     case '^':
7924         RExC_seen_zerolen++;
7925         nextchar(pRExC_state);
7926         if (RExC_flags & RXf_PMf_MULTILINE)
7927             ret = reg_node(pRExC_state, MBOL);
7928         else if (RExC_flags & RXf_PMf_SINGLELINE)
7929             ret = reg_node(pRExC_state, SBOL);
7930         else
7931             ret = reg_node(pRExC_state, BOL);
7932         Set_Node_Length(ret, 1); /* MJD */
7933         break;
7934     case '$':
7935         nextchar(pRExC_state);
7936         if (*RExC_parse)
7937             RExC_seen_zerolen++;
7938         if (RExC_flags & RXf_PMf_MULTILINE)
7939             ret = reg_node(pRExC_state, MEOL);
7940         else if (RExC_flags & RXf_PMf_SINGLELINE)
7941             ret = reg_node(pRExC_state, SEOL);
7942         else
7943             ret = reg_node(pRExC_state, EOL);
7944         Set_Node_Length(ret, 1); /* MJD */
7945         break;
7946     case '.':
7947         nextchar(pRExC_state);
7948         if (RExC_flags & RXf_PMf_SINGLELINE)
7949             ret = reg_node(pRExC_state, SANY);
7950         else
7951             ret = reg_node(pRExC_state, REG_ANY);
7952         *flagp |= HASWIDTH|SIMPLE;
7953         RExC_naughty++;
7954         Set_Node_Length(ret, 1); /* MJD */
7955         break;
7956     case '[':
7957     {
7958         char * const oregcomp_parse = ++RExC_parse;
7959         ret = regclass(pRExC_state,depth+1);
7960         if (*RExC_parse != ']') {
7961             RExC_parse = oregcomp_parse;
7962             vFAIL("Unmatched [");
7963         }
7964         nextchar(pRExC_state);
7965         *flagp |= HASWIDTH|SIMPLE;
7966         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
7967         break;
7968     }
7969     case '(':
7970         nextchar(pRExC_state);
7971         ret = reg(pRExC_state, 1, &flags,depth+1);
7972         if (ret == NULL) {
7973                 if (flags & TRYAGAIN) {
7974                     if (RExC_parse == RExC_end) {
7975                          /* Make parent create an empty node if needed. */
7976                         *flagp |= TRYAGAIN;
7977                         return(NULL);
7978                     }
7979                     goto tryagain;
7980                 }
7981                 return(NULL);
7982         }
7983         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
7984         break;
7985     case '|':
7986     case ')':
7987         if (flags & TRYAGAIN) {
7988             *flagp |= TRYAGAIN;
7989             return NULL;
7990         }
7991         vFAIL("Internal urp");
7992                                 /* Supposed to be caught earlier. */
7993         break;
7994     case '{':
7995         if (!regcurly(RExC_parse)) {
7996             RExC_parse++;
7997             goto defchar;
7998         }
7999         /* FALL THROUGH */
8000     case '?':
8001     case '+':
8002     case '*':
8003         RExC_parse++;
8004         vFAIL("Quantifier follows nothing");
8005         break;
8006     case LATIN_SMALL_LETTER_SHARP_S:
8007     case UTF8_TWO_BYTE_HI_nocast(LATIN_SMALL_LETTER_SHARP_S):
8008     case UTF8_TWO_BYTE_HI_nocast(IOTA_D_T):
8009 #if UTF8_TWO_BYTE_HI_nocast(UPSILON_D_T) != UTF8_TWO_BYTE_HI_nocast(IOTA_D_T)
8010 #error The beginning utf8 byte of IOTA_D_T and UPSILON_D_T unexpectedly differ.  Other instances in this code should have the case statement below.
8011     case UTF8_TWO_BYTE_HI_nocast(UPSILON_D_T):
8012 #endif
8013         do_foldchar:
8014         if (!LOC && FOLD) {
8015             U32 len,cp;
8016             len=0; /* silence a spurious compiler warning */
8017             if ((cp = what_len_TRICKYFOLD_safe(RExC_parse,RExC_end,UTF,len))) {
8018                 *flagp |= HASWIDTH; /* could be SIMPLE too, but needs a handler in regexec.regrepeat */
8019                 RExC_parse+=len-1; /* we get one from nextchar() as well. :-( */
8020                 ret = reganode(pRExC_state, FOLDCHAR, cp);
8021                 Set_Node_Length(ret, 1); /* MJD */
8022                 nextchar(pRExC_state); /* kill whitespace under /x */
8023                 return ret;
8024             }
8025         }
8026         goto outer_default;
8027     case '\\':
8028         /* Special Escapes
8029
8030            This switch handles escape sequences that resolve to some kind
8031            of special regop and not to literal text. Escape sequnces that
8032            resolve to literal text are handled below in the switch marked
8033            "Literal Escapes".
8034
8035            Every entry in this switch *must* have a corresponding entry
8036            in the literal escape switch. However, the opposite is not
8037            required, as the default for this switch is to jump to the
8038            literal text handling code.
8039         */
8040         switch ((U8)*++RExC_parse) {
8041         case LATIN_SMALL_LETTER_SHARP_S:
8042         case UTF8_TWO_BYTE_HI_nocast(LATIN_SMALL_LETTER_SHARP_S):
8043         case UTF8_TWO_BYTE_HI_nocast(IOTA_D_T):
8044                    goto do_foldchar;        
8045         /* Special Escapes */
8046         case 'A':
8047             RExC_seen_zerolen++;
8048             ret = reg_node(pRExC_state, SBOL);
8049             *flagp |= SIMPLE;
8050             goto finish_meta_pat;
8051         case 'G':
8052             ret = reg_node(pRExC_state, GPOS);
8053             RExC_seen |= REG_SEEN_GPOS;
8054             *flagp |= SIMPLE;
8055             goto finish_meta_pat;
8056         case 'K':
8057             RExC_seen_zerolen++;
8058             ret = reg_node(pRExC_state, KEEPS);
8059             *flagp |= SIMPLE;
8060             /* XXX:dmq : disabling in-place substitution seems to
8061              * be necessary here to avoid cases of memory corruption, as
8062              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
8063              */
8064             RExC_seen |= REG_SEEN_LOOKBEHIND;
8065             goto finish_meta_pat;
8066         case 'Z':
8067             ret = reg_node(pRExC_state, SEOL);
8068             *flagp |= SIMPLE;
8069             RExC_seen_zerolen++;                /* Do not optimize RE away */
8070             goto finish_meta_pat;
8071         case 'z':
8072             ret = reg_node(pRExC_state, EOS);
8073             *flagp |= SIMPLE;
8074             RExC_seen_zerolen++;                /* Do not optimize RE away */
8075             goto finish_meta_pat;
8076         case 'C':
8077             ret = reg_node(pRExC_state, CANY);
8078             RExC_seen |= REG_SEEN_CANY;
8079             *flagp |= HASWIDTH|SIMPLE;
8080             goto finish_meta_pat;
8081         case 'X':
8082             ret = reg_node(pRExC_state, CLUMP);
8083             *flagp |= HASWIDTH;
8084             goto finish_meta_pat;
8085         case 'w':
8086             switch (get_regex_charset(RExC_flags)) {
8087                 case REGEX_LOCALE_CHARSET:
8088                     op = ALNUML;
8089                     break;
8090                 case REGEX_UNICODE_CHARSET:
8091                     op = ALNUMU;
8092                     break;
8093                 case REGEX_ASCII_RESTRICTED_CHARSET:
8094                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8095                     op = ALNUMA;
8096                     break;
8097                 case REGEX_DEPENDS_CHARSET:
8098                     op = ALNUM;
8099                     break;
8100                 default:
8101                     goto bad_charset;
8102             }
8103             ret = reg_node(pRExC_state, op);
8104             *flagp |= HASWIDTH|SIMPLE;
8105             goto finish_meta_pat;
8106         case 'W':
8107             switch (get_regex_charset(RExC_flags)) {
8108                 case REGEX_LOCALE_CHARSET:
8109                     op = NALNUML;
8110                     break;
8111                 case REGEX_UNICODE_CHARSET:
8112                     op = NALNUMU;
8113                     break;
8114                 case REGEX_ASCII_RESTRICTED_CHARSET:
8115                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8116                     op = NALNUMA;
8117                     break;
8118                 case REGEX_DEPENDS_CHARSET:
8119                     op = NALNUM;
8120                     break;
8121                 default:
8122                     goto bad_charset;
8123             }
8124             ret = reg_node(pRExC_state, op);
8125             *flagp |= HASWIDTH|SIMPLE;
8126             goto finish_meta_pat;
8127         case 'b':
8128             RExC_seen_zerolen++;
8129             RExC_seen |= REG_SEEN_LOOKBEHIND;
8130             switch (get_regex_charset(RExC_flags)) {
8131                 case REGEX_LOCALE_CHARSET:
8132                     op = BOUNDL;
8133                     break;
8134                 case REGEX_UNICODE_CHARSET:
8135                     op = BOUNDU;
8136                     break;
8137                 case REGEX_ASCII_RESTRICTED_CHARSET:
8138                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8139                     op = BOUNDA;
8140                     break;
8141                 case REGEX_DEPENDS_CHARSET:
8142                     op = BOUND;
8143                     break;
8144                 default:
8145                     goto bad_charset;
8146             }
8147             ret = reg_node(pRExC_state, op);
8148             FLAGS(ret) = get_regex_charset(RExC_flags);
8149             *flagp |= SIMPLE;
8150             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
8151                 ckWARNregdep(RExC_parse, "\"\\b{\" is deprecated; use \"\\b\\{\" instead");
8152             }
8153             goto finish_meta_pat;
8154         case 'B':
8155             RExC_seen_zerolen++;
8156             RExC_seen |= REG_SEEN_LOOKBEHIND;
8157             switch (get_regex_charset(RExC_flags)) {
8158                 case REGEX_LOCALE_CHARSET:
8159                     op = NBOUNDL;
8160                     break;
8161                 case REGEX_UNICODE_CHARSET:
8162                     op = NBOUNDU;
8163                     break;
8164                 case REGEX_ASCII_RESTRICTED_CHARSET:
8165                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8166                     op = NBOUNDA;
8167                     break;
8168                 case REGEX_DEPENDS_CHARSET:
8169                     op = NBOUND;
8170                     break;
8171                 default:
8172                     goto bad_charset;
8173             }
8174             ret = reg_node(pRExC_state, op);
8175             FLAGS(ret) = get_regex_charset(RExC_flags);
8176             *flagp |= SIMPLE;
8177             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
8178                 ckWARNregdep(RExC_parse, "\"\\B{\" is deprecated; use \"\\B\\{\" instead");
8179             }
8180             goto finish_meta_pat;
8181         case 's':
8182             switch (get_regex_charset(RExC_flags)) {
8183                 case REGEX_LOCALE_CHARSET:
8184                     op = SPACEL;
8185                     break;
8186                 case REGEX_UNICODE_CHARSET:
8187                     op = SPACEU;
8188                     break;
8189                 case REGEX_ASCII_RESTRICTED_CHARSET:
8190                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8191                     op = SPACEA;
8192                     break;
8193                 case REGEX_DEPENDS_CHARSET:
8194                     op = SPACE;
8195                     break;
8196                 default:
8197                     goto bad_charset;
8198             }
8199             ret = reg_node(pRExC_state, op);
8200             *flagp |= HASWIDTH|SIMPLE;
8201             goto finish_meta_pat;
8202         case 'S':
8203             switch (get_regex_charset(RExC_flags)) {
8204                 case REGEX_LOCALE_CHARSET:
8205                     op = NSPACEL;
8206                     break;
8207                 case REGEX_UNICODE_CHARSET:
8208                     op = NSPACEU;
8209                     break;
8210                 case REGEX_ASCII_RESTRICTED_CHARSET:
8211                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8212                     op = NSPACEA;
8213                     break;
8214                 case REGEX_DEPENDS_CHARSET:
8215                     op = NSPACE;
8216                     break;
8217                 default:
8218                     goto bad_charset;
8219             }
8220             ret = reg_node(pRExC_state, op);
8221             *flagp |= HASWIDTH|SIMPLE;
8222             goto finish_meta_pat;
8223         case 'd':
8224             switch (get_regex_charset(RExC_flags)) {
8225                 case REGEX_LOCALE_CHARSET:
8226                     op = DIGITL;
8227                     break;
8228                 case REGEX_ASCII_RESTRICTED_CHARSET:
8229                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8230                     op = DIGITA;
8231                     break;
8232                 case REGEX_DEPENDS_CHARSET: /* No difference between these */
8233                 case REGEX_UNICODE_CHARSET:
8234                     op = DIGIT;
8235                     break;
8236                 default:
8237                     goto bad_charset;
8238             }
8239             ret = reg_node(pRExC_state, op);
8240             *flagp |= HASWIDTH|SIMPLE;
8241             goto finish_meta_pat;
8242         case 'D':
8243             switch (get_regex_charset(RExC_flags)) {
8244                 case REGEX_LOCALE_CHARSET:
8245                     op = NDIGITL;
8246                     break;
8247                 case REGEX_ASCII_RESTRICTED_CHARSET:
8248                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8249                     op = NDIGITA;
8250                     break;
8251                 case REGEX_DEPENDS_CHARSET: /* No difference between these */
8252                 case REGEX_UNICODE_CHARSET:
8253                     op = NDIGIT;
8254                     break;
8255                 default:
8256                     goto bad_charset;
8257             }
8258             ret = reg_node(pRExC_state, op);
8259             *flagp |= HASWIDTH|SIMPLE;
8260             goto finish_meta_pat;
8261         case 'R':
8262             ret = reg_node(pRExC_state, LNBREAK);
8263             *flagp |= HASWIDTH|SIMPLE;
8264             goto finish_meta_pat;
8265         case 'h':
8266             ret = reg_node(pRExC_state, HORIZWS);
8267             *flagp |= HASWIDTH|SIMPLE;
8268             goto finish_meta_pat;
8269         case 'H':
8270             ret = reg_node(pRExC_state, NHORIZWS);
8271             *flagp |= HASWIDTH|SIMPLE;
8272             goto finish_meta_pat;
8273         case 'v':
8274             ret = reg_node(pRExC_state, VERTWS);
8275             *flagp |= HASWIDTH|SIMPLE;
8276             goto finish_meta_pat;
8277         case 'V':
8278             ret = reg_node(pRExC_state, NVERTWS);
8279             *flagp |= HASWIDTH|SIMPLE;
8280          finish_meta_pat:           
8281             nextchar(pRExC_state);
8282             Set_Node_Length(ret, 2); /* MJD */
8283             break;          
8284         case 'p':
8285         case 'P':
8286             {   
8287                 char* const oldregxend = RExC_end;
8288 #ifdef DEBUGGING
8289                 char* parse_start = RExC_parse - 2;
8290 #endif
8291
8292                 if (RExC_parse[1] == '{') {
8293                   /* a lovely hack--pretend we saw [\pX] instead */
8294                     RExC_end = strchr(RExC_parse, '}');
8295                     if (!RExC_end) {
8296                         const U8 c = (U8)*RExC_parse;
8297                         RExC_parse += 2;
8298                         RExC_end = oldregxend;
8299                         vFAIL2("Missing right brace on \\%c{}", c);
8300                     }
8301                     RExC_end++;
8302                 }
8303                 else {
8304                     RExC_end = RExC_parse + 2;
8305                     if (RExC_end > oldregxend)
8306                         RExC_end = oldregxend;
8307                 }
8308                 RExC_parse--;
8309
8310                 ret = regclass(pRExC_state,depth+1);
8311
8312                 RExC_end = oldregxend;
8313                 RExC_parse--;
8314
8315                 Set_Node_Offset(ret, parse_start + 2);
8316                 Set_Node_Cur_Length(ret);
8317                 nextchar(pRExC_state);
8318                 *flagp |= HASWIDTH|SIMPLE;
8319             }
8320             break;
8321         case 'N': 
8322             /* Handle \N and \N{NAME} here and not below because it can be
8323             multicharacter. join_exact() will join them up later on. 
8324             Also this makes sure that things like /\N{BLAH}+/ and 
8325             \N{BLAH} being multi char Just Happen. dmq*/
8326             ++RExC_parse;
8327             ret= reg_namedseq(pRExC_state, NULL, flagp); 
8328             break;
8329         case 'k':    /* Handle \k<NAME> and \k'NAME' */
8330         parse_named_seq:
8331         {   
8332             char ch= RExC_parse[1];         
8333             if (ch != '<' && ch != '\'' && ch != '{') {
8334                 RExC_parse++;
8335                 vFAIL2("Sequence %.2s... not terminated",parse_start);
8336             } else {
8337                 /* this pretty much dupes the code for (?P=...) in reg(), if
8338                    you change this make sure you change that */
8339                 char* name_start = (RExC_parse += 2);
8340                 U32 num = 0;
8341                 SV *sv_dat = reg_scan_name(pRExC_state,
8342                     SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8343                 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
8344                 if (RExC_parse == name_start || *RExC_parse != ch)
8345                     vFAIL2("Sequence %.3s... not terminated",parse_start);
8346
8347                 if (!SIZE_ONLY) {
8348                     num = add_data( pRExC_state, 1, "S" );
8349                     RExC_rxi->data->data[num]=(void*)sv_dat;
8350                     SvREFCNT_inc_simple_void(sv_dat);
8351                 }
8352
8353                 RExC_sawback = 1;
8354                 ret = reganode(pRExC_state,
8355                                ((! FOLD)
8356                                  ? NREF
8357                                  : (MORE_ASCII_RESTRICTED)
8358                                    ? NREFFA
8359                                    : (AT_LEAST_UNI_SEMANTICS)
8360                                      ? NREFFU
8361                                      : (LOC)
8362                                        ? NREFFL
8363                                        : NREFF),
8364                                 num);
8365                 *flagp |= HASWIDTH;
8366
8367                 /* override incorrect value set in reganode MJD */
8368                 Set_Node_Offset(ret, parse_start+1);
8369                 Set_Node_Cur_Length(ret); /* MJD */
8370                 nextchar(pRExC_state);
8371
8372             }
8373             break;
8374         }
8375         case 'g': 
8376         case '1': case '2': case '3': case '4':
8377         case '5': case '6': case '7': case '8': case '9':
8378             {
8379                 I32 num;
8380                 bool isg = *RExC_parse == 'g';
8381                 bool isrel = 0; 
8382                 bool hasbrace = 0;
8383                 if (isg) {
8384                     RExC_parse++;
8385                     if (*RExC_parse == '{') {
8386                         RExC_parse++;
8387                         hasbrace = 1;
8388                     }
8389                     if (*RExC_parse == '-') {
8390                         RExC_parse++;
8391                         isrel = 1;
8392                     }
8393                     if (hasbrace && !isDIGIT(*RExC_parse)) {
8394                         if (isrel) RExC_parse--;
8395                         RExC_parse -= 2;                            
8396                         goto parse_named_seq;
8397                 }   }
8398                 num = atoi(RExC_parse);
8399                 if (isg && num == 0)
8400                     vFAIL("Reference to invalid group 0");
8401                 if (isrel) {
8402                     num = RExC_npar - num;
8403                     if (num < 1)
8404                         vFAIL("Reference to nonexistent or unclosed group");
8405                 }
8406                 if (!isg && num > 9 && num >= RExC_npar)
8407                     goto defchar;
8408                 else {
8409                     char * const parse_start = RExC_parse - 1; /* MJD */
8410                     while (isDIGIT(*RExC_parse))
8411                         RExC_parse++;
8412                     if (parse_start == RExC_parse - 1) 
8413                         vFAIL("Unterminated \\g... pattern");
8414                     if (hasbrace) {
8415                         if (*RExC_parse != '}') 
8416                             vFAIL("Unterminated \\g{...} pattern");
8417                         RExC_parse++;
8418                     }    
8419                     if (!SIZE_ONLY) {
8420                         if (num > (I32)RExC_rx->nparens)
8421                             vFAIL("Reference to nonexistent group");
8422                     }
8423                     RExC_sawback = 1;
8424                     ret = reganode(pRExC_state,
8425                                    ((! FOLD)
8426                                      ? REF
8427                                      : (MORE_ASCII_RESTRICTED)
8428                                        ? REFFA
8429                                        : (AT_LEAST_UNI_SEMANTICS)
8430                                          ? REFFU
8431                                          : (LOC)
8432                                            ? REFFL
8433                                            : REFF),
8434                                     num);
8435                     *flagp |= HASWIDTH;
8436
8437                     /* override incorrect value set in reganode MJD */
8438                     Set_Node_Offset(ret, parse_start+1);
8439                     Set_Node_Cur_Length(ret); /* MJD */
8440                     RExC_parse--;
8441                     nextchar(pRExC_state);
8442                 }
8443             }
8444             break;
8445         case '\0':
8446             if (RExC_parse >= RExC_end)
8447                 FAIL("Trailing \\");
8448             /* FALL THROUGH */
8449         default:
8450             /* Do not generate "unrecognized" warnings here, we fall
8451                back into the quick-grab loop below */
8452             parse_start--;
8453             goto defchar;
8454         }
8455         break;
8456
8457     case '#':
8458         if (RExC_flags & RXf_PMf_EXTENDED) {
8459             if ( reg_skipcomment( pRExC_state ) )
8460                 goto tryagain;
8461         }
8462         /* FALL THROUGH */
8463
8464     default:
8465         outer_default:{
8466             register STRLEN len;
8467             register UV ender;
8468             register char *p;
8469             char *s;
8470             STRLEN foldlen;
8471             U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
8472             regnode * orig_emit;
8473
8474             parse_start = RExC_parse - 1;
8475
8476             RExC_parse++;
8477
8478         defchar:
8479             ender = 0;
8480             orig_emit = RExC_emit; /* Save the original output node position in
8481                                       case we need to output a different node
8482                                       type */
8483             ret = reg_node(pRExC_state,
8484                            (U8) ((! FOLD) ? EXACT
8485                                           : (LOC)
8486                                              ? EXACTFL
8487                                              : (MORE_ASCII_RESTRICTED)
8488                                                ? EXACTFA
8489                                                : (AT_LEAST_UNI_SEMANTICS)
8490                                                  ? EXACTFU
8491                                                  : EXACTF)
8492                     );
8493             s = STRING(ret);
8494             for (len = 0, p = RExC_parse - 1;
8495               len < 127 && p < RExC_end;
8496               len++)
8497             {
8498                 char * const oldp = p;
8499
8500                 if (RExC_flags & RXf_PMf_EXTENDED)
8501                     p = regwhite( pRExC_state, p );
8502                 switch ((U8)*p) {
8503                 case LATIN_SMALL_LETTER_SHARP_S:
8504                 case UTF8_TWO_BYTE_HI_nocast(LATIN_SMALL_LETTER_SHARP_S):
8505                 case UTF8_TWO_BYTE_HI_nocast(IOTA_D_T):
8506                            if (LOC || !FOLD || !is_TRICKYFOLD_safe(p,RExC_end,UTF))
8507                                 goto normal_default;
8508                 case '^':
8509                 case '$':
8510                 case '.':
8511                 case '[':
8512                 case '(':
8513                 case ')':
8514                 case '|':
8515                     goto loopdone;
8516                 case '\\':
8517                     /* Literal Escapes Switch
8518
8519                        This switch is meant to handle escape sequences that
8520                        resolve to a literal character.
8521
8522                        Every escape sequence that represents something
8523                        else, like an assertion or a char class, is handled
8524                        in the switch marked 'Special Escapes' above in this
8525                        routine, but also has an entry here as anything that
8526                        isn't explicitly mentioned here will be treated as
8527                        an unescaped equivalent literal.
8528                     */
8529
8530                     switch ((U8)*++p) {
8531                     /* These are all the special escapes. */
8532                     case LATIN_SMALL_LETTER_SHARP_S:
8533                     case UTF8_TWO_BYTE_HI_nocast(LATIN_SMALL_LETTER_SHARP_S):
8534                     case UTF8_TWO_BYTE_HI_nocast(IOTA_D_T):
8535                            if (LOC || !FOLD || !is_TRICKYFOLD_safe(p,RExC_end,UTF))
8536                                 goto normal_default;                
8537                     case 'A':             /* Start assertion */
8538                     case 'b': case 'B':   /* Word-boundary assertion*/
8539                     case 'C':             /* Single char !DANGEROUS! */
8540                     case 'd': case 'D':   /* digit class */
8541                     case 'g': case 'G':   /* generic-backref, pos assertion */
8542                     case 'h': case 'H':   /* HORIZWS */
8543                     case 'k': case 'K':   /* named backref, keep marker */
8544                     case 'N':             /* named char sequence */
8545                     case 'p': case 'P':   /* Unicode property */
8546                               case 'R':   /* LNBREAK */
8547                     case 's': case 'S':   /* space class */
8548                     case 'v': case 'V':   /* VERTWS */
8549                     case 'w': case 'W':   /* word class */
8550                     case 'X':             /* eXtended Unicode "combining character sequence" */
8551                     case 'z': case 'Z':   /* End of line/string assertion */
8552                         --p;
8553                         goto loopdone;
8554
8555                     /* Anything after here is an escape that resolves to a
8556                        literal. (Except digits, which may or may not)
8557                      */
8558                     case 'n':
8559                         ender = '\n';
8560                         p++;
8561                         break;
8562                     case 'r':
8563                         ender = '\r';
8564                         p++;
8565                         break;
8566                     case 't':
8567                         ender = '\t';
8568                         p++;
8569                         break;
8570                     case 'f':
8571                         ender = '\f';
8572                         p++;
8573                         break;
8574                     case 'e':
8575                           ender = ASCII_TO_NATIVE('\033');
8576                         p++;
8577                         break;
8578                     case 'a':
8579                           ender = ASCII_TO_NATIVE('\007');
8580                         p++;
8581                         break;
8582                     case 'o':
8583                         {
8584                             STRLEN brace_len = len;
8585                             UV result;
8586                             const char* error_msg;
8587
8588                             bool valid = grok_bslash_o(p,
8589                                                        &result,
8590                                                        &brace_len,
8591                                                        &error_msg,
8592                                                        1);
8593                             p += brace_len;
8594                             if (! valid) {
8595                                 RExC_parse = p; /* going to die anyway; point
8596                                                    to exact spot of failure */
8597                                 vFAIL(error_msg);
8598                             }
8599                             else
8600                             {
8601                                 ender = result;
8602                             }
8603                             if (PL_encoding && ender < 0x100) {
8604                                 goto recode_encoding;
8605                             }
8606                             if (ender > 0xff) {
8607                                 REQUIRE_UTF8;
8608                             }
8609                             break;
8610                         }
8611                     case 'x':
8612                         if (*++p == '{') {
8613                             char* const e = strchr(p, '}');
8614         
8615                             if (!e) {
8616                                 RExC_parse = p + 1;
8617                                 vFAIL("Missing right brace on \\x{}");
8618                             }
8619                             else {
8620                                 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
8621                                     | PERL_SCAN_DISALLOW_PREFIX;
8622                                 STRLEN numlen = e - p - 1;
8623                                 ender = grok_hex(p + 1, &numlen, &flags, NULL);
8624                                 if (ender > 0xff)
8625                                     REQUIRE_UTF8;
8626                                 p = e + 1;
8627                             }
8628                         }
8629                         else {
8630                             I32 flags = PERL_SCAN_DISALLOW_PREFIX;
8631                             STRLEN numlen = 2;
8632                             ender = grok_hex(p, &numlen, &flags, NULL);
8633                             p += numlen;
8634                         }
8635                         if (PL_encoding && ender < 0x100)
8636                             goto recode_encoding;
8637                         break;
8638                     case 'c':
8639                         p++;
8640                         ender = grok_bslash_c(*p++, UTF, SIZE_ONLY);
8641                         break;
8642                     case '0': case '1': case '2': case '3':case '4':
8643                     case '5': case '6': case '7': case '8':case '9':
8644                         if (*p == '0' ||
8645                             (isDIGIT(p[1]) && atoi(p) >= RExC_npar))
8646                         {
8647                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
8648                             STRLEN numlen = 3;
8649                             ender = grok_oct(p, &numlen, &flags, NULL);
8650                             if (ender > 0xff) {
8651                                 REQUIRE_UTF8;
8652                             }
8653                             p += numlen;
8654                         }
8655                         else {
8656                             --p;
8657                             goto loopdone;
8658                         }
8659                         if (PL_encoding && ender < 0x100)
8660                             goto recode_encoding;
8661                         break;
8662                     recode_encoding:
8663                         {
8664                             SV* enc = PL_encoding;
8665                             ender = reg_recode((const char)(U8)ender, &enc);
8666                             if (!enc && SIZE_ONLY)
8667                                 ckWARNreg(p, "Invalid escape in the specified encoding");
8668                             REQUIRE_UTF8;
8669                         }
8670                         break;
8671                     case '\0':
8672                         if (p >= RExC_end)
8673                             FAIL("Trailing \\");
8674                         /* FALL THROUGH */
8675                     default:
8676                         if (!SIZE_ONLY&& isALPHA(*p)) {
8677                             /* Include any { following the alpha to emphasize
8678                              * that it could be part of an escape at some point
8679                              * in the future */
8680                             int len = (*(p + 1) == '{') ? 2 : 1;
8681                             ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
8682                         }
8683                         goto normal_default;
8684                     }
8685                     break;
8686                 default:
8687                   normal_default:
8688                     if (UTF8_IS_START(*p) && UTF) {
8689                         STRLEN numlen;
8690                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
8691                                                &numlen, UTF8_ALLOW_DEFAULT);
8692                         p += numlen;
8693                     }
8694                     else
8695                         ender = (U8) *p++;
8696                     break;
8697                 } /* End of switch on the literal */
8698
8699                 /* Certain characters are problematic because their folded
8700                  * length is so different from their original length that it
8701                  * isn't handleable by the optimizer.  They are therefore not
8702                  * placed in an EXACTish node; and are here handled specially.
8703                  * (Even if the optimizer handled LATIN_SMALL_LETTER_SHARP_S,
8704                  * putting it in a special node keeps regexec from having to
8705                  * deal with a non-utf8 multi-char fold */
8706                 if (FOLD
8707                     && (ender > 255 || (! MORE_ASCII_RESTRICTED && ! LOC))
8708                     && is_TRICKYFOLD_cp(ender))
8709                 {
8710                     /* If is in middle of outputting characters into an
8711                      * EXACTish node, go output what we have so far, and
8712                      * position the parse so that this will be called again
8713                      * immediately */
8714                     if (len) {
8715                         p  = RExC_parse + len - 1;
8716                         goto loopdone;
8717                     }
8718                     else {
8719
8720                         /* Here we are ready to output our tricky fold
8721                          * character.  What's done is to pretend it's in a
8722                          * [bracketed] class, and let the code that deals with
8723                          * those handle it, as that code has all the
8724                          * intelligence necessary.  First save the current
8725                          * parse state, get rid of the already allocated EXACT
8726                          * node that the ANYOFV node will replace, and point
8727                          * the parse to a buffer which we fill with the
8728                          * character we want the regclass code to think is
8729                          * being parsed */
8730                         char* const oldregxend = RExC_end;
8731                         char tmpbuf[2];
8732                         RExC_emit = orig_emit;
8733                         RExC_parse = tmpbuf;
8734                         if (UTF) {
8735                             tmpbuf[0] = UTF8_TWO_BYTE_HI(ender);
8736                             tmpbuf[1] = UTF8_TWO_BYTE_LO(ender);
8737                             RExC_end = RExC_parse + 2;
8738                         }
8739                         else {
8740                             tmpbuf[0] = (char) ender;
8741                             RExC_end = RExC_parse + 1;
8742                         }
8743
8744                         ret = regclass(pRExC_state,depth+1);
8745
8746                         /* Here, have parsed the buffer.  Reset the parse to
8747                          * the actual input, and return */
8748                         RExC_end = oldregxend;
8749                         RExC_parse = p - 1;
8750
8751                         Set_Node_Offset(ret, RExC_parse);
8752                         Set_Node_Cur_Length(ret);
8753                         nextchar(pRExC_state);
8754                         *flagp |= HASWIDTH|SIMPLE;
8755                         return ret;
8756                     }
8757                 }
8758
8759                 if ( RExC_flags & RXf_PMf_EXTENDED)
8760                     p = regwhite( pRExC_state, p );
8761                 if (UTF && FOLD) {
8762                     /* Prime the casefolded buffer.  Locale rules, which apply
8763                      * only to code points < 256, aren't known until execution,
8764                      * so for them, just output the original character using
8765                      * utf8 */
8766                     if (LOC && ender < 256) {
8767                         if (UNI_IS_INVARIANT(ender)) {
8768                             *tmpbuf = (U8) ender;
8769                             foldlen = 1;
8770                         } else {
8771                             *tmpbuf = UTF8_TWO_BYTE_HI(ender);
8772                             *(tmpbuf + 1) = UTF8_TWO_BYTE_LO(ender);
8773                             foldlen = 2;
8774                         }
8775                     }
8776                     else if (isASCII(ender)) {  /* Note: Here can't also be LOC
8777                                                  */
8778                         ender = toLOWER(ender);
8779                         *tmpbuf = (U8) ender;
8780                         foldlen = 1;
8781                     }
8782                     else if (! MORE_ASCII_RESTRICTED && ! LOC) {
8783
8784                         /* Locale and /aa require more selectivity about the
8785                          * fold, so are handled below.  Otherwise, here, just
8786                          * use the fold */
8787                         ender = toFOLD_uni(ender, tmpbuf, &foldlen);
8788                     }
8789                     else {
8790                         /* Under locale rules or /aa we are not to mix,
8791                          * respectively, ords < 256 or ASCII with non-.  So
8792                          * reject folds that mix them, using only the
8793                          * non-folded code point.  So do the fold to a
8794                          * temporary, and inspect each character in it. */
8795                         U8 trialbuf[UTF8_MAXBYTES_CASE+1];
8796                         U8* s = trialbuf;
8797                         UV tmpender = toFOLD_uni(ender, trialbuf, &foldlen);
8798                         U8* e = s + foldlen;
8799                         bool fold_ok = TRUE;
8800
8801                         while (s < e) {
8802                             if (isASCII(*s)
8803                                 || (LOC && (UTF8_IS_INVARIANT(*s)
8804                                            || UTF8_IS_DOWNGRADEABLE_START(*s))))
8805                             {
8806                                 fold_ok = FALSE;
8807                                 break;
8808                             }
8809                             s += UTF8SKIP(s);
8810                         }
8811                         if (fold_ok) {
8812                             Copy(trialbuf, tmpbuf, foldlen, U8);
8813                             ender = tmpender;
8814                         }
8815                         else {
8816                             uvuni_to_utf8(tmpbuf, ender);
8817                             foldlen = UNISKIP(ender);
8818                         }
8819                     }
8820                 }
8821                 if (p < RExC_end && ISMULT2(p)) { /* Back off on ?+*. */
8822                     if (len)
8823                         p = oldp;
8824                     else if (UTF) {
8825                          if (FOLD) {
8826                               /* Emit all the Unicode characters. */
8827                               STRLEN numlen;
8828                               for (foldbuf = tmpbuf;
8829                                    foldlen;
8830                                    foldlen -= numlen) {
8831                                    ender = utf8_to_uvchr(foldbuf, &numlen);
8832                                    if (numlen > 0) {
8833                                         const STRLEN unilen = reguni(pRExC_state, ender, s);
8834                                         s       += unilen;
8835                                         len     += unilen;
8836                                         /* In EBCDIC the numlen
8837                                          * and unilen can differ. */
8838                                         foldbuf += numlen;
8839                                         if (numlen >= foldlen)
8840                                              break;
8841                                    }
8842                                    else
8843                                         break; /* "Can't happen." */
8844                               }
8845                          }
8846                          else {
8847                               const STRLEN unilen = reguni(pRExC_state, ender, s);
8848                               if (unilen > 0) {
8849                                    s   += unilen;
8850                                    len += unilen;
8851                               }
8852                          }
8853                     }
8854                     else {
8855                         len++;
8856                         REGC((char)ender, s++);
8857                     }
8858                     break;
8859                 }
8860                 if (UTF) {
8861                      if (FOLD) {
8862                           /* Emit all the Unicode characters. */
8863                           STRLEN numlen;
8864                           for (foldbuf = tmpbuf;
8865                                foldlen;
8866                                foldlen -= numlen) {
8867                                ender = utf8_to_uvchr(foldbuf, &numlen);
8868                                if (numlen > 0) {
8869                                     const STRLEN unilen = reguni(pRExC_state, ender, s);
8870                                     len     += unilen;
8871                                     s       += unilen;
8872                                     /* In EBCDIC the numlen
8873                                      * and unilen can differ. */
8874                                     foldbuf += numlen;
8875                                     if (numlen >= foldlen)
8876                                          break;
8877                                }
8878                                else
8879                                     break;
8880                           }
8881                      }
8882                      else {
8883                           const STRLEN unilen = reguni(pRExC_state, ender, s);
8884                           if (unilen > 0) {
8885                                s   += unilen;
8886                                len += unilen;
8887                           }
8888                      }
8889                      len--;
8890                 }
8891                 else
8892                     REGC((char)ender, s++);
8893             }
8894         loopdone:   /* Jumped to when encounters something that shouldn't be in
8895                        the node */
8896             RExC_parse = p - 1;
8897             Set_Node_Cur_Length(ret); /* MJD */
8898             nextchar(pRExC_state);
8899             {
8900                 /* len is STRLEN which is unsigned, need to copy to signed */
8901                 IV iv = len;
8902                 if (iv < 0)
8903                     vFAIL("Internal disaster");
8904             }
8905             if (len > 0)
8906                 *flagp |= HASWIDTH;
8907             if (len == 1 && UNI_IS_INVARIANT(ender))
8908                 *flagp |= SIMPLE;
8909                 
8910             if (SIZE_ONLY)
8911                 RExC_size += STR_SZ(len);
8912             else {
8913                 STR_LEN(ret) = len;
8914                 RExC_emit += STR_SZ(len);
8915             }
8916         }
8917         break;
8918     }
8919
8920     return(ret);
8921
8922 /* Jumped to when an unrecognized character set is encountered */
8923 bad_charset:
8924     Perl_croak(aTHX_ "panic: Unknown regex character set encoding: %u", get_regex_charset(RExC_flags));
8925     return(NULL);
8926 }
8927
8928 STATIC char *
8929 S_regwhite( RExC_state_t *pRExC_state, char *p )
8930 {
8931     const char *e = RExC_end;
8932
8933     PERL_ARGS_ASSERT_REGWHITE;
8934
8935     while (p < e) {
8936         if (isSPACE(*p))
8937             ++p;
8938         else if (*p == '#') {
8939             bool ended = 0;
8940             do {
8941                 if (*p++ == '\n') {
8942                     ended = 1;
8943                     break;
8944                 }
8945             } while (p < e);
8946             if (!ended)
8947                 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
8948         }
8949         else
8950             break;
8951     }
8952     return p;
8953 }
8954
8955 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
8956    Character classes ([:foo:]) can also be negated ([:^foo:]).
8957    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
8958    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
8959    but trigger failures because they are currently unimplemented. */
8960
8961 #define POSIXCC_DONE(c)   ((c) == ':')
8962 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
8963 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
8964
8965 STATIC I32
8966 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
8967 {
8968     dVAR;
8969     I32 namedclass = OOB_NAMEDCLASS;
8970
8971     PERL_ARGS_ASSERT_REGPPOSIXCC;
8972
8973     if (value == '[' && RExC_parse + 1 < RExC_end &&
8974         /* I smell either [: or [= or [. -- POSIX has been here, right? */
8975         POSIXCC(UCHARAT(RExC_parse))) {
8976         const char c = UCHARAT(RExC_parse);
8977         char* const s = RExC_parse++;
8978         
8979         while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
8980             RExC_parse++;
8981         if (RExC_parse == RExC_end)
8982             /* Grandfather lone [:, [=, [. */
8983             RExC_parse = s;
8984         else {
8985             const char* const t = RExC_parse++; /* skip over the c */
8986             assert(*t == c);
8987
8988             if (UCHARAT(RExC_parse) == ']') {
8989                 const char *posixcc = s + 1;
8990                 RExC_parse++; /* skip over the ending ] */
8991
8992                 if (*s == ':') {
8993                     const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
8994                     const I32 skip = t - posixcc;
8995
8996                     /* Initially switch on the length of the name.  */
8997                     switch (skip) {
8998                     case 4:
8999                         if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
9000                             namedclass = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
9001                         break;
9002                     case 5:
9003                         /* Names all of length 5.  */
9004                         /* alnum alpha ascii blank cntrl digit graph lower
9005                            print punct space upper  */
9006                         /* Offset 4 gives the best switch position.  */
9007                         switch (posixcc[4]) {
9008                         case 'a':
9009                             if (memEQ(posixcc, "alph", 4)) /* alpha */
9010                                 namedclass = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
9011                             break;
9012                         case 'e':
9013                             if (memEQ(posixcc, "spac", 4)) /* space */
9014                                 namedclass = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
9015                             break;
9016                         case 'h':
9017                             if (memEQ(posixcc, "grap", 4)) /* graph */
9018                                 namedclass = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
9019                             break;
9020                         case 'i':
9021                             if (memEQ(posixcc, "asci", 4)) /* ascii */
9022                                 namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII;
9023                             break;
9024                         case 'k':
9025                             if (memEQ(posixcc, "blan", 4)) /* blank */
9026                                 namedclass = complement ? ANYOF_NBLANK : ANYOF_BLANK;
9027                             break;
9028                         case 'l':
9029                             if (memEQ(posixcc, "cntr", 4)) /* cntrl */
9030                                 namedclass = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
9031                             break;
9032                         case 'm':
9033                             if (memEQ(posixcc, "alnu", 4)) /* alnum */
9034                                 namedclass = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
9035                             break;
9036                         case 'r':
9037                             if (memEQ(posixcc, "lowe", 4)) /* lower */
9038                                 namedclass = complement ? ANYOF_NLOWER : ANYOF_LOWER;
9039                             else if (memEQ(posixcc, "uppe", 4)) /* upper */
9040                                 namedclass = complement ? ANYOF_NUPPER : ANYOF_UPPER;
9041                             break;
9042                         case 't':
9043                             if (memEQ(posixcc, "digi", 4)) /* digit */
9044                                 namedclass = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
9045                             else if (memEQ(posixcc, "prin", 4)) /* print */
9046                                 namedclass = complement ? ANYOF_NPRINT : ANYOF_PRINT;
9047                             else if (memEQ(posixcc, "punc", 4)) /* punct */
9048                                 namedclass = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
9049                             break;
9050                         }
9051                         break;
9052                     case 6:
9053                         if (memEQ(posixcc, "xdigit", 6))
9054                             namedclass = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
9055                         break;
9056                     }
9057
9058                     if (namedclass == OOB_NAMEDCLASS)
9059                         Simple_vFAIL3("POSIX class [:%.*s:] unknown",
9060                                       t - s - 1, s + 1);
9061                     assert (posixcc[skip] == ':');
9062                     assert (posixcc[skip+1] == ']');
9063                 } else if (!SIZE_ONLY) {
9064                     /* [[=foo=]] and [[.foo.]] are still future. */
9065
9066                     /* adjust RExC_parse so the warning shows after
9067                        the class closes */
9068                     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
9069                         RExC_parse++;
9070                     Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
9071                 }
9072             } else {
9073                 /* Maternal grandfather:
9074                  * "[:" ending in ":" but not in ":]" */
9075                 RExC_parse = s;
9076             }
9077         }
9078     }
9079
9080     return namedclass;
9081 }
9082
9083 STATIC void
9084 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
9085 {
9086     dVAR;
9087
9088     PERL_ARGS_ASSERT_CHECKPOSIXCC;
9089
9090     if (POSIXCC(UCHARAT(RExC_parse))) {
9091         const char *s = RExC_parse;
9092         const char  c = *s++;
9093
9094         while (isALNUM(*s))
9095             s++;
9096         if (*s && c == *s && s[1] == ']') {
9097             ckWARN3reg(s+2,
9098                        "POSIX syntax [%c %c] belongs inside character classes",
9099                        c, c);
9100
9101             /* [[=foo=]] and [[.foo.]] are still future. */
9102             if (POSIXCC_NOTYET(c)) {
9103                 /* adjust RExC_parse so the error shows after
9104                    the class closes */
9105                 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
9106                     NOOP;
9107                 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
9108             }
9109         }
9110     }
9111 }
9112
9113 /* No locale test, and always Unicode semantics */
9114 #define _C_C_T_NOLOC_(NAME,TEST,WORD)                                          \
9115 ANYOF_##NAME:                                                                  \
9116         for (value = 0; value < 256; value++)                                  \
9117             if (TEST)                                                          \
9118             stored += set_regclass_bit(pRExC_state, ret, (U8) value, &nonbitmap);  \
9119     yesno = '+';                                                               \
9120     what = WORD;                                                               \
9121     break;                                                                     \
9122 case ANYOF_N##NAME:                                                            \
9123         for (value = 0; value < 256; value++)                                  \
9124             if (!TEST)                                                         \
9125             stored += set_regclass_bit(pRExC_state, ret, (U8) value, &nonbitmap);  \
9126     yesno = '!';                                                               \
9127     what = WORD;                                                               \
9128     break
9129
9130 /* Like the above, but there are differences if we are in uni-8-bit or not, so
9131  * there are two tests passed in, to use depending on that. There aren't any
9132  * cases where the label is different from the name, so no need for that
9133  * parameter */
9134 #define _C_C_T_(NAME, TEST_8, TEST_7, WORD)                                    \
9135 ANYOF_##NAME:                                                                  \
9136     if (LOC) ANYOF_CLASS_SET(ret, ANYOF_##NAME);                               \
9137     else if (UNI_SEMANTICS) {                                                  \
9138         for (value = 0; value < 256; value++) {                                \
9139             if (TEST_8(value)) stored +=                                       \
9140                       set_regclass_bit(pRExC_state, ret, (U8) value, &nonbitmap);  \
9141         }                                                                      \
9142     }                                                                          \
9143     else {                                                                     \
9144         for (value = 0; value < 128; value++) {                                \
9145             if (TEST_7(UNI_TO_NATIVE(value))) stored +=                        \
9146                 set_regclass_bit(pRExC_state, ret,                     \
9147                                    (U8) UNI_TO_NATIVE(value), &nonbitmap);                 \
9148         }                                                                      \
9149     }                                                                          \
9150     yesno = '+';                                                               \
9151     what = WORD;                                                               \
9152     break;                                                                     \
9153 case ANYOF_N##NAME:                                                            \
9154     if (LOC) ANYOF_CLASS_SET(ret, ANYOF_N##NAME);                              \
9155     else if (UNI_SEMANTICS) {                                                  \
9156         for (value = 0; value < 256; value++) {                                \
9157             if (! TEST_8(value)) stored +=                                     \
9158                     set_regclass_bit(pRExC_state, ret, (U8) value, &nonbitmap);    \
9159         }                                                                      \
9160     }                                                                          \
9161     else {                                                                     \
9162         for (value = 0; value < 128; value++) {                                \
9163             if (! TEST_7(UNI_TO_NATIVE(value))) stored += set_regclass_bit(  \
9164                         pRExC_state, ret, (U8) UNI_TO_NATIVE(value), &nonbitmap);    \
9165         }                                                                      \
9166         if (AT_LEAST_ASCII_RESTRICTED) {                                       \
9167             for (value = 128; value < 256; value++) {                          \
9168              stored += set_regclass_bit(                                     \
9169                            pRExC_state, ret, (U8) UNI_TO_NATIVE(value), &nonbitmap); \
9170             }                                                                  \
9171             ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL|ANYOF_UTF8;                  \
9172         }                                                                      \
9173         else {                                                                 \
9174             /* For a non-ut8 target string with DEPENDS semantics, all above   \
9175              * ASCII Latin1 code points match the complement of any of the     \
9176              * classes.  But in utf8, they have their Unicode semantics, so    \
9177              * can't just set them in the bitmap, or else regexec.c will think \
9178              * they matched when they shouldn't. */                            \
9179             ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL|ANYOF_UTF8;          \
9180         }                                                                      \
9181     }                                                                          \
9182     yesno = '!';                                                               \
9183     what = WORD;                                                               \
9184     break
9185
9186 /* 
9187    We dont use PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS as the direct test
9188    so that it is possible to override the option here without having to 
9189    rebuild the entire core. as we are required to do if we change regcomp.h
9190    which is where PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS is defined.
9191 */
9192 #if PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS
9193 #define BROKEN_UNICODE_CHARCLASS_MAPPINGS
9194 #endif
9195
9196 #ifdef BROKEN_UNICODE_CHARCLASS_MAPPINGS
9197 #define POSIX_CC_UNI_NAME(CCNAME) CCNAME
9198 #else
9199 #define POSIX_CC_UNI_NAME(CCNAME) "Posix" CCNAME
9200 #endif
9201
9202 STATIC U8
9203 S_set_regclass_bit_fold(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, HV** nonbitmap_ptr)
9204 {
9205
9206     /* Handle the setting of folds in the bitmap for non-locale ANYOF nodes.
9207      * Locale folding is done at run-time, so this function should not be
9208      * called for nodes that are for locales.
9209      *
9210      * This function simply sets the bit corresponding to the fold of the input
9211      * 'value', if not already set.  The fold of 'f' is 'F', and the fold of
9212      * 'F' is 'f'.
9213      *
9214      * It also sets any necessary flags, and returns the number of bits that
9215      * actually changed from 0 to 1 */
9216
9217     U8 stored = 0;
9218     U8 fold;
9219
9220     PERL_ARGS_ASSERT_SET_REGCLASS_BIT_FOLD;
9221
9222     fold = (AT_LEAST_UNI_SEMANTICS) ? PL_fold_latin1[value]
9223                                     : PL_fold[value];
9224
9225     /* It assumes the bit for 'value' has already been set */
9226     if (fold != value && ! ANYOF_BITMAP_TEST(node, fold)) {
9227         ANYOF_BITMAP_SET(node, fold);
9228         stored++;
9229     }
9230     if ((_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value) && (! isASCII(value) || ! MORE_ASCII_RESTRICTED))
9231         || (! UNI_SEMANTICS
9232             && ! isASCII(value)
9233             && PL_fold_latin1[value] != value))
9234     {   /* A character that has a fold outside of Latin1 matches outside the
9235            bitmap, but only when the target string is utf8.  Similarly when we
9236            don't have unicode semantics for the above ASCII Latin-1 characters,
9237            and they have a fold, they should match if the target is utf8, and
9238            not otherwise */
9239         if (! *nonbitmap_ptr) {
9240             *nonbitmap_ptr = _new_invlist(2);
9241         }
9242         *nonbitmap_ptr = add_range_to_invlist(*nonbitmap_ptr, value, value);
9243         ANYOF_FLAGS(node) |= ANYOF_UTF8;
9244     }
9245
9246     return stored;
9247 }
9248
9249
9250 PERL_STATIC_INLINE U8
9251 S_set_regclass_bit(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, HV** nonbitmap_ptr)
9252 {
9253     /* This inline function sets a bit in the bitmap if not already set, and if
9254      * appropriate, its fold, returning the number of bits that actually
9255      * changed from 0 to 1 */
9256
9257     U8 stored;
9258
9259     PERL_ARGS_ASSERT_SET_REGCLASS_BIT;
9260
9261     if (ANYOF_BITMAP_TEST(node, value)) {   /* Already set */
9262         return 0;
9263     }
9264
9265     ANYOF_BITMAP_SET(node, value);
9266     stored = 1;
9267
9268     if (FOLD && ! LOC) {        /* Locale folds aren't known until runtime */
9269         stored += set_regclass_bit_fold(pRExC_state, node, value, nonbitmap_ptr);
9270     }
9271
9272     return stored;
9273 }
9274
9275 /*
9276    parse a class specification and produce either an ANYOF node that
9277    matches the pattern or perhaps will be optimized into an EXACTish node
9278    instead. The node contains a bit map for the first 256 characters, with the
9279    corresponding bit set if that character is in the list.  For characters
9280    above 255, a range list is used */
9281
9282 STATIC regnode *
9283 S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
9284 {
9285     dVAR;
9286     register UV nextvalue;
9287     register IV prevvalue = OOB_UNICODE;
9288     register IV range = 0;
9289     UV value = 0; /* XXX:dmq: needs to be referenceable (unfortunately) */
9290     register regnode *ret;
9291     STRLEN numlen;
9292     IV namedclass;
9293     char *rangebegin = NULL;
9294     bool need_class = 0;
9295     SV *listsv = NULL;
9296     UV n;
9297     HV* nonbitmap = NULL;
9298     AV* unicode_alternate  = NULL;
9299 #ifdef EBCDIC
9300     UV literal_endpoint = 0;
9301 #endif
9302     UV stored = 0;  /* how many chars stored in the bitmap */
9303
9304     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
9305         case we need to change the emitted regop to an EXACT. */
9306     const char * orig_parse = RExC_parse;
9307     GET_RE_DEBUG_FLAGS_DECL;
9308
9309     PERL_ARGS_ASSERT_REGCLASS;
9310 #ifndef DEBUGGING
9311     PERL_UNUSED_ARG(depth);
9312 #endif
9313
9314     DEBUG_PARSE("clas");
9315
9316     /* Assume we are going to generate an ANYOF node. */
9317     ret = reganode(pRExC_state, ANYOF, 0);
9318
9319
9320     if (!SIZE_ONLY) {
9321         ANYOF_FLAGS(ret) = 0;
9322     }
9323
9324     if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
9325         RExC_naughty++;
9326         RExC_parse++;
9327         if (!SIZE_ONLY)
9328             ANYOF_FLAGS(ret) |= ANYOF_INVERT;
9329     }
9330
9331     if (SIZE_ONLY) {
9332         RExC_size += ANYOF_SKIP;
9333 #ifdef ANYOF_ADD_LOC_SKIP
9334         if (LOC) {
9335             RExC_size += ANYOF_ADD_LOC_SKIP;
9336         }
9337 #endif
9338         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
9339     }
9340     else {
9341         RExC_emit += ANYOF_SKIP;
9342         if (LOC) {
9343             ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
9344 #ifdef ANYOF_ADD_LOC_SKIP
9345             RExC_emit += ANYOF_ADD_LOC_SKIP;
9346 #endif
9347         }
9348         ANYOF_BITMAP_ZERO(ret);
9349         listsv = newSVpvs("# comment\n");
9350     }
9351
9352     nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
9353
9354     if (!SIZE_ONLY && POSIXCC(nextvalue))
9355         checkposixcc(pRExC_state);
9356
9357     /* allow 1st char to be ] (allowing it to be - is dealt with later) */
9358     if (UCHARAT(RExC_parse) == ']')
9359         goto charclassloop;
9360
9361 parseit:
9362     while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
9363
9364     charclassloop:
9365
9366         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
9367
9368         if (!range)
9369             rangebegin = RExC_parse;
9370         if (UTF) {
9371             value = utf8n_to_uvchr((U8*)RExC_parse,
9372                                    RExC_end - RExC_parse,
9373                                    &numlen, UTF8_ALLOW_DEFAULT);
9374             RExC_parse += numlen;
9375         }
9376         else
9377             value = UCHARAT(RExC_parse++);
9378
9379         nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
9380         if (value == '[' && POSIXCC(nextvalue))
9381             namedclass = regpposixcc(pRExC_state, value);
9382         else if (value == '\\') {
9383             if (UTF) {
9384                 value = utf8n_to_uvchr((U8*)RExC_parse,
9385                                    RExC_end - RExC_parse,
9386                                    &numlen, UTF8_ALLOW_DEFAULT);
9387                 RExC_parse += numlen;
9388             }
9389             else
9390                 value = UCHARAT(RExC_parse++);
9391             /* Some compilers cannot handle switching on 64-bit integer
9392              * values, therefore value cannot be an UV.  Yes, this will
9393              * be a problem later if we want switch on Unicode.
9394              * A similar issue a little bit later when switching on
9395              * namedclass. --jhi */
9396             switch ((I32)value) {
9397             case 'w':   namedclass = ANYOF_ALNUM;       break;
9398             case 'W':   namedclass = ANYOF_NALNUM;      break;
9399             case 's':   namedclass = ANYOF_SPACE;       break;
9400             case 'S':   namedclass = ANYOF_NSPACE;      break;
9401             case 'd':   namedclass = ANYOF_DIGIT;       break;
9402             case 'D':   namedclass = ANYOF_NDIGIT;      break;
9403             case 'v':   namedclass = ANYOF_VERTWS;      break;
9404             case 'V':   namedclass = ANYOF_NVERTWS;     break;
9405             case 'h':   namedclass = ANYOF_HORIZWS;     break;
9406             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
9407             case 'N':  /* Handle \N{NAME} in class */
9408                 {
9409                     /* We only pay attention to the first char of 
9410                     multichar strings being returned. I kinda wonder
9411                     if this makes sense as it does change the behaviour
9412                     from earlier versions, OTOH that behaviour was broken
9413                     as well. */
9414                     UV v; /* value is register so we cant & it /grrr */
9415                     if (reg_namedseq(pRExC_state, &v, NULL)) {
9416                         goto parseit;
9417                     }
9418                     value= v; 
9419                 }
9420                 break;
9421             case 'p':
9422             case 'P':
9423                 {
9424                 char *e;
9425                 if (RExC_parse >= RExC_end)
9426                     vFAIL2("Empty \\%c{}", (U8)value);
9427                 if (*RExC_parse == '{') {
9428                     const U8 c = (U8)value;
9429                     e = strchr(RExC_parse++, '}');
9430                     if (!e)
9431                         vFAIL2("Missing right brace on \\%c{}", c);
9432                     while (isSPACE(UCHARAT(RExC_parse)))
9433                         RExC_parse++;
9434                     if (e == RExC_parse)
9435                         vFAIL2("Empty \\%c{}", c);
9436                     n = e - RExC_parse;
9437                     while (isSPACE(UCHARAT(RExC_parse + n - 1)))
9438                         n--;
9439                 }
9440                 else {
9441                     e = RExC_parse;
9442                     n = 1;
9443                 }
9444                 if (!SIZE_ONLY) {
9445                     if (UCHARAT(RExC_parse) == '^') {
9446                          RExC_parse++;
9447                          n--;
9448                          value = value == 'p' ? 'P' : 'p'; /* toggle */
9449                          while (isSPACE(UCHARAT(RExC_parse))) {
9450                               RExC_parse++;
9451                               n--;
9452                          }
9453                     }
9454
9455                     /* Add the property name to the list.  If /i matching, give
9456                      * a different name which consists of the normal name
9457                      * sandwiched between two underscores and '_i'.  The design
9458                      * is discussed in the commit message for this. */
9459                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s%.*s%s\n",
9460                                         (value=='p' ? '+' : '!'),
9461                                         (FOLD) ? "__" : "",
9462                                         (int)n,
9463                                         RExC_parse,
9464                                         (FOLD) ? "_i" : ""
9465                                     );
9466                 }
9467                 RExC_parse = e + 1;
9468
9469                 /* The \p could match something in the Latin1 range, hence
9470                  * something that isn't utf8 */
9471                 ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP;
9472                 namedclass = ANYOF_MAX;  /* no official name, but it's named */
9473
9474                 /* \p means they want Unicode semantics */
9475                 RExC_uni_semantics = 1;
9476                 }
9477                 break;
9478             case 'n':   value = '\n';                   break;
9479             case 'r':   value = '\r';                   break;
9480             case 't':   value = '\t';                   break;
9481             case 'f':   value = '\f';                   break;
9482             case 'b':   value = '\b';                   break;
9483             case 'e':   value = ASCII_TO_NATIVE('\033');break;
9484             case 'a':   value = ASCII_TO_NATIVE('\007');break;
9485             case 'o':
9486                 RExC_parse--;   /* function expects to be pointed at the 'o' */
9487                 {
9488                     const char* error_msg;
9489                     bool valid = grok_bslash_o(RExC_parse,
9490                                                &value,
9491                                                &numlen,
9492                                                &error_msg,
9493                                                SIZE_ONLY);
9494                     RExC_parse += numlen;
9495                     if (! valid) {
9496                         vFAIL(error_msg);
9497                     }
9498                 }
9499                 if (PL_encoding && value < 0x100) {
9500                     goto recode_encoding;
9501                 }
9502                 break;
9503             case 'x':
9504                 if (*RExC_parse == '{') {
9505                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
9506                         | PERL_SCAN_DISALLOW_PREFIX;
9507                     char * const e = strchr(RExC_parse++, '}');
9508                     if (!e)
9509                         vFAIL("Missing right brace on \\x{}");
9510
9511                     numlen = e - RExC_parse;
9512                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
9513                     RExC_parse = e + 1;
9514                 }
9515                 else {
9516                     I32 flags = PERL_SCAN_DISALLOW_PREFIX;
9517                     numlen = 2;
9518                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
9519                     RExC_parse += numlen;
9520                 }
9521                 if (PL_encoding && value < 0x100)
9522                     goto recode_encoding;
9523                 break;
9524             case 'c':
9525                 value = grok_bslash_c(*RExC_parse++, UTF, SIZE_ONLY);
9526                 break;
9527             case '0': case '1': case '2': case '3': case '4':
9528             case '5': case '6': case '7':
9529                 {
9530                     /* Take 1-3 octal digits */
9531                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
9532                     numlen = 3;
9533                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
9534                     RExC_parse += numlen;
9535                     if (PL_encoding && value < 0x100)
9536                         goto recode_encoding;
9537                     break;
9538                 }
9539             recode_encoding:
9540                 {
9541                     SV* enc = PL_encoding;
9542                     value = reg_recode((const char)(U8)value, &enc);
9543                     if (!enc && SIZE_ONLY)
9544                         ckWARNreg(RExC_parse,
9545                                   "Invalid escape in the specified encoding");
9546                     break;
9547                 }
9548             default:
9549                 /* Allow \_ to not give an error */
9550                 if (!SIZE_ONLY && isALNUM(value) && value != '_') {
9551                     ckWARN2reg(RExC_parse,
9552                                "Unrecognized escape \\%c in character class passed through",
9553                                (int)value);
9554                 }
9555                 break;
9556             }
9557         } /* end of \blah */
9558 #ifdef EBCDIC
9559         else
9560             literal_endpoint++;
9561 #endif
9562
9563         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
9564
9565             /* What matches in a locale is not known until runtime, so need to
9566              * (one time per class) allocate extra space to pass to regexec.
9567              * The space will contain a bit for each named class that is to be
9568              * matched against.  This isn't needed for \p{} and pseudo-classes,
9569              * as they are not affected by locale, and hence are dealt with
9570              * separately */
9571             if (LOC && namedclass < ANYOF_MAX && ! need_class) {
9572                 need_class = 1;
9573                 if (SIZE_ONLY) {
9574 #ifdef ANYOF_CLASS_ADD_SKIP
9575                     RExC_size += ANYOF_CLASS_ADD_SKIP;
9576 #endif
9577                 }
9578                 else {
9579 #ifdef ANYOF_CLASS_ADD_SKIP
9580                     RExC_emit += ANYOF_CLASS_ADD_SKIP;
9581 #endif
9582                     ANYOF_CLASS_ZERO(ret);
9583                 }
9584                 ANYOF_FLAGS(ret) |= ANYOF_CLASS;
9585             }
9586
9587             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
9588              * literal */
9589             if (range) {
9590                 if (!SIZE_ONLY) {
9591                     const int w =
9592                         RExC_parse >= rangebegin ?
9593                         RExC_parse - rangebegin : 0;
9594                     ckWARN4reg(RExC_parse,
9595                                "False [] range \"%*.*s\"",
9596                                w, w, rangebegin);
9597
9598                     if (prevvalue < 256) {
9599                         stored +=
9600                          set_regclass_bit(pRExC_state, ret, (U8) prevvalue, &nonbitmap);
9601                         stored +=
9602                          set_regclass_bit(pRExC_state, ret, '-', &nonbitmap);
9603                     }
9604                     else {
9605                         ANYOF_FLAGS(ret) |= ANYOF_UTF8;
9606                         Perl_sv_catpvf(aTHX_ listsv,
9607                            "%04"UVxf"\n%04"UVxf"\n", (UV)prevvalue, (UV) '-');
9608                     }
9609                 }
9610
9611                 range = 0; /* this was not a true range */
9612             }
9613
9614
9615     
9616             if (!SIZE_ONLY) {
9617                 const char *what = NULL;
9618                 char yesno = 0;
9619
9620                 /* Possible truncation here but in some 64-bit environments
9621                  * the compiler gets heartburn about switch on 64-bit values.
9622                  * A similar issue a little earlier when switching on value.
9623                  * --jhi */
9624                 switch ((I32)namedclass) {
9625                 
9626                 case _C_C_T_(ALNUMC, isALNUMC_L1, isALNUMC, "XPosixAlnum");
9627                 case _C_C_T_(ALPHA, isALPHA_L1, isALPHA, "XPosixAlpha");
9628                 case _C_C_T_(BLANK, isBLANK_L1, isBLANK, "XPosixBlank");
9629                 case _C_C_T_(CNTRL, isCNTRL_L1, isCNTRL, "XPosixCntrl");
9630                 case _C_C_T_(GRAPH, isGRAPH_L1, isGRAPH, "XPosixGraph");
9631                 case _C_C_T_(LOWER, isLOWER_L1, isLOWER, "XPosixLower");
9632                 case _C_C_T_(PRINT, isPRINT_L1, isPRINT, "XPosixPrint");
9633                 case _C_C_T_(PSXSPC, isPSXSPC_L1, isPSXSPC, "XPosixSpace");
9634                 case _C_C_T_(PUNCT, isPUNCT_L1, isPUNCT, "XPosixPunct");
9635                 case _C_C_T_(UPPER, isUPPER_L1, isUPPER, "XPosixUpper");
9636 #ifdef BROKEN_UNICODE_CHARCLASS_MAPPINGS
9637                 /* \s, \w match all unicode if utf8. */
9638                 case _C_C_T_(SPACE, isSPACE_L1, isSPACE, "SpacePerl");
9639                 case _C_C_T_(ALNUM, isWORDCHAR_L1, isALNUM, "Word");
9640 #else
9641                 /* \s, \w match ascii and locale only */
9642                 case _C_C_T_(SPACE, isSPACE_L1, isSPACE, "PerlSpace");
9643                 case _C_C_T_(ALNUM, isWORDCHAR_L1, isALNUM, "PerlWord");
9644 #endif          
9645                 case _C_C_T_(XDIGIT, isXDIGIT_L1, isXDIGIT, "XPosixXDigit");
9646                 case _C_C_T_NOLOC_(VERTWS, is_VERTWS_latin1(&value), "VertSpace");
9647                 case _C_C_T_NOLOC_(HORIZWS, is_HORIZWS_latin1(&value), "HorizSpace");
9648                 case ANYOF_ASCII:
9649                     if (LOC)
9650                         ANYOF_CLASS_SET(ret, ANYOF_ASCII);
9651                     else {
9652                         for (value = 0; value < 128; value++)
9653                             stored +=
9654                               set_regclass_bit(pRExC_state, ret, (U8) ASCII_TO_NATIVE(value), &nonbitmap);
9655                     }
9656                     yesno = '+';
9657                     what = NULL;        /* Doesn't match outside ascii, so
9658                                            don't want to add +utf8:: */
9659                     break;
9660                 case ANYOF_NASCII:
9661                     if (LOC)
9662                         ANYOF_CLASS_SET(ret, ANYOF_NASCII);
9663                     else {
9664                         for (value = 128; value < 256; value++)
9665                             stored +=
9666                               set_regclass_bit(pRExC_state, ret, (U8) ASCII_TO_NATIVE(value), &nonbitmap);
9667                     }
9668                     ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
9669                     yesno = '!';
9670                     what = "ASCII";
9671                     break;              
9672                 case ANYOF_DIGIT:
9673                     if (LOC)
9674                         ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
9675                     else {
9676                         /* consecutive digits assumed */
9677                         for (value = '0'; value <= '9'; value++)
9678                             stored +=
9679                               set_regclass_bit(pRExC_state, ret, (U8) value, &nonbitmap);
9680                     }
9681                     yesno = '+';
9682                     what = POSIX_CC_UNI_NAME("Digit");
9683                     break;
9684                 case ANYOF_NDIGIT:
9685                     if (LOC)
9686                         ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
9687                     else {
9688                         /* consecutive digits assumed */
9689                         for (value = 0; value < '0'; value++)
9690                             stored +=
9691                               set_regclass_bit(pRExC_state, ret, (U8) value, &nonbitmap);
9692                         for (value = '9' + 1; value < 256; value++)
9693                             stored +=
9694                               set_regclass_bit(pRExC_state, ret, (U8) value, &nonbitmap);
9695                     }
9696                     yesno = '!';
9697                     what = POSIX_CC_UNI_NAME("Digit");
9698                     if (AT_LEAST_ASCII_RESTRICTED ) {
9699                         ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
9700                     }
9701                     break;              
9702                 case ANYOF_MAX:
9703                     /* this is to handle \p and \P */
9704                     break;
9705                 default:
9706                     vFAIL("Invalid [::] class");
9707                     break;
9708                 }
9709                 if (what && ! (AT_LEAST_ASCII_RESTRICTED)) {
9710                     /* Strings such as "+utf8::isWord\n" */
9711                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::Is%s\n", yesno, what);
9712                     ANYOF_FLAGS(ret) |= ANYOF_UTF8;
9713                 }
9714
9715                 continue;
9716             }
9717         } /* end of namedclass \blah */
9718
9719         if (range) {
9720             if (prevvalue > (IV)value) /* b-a */ {
9721                 const int w = RExC_parse - rangebegin;
9722                 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
9723                 range = 0; /* not a valid range */
9724             }
9725         }
9726         else {
9727             prevvalue = value; /* save the beginning of the range */
9728             if (*RExC_parse == '-' && RExC_parse+1 < RExC_end &&
9729                 RExC_parse[1] != ']') {
9730                 RExC_parse++;
9731
9732                 /* a bad range like \w-, [:word:]- ? */
9733                 if (namedclass > OOB_NAMEDCLASS) {
9734                     if (ckWARN(WARN_REGEXP)) {
9735                         const int w =
9736                             RExC_parse >= rangebegin ?
9737                             RExC_parse - rangebegin : 0;
9738                         vWARN4(RExC_parse,
9739                                "False [] range \"%*.*s\"",
9740                                w, w, rangebegin);
9741                     }
9742                     if (!SIZE_ONLY)
9743                         stored +=
9744                             set_regclass_bit(pRExC_state, ret, '-', &nonbitmap);
9745                 } else
9746                     range = 1;  /* yeah, it's a range! */
9747                 continue;       /* but do it the next time */
9748             }
9749         }
9750
9751         /* non-Latin1 code point implies unicode semantics.  Must be set in
9752          * pass1 so is there for the whole of pass 2 */
9753         if (value > 255) {
9754             RExC_uni_semantics = 1;
9755         }
9756
9757         /* now is the next time */
9758         if (!SIZE_ONLY) {
9759             if (prevvalue < 256) {
9760                 const IV ceilvalue = value < 256 ? value : 255;
9761                 IV i;
9762 #ifdef EBCDIC
9763                 /* In EBCDIC [\x89-\x91] should include
9764                  * the \x8e but [i-j] should not. */
9765                 if (literal_endpoint == 2 &&
9766                     ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
9767                      (isUPPER(prevvalue) && isUPPER(ceilvalue))))
9768                 {
9769                     if (isLOWER(prevvalue)) {
9770                         for (i = prevvalue; i <= ceilvalue; i++)
9771                             if (isLOWER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
9772                                 stored +=
9773                                   set_regclass_bit(pRExC_state, ret, (U8) i, &nonbitmap);
9774                             }
9775                     } else {
9776                         for (i = prevvalue; i <= ceilvalue; i++)
9777                             if (isUPPER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
9778                                 stored +=
9779                                   set_regclass_bit(pRExC_state, ret, (U8) i, &nonbitmap);
9780                             }
9781                     }
9782                 }
9783                 else
9784 #endif
9785                       for (i = prevvalue; i <= ceilvalue; i++) {
9786                         stored += set_regclass_bit(pRExC_state, ret, (U8) i, &nonbitmap);
9787                       }
9788           }
9789           if (value > 255) {
9790             const UV prevnatvalue  = NATIVE_TO_UNI(prevvalue);
9791             const UV natvalue      = NATIVE_TO_UNI(value);
9792             if (! nonbitmap) {
9793                 nonbitmap = _new_invlist(2);
9794             }
9795             nonbitmap = add_range_to_invlist(nonbitmap, prevnatvalue, natvalue);
9796             ANYOF_FLAGS(ret) |= ANYOF_UTF8;
9797         }
9798 #if 0
9799
9800                 /* If the code point requires utf8 to represent, and we are not
9801                  * folding, it can't match unless the target is in utf8.  Only
9802                  * a few code points above 255 fold to below it, so XXX an
9803                  * optimization would be to know which ones and set the flag
9804                  * appropriately. */
9805                 ANYOF_FLAGS(ret) |= (FOLD || value < 256)
9806                                     ? ANYOF_NONBITMAP
9807                                     : ANYOF_UTF8;
9808                 if (prevnatvalue < natvalue) { /* '>' case is fatal error above */
9809
9810                     /* The \t sets the whole range */
9811                     Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
9812                                    prevnatvalue, natvalue);
9813
9814                     /* Currently, we don't look at every value in the range.
9815                      * Therefore we have to assume the worst case: that if
9816                      * folding, it will match more than one character.  But in
9817                      * lookbehind patterns, can only be single character
9818                      * length, so disallow those folds */
9819                     if (FOLD && ! RExC_in_lookbehind) {
9820                       OP(ret) = ANYOFV;
9821                     }
9822                 }
9823                 else if (prevnatvalue == natvalue) {
9824                     Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", natvalue);
9825                     if (FOLD) {
9826                          U8 foldbuf[UTF8_MAXBYTES_CASE+1];
9827                          STRLEN foldlen;
9828                          const UV f = to_uni_fold(natvalue, foldbuf, &foldlen);
9829
9830 #ifdef EBCDIC /* RD t/uni/fold ff and 6b */
9831                          if (RExC_precomp[0] == ':' &&
9832                              RExC_precomp[1] == '[' &&
9833                              (f == 0xDF || f == 0x92)) {
9834                              f = NATIVE_TO_UNI(f);
9835                         }
9836 #endif
9837                          /* If folding and foldable and a single
9838                           * character, insert also the folded version
9839                           * to the charclass. */
9840                          if (f != value) {
9841 #ifdef EBCDIC /* RD tunifold ligatures s,t fb05, fb06 */
9842                              if ((RExC_precomp[0] == ':' &&
9843                                   RExC_precomp[1] == '[' &&
9844                                   (f == 0xA2 &&
9845                                    (value == 0xFB05 || value == 0xFB06))) ?
9846                                  foldlen == ((STRLEN)UNISKIP(f) - 1) :
9847                                  foldlen == (STRLEN)UNISKIP(f) )
9848 #else
9849                               if (foldlen == (STRLEN)UNISKIP(f))
9850 #endif
9851                                   Perl_sv_catpvf(aTHX_ listsv,
9852                                                  "%04"UVxf"\n", f);
9853                               else if (! RExC_in_lookbehind) {
9854                                   /* Any multicharacter foldings
9855                                    * (disallowed in lookbehind patterns)
9856                                    * require the following transform:
9857                                    * [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst)
9858                                    * where E folds into "pq" and F folds
9859                                    * into "rst", all other characters
9860                                    * fold to single characters.  We save
9861                                    * away these multicharacter foldings,
9862                                    * to be later saved as part of the
9863                                    * additional "s" data. */
9864                                   SV *sv;
9865
9866                                   if (!unicode_alternate)
9867                                       unicode_alternate = newAV();
9868                                   sv = newSVpvn_utf8((char*)foldbuf, foldlen,
9869                                                      TRUE);
9870                                   av_push(unicode_alternate, sv);
9871                                   OP(ret) = ANYOFV;
9872                               }
9873                          }
9874
9875                          /* If folding and the value is one of the Greek
9876                           * sigmas insert a few more sigmas to make the
9877                           * folding rules of the sigmas to work right.
9878                           * Note that not all the possible combinations
9879                           * are handled here: some of them are handled
9880                           * by the standard folding rules, and some of
9881                           * them (literal or EXACTF cases) are handled
9882                           * during runtime in regexec.c:S_find_byclass(). */
9883                          if (value == UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) {
9884                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
9885                                              (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA);
9886                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
9887                                              (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
9888                          }
9889                          else if (value == UNICODE_GREEK_CAPITAL_LETTER_SIGMA)
9890                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
9891                                              (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
9892                     }
9893                 }
9894             }
9895 #endif
9896 #ifdef EBCDIC
9897             literal_endpoint = 0;
9898 #endif
9899         }
9900
9901         range = 0; /* this range (if it was one) is done now */
9902     }
9903
9904
9905
9906     if (SIZE_ONLY)
9907         return ret;
9908     /****** !SIZE_ONLY AFTER HERE *********/
9909
9910     /* Finish up the non-bitmap entries */
9911     if (nonbitmap) {
9912         UV* nonbitmap_array;
9913         UV i;
9914
9915         /* If folding, we add to the list all characters that could fold to or
9916          * from the ones already on the list */
9917         if (FOLD) {
9918             HV* fold_intersection;
9919             UV* fold_list;
9920
9921             /* This is a list of all the characters that participate in folds
9922              * (except marks, etc in multi-char folds */
9923             if (! PL_utf8_foldable) {
9924                 SV* swash = swash_init("utf8", "Cased", &PL_sv_undef, 1, 0);
9925                 PL_utf8_foldable = _swash_to_invlist(swash);
9926             }
9927
9928             /* This is a hash that for a particular fold gives all characters
9929              * that are involved in it */
9930             if (! PL_utf8_foldclosures) {
9931
9932                 /* If we were unable to find any folds, then we likely won't be
9933                  * able to find the closures.  So just create an empty list.
9934                  * Folding will effectively be restricted to the non-Unicode
9935                  * rules hard-coded into Perl.  (This case happens legitimately
9936                  * during compilation of Perl itself before the Unicode tables
9937                  * are generated) */
9938                 if (invlist_len(PL_utf8_foldable) == 0) {
9939                     PL_utf8_foldclosures = _new_invlist(0);
9940                 } else {
9941                     /* If the folds haven't been read in, call a fold function
9942                      * to force that */
9943                     if (! PL_utf8_tofold) {
9944                         U8 dummy[UTF8_MAXBYTES+1];
9945                         STRLEN dummy_len;
9946                         to_utf8_fold((U8*) "A", dummy, &dummy_len);
9947                     }
9948                     PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
9949                 }
9950             }
9951
9952             /* Only the characters in this class that participate in folds need
9953              * be checked.  Get the intersection of this class and all the
9954              * possible characters that are foldable.  This can quickly narrow
9955              * down a large class */
9956             fold_intersection = invlist_intersection(PL_utf8_foldable, nonbitmap);
9957
9958             /* Now look at the foldable characters in this class individually */
9959             fold_list = invlist_array(fold_intersection);
9960             for (i = 0; i < invlist_len(fold_intersection); i++) {
9961                 UV j;
9962
9963                 /* The next entry is the beginning of the range that is in the
9964                  * class */
9965                 UV start = fold_list[i++];
9966
9967
9968                 /* The next entry is the beginning of the next range, which
9969                  * isn't in the class, so the end of the current range is one
9970                  * less than that */
9971                 UV end = fold_list[i] - 1;
9972
9973                 /* Look at every character in the range */
9974                 for (j = start; j <= end; j++) {
9975
9976                     /* Get its fold */
9977                     U8 foldbuf[UTF8_MAXBYTES_CASE+1];
9978                     STRLEN foldlen;
9979                     const UV f = to_uni_fold(j, foldbuf, &foldlen);
9980
9981                     if (foldlen > (STRLEN)UNISKIP(f)) {
9982
9983                         /* Any multicharacter foldings (disallowed in
9984                          * lookbehind patterns) require the following
9985                          * transform: [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst) where
9986                          * E folds into "pq" and F folds into "rst", all other
9987                          * characters fold to single characters.  We save away
9988                          * these multicharacter foldings, to be later saved as
9989                          * part of the additional "s" data. */
9990                         if (! RExC_in_lookbehind) {
9991                             SV *sv;
9992                             U8* loc = foldbuf;
9993                             U8* e = foldbuf + foldlen;
9994
9995                             /* If any of the folded characters of this are in
9996                              * the Latin1 range, tell the regex engine that
9997                              * this can match a non-utf8 target string.  The
9998                              * only multi-byte fold whose source is in the
9999                              * Latin1 range (U+00DF) applies only when the
10000                              * target string is utf8, or under unicode rules */
10001                             if (j > 255 || AT_LEAST_UNI_SEMANTICS) {
10002                                 while (loc < e) {
10003
10004                                     /* Can't mix ascii with non- under /aa */
10005                                     if (MORE_ASCII_RESTRICTED
10006                                         && (isASCII(*loc) != isASCII(j)))
10007                                     {
10008                                         goto end_multi_fold;
10009                                     }
10010                                     if (UTF8_IS_INVARIANT(*loc)
10011                                         || UTF8_IS_DOWNGRADEABLE_START(*loc))
10012                                     {
10013                                         /* Can't mix above and below 256 under
10014                                          * LOC */
10015                                         if (LOC) {
10016                                             goto end_multi_fold;
10017                                         }
10018                                         ANYOF_FLAGS(ret)
10019                                                 |= ANYOF_NONBITMAP_NON_UTF8;
10020                                         break;
10021                                     }
10022                                     loc += UTF8SKIP(loc);
10023                                 }
10024                             }
10025                             ANYOF_FLAGS(ret) |= ANYOF_UTF8;
10026
10027                             if (!unicode_alternate) {
10028                                 unicode_alternate = newAV();
10029                             }
10030                             sv = newSVpvn_utf8((char*)foldbuf, foldlen, TRUE);
10031                             av_push(unicode_alternate, sv);
10032
10033                             /* This node is variable length */
10034                             OP(ret) = ANYOFV;
10035                         end_multi_fold: ;
10036                         }
10037                     }
10038                     else {
10039                         /* Single character fold.  Add everything in its fold
10040                          * closure to the list that this node should match */
10041                         SV** listp;
10042
10043                         /* The fold closures data structure is a hash with the
10044                          * keys being every character that is folded to, like
10045                          * 'k', and the values each an array of everything that
10046                          * folds to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ] */
10047                         if ((listp = hv_fetch(PL_utf8_foldclosures,
10048                                       (char *) foldbuf, foldlen, FALSE)))
10049                         {
10050                             AV* list = (AV*) *listp;
10051                             IV k;
10052                             for (k = 0; k <= av_len(list); k++) {
10053                                 SV** c_p = av_fetch(list, k, FALSE);
10054                                 UV c;
10055                                 if (c_p == NULL) {
10056                                     Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
10057                                 }
10058                                 c = SvUV(*c_p);
10059
10060                                 /* /aa doesn't allow folds between ASCII and
10061                                  * non-; /l doesn't allow them between above
10062                                  * and below 256 */
10063                                 if ((MORE_ASCII_RESTRICTED && (isASCII(c) != isASCII(j)))
10064                                      || (LOC && ((c < 256) != (j < 256))))
10065                                 {
10066                                     continue;
10067                                 }
10068
10069                                 if (c < 256 && AT_LEAST_UNI_SEMANTICS) {
10070                                     stored += set_regclass_bit(pRExC_state, ret, (U8) c, &nonbitmap);
10071                                 }
10072                                     /* It may be that the code point is already
10073                                      * in this range or already in the bitmap,
10074                                      * in which case we need do nothing */
10075                                 else if ((c < start || c > end)
10076                                          && (c > 255
10077                                              || ! ANYOF_BITMAP_TEST(ret, c)))
10078                                 {
10079                                     nonbitmap = add_range_to_invlist(nonbitmap, c, c);
10080                                 }
10081                             }
10082                         }
10083                     }
10084                 }
10085             }
10086             invlist_destroy(fold_intersection);
10087         } /* End of processing all the folds */
10088
10089         /*  Here have the full list of items to match that aren't in the
10090          *  bitmap.  Convert to the structure that the rest of the code is
10091          *  expecting.   XXX That rest of the code should convert to this
10092          *  structure */
10093         nonbitmap_array = invlist_array(nonbitmap);
10094         for (i = 0; i < invlist_len(nonbitmap); i++) {
10095
10096             /* The next entry is the beginning of the range that is in the
10097              * class */
10098             UV start = nonbitmap_array[i++];
10099
10100             /* The next entry is the beginning of the next range, which isn't
10101              * in the class, so the end of the current range is one less than
10102              * that */
10103             UV end = nonbitmap_array[i] - 1;
10104
10105             if (start == end) {
10106                 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", start);
10107             }
10108             else {
10109                 /* The \t sets the whole range */
10110                 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
10111                         /* XXX EBCDIC */
10112                                    start, end);
10113             }
10114         }
10115         invlist_destroy(nonbitmap);
10116     }
10117
10118     /* Here, we have calculated what code points should be in the character
10119      * class.   Now we can see about various optimizations.  Fold calculation
10120      * needs to take place before inversion.  Otherwise /[^k]/i would invert to
10121      * include K, which under /i would match k. */
10122
10123     /* Optimize inverted simple patterns (e.g. [^a-z]).  Note that we haven't
10124      * set the FOLD flag yet, so this this does optimize those.  It doesn't
10125      * optimize locale.  Doing so perhaps could be done as long as there is
10126      * nothing like \w in it; some thought also would have to be given to the
10127      * interaction with above 0x100 chars */
10128     if (! LOC && (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT) {
10129         for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
10130             ANYOF_BITMAP(ret)[value] ^= 0xFF;
10131         stored = 256 - stored;
10132
10133         /* The inversion means that everything above 255 is matched; and at the
10134          * same time we clear the invert flag */
10135         ANYOF_FLAGS(ret) = ANYOF_UTF8|ANYOF_UNICODE_ALL;
10136     }
10137
10138     /* Folding in the bitmap is taken care of above, but not for locale (for
10139      * which we have to wait to see what folding is in effect at runtime), and
10140      * for things not in the bitmap.  Set run-time fold flag for these */
10141     if (FOLD && (LOC || (ANYOF_FLAGS(ret) & ANYOF_NONBITMAP))) {
10142         ANYOF_FLAGS(ret) |= ANYOF_LOC_NONBITMAP_FOLD;
10143     }
10144
10145     /* A single character class can be "optimized" into an EXACTish node.
10146      * Note that since we don't currently count how many characters there are
10147      * outside the bitmap, we are XXX missing optimization possibilities for
10148      * them.  This optimization can't happen unless this is a truly single
10149      * character class, which means that it can't be an inversion into a
10150      * many-character class, and there must be no possibility of there being
10151      * things outside the bitmap.  'stored' (only) for locales doesn't include
10152      * \w, etc, so have to make a special test that they aren't present
10153      *
10154      * Similarly A 2-character class of the very special form like [bB] can be
10155      * optimized into an EXACTFish node, but only for non-locales, and for
10156      * characters which only have the two folds; so things like 'fF' and 'Ii'
10157      * wouldn't work because they are part of the fold of 'LATIN SMALL LIGATURE
10158      * FI'. */
10159     if (! (ANYOF_FLAGS(ret) & (ANYOF_NONBITMAP|ANYOF_INVERT|ANYOF_UNICODE_ALL))
10160         && (((stored == 1 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
10161                               || (! ANYOF_CLASS_TEST_ANY_SET(ret)))))
10162             || (stored == 2 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
10163                                  && (! _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value))
10164                                  /* If the latest code point has a fold whose
10165                                   * bit is set, it must be the only other one */
10166                                 && ((prevvalue = PL_fold_latin1[value]) != (IV)value)
10167                                  && ANYOF_BITMAP_TEST(ret, prevvalue)))))
10168     {
10169         /* Note that the information needed to decide to do this optimization
10170          * is not currently available until the 2nd pass, and that the actually
10171          * used EXACTish node takes less space than the calculated ANYOF node,
10172          * and hence the amount of space calculated in the first pass is larger
10173          * than actually used, so this optimization doesn't gain us any space.
10174          * But an EXACT node is faster than an ANYOF node, and can be combined
10175          * with any adjacent EXACT nodes later by the optimizer for further
10176          * gains.  The speed of executing an EXACTF is similar to an ANYOF
10177          * node, so the optimization advantage comes from the ability to join
10178          * it to adjacent EXACT nodes */
10179
10180         const char * cur_parse= RExC_parse;
10181         U8 op;
10182         RExC_emit = (regnode *)orig_emit;
10183         RExC_parse = (char *)orig_parse;
10184
10185         if (stored == 1) {
10186
10187             /* A locale node with one point can be folded; all the other cases
10188              * with folding will have two points, since we calculate them above
10189              */
10190             if (ANYOF_FLAGS(ret) & ANYOF_LOC_NONBITMAP_FOLD) {
10191                  op = EXACTFL;
10192             }
10193             else {
10194                 op = EXACT;
10195             }
10196         }   /* else 2 chars in the bit map: the folds of each other */
10197         else if (AT_LEAST_UNI_SEMANTICS || !isASCII(value)) {
10198
10199             /* To join adjacent nodes, they must be the exact EXACTish type.
10200              * Try to use the most likely type, by using EXACTFU if the regex
10201              * calls for them, or is required because the character is
10202              * non-ASCII */
10203             op = EXACTFU;
10204         }
10205         else {    /* Otherwise, more likely to be EXACTF type */
10206             op = EXACTF;
10207         }
10208
10209         ret = reg_node(pRExC_state, op);
10210         RExC_parse = (char *)cur_parse;
10211         if (UTF && ! NATIVE_IS_INVARIANT(value)) {
10212             *STRING(ret)= UTF8_EIGHT_BIT_HI((U8) value);
10213             *(STRING(ret) + 1)= UTF8_EIGHT_BIT_LO((U8) value);
10214             STR_LEN(ret)= 2;
10215             RExC_emit += STR_SZ(2);
10216         }
10217         else {
10218             *STRING(ret)= (char)value;
10219             STR_LEN(ret)= 1;
10220             RExC_emit += STR_SZ(1);
10221         }
10222         SvREFCNT_dec(listsv);
10223         return ret;
10224     }
10225
10226     {
10227         AV * const av = newAV();
10228         SV *rv;
10229         /* The 0th element stores the character class description
10230          * in its textual form: used later (regexec.c:Perl_regclass_swash())
10231          * to initialize the appropriate swash (which gets stored in
10232          * the 1st element), and also useful for dumping the regnode.
10233          * The 2nd element stores the multicharacter foldings,
10234          * used later (regexec.c:S_reginclass()). */
10235         av_store(av, 0, listsv);
10236         av_store(av, 1, NULL);
10237         av_store(av, 2, MUTABLE_SV(unicode_alternate));
10238         rv = newRV_noinc(MUTABLE_SV(av));
10239         n = add_data(pRExC_state, 1, "s");
10240         RExC_rxi->data->data[n] = (void*)rv;
10241         ARG_SET(ret, n);
10242     }
10243     return ret;
10244 }
10245 #undef _C_C_T_
10246
10247
10248 /* reg_skipcomment()
10249
10250    Absorbs an /x style # comments from the input stream.
10251    Returns true if there is more text remaining in the stream.
10252    Will set the REG_SEEN_RUN_ON_COMMENT flag if the comment
10253    terminates the pattern without including a newline.
10254
10255    Note its the callers responsibility to ensure that we are
10256    actually in /x mode
10257
10258 */
10259
10260 STATIC bool
10261 S_reg_skipcomment(pTHX_ RExC_state_t *pRExC_state)
10262 {
10263     bool ended = 0;
10264
10265     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
10266
10267     while (RExC_parse < RExC_end)
10268         if (*RExC_parse++ == '\n') {
10269             ended = 1;
10270             break;
10271         }
10272     if (!ended) {
10273         /* we ran off the end of the pattern without ending
10274            the comment, so we have to add an \n when wrapping */
10275         RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
10276         return 0;
10277     } else
10278         return 1;
10279 }
10280
10281 /* nextchar()
10282
10283    Advances the parse position, and optionally absorbs
10284    "whitespace" from the inputstream.
10285
10286    Without /x "whitespace" means (?#...) style comments only,
10287    with /x this means (?#...) and # comments and whitespace proper.
10288
10289    Returns the RExC_parse point from BEFORE the scan occurs.
10290
10291    This is the /x friendly way of saying RExC_parse++.
10292 */
10293
10294 STATIC char*
10295 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
10296 {
10297     char* const retval = RExC_parse++;
10298
10299     PERL_ARGS_ASSERT_NEXTCHAR;
10300
10301     for (;;) {
10302         if (*RExC_parse == '(' && RExC_parse[1] == '?' &&
10303                 RExC_parse[2] == '#') {
10304             while (*RExC_parse != ')') {
10305                 if (RExC_parse == RExC_end)
10306                     FAIL("Sequence (?#... not terminated");
10307                 RExC_parse++;
10308             }
10309             RExC_parse++;
10310             continue;
10311         }
10312         if (RExC_flags & RXf_PMf_EXTENDED) {
10313             if (isSPACE(*RExC_parse)) {
10314                 RExC_parse++;
10315                 continue;
10316             }
10317             else if (*RExC_parse == '#') {
10318                 if ( reg_skipcomment( pRExC_state ) )
10319                     continue;
10320             }
10321         }
10322         return retval;
10323     }
10324 }
10325
10326 /*
10327 - reg_node - emit a node
10328 */
10329 STATIC regnode *                        /* Location. */
10330 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
10331 {
10332     dVAR;
10333     register regnode *ptr;
10334     regnode * const ret = RExC_emit;
10335     GET_RE_DEBUG_FLAGS_DECL;
10336
10337     PERL_ARGS_ASSERT_REG_NODE;
10338
10339     if (SIZE_ONLY) {
10340         SIZE_ALIGN(RExC_size);
10341         RExC_size += 1;
10342         return(ret);
10343     }
10344     if (RExC_emit >= RExC_emit_bound)
10345         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d", op);
10346
10347     NODE_ALIGN_FILL(ret);
10348     ptr = ret;
10349     FILL_ADVANCE_NODE(ptr, op);
10350     REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (ptr) - 1);
10351 #ifdef RE_TRACK_PATTERN_OFFSETS
10352     if (RExC_offsets) {         /* MJD */
10353         MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n", 
10354               "reg_node", __LINE__, 
10355               PL_reg_name[op],
10356               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] 
10357                 ? "Overwriting end of array!\n" : "OK",
10358               (UV)(RExC_emit - RExC_emit_start),
10359               (UV)(RExC_parse - RExC_start),
10360               (UV)RExC_offsets[0])); 
10361         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
10362     }
10363 #endif
10364     RExC_emit = ptr;
10365     return(ret);
10366 }
10367
10368 /*
10369 - reganode - emit a node with an argument
10370 */
10371 STATIC regnode *                        /* Location. */
10372 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
10373 {
10374     dVAR;
10375     register regnode *ptr;
10376     regnode * const ret = RExC_emit;
10377     GET_RE_DEBUG_FLAGS_DECL;
10378
10379     PERL_ARGS_ASSERT_REGANODE;
10380
10381     if (SIZE_ONLY) {
10382         SIZE_ALIGN(RExC_size);
10383         RExC_size += 2;
10384         /* 
10385            We can't do this:
10386            
10387            assert(2==regarglen[op]+1); 
10388         
10389            Anything larger than this has to allocate the extra amount.
10390            If we changed this to be:
10391            
10392            RExC_size += (1 + regarglen[op]);
10393            
10394            then it wouldn't matter. Its not clear what side effect
10395            might come from that so its not done so far.
10396            -- dmq
10397         */
10398         return(ret);
10399     }
10400     if (RExC_emit >= RExC_emit_bound)
10401         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d", op);
10402
10403     NODE_ALIGN_FILL(ret);
10404     ptr = ret;
10405     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
10406     REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (ptr) - 2);
10407 #ifdef RE_TRACK_PATTERN_OFFSETS
10408     if (RExC_offsets) {         /* MJD */
10409         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
10410               "reganode",
10411               __LINE__,
10412               PL_reg_name[op],
10413               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? 
10414               "Overwriting end of array!\n" : "OK",
10415               (UV)(RExC_emit - RExC_emit_start),
10416               (UV)(RExC_parse - RExC_start),
10417               (UV)RExC_offsets[0])); 
10418         Set_Cur_Node_Offset;
10419     }
10420 #endif            
10421     RExC_emit = ptr;
10422     return(ret);
10423 }
10424
10425 /*
10426 - reguni - emit (if appropriate) a Unicode character
10427 */
10428 STATIC STRLEN
10429 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
10430 {
10431     dVAR;
10432
10433     PERL_ARGS_ASSERT_REGUNI;
10434
10435     return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
10436 }
10437
10438 /*
10439 - reginsert - insert an operator in front of already-emitted operand
10440 *
10441 * Means relocating the operand.
10442 */
10443 STATIC void
10444 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
10445 {
10446     dVAR;
10447     register regnode *src;
10448     register regnode *dst;
10449     register regnode *place;
10450     const int offset = regarglen[(U8)op];
10451     const int size = NODE_STEP_REGNODE + offset;
10452     GET_RE_DEBUG_FLAGS_DECL;
10453
10454     PERL_ARGS_ASSERT_REGINSERT;
10455     PERL_UNUSED_ARG(depth);
10456 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
10457     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
10458     if (SIZE_ONLY) {
10459         RExC_size += size;
10460         return;
10461     }
10462
10463     src = RExC_emit;
10464     RExC_emit += size;
10465     dst = RExC_emit;
10466     if (RExC_open_parens) {
10467         int paren;
10468         /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
10469         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
10470             if ( RExC_open_parens[paren] >= opnd ) {
10471                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
10472                 RExC_open_parens[paren] += size;
10473             } else {
10474                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
10475             }
10476             if ( RExC_close_parens[paren] >= opnd ) {
10477                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
10478                 RExC_close_parens[paren] += size;
10479             } else {
10480                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
10481             }
10482         }
10483     }
10484
10485     while (src > opnd) {
10486         StructCopy(--src, --dst, regnode);
10487 #ifdef RE_TRACK_PATTERN_OFFSETS
10488         if (RExC_offsets) {     /* MJD 20010112 */
10489             MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
10490                   "reg_insert",
10491                   __LINE__,
10492                   PL_reg_name[op],
10493                   (UV)(dst - RExC_emit_start) > RExC_offsets[0] 
10494                     ? "Overwriting end of array!\n" : "OK",
10495                   (UV)(src - RExC_emit_start),
10496                   (UV)(dst - RExC_emit_start),
10497                   (UV)RExC_offsets[0])); 
10498             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
10499             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
10500         }
10501 #endif
10502     }
10503     
10504
10505     place = opnd;               /* Op node, where operand used to be. */
10506 #ifdef RE_TRACK_PATTERN_OFFSETS
10507     if (RExC_offsets) {         /* MJD */
10508         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
10509               "reginsert",
10510               __LINE__,
10511               PL_reg_name[op],
10512               (UV)(place - RExC_emit_start) > RExC_offsets[0] 
10513               ? "Overwriting end of array!\n" : "OK",
10514               (UV)(place - RExC_emit_start),
10515               (UV)(RExC_parse - RExC_start),
10516               (UV)RExC_offsets[0]));
10517         Set_Node_Offset(place, RExC_parse);
10518         Set_Node_Length(place, 1);
10519     }
10520 #endif    
10521     src = NEXTOPER(place);
10522     FILL_ADVANCE_NODE(place, op);
10523     REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (place) - 1);
10524     Zero(src, offset, regnode);
10525 }
10526
10527 /*
10528 - regtail - set the next-pointer at the end of a node chain of p to val.
10529 - SEE ALSO: regtail_study
10530 */
10531 /* TODO: All three parms should be const */
10532 STATIC void
10533 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
10534 {
10535     dVAR;
10536     register regnode *scan;
10537     GET_RE_DEBUG_FLAGS_DECL;
10538
10539     PERL_ARGS_ASSERT_REGTAIL;
10540 #ifndef DEBUGGING
10541     PERL_UNUSED_ARG(depth);
10542 #endif
10543
10544     if (SIZE_ONLY)
10545         return;
10546
10547     /* Find last node. */
10548     scan = p;
10549     for (;;) {
10550         regnode * const temp = regnext(scan);
10551         DEBUG_PARSE_r({
10552             SV * const mysv=sv_newmortal();
10553             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
10554             regprop(RExC_rx, mysv, scan);
10555             PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
10556                 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
10557                     (temp == NULL ? "->" : ""),
10558                     (temp == NULL ? PL_reg_name[OP(val)] : "")
10559             );
10560         });
10561         if (temp == NULL)
10562             break;
10563         scan = temp;
10564     }
10565
10566     if (reg_off_by_arg[OP(scan)]) {
10567         ARG_SET(scan, val - scan);
10568     }
10569     else {
10570         NEXT_OFF(scan) = val - scan;
10571     }
10572 }
10573
10574 #ifdef DEBUGGING
10575 /*
10576 - regtail_study - set the next-pointer at the end of a node chain of p to val.
10577 - Look for optimizable sequences at the same time.
10578 - currently only looks for EXACT chains.
10579
10580 This is experimental code. The idea is to use this routine to perform 
10581 in place optimizations on branches and groups as they are constructed,
10582 with the long term intention of removing optimization from study_chunk so
10583 that it is purely analytical.
10584
10585 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
10586 to control which is which.
10587
10588 */
10589 /* TODO: All four parms should be const */
10590
10591 STATIC U8
10592 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
10593 {
10594     dVAR;
10595     register regnode *scan;
10596     U8 exact = PSEUDO;
10597 #ifdef EXPERIMENTAL_INPLACESCAN
10598     I32 min = 0;
10599 #endif
10600     GET_RE_DEBUG_FLAGS_DECL;
10601
10602     PERL_ARGS_ASSERT_REGTAIL_STUDY;
10603
10604
10605     if (SIZE_ONLY)
10606         return exact;
10607
10608     /* Find last node. */
10609
10610     scan = p;
10611     for (;;) {
10612         regnode * const temp = regnext(scan);
10613 #ifdef EXPERIMENTAL_INPLACESCAN
10614         if (PL_regkind[OP(scan)] == EXACT)
10615             if (join_exact(pRExC_state,scan,&min,1,val,depth+1))
10616                 return EXACT;
10617 #endif
10618         if ( exact ) {
10619             switch (OP(scan)) {
10620                 case EXACT:
10621                 case EXACTF:
10622                 case EXACTFA:
10623                 case EXACTFU:
10624                 case EXACTFL:
10625                         if( exact == PSEUDO )
10626                             exact= OP(scan);
10627                         else if ( exact != OP(scan) )
10628                             exact= 0;
10629                 case NOTHING:
10630                     break;
10631                 default:
10632                     exact= 0;
10633             }
10634         }
10635         DEBUG_PARSE_r({
10636             SV * const mysv=sv_newmortal();
10637             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
10638             regprop(RExC_rx, mysv, scan);
10639             PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
10640                 SvPV_nolen_const(mysv),
10641                 REG_NODE_NUM(scan),
10642                 PL_reg_name[exact]);
10643         });
10644         if (temp == NULL)
10645             break;
10646         scan = temp;
10647     }
10648     DEBUG_PARSE_r({
10649         SV * const mysv_val=sv_newmortal();
10650         DEBUG_PARSE_MSG("");
10651         regprop(RExC_rx, mysv_val, val);
10652         PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
10653                       SvPV_nolen_const(mysv_val),
10654                       (IV)REG_NODE_NUM(val),
10655                       (IV)(val - scan)
10656         );
10657     });
10658     if (reg_off_by_arg[OP(scan)]) {
10659         ARG_SET(scan, val - scan);
10660     }
10661     else {
10662         NEXT_OFF(scan) = val - scan;
10663     }
10664
10665     return exact;
10666 }
10667 #endif
10668
10669 /*
10670  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
10671  */
10672 #ifdef DEBUGGING
10673 static void 
10674 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
10675 {
10676     int bit;
10677     int set=0;
10678     regex_charset cs;
10679
10680     for (bit=0; bit<32; bit++) {
10681         if (flags & (1<<bit)) {
10682             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
10683                 continue;
10684             }
10685             if (!set++ && lead) 
10686                 PerlIO_printf(Perl_debug_log, "%s",lead);
10687             PerlIO_printf(Perl_debug_log, "%s ",PL_reg_extflags_name[bit]);
10688         }               
10689     }      
10690     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
10691             if (!set++ && lead) {
10692                 PerlIO_printf(Perl_debug_log, "%s",lead);
10693             }
10694             switch (cs) {
10695                 case REGEX_UNICODE_CHARSET:
10696                     PerlIO_printf(Perl_debug_log, "UNICODE");
10697                     break;
10698                 case REGEX_LOCALE_CHARSET:
10699                     PerlIO_printf(Perl_debug_log, "LOCALE");
10700                     break;
10701                 case REGEX_ASCII_RESTRICTED_CHARSET:
10702                     PerlIO_printf(Perl_debug_log, "ASCII-RESTRICTED");
10703                     break;
10704                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
10705                     PerlIO_printf(Perl_debug_log, "ASCII-MORE_RESTRICTED");
10706                     break;
10707                 default:
10708                     PerlIO_printf(Perl_debug_log, "UNKNOWN CHARACTER SET");
10709                     break;
10710             }
10711     }
10712     if (lead)  {
10713         if (set) 
10714             PerlIO_printf(Perl_debug_log, "\n");
10715         else 
10716             PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
10717     }            
10718 }   
10719 #endif
10720
10721 void
10722 Perl_regdump(pTHX_ const regexp *r)
10723 {
10724 #ifdef DEBUGGING
10725     dVAR;
10726     SV * const sv = sv_newmortal();
10727     SV *dsv= sv_newmortal();
10728     RXi_GET_DECL(r,ri);
10729     GET_RE_DEBUG_FLAGS_DECL;
10730
10731     PERL_ARGS_ASSERT_REGDUMP;
10732
10733     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
10734
10735     /* Header fields of interest. */
10736     if (r->anchored_substr) {
10737         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr), 
10738             RE_SV_DUMPLEN(r->anchored_substr), 30);
10739         PerlIO_printf(Perl_debug_log,
10740                       "anchored %s%s at %"IVdf" ",
10741                       s, RE_SV_TAIL(r->anchored_substr),
10742                       (IV)r->anchored_offset);
10743     } else if (r->anchored_utf8) {
10744         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8), 
10745             RE_SV_DUMPLEN(r->anchored_utf8), 30);
10746         PerlIO_printf(Perl_debug_log,
10747                       "anchored utf8 %s%s at %"IVdf" ",
10748                       s, RE_SV_TAIL(r->anchored_utf8),
10749                       (IV)r->anchored_offset);
10750     }                 
10751     if (r->float_substr) {
10752         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr), 
10753             RE_SV_DUMPLEN(r->float_substr), 30);
10754         PerlIO_printf(Perl_debug_log,
10755                       "floating %s%s at %"IVdf"..%"UVuf" ",
10756                       s, RE_SV_TAIL(r->float_substr),
10757                       (IV)r->float_min_offset, (UV)r->float_max_offset);
10758     } else if (r->float_utf8) {
10759         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8), 
10760             RE_SV_DUMPLEN(r->float_utf8), 30);
10761         PerlIO_printf(Perl_debug_log,
10762                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
10763                       s, RE_SV_TAIL(r->float_utf8),
10764                       (IV)r->float_min_offset, (UV)r->float_max_offset);
10765     }
10766     if (r->check_substr || r->check_utf8)
10767         PerlIO_printf(Perl_debug_log,
10768                       (const char *)
10769                       (r->check_substr == r->float_substr
10770                        && r->check_utf8 == r->float_utf8
10771                        ? "(checking floating" : "(checking anchored"));
10772     if (r->extflags & RXf_NOSCAN)
10773         PerlIO_printf(Perl_debug_log, " noscan");
10774     if (r->extflags & RXf_CHECK_ALL)
10775         PerlIO_printf(Perl_debug_log, " isall");
10776     if (r->check_substr || r->check_utf8)
10777         PerlIO_printf(Perl_debug_log, ") ");
10778
10779     if (ri->regstclass) {
10780         regprop(r, sv, ri->regstclass);
10781         PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
10782     }
10783     if (r->extflags & RXf_ANCH) {
10784         PerlIO_printf(Perl_debug_log, "anchored");
10785         if (r->extflags & RXf_ANCH_BOL)
10786             PerlIO_printf(Perl_debug_log, "(BOL)");
10787         if (r->extflags & RXf_ANCH_MBOL)
10788             PerlIO_printf(Perl_debug_log, "(MBOL)");
10789         if (r->extflags & RXf_ANCH_SBOL)
10790             PerlIO_printf(Perl_debug_log, "(SBOL)");
10791         if (r->extflags & RXf_ANCH_GPOS)
10792             PerlIO_printf(Perl_debug_log, "(GPOS)");
10793         PerlIO_putc(Perl_debug_log, ' ');
10794     }
10795     if (r->extflags & RXf_GPOS_SEEN)
10796         PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
10797     if (r->intflags & PREGf_SKIP)
10798         PerlIO_printf(Perl_debug_log, "plus ");
10799     if (r->intflags & PREGf_IMPLICIT)
10800         PerlIO_printf(Perl_debug_log, "implicit ");
10801     PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
10802     if (r->extflags & RXf_EVAL_SEEN)
10803         PerlIO_printf(Perl_debug_log, "with eval ");
10804     PerlIO_printf(Perl_debug_log, "\n");
10805     DEBUG_FLAGS_r(regdump_extflags("r->extflags: ",r->extflags));            
10806 #else
10807     PERL_ARGS_ASSERT_REGDUMP;
10808     PERL_UNUSED_CONTEXT;
10809     PERL_UNUSED_ARG(r);
10810 #endif  /* DEBUGGING */
10811 }
10812
10813 /*
10814 - regprop - printable representation of opcode
10815 */
10816 #define EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags) \
10817 STMT_START { \
10818         if (do_sep) {                           \
10819             Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]); \
10820             if (flags & ANYOF_INVERT)           \
10821                 /*make sure the invert info is in each */ \
10822                 sv_catpvs(sv, "^");             \
10823             do_sep = 0;                         \
10824         }                                       \
10825 } STMT_END
10826
10827 void
10828 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
10829 {
10830 #ifdef DEBUGGING
10831     dVAR;
10832     register int k;
10833     RXi_GET_DECL(prog,progi);
10834     GET_RE_DEBUG_FLAGS_DECL;
10835     
10836     PERL_ARGS_ASSERT_REGPROP;
10837
10838     sv_setpvs(sv, "");
10839
10840     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
10841         /* It would be nice to FAIL() here, but this may be called from
10842            regexec.c, and it would be hard to supply pRExC_state. */
10843         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
10844     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
10845
10846     k = PL_regkind[OP(o)];
10847
10848     if (k == EXACT) {
10849         sv_catpvs(sv, " ");
10850         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT) 
10851          * is a crude hack but it may be the best for now since 
10852          * we have no flag "this EXACTish node was UTF-8" 
10853          * --jhi */
10854         pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
10855                   PERL_PV_ESCAPE_UNI_DETECT |
10856                   PERL_PV_ESCAPE_NONASCII   |
10857                   PERL_PV_PRETTY_ELLIPSES   |
10858                   PERL_PV_PRETTY_LTGT       |
10859                   PERL_PV_PRETTY_NOCLEAR
10860                   );
10861     } else if (k == TRIE) {
10862         /* print the details of the trie in dumpuntil instead, as
10863          * progi->data isn't available here */
10864         const char op = OP(o);
10865         const U32 n = ARG(o);
10866         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
10867                (reg_ac_data *)progi->data->data[n] :
10868                NULL;
10869         const reg_trie_data * const trie
10870             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
10871         
10872         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
10873         DEBUG_TRIE_COMPILE_r(
10874             Perl_sv_catpvf(aTHX_ sv,
10875                 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
10876                 (UV)trie->startstate,
10877                 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
10878                 (UV)trie->wordcount,
10879                 (UV)trie->minlen,
10880                 (UV)trie->maxlen,
10881                 (UV)TRIE_CHARCOUNT(trie),
10882                 (UV)trie->uniquecharcount
10883             )
10884         );
10885         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
10886             int i;
10887             int rangestart = -1;
10888             U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
10889             sv_catpvs(sv, "[");
10890             for (i = 0; i <= 256; i++) {
10891                 if (i < 256 && BITMAP_TEST(bitmap,i)) {
10892                     if (rangestart == -1)
10893                         rangestart = i;
10894                 } else if (rangestart != -1) {
10895                     if (i <= rangestart + 3)
10896                         for (; rangestart < i; rangestart++)
10897                             put_byte(sv, rangestart);
10898                     else {
10899                         put_byte(sv, rangestart);
10900                         sv_catpvs(sv, "-");
10901                         put_byte(sv, i - 1);
10902                     }
10903                     rangestart = -1;
10904                 }
10905             }
10906             sv_catpvs(sv, "]");
10907         } 
10908          
10909     } else if (k == CURLY) {
10910         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
10911             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
10912         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
10913     }
10914     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
10915         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
10916     else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
10917         Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
10918         if ( RXp_PAREN_NAMES(prog) ) {
10919             if ( k != REF || (OP(o) < NREF)) {
10920                 AV *list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
10921                 SV **name= av_fetch(list, ARG(o), 0 );
10922                 if (name)
10923                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
10924             }       
10925             else {
10926                 AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]);
10927                 SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]);
10928                 I32 *nums=(I32*)SvPVX(sv_dat);
10929                 SV **name= av_fetch(list, nums[0], 0 );
10930                 I32 n;
10931                 if (name) {
10932                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
10933                         Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
10934                                     (n ? "," : ""), (IV)nums[n]);
10935                     }
10936                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
10937                 }
10938             }
10939         }            
10940     } else if (k == GOSUB) 
10941         Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
10942     else if (k == VERB) {
10943         if (!o->flags) 
10944             Perl_sv_catpvf(aTHX_ sv, ":%"SVf, 
10945                            SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
10946     } else if (k == LOGICAL)
10947         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);     /* 2: embedded, otherwise 1 */
10948     else if (k == FOLDCHAR)
10949         Perl_sv_catpvf(aTHX_ sv, "[0x%"UVXf"]", PTR2UV(ARG(o)) );
10950     else if (k == ANYOF) {
10951         int i, rangestart = -1;
10952         const U8 flags = ANYOF_FLAGS(o);
10953         int do_sep = 0;
10954
10955         /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
10956         static const char * const anyofs[] = {
10957             "\\w",
10958             "\\W",
10959             "\\s",
10960             "\\S",
10961             "\\d",
10962             "\\D",
10963             "[:alnum:]",
10964             "[:^alnum:]",
10965             "[:alpha:]",
10966             "[:^alpha:]",
10967             "[:ascii:]",
10968             "[:^ascii:]",
10969             "[:cntrl:]",
10970             "[:^cntrl:]",
10971             "[:graph:]",
10972             "[:^graph:]",
10973             "[:lower:]",
10974             "[:^lower:]",
10975             "[:print:]",
10976             "[:^print:]",
10977             "[:punct:]",
10978             "[:^punct:]",
10979             "[:upper:]",
10980             "[:^upper:]",
10981             "[:xdigit:]",
10982             "[:^xdigit:]",
10983             "[:space:]",
10984             "[:^space:]",
10985             "[:blank:]",
10986             "[:^blank:]"
10987         };
10988
10989         if (flags & ANYOF_LOCALE)
10990             sv_catpvs(sv, "{loc}");
10991         if (flags & ANYOF_LOC_NONBITMAP_FOLD)
10992             sv_catpvs(sv, "{i}");
10993         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
10994         if (flags & ANYOF_INVERT)
10995             sv_catpvs(sv, "^");
10996         
10997         /* output what the standard cp 0-255 bitmap matches */
10998         for (i = 0; i <= 256; i++) {
10999             if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
11000                 if (rangestart == -1)
11001                     rangestart = i;
11002             } else if (rangestart != -1) {
11003                 if (i <= rangestart + 3)
11004                     for (; rangestart < i; rangestart++)
11005                         put_byte(sv, rangestart);
11006                 else {
11007                     put_byte(sv, rangestart);
11008                     sv_catpvs(sv, "-");
11009                     put_byte(sv, i - 1);
11010                 }
11011                 do_sep = 1;
11012                 rangestart = -1;
11013             }
11014         }
11015         
11016         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
11017         /* output any special charclass tests (used entirely under use locale) */
11018         if (ANYOF_CLASS_TEST_ANY_SET(o))
11019             for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
11020                 if (ANYOF_CLASS_TEST(o,i)) {
11021                     sv_catpv(sv, anyofs[i]);
11022                     do_sep = 1;
11023                 }
11024         
11025         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
11026         
11027         if (flags & ANYOF_NON_UTF8_LATIN1_ALL) {
11028             sv_catpvs(sv, "{non-utf8-latin1-all}");
11029         }
11030
11031         /* output information about the unicode matching */
11032         if (flags & ANYOF_UNICODE_ALL)
11033             sv_catpvs(sv, "{unicode_all}");
11034         else if (flags & ANYOF_UTF8)
11035             sv_catpvs(sv, "{unicode}");
11036         if (flags & ANYOF_NONBITMAP_NON_UTF8)
11037             sv_catpvs(sv, "{outside bitmap}");
11038
11039         {
11040             SV *lv;
11041             SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
11042         
11043             if (lv) {
11044                 if (sw) {
11045                     U8 s[UTF8_MAXBYTES_CASE+1];
11046
11047                     for (i = 0; i <= 256; i++) { /* just the first 256 */
11048                         uvchr_to_utf8(s, i);
11049                         
11050                         if (i < 256 && swash_fetch(sw, s, TRUE)) {
11051                             if (rangestart == -1)
11052                                 rangestart = i;
11053                         } else if (rangestart != -1) {
11054                             if (i <= rangestart + 3)
11055                                 for (; rangestart < i; rangestart++) {
11056                                     const U8 * const e = uvchr_to_utf8(s,rangestart);
11057                                     U8 *p;
11058                                     for(p = s; p < e; p++)
11059                                         put_byte(sv, *p);
11060                                 }
11061                             else {
11062                                 const U8 *e = uvchr_to_utf8(s,rangestart);
11063                                 U8 *p;
11064                                 for (p = s; p < e; p++)
11065                                     put_byte(sv, *p);
11066                                 sv_catpvs(sv, "-");
11067                                 e = uvchr_to_utf8(s, i-1);
11068                                 for (p = s; p < e; p++)
11069                                     put_byte(sv, *p);
11070                                 }
11071                                 rangestart = -1;
11072                             }
11073                         }
11074                         
11075                     sv_catpvs(sv, "..."); /* et cetera */
11076                 }
11077
11078                 {
11079                     char *s = savesvpv(lv);
11080                     char * const origs = s;
11081                 
11082                     while (*s && *s != '\n')
11083                         s++;
11084                 
11085                     if (*s == '\n') {
11086                         const char * const t = ++s;
11087                         
11088                         while (*s) {
11089                             if (*s == '\n')
11090                                 *s = ' ';
11091                             s++;
11092                         }
11093                         if (s[-1] == ' ')
11094                             s[-1] = 0;
11095                         
11096                         sv_catpv(sv, t);
11097                     }
11098                 
11099                     Safefree(origs);
11100                 }
11101             }
11102         }
11103
11104         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
11105     }
11106     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
11107         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
11108 #else
11109     PERL_UNUSED_CONTEXT;
11110     PERL_UNUSED_ARG(sv);
11111     PERL_UNUSED_ARG(o);
11112     PERL_UNUSED_ARG(prog);
11113 #endif  /* DEBUGGING */
11114 }
11115
11116 SV *
11117 Perl_re_intuit_string(pTHX_ REGEXP * const r)
11118 {                               /* Assume that RE_INTUIT is set */
11119     dVAR;
11120     struct regexp *const prog = (struct regexp *)SvANY(r);
11121     GET_RE_DEBUG_FLAGS_DECL;
11122
11123     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
11124     PERL_UNUSED_CONTEXT;
11125
11126     DEBUG_COMPILE_r(
11127         {
11128             const char * const s = SvPV_nolen_const(prog->check_substr
11129                       ? prog->check_substr : prog->check_utf8);
11130
11131             if (!PL_colorset) reginitcolors();
11132             PerlIO_printf(Perl_debug_log,
11133                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
11134                       PL_colors[4],
11135                       prog->check_substr ? "" : "utf8 ",
11136                       PL_colors[5],PL_colors[0],
11137                       s,
11138                       PL_colors[1],
11139                       (strlen(s) > 60 ? "..." : ""));
11140         } );
11141
11142     return prog->check_substr ? prog->check_substr : prog->check_utf8;
11143 }
11144
11145 /* 
11146    pregfree() 
11147    
11148    handles refcounting and freeing the perl core regexp structure. When 
11149    it is necessary to actually free the structure the first thing it 
11150    does is call the 'free' method of the regexp_engine associated to
11151    the regexp, allowing the handling of the void *pprivate; member 
11152    first. (This routine is not overridable by extensions, which is why 
11153    the extensions free is called first.)
11154    
11155    See regdupe and regdupe_internal if you change anything here. 
11156 */
11157 #ifndef PERL_IN_XSUB_RE
11158 void
11159 Perl_pregfree(pTHX_ REGEXP *r)
11160 {
11161     SvREFCNT_dec(r);
11162 }
11163
11164 void
11165 Perl_pregfree2(pTHX_ REGEXP *rx)
11166 {
11167     dVAR;
11168     struct regexp *const r = (struct regexp *)SvANY(rx);
11169     GET_RE_DEBUG_FLAGS_DECL;
11170
11171     PERL_ARGS_ASSERT_PREGFREE2;
11172
11173     if (r->mother_re) {
11174         ReREFCNT_dec(r->mother_re);
11175     } else {
11176         CALLREGFREE_PVT(rx); /* free the private data */
11177         SvREFCNT_dec(RXp_PAREN_NAMES(r));
11178     }        
11179     if (r->substrs) {
11180         SvREFCNT_dec(r->anchored_substr);
11181         SvREFCNT_dec(r->anchored_utf8);
11182         SvREFCNT_dec(r->float_substr);
11183         SvREFCNT_dec(r->float_utf8);
11184         Safefree(r->substrs);
11185     }
11186     RX_MATCH_COPY_FREE(rx);
11187 #ifdef PERL_OLD_COPY_ON_WRITE
11188     SvREFCNT_dec(r->saved_copy);
11189 #endif
11190     Safefree(r->offs);
11191 }
11192
11193 /*  reg_temp_copy()
11194     
11195     This is a hacky workaround to the structural issue of match results
11196     being stored in the regexp structure which is in turn stored in
11197     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
11198     could be PL_curpm in multiple contexts, and could require multiple
11199     result sets being associated with the pattern simultaneously, such
11200     as when doing a recursive match with (??{$qr})
11201     
11202     The solution is to make a lightweight copy of the regexp structure 
11203     when a qr// is returned from the code executed by (??{$qr}) this
11204     lightweight copy doesn't actually own any of its data except for
11205     the starp/end and the actual regexp structure itself. 
11206     
11207 */    
11208     
11209     
11210 REGEXP *
11211 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
11212 {
11213     struct regexp *ret;
11214     struct regexp *const r = (struct regexp *)SvANY(rx);
11215     register const I32 npar = r->nparens+1;
11216
11217     PERL_ARGS_ASSERT_REG_TEMP_COPY;
11218
11219     if (!ret_x)
11220         ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
11221     ret = (struct regexp *)SvANY(ret_x);
11222     
11223     (void)ReREFCNT_inc(rx);
11224     /* We can take advantage of the existing "copied buffer" mechanism in SVs
11225        by pointing directly at the buffer, but flagging that the allocated
11226        space in the copy is zero. As we've just done a struct copy, it's now
11227        a case of zero-ing that, rather than copying the current length.  */
11228     SvPV_set(ret_x, RX_WRAPPED(rx));
11229     SvFLAGS(ret_x) |= SvFLAGS(rx) & (SVf_POK|SVp_POK|SVf_UTF8);
11230     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
11231            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
11232     SvLEN_set(ret_x, 0);
11233     SvSTASH_set(ret_x, NULL);
11234     SvMAGIC_set(ret_x, NULL);
11235     Newx(ret->offs, npar, regexp_paren_pair);
11236     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
11237     if (r->substrs) {
11238         Newx(ret->substrs, 1, struct reg_substr_data);
11239         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
11240
11241         SvREFCNT_inc_void(ret->anchored_substr);
11242         SvREFCNT_inc_void(ret->anchored_utf8);
11243         SvREFCNT_inc_void(ret->float_substr);
11244         SvREFCNT_inc_void(ret->float_utf8);
11245
11246         /* check_substr and check_utf8, if non-NULL, point to either their
11247            anchored or float namesakes, and don't hold a second reference.  */
11248     }
11249     RX_MATCH_COPIED_off(ret_x);
11250 #ifdef PERL_OLD_COPY_ON_WRITE
11251     ret->saved_copy = NULL;
11252 #endif
11253     ret->mother_re = rx;
11254     
11255     return ret_x;
11256 }
11257 #endif
11258
11259 /* regfree_internal() 
11260
11261    Free the private data in a regexp. This is overloadable by 
11262    extensions. Perl takes care of the regexp structure in pregfree(), 
11263    this covers the *pprivate pointer which technically perl doesn't 
11264    know about, however of course we have to handle the 
11265    regexp_internal structure when no extension is in use. 
11266    
11267    Note this is called before freeing anything in the regexp 
11268    structure. 
11269  */
11270  
11271 void
11272 Perl_regfree_internal(pTHX_ REGEXP * const rx)
11273 {
11274     dVAR;
11275     struct regexp *const r = (struct regexp *)SvANY(rx);
11276     RXi_GET_DECL(r,ri);
11277     GET_RE_DEBUG_FLAGS_DECL;
11278
11279     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
11280
11281     DEBUG_COMPILE_r({
11282         if (!PL_colorset)
11283             reginitcolors();
11284         {
11285             SV *dsv= sv_newmortal();
11286             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
11287                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
11288             PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n", 
11289                 PL_colors[4],PL_colors[5],s);
11290         }
11291     });
11292 #ifdef RE_TRACK_PATTERN_OFFSETS
11293     if (ri->u.offsets)
11294         Safefree(ri->u.offsets);             /* 20010421 MJD */
11295 #endif
11296     if (ri->data) {
11297         int n = ri->data->count;
11298         PAD* new_comppad = NULL;
11299         PAD* old_comppad;
11300         PADOFFSET refcnt;
11301
11302         while (--n >= 0) {
11303           /* If you add a ->what type here, update the comment in regcomp.h */
11304             switch (ri->data->what[n]) {
11305             case 'a':
11306             case 's':
11307             case 'S':
11308             case 'u':
11309                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
11310                 break;
11311             case 'f':
11312                 Safefree(ri->data->data[n]);
11313                 break;
11314             case 'p':
11315                 new_comppad = MUTABLE_AV(ri->data->data[n]);
11316                 break;
11317             case 'o':
11318                 if (new_comppad == NULL)
11319                     Perl_croak(aTHX_ "panic: pregfree comppad");
11320                 PAD_SAVE_LOCAL(old_comppad,
11321                     /* Watch out for global destruction's random ordering. */
11322                     (SvTYPE(new_comppad) == SVt_PVAV) ? new_comppad : NULL
11323                 );
11324                 OP_REFCNT_LOCK;
11325                 refcnt = OpREFCNT_dec((OP_4tree*)ri->data->data[n]);
11326                 OP_REFCNT_UNLOCK;
11327                 if (!refcnt)
11328                     op_free((OP_4tree*)ri->data->data[n]);
11329
11330                 PAD_RESTORE_LOCAL(old_comppad);
11331                 SvREFCNT_dec(MUTABLE_SV(new_comppad));
11332                 new_comppad = NULL;
11333                 break;
11334             case 'n':
11335                 break;
11336             case 'T':           
11337                 { /* Aho Corasick add-on structure for a trie node.
11338                      Used in stclass optimization only */
11339                     U32 refcount;
11340                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
11341                     OP_REFCNT_LOCK;
11342                     refcount = --aho->refcount;
11343                     OP_REFCNT_UNLOCK;
11344                     if ( !refcount ) {
11345                         PerlMemShared_free(aho->states);
11346                         PerlMemShared_free(aho->fail);
11347                          /* do this last!!!! */
11348                         PerlMemShared_free(ri->data->data[n]);
11349                         PerlMemShared_free(ri->regstclass);
11350                     }
11351                 }
11352                 break;
11353             case 't':
11354                 {
11355                     /* trie structure. */
11356                     U32 refcount;
11357                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
11358                     OP_REFCNT_LOCK;
11359                     refcount = --trie->refcount;
11360                     OP_REFCNT_UNLOCK;
11361                     if ( !refcount ) {
11362                         PerlMemShared_free(trie->charmap);
11363                         PerlMemShared_free(trie->states);
11364                         PerlMemShared_free(trie->trans);
11365                         if (trie->bitmap)
11366                             PerlMemShared_free(trie->bitmap);
11367                         if (trie->jump)
11368                             PerlMemShared_free(trie->jump);
11369                         PerlMemShared_free(trie->wordinfo);
11370                         /* do this last!!!! */
11371                         PerlMemShared_free(ri->data->data[n]);
11372                     }
11373                 }
11374                 break;
11375             default:
11376                 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
11377             }
11378         }
11379         Safefree(ri->data->what);
11380         Safefree(ri->data);
11381     }
11382
11383     Safefree(ri);
11384 }
11385
11386 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
11387 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
11388 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
11389
11390 /* 
11391    re_dup - duplicate a regexp. 
11392    
11393    This routine is expected to clone a given regexp structure. It is only
11394    compiled under USE_ITHREADS.
11395
11396    After all of the core data stored in struct regexp is duplicated
11397    the regexp_engine.dupe method is used to copy any private data
11398    stored in the *pprivate pointer. This allows extensions to handle
11399    any duplication it needs to do.
11400
11401    See pregfree() and regfree_internal() if you change anything here. 
11402 */
11403 #if defined(USE_ITHREADS)
11404 #ifndef PERL_IN_XSUB_RE
11405 void
11406 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
11407 {
11408     dVAR;
11409     I32 npar;
11410     const struct regexp *r = (const struct regexp *)SvANY(sstr);
11411     struct regexp *ret = (struct regexp *)SvANY(dstr);
11412     
11413     PERL_ARGS_ASSERT_RE_DUP_GUTS;
11414
11415     npar = r->nparens+1;
11416     Newx(ret->offs, npar, regexp_paren_pair);
11417     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
11418     if(ret->swap) {
11419         /* no need to copy these */
11420         Newx(ret->swap, npar, regexp_paren_pair);
11421     }
11422
11423     if (ret->substrs) {
11424         /* Do it this way to avoid reading from *r after the StructCopy().
11425            That way, if any of the sv_dup_inc()s dislodge *r from the L1
11426            cache, it doesn't matter.  */
11427         const bool anchored = r->check_substr
11428             ? r->check_substr == r->anchored_substr
11429             : r->check_utf8 == r->anchored_utf8;
11430         Newx(ret->substrs, 1, struct reg_substr_data);
11431         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
11432
11433         ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
11434         ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
11435         ret->float_substr = sv_dup_inc(ret->float_substr, param);
11436         ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
11437
11438         /* check_substr and check_utf8, if non-NULL, point to either their
11439            anchored or float namesakes, and don't hold a second reference.  */
11440
11441         if (ret->check_substr) {
11442             if (anchored) {
11443                 assert(r->check_utf8 == r->anchored_utf8);
11444                 ret->check_substr = ret->anchored_substr;
11445                 ret->check_utf8 = ret->anchored_utf8;
11446             } else {
11447                 assert(r->check_substr == r->float_substr);
11448                 assert(r->check_utf8 == r->float_utf8);
11449                 ret->check_substr = ret->float_substr;
11450                 ret->check_utf8 = ret->float_utf8;
11451             }
11452         } else if (ret->check_utf8) {
11453             if (anchored) {
11454                 ret->check_utf8 = ret->anchored_utf8;
11455             } else {
11456                 ret->check_utf8 = ret->float_utf8;
11457             }
11458         }
11459     }
11460
11461     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
11462
11463     if (ret->pprivate)
11464         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
11465
11466     if (RX_MATCH_COPIED(dstr))
11467         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
11468     else
11469         ret->subbeg = NULL;
11470 #ifdef PERL_OLD_COPY_ON_WRITE
11471     ret->saved_copy = NULL;
11472 #endif
11473
11474     if (ret->mother_re) {
11475         if (SvPVX_const(dstr) == SvPVX_const(ret->mother_re)) {
11476             /* Our storage points directly to our mother regexp, but that's
11477                1: a buffer in a different thread
11478                2: something we no longer hold a reference on
11479                so we need to copy it locally.  */
11480             /* Note we need to sue SvCUR() on our mother_re, because it, in
11481                turn, may well be pointing to its own mother_re.  */
11482             SvPV_set(dstr, SAVEPVN(SvPVX_const(ret->mother_re),
11483                                    SvCUR(ret->mother_re)+1));
11484             SvLEN_set(dstr, SvCUR(ret->mother_re)+1);
11485         }
11486         ret->mother_re      = NULL;
11487     }
11488     ret->gofs = 0;
11489 }
11490 #endif /* PERL_IN_XSUB_RE */
11491
11492 /*
11493    regdupe_internal()
11494    
11495    This is the internal complement to regdupe() which is used to copy
11496    the structure pointed to by the *pprivate pointer in the regexp.
11497    This is the core version of the extension overridable cloning hook.
11498    The regexp structure being duplicated will be copied by perl prior
11499    to this and will be provided as the regexp *r argument, however 
11500    with the /old/ structures pprivate pointer value. Thus this routine
11501    may override any copying normally done by perl.
11502    
11503    It returns a pointer to the new regexp_internal structure.
11504 */
11505
11506 void *
11507 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
11508 {
11509     dVAR;
11510     struct regexp *const r = (struct regexp *)SvANY(rx);
11511     regexp_internal *reti;
11512     int len, npar;
11513     RXi_GET_DECL(r,ri);
11514
11515     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
11516     
11517     npar = r->nparens+1;
11518     len = ProgLen(ri);
11519     
11520     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), char, regexp_internal);
11521     Copy(ri->program, reti->program, len+1, regnode);
11522     
11523
11524     reti->regstclass = NULL;
11525
11526     if (ri->data) {
11527         struct reg_data *d;
11528         const int count = ri->data->count;
11529         int i;
11530
11531         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
11532                 char, struct reg_data);
11533         Newx(d->what, count, U8);
11534
11535         d->count = count;
11536         for (i = 0; i < count; i++) {
11537             d->what[i] = ri->data->what[i];
11538             switch (d->what[i]) {
11539                 /* legal options are one of: sSfpontTua
11540                    see also regcomp.h and pregfree() */
11541             case 'a': /* actually an AV, but the dup function is identical.  */
11542             case 's':
11543             case 'S':
11544             case 'p': /* actually an AV, but the dup function is identical.  */
11545             case 'u': /* actually an HV, but the dup function is identical.  */
11546                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
11547                 break;
11548             case 'f':
11549                 /* This is cheating. */
11550                 Newx(d->data[i], 1, struct regnode_charclass_class);
11551                 StructCopy(ri->data->data[i], d->data[i],
11552                             struct regnode_charclass_class);
11553                 reti->regstclass = (regnode*)d->data[i];
11554                 break;
11555             case 'o':
11556                 /* Compiled op trees are readonly and in shared memory,
11557                    and can thus be shared without duplication. */
11558                 OP_REFCNT_LOCK;
11559                 d->data[i] = (void*)OpREFCNT_inc((OP*)ri->data->data[i]);
11560                 OP_REFCNT_UNLOCK;
11561                 break;
11562             case 'T':
11563                 /* Trie stclasses are readonly and can thus be shared
11564                  * without duplication. We free the stclass in pregfree
11565                  * when the corresponding reg_ac_data struct is freed.
11566                  */
11567                 reti->regstclass= ri->regstclass;
11568                 /* Fall through */
11569             case 't':
11570                 OP_REFCNT_LOCK;
11571                 ((reg_trie_data*)ri->data->data[i])->refcount++;
11572                 OP_REFCNT_UNLOCK;
11573                 /* Fall through */
11574             case 'n':
11575                 d->data[i] = ri->data->data[i];
11576                 break;
11577             default:
11578                 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
11579             }
11580         }
11581
11582         reti->data = d;
11583     }
11584     else
11585         reti->data = NULL;
11586
11587     reti->name_list_idx = ri->name_list_idx;
11588
11589 #ifdef RE_TRACK_PATTERN_OFFSETS
11590     if (ri->u.offsets) {
11591         Newx(reti->u.offsets, 2*len+1, U32);
11592         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
11593     }
11594 #else
11595     SetProgLen(reti,len);
11596 #endif
11597
11598     return (void*)reti;
11599 }
11600
11601 #endif    /* USE_ITHREADS */
11602
11603 #ifndef PERL_IN_XSUB_RE
11604
11605 /*
11606  - regnext - dig the "next" pointer out of a node
11607  */
11608 regnode *
11609 Perl_regnext(pTHX_ register regnode *p)
11610 {
11611     dVAR;
11612     register I32 offset;
11613
11614     if (!p)
11615         return(NULL);
11616
11617     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
11618         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(p), (int)REGNODE_MAX);
11619     }
11620
11621     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
11622     if (offset == 0)
11623         return(NULL);
11624
11625     return(p+offset);
11626 }
11627 #endif
11628
11629 STATIC void     
11630 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
11631 {
11632     va_list args;
11633     STRLEN l1 = strlen(pat1);
11634     STRLEN l2 = strlen(pat2);
11635     char buf[512];
11636     SV *msv;
11637     const char *message;
11638
11639     PERL_ARGS_ASSERT_RE_CROAK2;
11640
11641     if (l1 > 510)
11642         l1 = 510;
11643     if (l1 + l2 > 510)
11644         l2 = 510 - l1;
11645     Copy(pat1, buf, l1 , char);
11646     Copy(pat2, buf + l1, l2 , char);
11647     buf[l1 + l2] = '\n';
11648     buf[l1 + l2 + 1] = '\0';
11649 #ifdef I_STDARG
11650     /* ANSI variant takes additional second argument */
11651     va_start(args, pat2);
11652 #else
11653     va_start(args);
11654 #endif
11655     msv = vmess(buf, &args);
11656     va_end(args);
11657     message = SvPV_const(msv,l1);
11658     if (l1 > 512)
11659         l1 = 512;
11660     Copy(message, buf, l1 , char);
11661     buf[l1-1] = '\0';                   /* Overwrite \n */
11662     Perl_croak(aTHX_ "%s", buf);
11663 }
11664
11665 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
11666
11667 #ifndef PERL_IN_XSUB_RE
11668 void
11669 Perl_save_re_context(pTHX)
11670 {
11671     dVAR;
11672
11673     struct re_save_state *state;
11674
11675     SAVEVPTR(PL_curcop);
11676     SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
11677
11678     state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
11679     PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
11680     SSPUSHUV(SAVEt_RE_STATE);
11681
11682     Copy(&PL_reg_state, state, 1, struct re_save_state);
11683
11684     PL_reg_start_tmp = 0;
11685     PL_reg_start_tmpl = 0;
11686     PL_reg_oldsaved = NULL;
11687     PL_reg_oldsavedlen = 0;
11688     PL_reg_maxiter = 0;
11689     PL_reg_leftiter = 0;
11690     PL_reg_poscache = NULL;
11691     PL_reg_poscache_size = 0;
11692 #ifdef PERL_OLD_COPY_ON_WRITE
11693     PL_nrs = NULL;
11694 #endif
11695
11696     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
11697     if (PL_curpm) {
11698         const REGEXP * const rx = PM_GETRE(PL_curpm);
11699         if (rx) {
11700             U32 i;
11701             for (i = 1; i <= RX_NPARENS(rx); i++) {
11702                 char digits[TYPE_CHARS(long)];
11703                 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
11704                 GV *const *const gvp
11705                     = (GV**)hv_fetch(PL_defstash, digits, len, 0);
11706
11707                 if (gvp) {
11708                     GV * const gv = *gvp;
11709                     if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
11710                         save_scalar(gv);
11711                 }
11712             }
11713         }
11714     }
11715 }
11716 #endif
11717
11718 static void
11719 clear_re(pTHX_ void *r)
11720 {
11721     dVAR;
11722     ReREFCNT_dec((REGEXP *)r);
11723 }
11724
11725 #ifdef DEBUGGING
11726
11727 STATIC void
11728 S_put_byte(pTHX_ SV *sv, int c)
11729 {
11730     PERL_ARGS_ASSERT_PUT_BYTE;
11731
11732     /* Our definition of isPRINT() ignores locales, so only bytes that are
11733        not part of UTF-8 are considered printable. I assume that the same
11734        holds for UTF-EBCDIC.
11735        Also, code point 255 is not printable in either (it's E0 in EBCDIC,
11736        which Wikipedia says:
11737
11738        EO, or Eight Ones, is an 8-bit EBCDIC character code represented as all
11739        ones (binary 1111 1111, hexadecimal FF). It is similar, but not
11740        identical, to the ASCII delete (DEL) or rubout control character.
11741        ) So the old condition can be simplified to !isPRINT(c)  */
11742     if (!isPRINT(c)) {
11743         if (c < 256) {
11744             Perl_sv_catpvf(aTHX_ sv, "\\x%02x", c);
11745         }
11746         else {
11747             Perl_sv_catpvf(aTHX_ sv, "\\x{%x}", c);
11748         }
11749     }
11750     else {
11751         const char string = c;
11752         if (c == '-' || c == ']' || c == '\\' || c == '^')
11753             sv_catpvs(sv, "\\");
11754         sv_catpvn(sv, &string, 1);
11755     }
11756 }
11757
11758
11759 #define CLEAR_OPTSTART \
11760     if (optstart) STMT_START { \
11761             DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
11762             optstart=NULL; \
11763     } STMT_END
11764
11765 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
11766
11767 STATIC const regnode *
11768 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
11769             const regnode *last, const regnode *plast, 
11770             SV* sv, I32 indent, U32 depth)
11771 {
11772     dVAR;
11773     register U8 op = PSEUDO;    /* Arbitrary non-END op. */
11774     register const regnode *next;
11775     const regnode *optstart= NULL;
11776     
11777     RXi_GET_DECL(r,ri);
11778     GET_RE_DEBUG_FLAGS_DECL;
11779
11780     PERL_ARGS_ASSERT_DUMPUNTIL;
11781
11782 #ifdef DEBUG_DUMPUNTIL
11783     PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
11784         last ? last-start : 0,plast ? plast-start : 0);
11785 #endif
11786             
11787     if (plast && plast < last) 
11788         last= plast;
11789
11790     while (PL_regkind[op] != END && (!last || node < last)) {
11791         /* While that wasn't END last time... */
11792         NODE_ALIGN(node);
11793         op = OP(node);
11794         if (op == CLOSE || op == WHILEM)
11795             indent--;
11796         next = regnext((regnode *)node);
11797
11798         /* Where, what. */
11799         if (OP(node) == OPTIMIZED) {
11800             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
11801                 optstart = node;
11802             else
11803                 goto after_print;
11804         } else
11805             CLEAR_OPTSTART;
11806         
11807         regprop(r, sv, node);
11808         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
11809                       (int)(2*indent + 1), "", SvPVX_const(sv));
11810         
11811         if (OP(node) != OPTIMIZED) {                  
11812             if (next == NULL)           /* Next ptr. */
11813                 PerlIO_printf(Perl_debug_log, " (0)");
11814             else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
11815                 PerlIO_printf(Perl_debug_log, " (FAIL)");
11816             else 
11817                 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
11818             (void)PerlIO_putc(Perl_debug_log, '\n'); 
11819         }
11820         
11821       after_print:
11822         if (PL_regkind[(U8)op] == BRANCHJ) {
11823             assert(next);
11824             {
11825                 register const regnode *nnode = (OP(next) == LONGJMP
11826                                              ? regnext((regnode *)next)
11827                                              : next);
11828                 if (last && nnode > last)
11829                     nnode = last;
11830                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
11831             }
11832         }
11833         else if (PL_regkind[(U8)op] == BRANCH) {
11834             assert(next);
11835             DUMPUNTIL(NEXTOPER(node), next);
11836         }
11837         else if ( PL_regkind[(U8)op]  == TRIE ) {
11838             const regnode *this_trie = node;
11839             const char op = OP(node);
11840             const U32 n = ARG(node);
11841             const reg_ac_data * const ac = op>=AHOCORASICK ?
11842                (reg_ac_data *)ri->data->data[n] :
11843                NULL;
11844             const reg_trie_data * const trie =
11845                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
11846 #ifdef DEBUGGING
11847             AV *const trie_words = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
11848 #endif
11849             const regnode *nextbranch= NULL;
11850             I32 word_idx;
11851             sv_setpvs(sv, "");
11852             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
11853                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
11854                 
11855                 PerlIO_printf(Perl_debug_log, "%*s%s ",
11856                    (int)(2*(indent+3)), "",
11857                     elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
11858                             PL_colors[0], PL_colors[1],
11859                             (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
11860                             PERL_PV_PRETTY_ELLIPSES    |
11861                             PERL_PV_PRETTY_LTGT
11862                             )
11863                             : "???"
11864                 );
11865                 if (trie->jump) {
11866                     U16 dist= trie->jump[word_idx+1];
11867                     PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
11868                                   (UV)((dist ? this_trie + dist : next) - start));
11869                     if (dist) {
11870                         if (!nextbranch)
11871                             nextbranch= this_trie + trie->jump[0];    
11872                         DUMPUNTIL(this_trie + dist, nextbranch);
11873                     }
11874                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
11875                         nextbranch= regnext((regnode *)nextbranch);
11876                 } else {
11877                     PerlIO_printf(Perl_debug_log, "\n");
11878                 }
11879             }
11880             if (last && next > last)
11881                 node= last;
11882             else
11883                 node= next;
11884         }
11885         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
11886             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
11887                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
11888         }
11889         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
11890             assert(next);
11891             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
11892         }
11893         else if ( op == PLUS || op == STAR) {
11894             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
11895         }
11896         else if (PL_regkind[(U8)op] == ANYOF) {
11897             /* arglen 1 + class block */
11898             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_CLASS)
11899                     ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
11900             node = NEXTOPER(node);
11901         }
11902         else if (PL_regkind[(U8)op] == EXACT) {
11903             /* Literal string, where present. */
11904             node += NODE_SZ_STR(node) - 1;
11905             node = NEXTOPER(node);
11906         }
11907         else {
11908             node = NEXTOPER(node);
11909             node += regarglen[(U8)op];
11910         }
11911         if (op == CURLYX || op == OPEN)
11912             indent++;
11913     }
11914     CLEAR_OPTSTART;
11915 #ifdef DEBUG_DUMPUNTIL    
11916     PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
11917 #endif
11918     return node;
11919 }
11920
11921 #endif  /* DEBUGGING */
11922
11923 /*
11924  * Local variables:
11925  * c-indentation-style: bsd
11926  * c-basic-offset: 4
11927  * indent-tabs-mode: t
11928  * End:
11929  *
11930  * ex: set ts=8 sts=4 sw=4 noet:
11931  */