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