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