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