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