[PATCH] Use short pathnames in $^X and @INC if the long form cannot be represented...
[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             case '&':            /* (?&NAME) */
5069                 parse_start = RExC_parse - 1;
5070               named_recursion:
5071                 {
5072                     SV *sv_dat = reg_scan_name(pRExC_state,
5073                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
5074                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
5075                 }
5076                 goto gen_recurse_regop;
5077                 /* NOT REACHED */
5078             case '+':
5079                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
5080                     RExC_parse++;
5081                     vFAIL("Illegal pattern");
5082                 }
5083                 goto parse_recursion;
5084                 /* NOT REACHED*/
5085             case '-': /* (?-1) */
5086                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
5087                     RExC_parse--; /* rewind to let it be handled later */
5088                     goto parse_flags;
5089                 } 
5090                 /*FALLTHROUGH */
5091             case '1': case '2': case '3': case '4': /* (?1) */
5092             case '5': case '6': case '7': case '8': case '9':
5093                 RExC_parse--;
5094               parse_recursion:
5095                 num = atoi(RExC_parse);
5096                 parse_start = RExC_parse - 1; /* MJD */
5097                 if (*RExC_parse == '-')
5098                     RExC_parse++;
5099                 while (isDIGIT(*RExC_parse))
5100                         RExC_parse++;
5101                 if (*RExC_parse!=')') 
5102                     vFAIL("Expecting close bracket");
5103                         
5104               gen_recurse_regop:
5105                 if ( paren == '-' ) {
5106                     /*
5107                     Diagram of capture buffer numbering.
5108                     Top line is the normal capture buffer numbers
5109                     Botton line is the negative indexing as from
5110                     the X (the (?-2))
5111
5112                     +   1 2    3 4 5 X          6 7
5113                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
5114                     -   5 4    3 2 1 X          x x
5115
5116                     */
5117                     num = RExC_npar + num;
5118                     if (num < 1)  {
5119                         RExC_parse++;
5120                         vFAIL("Reference to nonexistent group");
5121                     }
5122                 } else if ( paren == '+' ) {
5123                     num = RExC_npar + num - 1;
5124                 }
5125
5126                 ret = reganode(pRExC_state, GOSUB, num);
5127                 if (!SIZE_ONLY) {
5128                     if (num > (I32)RExC_rx->nparens) {
5129                         RExC_parse++;
5130                         vFAIL("Reference to nonexistent group");
5131                     }
5132                     ARG2L_SET( ret, RExC_recurse_count++);
5133                     RExC_emit++;
5134                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
5135                         "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
5136                 } else {
5137                     RExC_size++;
5138                 }
5139                 RExC_seen |= REG_SEEN_RECURSE;
5140                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
5141                 Set_Node_Offset(ret, parse_start); /* MJD */
5142
5143                 nextchar(pRExC_state);
5144                 return ret;
5145             } /* named and numeric backreferences */
5146             /* NOT REACHED */
5147
5148             case 'p':           /* (?p...) */
5149                 if (SIZE_ONLY && ckWARN2(WARN_DEPRECATED, WARN_REGEXP))
5150                     vWARNdep(RExC_parse, "(?p{}) is deprecated - use (??{})");
5151                 /* FALL THROUGH*/
5152             case '?':           /* (??...) */
5153                 is_logical = 1;
5154                 if (*RExC_parse != '{')
5155                     goto unknown;
5156                 paren = *RExC_parse++;
5157                 /* FALL THROUGH */
5158             case '{':           /* (?{...}) */
5159             {
5160                 I32 count = 1;
5161                 U32 n = 0;
5162                 char c;
5163                 char *s = RExC_parse;
5164
5165                 RExC_seen_zerolen++;
5166                 RExC_seen |= REG_SEEN_EVAL;
5167                 while (count && (c = *RExC_parse)) {
5168                     if (c == '\\') {
5169                         if (RExC_parse[1])
5170                             RExC_parse++;
5171                     }
5172                     else if (c == '{')
5173                         count++;
5174                     else if (c == '}')
5175                         count--;
5176                     RExC_parse++;
5177                 }
5178                 if (*RExC_parse != ')') {
5179                     RExC_parse = s;             
5180                     vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
5181                 }
5182                 if (!SIZE_ONLY) {
5183                     PAD *pad;
5184                     OP_4tree *sop, *rop;
5185                     SV * const sv = newSVpvn(s, RExC_parse - 1 - s);
5186
5187                     ENTER;
5188                     Perl_save_re_context(aTHX);
5189                     rop = sv_compile_2op(sv, &sop, "re", &pad);
5190                     sop->op_private |= OPpREFCOUNTED;
5191                     /* re_dup will OpREFCNT_inc */
5192                     OpREFCNT_set(sop, 1);
5193                     LEAVE;
5194
5195                     n = add_data(pRExC_state, 3, "nop");
5196                     RExC_rxi->data->data[n] = (void*)rop;
5197                     RExC_rxi->data->data[n+1] = (void*)sop;
5198                     RExC_rxi->data->data[n+2] = (void*)pad;
5199                     SvREFCNT_dec(sv);
5200                 }
5201                 else {                                          /* First pass */
5202                     if (PL_reginterp_cnt < ++RExC_seen_evals
5203                         && IN_PERL_RUNTIME)
5204                         /* No compiled RE interpolated, has runtime
5205                            components ===> unsafe.  */
5206                         FAIL("Eval-group not allowed at runtime, use re 'eval'");
5207                     if (PL_tainting && PL_tainted)
5208                         FAIL("Eval-group in insecure regular expression");
5209 #if PERL_VERSION > 8
5210                     if (IN_PERL_COMPILETIME)
5211                         PL_cv_has_eval = 1;
5212 #endif
5213                 }
5214
5215                 nextchar(pRExC_state);
5216                 if (is_logical) {
5217                     ret = reg_node(pRExC_state, LOGICAL);
5218                     if (!SIZE_ONLY)
5219                         ret->flags = 2;
5220                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
5221                     /* deal with the length of this later - MJD */
5222                     return ret;
5223                 }
5224                 ret = reganode(pRExC_state, EVAL, n);
5225                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
5226                 Set_Node_Offset(ret, parse_start);
5227                 return ret;
5228             }
5229             case '(':           /* (?(?{...})...) and (?(?=...)...) */
5230             {
5231                 int is_define= 0;
5232                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
5233                     if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
5234                         || RExC_parse[1] == '<'
5235                         || RExC_parse[1] == '{') { /* Lookahead or eval. */
5236                         I32 flag;
5237                         
5238                         ret = reg_node(pRExC_state, LOGICAL);
5239                         if (!SIZE_ONLY)
5240                             ret->flags = 1;
5241                         REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
5242                         goto insert_if;
5243                     }
5244                 }
5245                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
5246                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
5247                 {
5248                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
5249                     char *name_start= RExC_parse++;
5250                     U32 num = 0;
5251                     SV *sv_dat=reg_scan_name(pRExC_state,
5252                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
5253                     if (RExC_parse == name_start || *RExC_parse != ch)
5254                         vFAIL2("Sequence (?(%c... not terminated",
5255                             (ch == '>' ? '<' : ch));
5256                     RExC_parse++;
5257                     if (!SIZE_ONLY) {
5258                         num = add_data( pRExC_state, 1, "S" );
5259                         RExC_rxi->data->data[num]=(void*)sv_dat;
5260                         SvREFCNT_inc(sv_dat);
5261                     }
5262                     ret = reganode(pRExC_state,NGROUPP,num);
5263                     goto insert_if_check_paren;
5264                 }
5265                 else if (RExC_parse[0] == 'D' &&
5266                          RExC_parse[1] == 'E' &&
5267                          RExC_parse[2] == 'F' &&
5268                          RExC_parse[3] == 'I' &&
5269                          RExC_parse[4] == 'N' &&
5270                          RExC_parse[5] == 'E')
5271                 {
5272                     ret = reganode(pRExC_state,DEFINEP,0);
5273                     RExC_parse +=6 ;
5274                     is_define = 1;
5275                     goto insert_if_check_paren;
5276                 }
5277                 else if (RExC_parse[0] == 'R') {
5278                     RExC_parse++;
5279                     parno = 0;
5280                     if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
5281                         parno = atoi(RExC_parse++);
5282                         while (isDIGIT(*RExC_parse))
5283                             RExC_parse++;
5284                     } else if (RExC_parse[0] == '&') {
5285                         SV *sv_dat;
5286                         RExC_parse++;
5287                         sv_dat = reg_scan_name(pRExC_state,
5288                             SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
5289                         parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
5290                     }
5291                     ret = reganode(pRExC_state,INSUBP,parno); 
5292                     goto insert_if_check_paren;
5293                 }
5294                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
5295                     /* (?(1)...) */
5296                     char c;
5297                     parno = atoi(RExC_parse++);
5298
5299                     while (isDIGIT(*RExC_parse))
5300                         RExC_parse++;
5301                     ret = reganode(pRExC_state, GROUPP, parno);
5302
5303                  insert_if_check_paren:
5304                     if ((c = *nextchar(pRExC_state)) != ')')
5305                         vFAIL("Switch condition not recognized");
5306                   insert_if:
5307                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
5308                     br = regbranch(pRExC_state, &flags, 1,depth+1);
5309                     if (br == NULL)
5310                         br = reganode(pRExC_state, LONGJMP, 0);
5311                     else
5312                         REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
5313                     c = *nextchar(pRExC_state);
5314                     if (flags&HASWIDTH)
5315                         *flagp |= HASWIDTH;
5316                     if (c == '|') {
5317                         if (is_define) 
5318                             vFAIL("(?(DEFINE)....) does not allow branches");
5319                         lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
5320                         regbranch(pRExC_state, &flags, 1,depth+1);
5321                         REGTAIL(pRExC_state, ret, lastbr);
5322                         if (flags&HASWIDTH)
5323                             *flagp |= HASWIDTH;
5324                         c = *nextchar(pRExC_state);
5325                     }
5326                     else
5327                         lastbr = NULL;
5328                     if (c != ')')
5329                         vFAIL("Switch (?(condition)... contains too many branches");
5330                     ender = reg_node(pRExC_state, TAIL);
5331                     REGTAIL(pRExC_state, br, ender);
5332                     if (lastbr) {
5333                         REGTAIL(pRExC_state, lastbr, ender);
5334                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
5335                     }
5336                     else
5337                         REGTAIL(pRExC_state, ret, ender);
5338                     return ret;
5339                 }
5340                 else {
5341                     vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
5342                 }
5343             }
5344             case 0:
5345                 RExC_parse--; /* for vFAIL to print correctly */
5346                 vFAIL("Sequence (? incomplete");
5347                 break;
5348             default:
5349                 --RExC_parse;
5350               parse_flags:      /* (?i) */
5351                 while (*RExC_parse && strchr("iogcmsx", *RExC_parse)) {
5352                     /* (?g), (?gc) and (?o) are useless here
5353                        and must be globally applied -- japhy */
5354
5355                     if (*RExC_parse == 'o' || *RExC_parse == 'g') {
5356                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
5357                             const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
5358                             if (! (wastedflags & wflagbit) ) {
5359                                 wastedflags |= wflagbit;
5360                                 vWARN5(
5361                                     RExC_parse + 1,
5362                                     "Useless (%s%c) - %suse /%c modifier",
5363                                     flagsp == &negflags ? "?-" : "?",
5364                                     *RExC_parse,
5365                                     flagsp == &negflags ? "don't " : "",
5366                                     *RExC_parse
5367                                 );
5368                             }
5369                         }
5370                     }
5371                     else if (*RExC_parse == 'c') {
5372                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
5373                             if (! (wastedflags & WASTED_C) ) {
5374                                 wastedflags |= WASTED_GC;
5375                                 vWARN3(
5376                                     RExC_parse + 1,
5377                                     "Useless (%sc) - %suse /gc modifier",
5378                                     flagsp == &negflags ? "?-" : "?",
5379                                     flagsp == &negflags ? "don't " : ""
5380                                 );
5381                             }
5382                         }
5383                     }
5384                     else { pmflag(flagsp, *RExC_parse); }
5385
5386                     ++RExC_parse;
5387                 }
5388                 if (*RExC_parse == '-') {
5389                     flagsp = &negflags;
5390                     wastedflags = 0;  /* reset so (?g-c) warns twice */
5391                     ++RExC_parse;
5392                     goto parse_flags;
5393                 }
5394                 RExC_flags |= posflags;
5395                 RExC_flags &= ~negflags;
5396                 if (*RExC_parse == ':') {
5397                     RExC_parse++;
5398                     paren = ':';
5399                     break;
5400                 }               
5401               unknown:
5402                 if (*RExC_parse != ')') {
5403                     RExC_parse++;
5404                     vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
5405                 }
5406                 nextchar(pRExC_state);
5407                 *flagp = TRYAGAIN;
5408                 return NULL;
5409             }
5410         }
5411         else {                  /* (...) */
5412           capturing_parens:
5413             parno = RExC_npar;
5414             RExC_npar++;
5415             
5416             ret = reganode(pRExC_state, OPEN, parno);
5417             if (!SIZE_ONLY ){
5418                 if (!RExC_nestroot) 
5419                     RExC_nestroot = parno;
5420                 if (RExC_seen & REG_SEEN_RECURSE) {
5421                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
5422                         "Setting open paren #%"IVdf" to %d\n", 
5423                         (IV)parno, REG_NODE_NUM(ret)));
5424                     RExC_open_parens[parno-1]= ret;
5425                 }
5426             }
5427             Set_Node_Length(ret, 1); /* MJD */
5428             Set_Node_Offset(ret, RExC_parse); /* MJD */
5429             is_open = 1;
5430         }
5431     }
5432     else                        /* ! paren */
5433         ret = NULL;
5434
5435     /* Pick up the branches, linking them together. */
5436     parse_start = RExC_parse;   /* MJD */
5437     br = regbranch(pRExC_state, &flags, 1,depth+1);
5438     /*     branch_len = (paren != 0); */
5439
5440     if (br == NULL)
5441         return(NULL);
5442     if (*RExC_parse == '|') {
5443         if (!SIZE_ONLY && RExC_extralen) {
5444             reginsert(pRExC_state, BRANCHJ, br, depth+1);
5445         }
5446         else {                  /* MJD */
5447             reginsert(pRExC_state, BRANCH, br, depth+1);
5448             Set_Node_Length(br, paren != 0);
5449             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
5450         }
5451         have_branch = 1;
5452         if (SIZE_ONLY)
5453             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
5454     }
5455     else if (paren == ':') {
5456         *flagp |= flags&SIMPLE;
5457     }
5458     if (is_open) {                              /* Starts with OPEN. */
5459         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
5460     }
5461     else if (paren != '?')              /* Not Conditional */
5462         ret = br;
5463     *flagp |= flags & (SPSTART | HASWIDTH);
5464     lastbr = br;
5465     while (*RExC_parse == '|') {
5466         if (!SIZE_ONLY && RExC_extralen) {
5467             ender = reganode(pRExC_state, LONGJMP,0);
5468             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
5469         }
5470         if (SIZE_ONLY)
5471             RExC_extralen += 2;         /* Account for LONGJMP. */
5472         nextchar(pRExC_state);
5473         br = regbranch(pRExC_state, &flags, 0, depth+1);
5474
5475         if (br == NULL)
5476             return(NULL);
5477         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
5478         lastbr = br;
5479         if (flags&HASWIDTH)
5480             *flagp |= HASWIDTH;
5481         *flagp |= flags&SPSTART;
5482     }
5483
5484     if (have_branch || paren != ':') {
5485         /* Make a closing node, and hook it on the end. */
5486         switch (paren) {
5487         case ':':
5488             ender = reg_node(pRExC_state, TAIL);
5489             break;
5490         case 1:
5491             ender = reganode(pRExC_state, CLOSE, parno);
5492             if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
5493                 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
5494                         "Setting close paren #%"IVdf" to %d\n", 
5495                         (IV)parno, REG_NODE_NUM(ender)));
5496                 RExC_close_parens[parno-1]= ender;
5497                 if (RExC_nestroot == parno) 
5498                     RExC_nestroot = 0;
5499             }       
5500             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
5501             Set_Node_Length(ender,1); /* MJD */
5502             break;
5503         case '<':
5504         case ',':
5505         case '=':
5506         case '!':
5507             *flagp &= ~HASWIDTH;
5508             /* FALL THROUGH */
5509         case '>':
5510             ender = reg_node(pRExC_state, SUCCEED);
5511             break;
5512         case 0:
5513             ender = reg_node(pRExC_state, END);
5514             if (!SIZE_ONLY) {
5515                 assert(!RExC_opend); /* there can only be one! */
5516                 RExC_opend = ender;
5517             }
5518             break;
5519         }
5520         REGTAIL(pRExC_state, lastbr, ender);
5521
5522         if (have_branch && !SIZE_ONLY) {
5523             if (depth==1)
5524                 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
5525
5526             /* Hook the tails of the branches to the closing node. */
5527             for (br = ret; br; br = regnext(br)) {
5528                 const U8 op = PL_regkind[OP(br)];
5529                 if (op == BRANCH) {
5530                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
5531                 }
5532                 else if (op == BRANCHJ) {
5533                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
5534                 }
5535             }
5536         }
5537     }
5538
5539     {
5540         const char *p;
5541         static const char parens[] = "=!<,>";
5542
5543         if (paren && (p = strchr(parens, paren))) {
5544             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
5545             int flag = (p - parens) > 1;
5546
5547             if (paren == '>')
5548                 node = SUSPEND, flag = 0;
5549             reginsert(pRExC_state, node,ret, depth+1);
5550             Set_Node_Cur_Length(ret);
5551             Set_Node_Offset(ret, parse_start + 1);
5552             ret->flags = flag;
5553             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
5554         }
5555     }
5556
5557     /* Check for proper termination. */
5558     if (paren) {
5559         RExC_flags = oregflags;
5560         if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
5561             RExC_parse = oregcomp_parse;
5562             vFAIL("Unmatched (");
5563         }
5564     }
5565     else if (!paren && RExC_parse < RExC_end) {
5566         if (*RExC_parse == ')') {
5567             RExC_parse++;
5568             vFAIL("Unmatched )");
5569         }
5570         else
5571             FAIL("Junk on end of regexp");      /* "Can't happen". */
5572         /* NOTREACHED */
5573     }
5574
5575     return(ret);
5576 }
5577
5578 /*
5579  - regbranch - one alternative of an | operator
5580  *
5581  * Implements the concatenation operator.
5582  */
5583 STATIC regnode *
5584 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
5585 {
5586     dVAR;
5587     register regnode *ret;
5588     register regnode *chain = NULL;
5589     register regnode *latest;
5590     I32 flags = 0, c = 0;
5591     GET_RE_DEBUG_FLAGS_DECL;
5592     DEBUG_PARSE("brnc");
5593     if (first)
5594         ret = NULL;
5595     else {
5596         if (!SIZE_ONLY && RExC_extralen)
5597             ret = reganode(pRExC_state, BRANCHJ,0);
5598         else {
5599             ret = reg_node(pRExC_state, BRANCH);
5600             Set_Node_Length(ret, 1);
5601         }
5602     }
5603         
5604     if (!first && SIZE_ONLY)
5605         RExC_extralen += 1;                     /* BRANCHJ */
5606
5607     *flagp = WORST;                     /* Tentatively. */
5608
5609     RExC_parse--;
5610     nextchar(pRExC_state);
5611     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
5612         flags &= ~TRYAGAIN;
5613         latest = regpiece(pRExC_state, &flags,depth+1);
5614         if (latest == NULL) {
5615             if (flags & TRYAGAIN)
5616                 continue;
5617             return(NULL);
5618         }
5619         else if (ret == NULL)
5620             ret = latest;
5621         *flagp |= flags&HASWIDTH;
5622         if (chain == NULL)      /* First piece. */
5623             *flagp |= flags&SPSTART;
5624         else {
5625             RExC_naughty++;
5626             REGTAIL(pRExC_state, chain, latest);
5627         }
5628         chain = latest;
5629         c++;
5630     }
5631     if (chain == NULL) {        /* Loop ran zero times. */
5632         chain = reg_node(pRExC_state, NOTHING);
5633         if (ret == NULL)
5634             ret = chain;
5635     }
5636     if (c == 1) {
5637         *flagp |= flags&SIMPLE;
5638     }
5639
5640     return ret;
5641 }
5642
5643 /*
5644  - regpiece - something followed by possible [*+?]
5645  *
5646  * Note that the branching code sequences used for ? and the general cases
5647  * of * and + are somewhat optimized:  they use the same NOTHING node as
5648  * both the endmarker for their branch list and the body of the last branch.
5649  * It might seem that this node could be dispensed with entirely, but the
5650  * endmarker role is not redundant.
5651  */
5652 STATIC regnode *
5653 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
5654 {
5655     dVAR;
5656     register regnode *ret;
5657     register char op;
5658     register char *next;
5659     I32 flags;
5660     const char * const origparse = RExC_parse;
5661     I32 min;
5662     I32 max = REG_INFTY;
5663     char *parse_start;
5664     const char *maxpos = NULL;
5665     GET_RE_DEBUG_FLAGS_DECL;
5666     DEBUG_PARSE("piec");
5667
5668     ret = regatom(pRExC_state, &flags,depth+1);
5669     if (ret == NULL) {
5670         if (flags & TRYAGAIN)
5671             *flagp |= TRYAGAIN;
5672         return(NULL);
5673     }
5674
5675     op = *RExC_parse;
5676
5677     if (op == '{' && regcurly(RExC_parse)) {
5678         maxpos = NULL;
5679         parse_start = RExC_parse; /* MJD */
5680         next = RExC_parse + 1;
5681         while (isDIGIT(*next) || *next == ',') {
5682             if (*next == ',') {
5683                 if (maxpos)
5684                     break;
5685                 else
5686                     maxpos = next;
5687             }
5688             next++;
5689         }
5690         if (*next == '}') {             /* got one */
5691             if (!maxpos)
5692                 maxpos = next;
5693             RExC_parse++;
5694             min = atoi(RExC_parse);
5695             if (*maxpos == ',')
5696                 maxpos++;
5697             else
5698                 maxpos = RExC_parse;
5699             max = atoi(maxpos);
5700             if (!max && *maxpos != '0')
5701                 max = REG_INFTY;                /* meaning "infinity" */
5702             else if (max >= REG_INFTY)
5703                 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
5704             RExC_parse = next;
5705             nextchar(pRExC_state);
5706
5707         do_curly:
5708             if ((flags&SIMPLE)) {
5709                 RExC_naughty += 2 + RExC_naughty / 2;
5710                 reginsert(pRExC_state, CURLY, ret, depth+1);
5711                 Set_Node_Offset(ret, parse_start+1); /* MJD */
5712                 Set_Node_Cur_Length(ret);
5713             }
5714             else {
5715                 regnode * const w = reg_node(pRExC_state, WHILEM);
5716
5717                 w->flags = 0;
5718                 REGTAIL(pRExC_state, ret, w);
5719                 if (!SIZE_ONLY && RExC_extralen) {
5720                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
5721                     reginsert(pRExC_state, NOTHING,ret, depth+1);
5722                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
5723                 }
5724                 reginsert(pRExC_state, CURLYX,ret, depth+1);
5725                                 /* MJD hk */
5726                 Set_Node_Offset(ret, parse_start+1);
5727                 Set_Node_Length(ret,
5728                                 op == '{' ? (RExC_parse - parse_start) : 1);
5729
5730                 if (!SIZE_ONLY && RExC_extralen)
5731                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
5732                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
5733                 if (SIZE_ONLY)
5734                     RExC_whilem_seen++, RExC_extralen += 3;
5735                 RExC_naughty += 4 + RExC_naughty;       /* compound interest */
5736             }
5737             ret->flags = 0;
5738
5739             if (min > 0)
5740                 *flagp = WORST;
5741             if (max > 0)
5742                 *flagp |= HASWIDTH;
5743             if (max && max < min)
5744                 vFAIL("Can't do {n,m} with n > m");
5745             if (!SIZE_ONLY) {
5746                 ARG1_SET(ret, (U16)min);
5747                 ARG2_SET(ret, (U16)max);
5748             }
5749
5750             goto nest_check;
5751         }
5752     }
5753
5754     if (!ISMULT1(op)) {
5755         *flagp = flags;
5756         return(ret);
5757     }
5758
5759 #if 0                           /* Now runtime fix should be reliable. */
5760
5761     /* if this is reinstated, don't forget to put this back into perldiag:
5762
5763             =item Regexp *+ operand could be empty at {#} in regex m/%s/
5764
5765            (F) The part of the regexp subject to either the * or + quantifier
5766            could match an empty string. The {#} shows in the regular
5767            expression about where the problem was discovered.
5768
5769     */
5770
5771     if (!(flags&HASWIDTH) && op != '?')
5772       vFAIL("Regexp *+ operand could be empty");
5773 #endif
5774
5775     parse_start = RExC_parse;
5776     nextchar(pRExC_state);
5777
5778     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
5779
5780     if (op == '*' && (flags&SIMPLE)) {
5781         reginsert(pRExC_state, STAR, ret, depth+1);
5782         ret->flags = 0;
5783         RExC_naughty += 4;
5784     }
5785     else if (op == '*') {
5786         min = 0;
5787         goto do_curly;
5788     }
5789     else if (op == '+' && (flags&SIMPLE)) {
5790         reginsert(pRExC_state, PLUS, ret, depth+1);
5791         ret->flags = 0;
5792         RExC_naughty += 3;
5793     }
5794     else if (op == '+') {
5795         min = 1;
5796         goto do_curly;
5797     }
5798     else if (op == '?') {
5799         min = 0; max = 1;
5800         goto do_curly;
5801     }
5802   nest_check:
5803     if (!SIZE_ONLY && !(flags&HASWIDTH) && max > REG_INFTY/3 && ckWARN(WARN_REGEXP)) {
5804         vWARN3(RExC_parse,
5805                "%.*s matches null string many times",
5806                (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
5807                origparse);
5808     }
5809
5810     if (RExC_parse < RExC_end && *RExC_parse == '?') {
5811         nextchar(pRExC_state);
5812         reginsert(pRExC_state, MINMOD, ret, depth+1);
5813         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
5814     }
5815 #ifndef REG_ALLOW_MINMOD_SUSPEND
5816     else
5817 #endif
5818     if (RExC_parse < RExC_end && *RExC_parse == '+') {
5819         regnode *ender;
5820         nextchar(pRExC_state);
5821         ender = reg_node(pRExC_state, SUCCEED);
5822         REGTAIL(pRExC_state, ret, ender);
5823         reginsert(pRExC_state, SUSPEND, ret, depth+1);
5824         ret->flags = 0;
5825         ender = reg_node(pRExC_state, TAIL);
5826         REGTAIL(pRExC_state, ret, ender);
5827         /*ret= ender;*/
5828     }
5829
5830     if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
5831         RExC_parse++;
5832         vFAIL("Nested quantifiers");
5833     }
5834
5835     return(ret);
5836 }
5837
5838
5839 /* reg_namedseq(pRExC_state,UVp)
5840    
5841    This is expected to be called by a parser routine that has 
5842    recognized'\N' and needs to handle the rest. RExC_parse is 
5843    expected to point at the first char following the N at the time
5844    of the call.
5845    
5846    If valuep is non-null then it is assumed that we are parsing inside 
5847    of a charclass definition and the first codepoint in the resolved
5848    string is returned via *valuep and the routine will return NULL. 
5849    In this mode if a multichar string is returned from the charnames 
5850    handler a warning will be issued, and only the first char in the 
5851    sequence will be examined. If the string returned is zero length
5852    then the value of *valuep is undefined and NON-NULL will 
5853    be returned to indicate failure. (This will NOT be a valid pointer 
5854    to a regnode.)
5855    
5856    If value is null then it is assumed that we are parsing normal text
5857    and inserts a new EXACT node into the program containing the resolved
5858    string and returns a pointer to the new node. If the string is 
5859    zerolength a NOTHING node is emitted.
5860    
5861    On success RExC_parse is set to the char following the endbrace.
5862    Parsing failures will generate a fatal errorvia vFAIL(...)
5863    
5864    NOTE: We cache all results from the charnames handler locally in 
5865    the RExC_charnames hash (created on first use) to prevent a charnames 
5866    handler from playing silly-buggers and returning a short string and 
5867    then a long string for a given pattern. Since the regexp program 
5868    size is calculated during an initial parse this would result
5869    in a buffer overrun so we cache to prevent the charname result from
5870    changing during the course of the parse.
5871    
5872  */
5873 STATIC regnode *
5874 S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep) 
5875 {
5876     char * name;        /* start of the content of the name */
5877     char * endbrace;    /* endbrace following the name */
5878     SV *sv_str = NULL;  
5879     SV *sv_name = NULL;
5880     STRLEN len; /* this has various purposes throughout the code */
5881     bool cached = 0; /* if this is true then we shouldn't refcount dev sv_str */
5882     regnode *ret = NULL;
5883     
5884     if (*RExC_parse != '{') {
5885         vFAIL("Missing braces on \\N{}");
5886     }
5887     name = RExC_parse+1;
5888     endbrace = strchr(RExC_parse, '}');
5889     if ( ! endbrace ) {
5890         RExC_parse++;
5891         vFAIL("Missing right brace on \\N{}");
5892     } 
5893     RExC_parse = endbrace + 1;  
5894     
5895     
5896     /* RExC_parse points at the beginning brace, 
5897        endbrace points at the last */
5898     if ( name[0]=='U' && name[1]=='+' ) {
5899         /* its a "unicode hex" notation {U+89AB} */
5900         I32 fl = PERL_SCAN_ALLOW_UNDERSCORES
5901             | PERL_SCAN_DISALLOW_PREFIX
5902             | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
5903         UV cp;
5904         len = (STRLEN)(endbrace - name - 2);
5905         cp = grok_hex(name + 2, &len, &fl, NULL);
5906         if ( len != (STRLEN)(endbrace - name - 2) ) {
5907             cp = 0xFFFD;
5908         }    
5909         if (cp > 0xff)
5910             RExC_utf8 = 1;
5911         if ( valuep ) {
5912             *valuep = cp;
5913             return NULL;
5914         }
5915         sv_str= Perl_newSVpvf_nocontext("%c",(int)cp);
5916     } else {
5917         /* fetch the charnames handler for this scope */
5918         HV * const table = GvHV(PL_hintgv);
5919         SV **cvp= table ? 
5920             hv_fetchs(table, "charnames", FALSE) :
5921             NULL;
5922         SV *cv= cvp ? *cvp : NULL;
5923         HE *he_str;
5924         int count;
5925         /* create an SV with the name as argument */
5926         sv_name = newSVpvn(name, endbrace - name);
5927         
5928         if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
5929             vFAIL2("Constant(\\N{%s}) unknown: "
5930                   "(possibly a missing \"use charnames ...\")",
5931                   SvPVX(sv_name));
5932         }
5933         if (!cvp || !SvOK(*cvp)) { /* when $^H{charnames} = undef; */
5934             vFAIL2("Constant(\\N{%s}): "
5935                   "$^H{charnames} is not defined",SvPVX(sv_name));
5936         }
5937         
5938         
5939         
5940         if (!RExC_charnames) {
5941             /* make sure our cache is allocated */
5942             RExC_charnames = newHV();
5943             sv_2mortal((SV*)RExC_charnames);
5944         } 
5945             /* see if we have looked this one up before */
5946         he_str = hv_fetch_ent( RExC_charnames, sv_name, 0, 0 );
5947         if ( he_str ) {
5948             sv_str = HeVAL(he_str);
5949             cached = 1;
5950         } else {
5951             dSP ;
5952
5953             ENTER ;
5954             SAVETMPS ;
5955             PUSHMARK(SP) ;
5956             
5957             XPUSHs(sv_name);
5958             
5959             PUTBACK ;
5960             
5961             count= call_sv(cv, G_SCALAR);
5962             
5963             if (count == 1) { /* XXXX is this right? dmq */
5964                 sv_str = POPs;
5965                 SvREFCNT_inc_simple_void(sv_str);
5966             } 
5967             
5968             SPAGAIN ;
5969             PUTBACK ;
5970             FREETMPS ;
5971             LEAVE ;
5972             
5973             if ( !sv_str || !SvOK(sv_str) ) {
5974                 vFAIL2("Constant(\\N{%s}): Call to &{$^H{charnames}} "
5975                       "did not return a defined value",SvPVX(sv_name));
5976             }
5977             if (hv_store_ent( RExC_charnames, sv_name, sv_str, 0))
5978                 cached = 1;
5979         }
5980     }
5981     if (valuep) {
5982         char *p = SvPV(sv_str, len);
5983         if (len) {
5984             STRLEN numlen = 1;
5985             if ( SvUTF8(sv_str) ) {
5986                 *valuep = utf8_to_uvchr((U8*)p, &numlen);
5987                 if (*valuep > 0x7F)
5988                     RExC_utf8 = 1; 
5989                 /* XXXX
5990                   We have to turn on utf8 for high bit chars otherwise
5991                   we get failures with
5992                   
5993                    "ss" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i
5994                    "SS" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i
5995                 
5996                   This is different from what \x{} would do with the same
5997                   codepoint, where the condition is > 0xFF.
5998                   - dmq
5999                 */
6000                 
6001                 
6002             } else {
6003                 *valuep = (UV)*p;
6004                 /* warn if we havent used the whole string? */
6005             }
6006             if (numlen<len && SIZE_ONLY && ckWARN(WARN_REGEXP)) {
6007                 vWARN2(RExC_parse,
6008                     "Ignoring excess chars from \\N{%s} in character class",
6009                     SvPVX(sv_name)
6010                 );
6011             }        
6012         } else if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
6013             vWARN2(RExC_parse,
6014                     "Ignoring zero length \\N{%s} in character class",
6015                     SvPVX(sv_name)
6016                 );
6017         }
6018         if (sv_name)    
6019             SvREFCNT_dec(sv_name);    
6020         if (!cached)
6021             SvREFCNT_dec(sv_str);    
6022         return len ? NULL : (regnode *)&len;
6023     } else if(SvCUR(sv_str)) {     
6024         
6025         char *s; 
6026         char *p, *pend;        
6027         STRLEN charlen = 1;
6028         char * parse_start = name-3; /* needed for the offsets */
6029         GET_RE_DEBUG_FLAGS_DECL;     /* needed for the offsets */
6030         
6031         ret = reg_node(pRExC_state,
6032             (U8)(FOLD ? (LOC ? EXACTFL : EXACTF) : EXACT));
6033         s= STRING(ret);
6034         
6035         if ( RExC_utf8 && !SvUTF8(sv_str) ) {
6036             sv_utf8_upgrade(sv_str);
6037         } else if ( !RExC_utf8 && SvUTF8(sv_str) ) {
6038             RExC_utf8= 1;
6039         }
6040         
6041         p = SvPV(sv_str, len);
6042         pend = p + len;
6043         /* len is the length written, charlen is the size the char read */
6044         for ( len = 0; p < pend; p += charlen ) {
6045             if (UTF) {
6046                 UV uvc = utf8_to_uvchr((U8*)p, &charlen);
6047                 if (FOLD) {
6048                     STRLEN foldlen,numlen;
6049                     U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
6050                     uvc = toFOLD_uni(uvc, tmpbuf, &foldlen);
6051                     /* Emit all the Unicode characters. */
6052                     
6053                     for (foldbuf = tmpbuf;
6054                         foldlen;
6055                         foldlen -= numlen) 
6056                     {
6057                         uvc = utf8_to_uvchr(foldbuf, &numlen);
6058                         if (numlen > 0) {
6059                             const STRLEN unilen = reguni(pRExC_state, uvc, s);
6060                             s       += unilen;
6061                             len     += unilen;
6062                             /* In EBCDIC the numlen
6063                             * and unilen can differ. */
6064                             foldbuf += numlen;
6065                             if (numlen >= foldlen)
6066                                 break;
6067                         }
6068                         else
6069                             break; /* "Can't happen." */
6070                     }                          
6071                 } else {
6072                     const STRLEN unilen = reguni(pRExC_state, uvc, s);
6073                     if (unilen > 0) {
6074                        s   += unilen;
6075                        len += unilen;
6076                     }
6077                 }
6078             } else {
6079                 len++;
6080                 REGC(*p, s++);
6081             }
6082         }
6083         if (SIZE_ONLY) {
6084             RExC_size += STR_SZ(len);
6085         } else {
6086             STR_LEN(ret) = len;
6087             RExC_emit += STR_SZ(len);
6088         }
6089         Set_Node_Cur_Length(ret); /* MJD */
6090         RExC_parse--; 
6091         nextchar(pRExC_state);
6092     } else {
6093         ret = reg_node(pRExC_state,NOTHING);
6094     }
6095     if (!cached) {
6096         SvREFCNT_dec(sv_str);
6097     }
6098     if (sv_name) {
6099         SvREFCNT_dec(sv_name); 
6100     }
6101     return ret;
6102
6103 }
6104
6105
6106 /*
6107  * reg_recode
6108  *
6109  * It returns the code point in utf8 for the value in *encp.
6110  *    value: a code value in the source encoding
6111  *    encp:  a pointer to an Encode object
6112  *
6113  * If the result from Encode is not a single character,
6114  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
6115  */
6116 STATIC UV
6117 S_reg_recode(pTHX_ const char value, SV **encp)
6118 {
6119     STRLEN numlen = 1;
6120     SV * const sv = sv_2mortal(newSVpvn(&value, numlen));
6121     const char * const s = encp && *encp ? sv_recode_to_utf8(sv, *encp)
6122                                          : SvPVX(sv);
6123     const STRLEN newlen = SvCUR(sv);
6124     UV uv = UNICODE_REPLACEMENT;
6125
6126     if (newlen)
6127         uv = SvUTF8(sv)
6128              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
6129              : *(U8*)s;
6130
6131     if (!newlen || numlen != newlen) {
6132         uv = UNICODE_REPLACEMENT;
6133         if (encp)
6134             *encp = NULL;
6135     }
6136     return uv;
6137 }
6138
6139
6140 /*
6141  - regatom - the lowest level
6142  *
6143  * Optimization:  gobbles an entire sequence of ordinary characters so that
6144  * it can turn them into a single node, which is smaller to store and
6145  * faster to run.  Backslashed characters are exceptions, each becoming a
6146  * separate node; the code is simpler that way and it's not worth fixing.
6147  *
6148  * [Yes, it is worth fixing, some scripts can run twice the speed.]
6149  * [It looks like its ok, as in S_study_chunk we merge adjacent EXACT nodes]
6150  */
6151 STATIC regnode *
6152 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
6153 {
6154     dVAR;
6155     register regnode *ret = NULL;
6156     I32 flags;
6157     char *parse_start = RExC_parse;
6158     GET_RE_DEBUG_FLAGS_DECL;
6159     DEBUG_PARSE("atom");
6160     *flagp = WORST;             /* Tentatively. */
6161
6162 tryagain:
6163     switch (*RExC_parse) {
6164     case '^':
6165         RExC_seen_zerolen++;
6166         nextchar(pRExC_state);
6167         if (RExC_flags & RXf_PMf_MULTILINE)
6168             ret = reg_node(pRExC_state, MBOL);
6169         else if (RExC_flags & RXf_PMf_SINGLELINE)
6170             ret = reg_node(pRExC_state, SBOL);
6171         else
6172             ret = reg_node(pRExC_state, BOL);
6173         Set_Node_Length(ret, 1); /* MJD */
6174         break;
6175     case '$':
6176         nextchar(pRExC_state);
6177         if (*RExC_parse)
6178             RExC_seen_zerolen++;
6179         if (RExC_flags & RXf_PMf_MULTILINE)
6180             ret = reg_node(pRExC_state, MEOL);
6181         else if (RExC_flags & RXf_PMf_SINGLELINE)
6182             ret = reg_node(pRExC_state, SEOL);
6183         else
6184             ret = reg_node(pRExC_state, EOL);
6185         Set_Node_Length(ret, 1); /* MJD */
6186         break;
6187     case '.':
6188         nextchar(pRExC_state);
6189         if (RExC_flags & RXf_PMf_SINGLELINE)
6190             ret = reg_node(pRExC_state, SANY);
6191         else
6192             ret = reg_node(pRExC_state, REG_ANY);
6193         *flagp |= HASWIDTH|SIMPLE;
6194         RExC_naughty++;
6195         Set_Node_Length(ret, 1); /* MJD */
6196         break;
6197     case '[':
6198     {
6199         char * const oregcomp_parse = ++RExC_parse;
6200         ret = regclass(pRExC_state,depth+1);
6201         if (*RExC_parse != ']') {
6202             RExC_parse = oregcomp_parse;
6203             vFAIL("Unmatched [");
6204         }
6205         nextchar(pRExC_state);
6206         *flagp |= HASWIDTH|SIMPLE;
6207         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
6208         break;
6209     }
6210     case '(':
6211         nextchar(pRExC_state);
6212         ret = reg(pRExC_state, 1, &flags,depth+1);
6213         if (ret == NULL) {
6214                 if (flags & TRYAGAIN) {
6215                     if (RExC_parse == RExC_end) {
6216                          /* Make parent create an empty node if needed. */
6217                         *flagp |= TRYAGAIN;
6218                         return(NULL);
6219                     }
6220                     goto tryagain;
6221                 }
6222                 return(NULL);
6223         }
6224         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE);
6225         break;
6226     case '|':
6227     case ')':
6228         if (flags & TRYAGAIN) {
6229             *flagp |= TRYAGAIN;
6230             return NULL;
6231         }
6232         vFAIL("Internal urp");
6233                                 /* Supposed to be caught earlier. */
6234         break;
6235     case '{':
6236         if (!regcurly(RExC_parse)) {
6237             RExC_parse++;
6238             goto defchar;
6239         }
6240         /* FALL THROUGH */
6241     case '?':
6242     case '+':
6243     case '*':
6244         RExC_parse++;
6245         vFAIL("Quantifier follows nothing");
6246         break;
6247     case '\\':
6248         switch (*++RExC_parse) {
6249         case 'A':
6250             RExC_seen_zerolen++;
6251             ret = reg_node(pRExC_state, SBOL);
6252             *flagp |= SIMPLE;
6253             nextchar(pRExC_state);
6254             Set_Node_Length(ret, 2); /* MJD */
6255             break;
6256         case 'G':
6257             ret = reg_node(pRExC_state, GPOS);
6258             RExC_seen |= REG_SEEN_GPOS;
6259             *flagp |= SIMPLE;
6260             nextchar(pRExC_state);
6261             Set_Node_Length(ret, 2); /* MJD */
6262             break;
6263         case 'Z':
6264             ret = reg_node(pRExC_state, SEOL);
6265             *flagp |= SIMPLE;
6266             RExC_seen_zerolen++;                /* Do not optimize RE away */
6267             nextchar(pRExC_state);
6268             break;
6269         case 'z':
6270             ret = reg_node(pRExC_state, EOS);
6271             *flagp |= SIMPLE;
6272             RExC_seen_zerolen++;                /* Do not optimize RE away */
6273             nextchar(pRExC_state);
6274             Set_Node_Length(ret, 2); /* MJD */
6275             break;
6276         case 'C':
6277             ret = reg_node(pRExC_state, CANY);
6278             RExC_seen |= REG_SEEN_CANY;
6279             *flagp |= HASWIDTH|SIMPLE;
6280             nextchar(pRExC_state);
6281             Set_Node_Length(ret, 2); /* MJD */
6282             break;
6283         case 'X':
6284             ret = reg_node(pRExC_state, CLUMP);
6285             *flagp |= HASWIDTH;
6286             nextchar(pRExC_state);
6287             Set_Node_Length(ret, 2); /* MJD */
6288             break;
6289         case 'w':
6290             ret = reg_node(pRExC_state, (U8)(LOC ? ALNUML     : ALNUM));
6291             *flagp |= HASWIDTH|SIMPLE;
6292             nextchar(pRExC_state);
6293             Set_Node_Length(ret, 2); /* MJD */
6294             break;
6295         case 'W':
6296             ret = reg_node(pRExC_state, (U8)(LOC ? NALNUML    : NALNUM));
6297             *flagp |= HASWIDTH|SIMPLE;
6298             nextchar(pRExC_state);
6299             Set_Node_Length(ret, 2); /* MJD */
6300             break;
6301         case 'b':
6302             RExC_seen_zerolen++;
6303             RExC_seen |= REG_SEEN_LOOKBEHIND;
6304             ret = reg_node(pRExC_state, (U8)(LOC ? BOUNDL     : BOUND));
6305             *flagp |= SIMPLE;
6306             nextchar(pRExC_state);
6307             Set_Node_Length(ret, 2); /* MJD */
6308             break;
6309         case 'B':
6310             RExC_seen_zerolen++;
6311             RExC_seen |= REG_SEEN_LOOKBEHIND;
6312             ret = reg_node(pRExC_state, (U8)(LOC ? NBOUNDL    : NBOUND));
6313             *flagp |= SIMPLE;
6314             nextchar(pRExC_state);
6315             Set_Node_Length(ret, 2); /* MJD */
6316             break;
6317         case 's':
6318             ret = reg_node(pRExC_state, (U8)(LOC ? SPACEL     : SPACE));
6319             *flagp |= HASWIDTH|SIMPLE;
6320             nextchar(pRExC_state);
6321             Set_Node_Length(ret, 2); /* MJD */
6322             break;
6323         case 'S':
6324             ret = reg_node(pRExC_state, (U8)(LOC ? NSPACEL    : NSPACE));
6325             *flagp |= HASWIDTH|SIMPLE;
6326             nextchar(pRExC_state);
6327             Set_Node_Length(ret, 2); /* MJD */
6328             break;
6329         case 'd':
6330             ret = reg_node(pRExC_state, DIGIT);
6331             *flagp |= HASWIDTH|SIMPLE;
6332             nextchar(pRExC_state);
6333             Set_Node_Length(ret, 2); /* MJD */
6334             break;
6335         case 'D':
6336             ret = reg_node(pRExC_state, NDIGIT);
6337             *flagp |= HASWIDTH|SIMPLE;
6338             nextchar(pRExC_state);
6339             Set_Node_Length(ret, 2); /* MJD */
6340             break;
6341         case 'p':
6342         case 'P':
6343             {   
6344                 char* const oldregxend = RExC_end;
6345                 char* parse_start = RExC_parse - 2;
6346
6347                 if (RExC_parse[1] == '{') {
6348                   /* a lovely hack--pretend we saw [\pX] instead */
6349                     RExC_end = strchr(RExC_parse, '}');
6350                     if (!RExC_end) {
6351                         const U8 c = (U8)*RExC_parse;
6352                         RExC_parse += 2;
6353                         RExC_end = oldregxend;
6354                         vFAIL2("Missing right brace on \\%c{}", c);
6355                     }
6356                     RExC_end++;
6357                 }
6358                 else {
6359                     RExC_end = RExC_parse + 2;
6360                     if (RExC_end > oldregxend)
6361                         RExC_end = oldregxend;
6362                 }
6363                 RExC_parse--;
6364
6365                 ret = regclass(pRExC_state,depth+1);
6366
6367                 RExC_end = oldregxend;
6368                 RExC_parse--;
6369
6370                 Set_Node_Offset(ret, parse_start + 2);
6371                 Set_Node_Cur_Length(ret);
6372                 nextchar(pRExC_state);
6373                 *flagp |= HASWIDTH|SIMPLE;
6374             }
6375             break;
6376         case 'N': 
6377             /* Handle \N{NAME} here and not below because it can be 
6378             multicharacter. join_exact() will join them up later on. 
6379             Also this makes sure that things like /\N{BLAH}+/ and 
6380             \N{BLAH} being multi char Just Happen. dmq*/
6381             ++RExC_parse;
6382             ret= reg_namedseq(pRExC_state, NULL); 
6383             break;
6384         case 'k':    /* Handle \k<NAME> and \k'NAME' */
6385         parse_named_seq:
6386         {   
6387             char ch= RExC_parse[1];         
6388             if (ch != '<' && ch != '\'' && ch != '{') {
6389                 RExC_parse++;
6390                 vFAIL2("Sequence %.2s... not terminated",parse_start);
6391             } else {
6392                 /* this pretty much dupes the code for (?P=...) in reg(), if
6393                    you change this make sure you change that */
6394                 char* name_start = (RExC_parse += 2);
6395                 U32 num = 0;
6396                 SV *sv_dat = reg_scan_name(pRExC_state,
6397                     SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6398                 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
6399                 if (RExC_parse == name_start || *RExC_parse != ch)
6400                     vFAIL2("Sequence %.3s... not terminated",parse_start);
6401
6402                 if (!SIZE_ONLY) {
6403                     num = add_data( pRExC_state, 1, "S" );
6404                     RExC_rxi->data->data[num]=(void*)sv_dat;
6405                     SvREFCNT_inc(sv_dat);
6406                 }
6407
6408                 RExC_sawback = 1;
6409                 ret = reganode(pRExC_state,
6410                            (U8)(FOLD ? (LOC ? NREFFL : NREFF) : NREF),
6411                            num);
6412                 *flagp |= HASWIDTH;
6413
6414                 /* override incorrect value set in reganode MJD */
6415                 Set_Node_Offset(ret, parse_start+1);
6416                 Set_Node_Cur_Length(ret); /* MJD */
6417                 nextchar(pRExC_state);
6418
6419             }
6420             break;
6421         }
6422         case 'n':
6423         case 'r':
6424         case 't':
6425         case 'f':
6426         case 'e':
6427         case 'a':
6428         case 'x':
6429         case 'c':
6430         case '0':
6431             goto defchar;
6432         case 'g': 
6433         case '1': case '2': case '3': case '4':
6434         case '5': case '6': case '7': case '8': case '9':
6435             {
6436                 I32 num;
6437                 bool isg = *RExC_parse == 'g';
6438                 bool isrel = 0; 
6439                 bool hasbrace = 0;
6440                 if (isg) {
6441                     RExC_parse++;
6442                     if (*RExC_parse == '{') {
6443                         RExC_parse++;
6444                         hasbrace = 1;
6445                     }
6446                     if (*RExC_parse == '-') {
6447                         RExC_parse++;
6448                         isrel = 1;
6449                     }
6450                     if (hasbrace && !isDIGIT(*RExC_parse)) {
6451                         if (isrel) RExC_parse--;
6452                         RExC_parse -= 2;                            
6453                         goto parse_named_seq;
6454                 }   }
6455                 num = atoi(RExC_parse);
6456                 if (isrel) {
6457                     num = RExC_npar - num;
6458                     if (num < 1)
6459                         vFAIL("Reference to nonexistent or unclosed group");
6460                 }
6461                 if (!isg && num > 9 && num >= RExC_npar)
6462                     goto defchar;
6463                 else {
6464                     char * const parse_start = RExC_parse - 1; /* MJD */
6465                     while (isDIGIT(*RExC_parse))
6466                         RExC_parse++;
6467                     if (parse_start == RExC_parse - 1) 
6468                         vFAIL("Unterminated \\g... pattern");
6469                     if (hasbrace) {
6470                         if (*RExC_parse != '}') 
6471                             vFAIL("Unterminated \\g{...} pattern");
6472                         RExC_parse++;
6473                     }    
6474                     if (!SIZE_ONLY) {
6475                         if (num > (I32)RExC_rx->nparens)
6476                             vFAIL("Reference to nonexistent group");
6477                     }
6478                     RExC_sawback = 1;
6479                     ret = reganode(pRExC_state,
6480                                    (U8)(FOLD ? (LOC ? REFFL : REFF) : REF),
6481                                    num);
6482                     *flagp |= HASWIDTH;
6483
6484                     /* override incorrect value set in reganode MJD */
6485                     Set_Node_Offset(ret, parse_start+1);
6486                     Set_Node_Cur_Length(ret); /* MJD */
6487                     RExC_parse--;
6488                     nextchar(pRExC_state);
6489                 }
6490             }
6491             break;
6492         case '\0':
6493             if (RExC_parse >= RExC_end)
6494                 FAIL("Trailing \\");
6495             /* FALL THROUGH */
6496         default:
6497             /* Do not generate "unrecognized" warnings here, we fall
6498                back into the quick-grab loop below */
6499             parse_start--;
6500             goto defchar;
6501         }
6502         break;
6503
6504     case '#':
6505         if (RExC_flags & RXf_PMf_EXTENDED) {
6506             while (RExC_parse < RExC_end && *RExC_parse != '\n')
6507                 RExC_parse++;
6508             if (RExC_parse < RExC_end)
6509                 goto tryagain;
6510         }
6511         /* FALL THROUGH */
6512
6513     default: {
6514             register STRLEN len;
6515             register UV ender;
6516             register char *p;
6517             char *s;
6518             STRLEN foldlen;
6519             U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
6520
6521             parse_start = RExC_parse - 1;
6522
6523             RExC_parse++;
6524
6525         defchar:
6526             ender = 0;
6527             ret = reg_node(pRExC_state,
6528                            (U8)(FOLD ? (LOC ? EXACTFL : EXACTF) : EXACT));
6529             s = STRING(ret);
6530             for (len = 0, p = RExC_parse - 1;
6531               len < 127 && p < RExC_end;
6532               len++)
6533             {
6534                 char * const oldp = p;
6535
6536                 if (RExC_flags & RXf_PMf_EXTENDED)
6537                     p = regwhite(p, RExC_end);
6538                 switch (*p) {
6539                 case '^':
6540                 case '$':
6541                 case '.':
6542                 case '[':
6543                 case '(':
6544                 case ')':
6545                 case '|':
6546                     goto loopdone;
6547                 case '\\':
6548                     switch (*++p) {
6549                     case 'A':
6550                     case 'C':
6551                     case 'X':
6552                     case 'G':
6553                     case 'g':
6554                     case 'Z':
6555                     case 'z':
6556                     case 'w':
6557                     case 'W':
6558                     case 'b':
6559                     case 'B':
6560                     case 's':
6561                     case 'S':
6562                     case 'd':
6563                     case 'D':
6564                     case 'p':
6565                     case 'P':
6566                     case 'N':
6567                     case 'R':
6568                     case 'k':
6569                         --p;
6570                         goto loopdone;
6571                     case 'n':
6572                         ender = '\n';
6573                         p++;
6574                         break;
6575                     case 'r':
6576                         ender = '\r';
6577                         p++;
6578                         break;
6579                     case 't':
6580                         ender = '\t';
6581                         p++;
6582                         break;
6583                     case 'f':
6584                         ender = '\f';
6585                         p++;
6586                         break;
6587                     case 'e':
6588                           ender = ASCII_TO_NATIVE('\033');
6589                         p++;
6590                         break;
6591                     case 'a':
6592                           ender = ASCII_TO_NATIVE('\007');
6593                         p++;
6594                         break;
6595                     case 'x':
6596                         if (*++p == '{') {
6597                             char* const e = strchr(p, '}');
6598         
6599                             if (!e) {
6600                                 RExC_parse = p + 1;
6601                                 vFAIL("Missing right brace on \\x{}");
6602                             }
6603                             else {
6604                                 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
6605                                     | PERL_SCAN_DISALLOW_PREFIX;
6606                                 STRLEN numlen = e - p - 1;
6607                                 ender = grok_hex(p + 1, &numlen, &flags, NULL);
6608                                 if (ender > 0xff)
6609                                     RExC_utf8 = 1;
6610                                 p = e + 1;
6611                             }
6612                         }
6613                         else {
6614                             I32 flags = PERL_SCAN_DISALLOW_PREFIX;
6615                             STRLEN numlen = 2;
6616                             ender = grok_hex(p, &numlen, &flags, NULL);
6617                             p += numlen;
6618                         }
6619                         if (PL_encoding && ender < 0x100)
6620                             goto recode_encoding;
6621                         break;
6622                     case 'c':
6623                         p++;
6624                         ender = UCHARAT(p++);
6625                         ender = toCTRL(ender);
6626                         break;
6627                     case '0': case '1': case '2': case '3':case '4':
6628                     case '5': case '6': case '7': case '8':case '9':
6629                         if (*p == '0' ||
6630                           (isDIGIT(p[1]) && atoi(p) >= RExC_npar) ) {
6631                             I32 flags = 0;
6632                             STRLEN numlen = 3;
6633                             ender = grok_oct(p, &numlen, &flags, NULL);
6634                             p += numlen;
6635                         }
6636                         else {
6637                             --p;
6638                             goto loopdone;
6639                         }
6640                         if (PL_encoding && ender < 0x100)
6641                             goto recode_encoding;
6642                         break;
6643                     recode_encoding:
6644                         {
6645                             SV* enc = PL_encoding;
6646                             ender = reg_recode((const char)(U8)ender, &enc);
6647                             if (!enc && SIZE_ONLY && ckWARN(WARN_REGEXP))
6648                                 vWARN(p, "Invalid escape in the specified encoding");
6649                             RExC_utf8 = 1;
6650                         }
6651                         break;
6652                     case '\0':
6653                         if (p >= RExC_end)
6654                             FAIL("Trailing \\");
6655                         /* FALL THROUGH */
6656                     default:
6657                         if (!SIZE_ONLY&& isALPHA(*p) && ckWARN(WARN_REGEXP))
6658                             vWARN2(p + 1, "Unrecognized escape \\%c passed through", UCHARAT(p));
6659                         goto normal_default;
6660                     }
6661                     break;
6662                 default:
6663                   normal_default:
6664                     if (UTF8_IS_START(*p) && UTF) {
6665                         STRLEN numlen;
6666                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
6667                                                &numlen, UTF8_ALLOW_DEFAULT);
6668                         p += numlen;
6669                     }
6670                     else
6671                         ender = *p++;
6672                     break;
6673                 }
6674                 if (RExC_flags & RXf_PMf_EXTENDED)
6675                     p = regwhite(p, RExC_end);
6676                 if (UTF && FOLD) {
6677                     /* Prime the casefolded buffer. */
6678                     ender = toFOLD_uni(ender, tmpbuf, &foldlen);
6679                 }
6680                 if (ISMULT2(p)) { /* Back off on ?+*. */
6681                     if (len)
6682                         p = oldp;
6683                     else if (UTF) {
6684                          if (FOLD) {
6685                               /* Emit all the Unicode characters. */
6686                               STRLEN numlen;
6687                               for (foldbuf = tmpbuf;
6688                                    foldlen;
6689                                    foldlen -= numlen) {
6690                                    ender = utf8_to_uvchr(foldbuf, &numlen);
6691                                    if (numlen > 0) {
6692                                         const STRLEN unilen = reguni(pRExC_state, ender, s);
6693                                         s       += unilen;
6694                                         len     += unilen;
6695                                         /* In EBCDIC the numlen
6696                                          * and unilen can differ. */
6697                                         foldbuf += numlen;
6698                                         if (numlen >= foldlen)
6699                                              break;
6700                                    }
6701                                    else
6702                                         break; /* "Can't happen." */
6703                               }
6704                          }
6705                          else {
6706                               const STRLEN unilen = reguni(pRExC_state, ender, s);
6707                               if (unilen > 0) {
6708                                    s   += unilen;
6709                                    len += unilen;
6710                               }
6711                          }
6712                     }
6713                     else {
6714                         len++;
6715                         REGC((char)ender, s++);
6716                     }
6717                     break;
6718                 }
6719                 if (UTF) {
6720                      if (FOLD) {
6721                           /* Emit all the Unicode characters. */
6722                           STRLEN numlen;
6723                           for (foldbuf = tmpbuf;
6724                                foldlen;
6725                                foldlen -= numlen) {
6726                                ender = utf8_to_uvchr(foldbuf, &numlen);
6727                                if (numlen > 0) {
6728                                     const STRLEN unilen = reguni(pRExC_state, ender, s);
6729                                     len     += unilen;
6730                                     s       += unilen;
6731                                     /* In EBCDIC the numlen
6732                                      * and unilen can differ. */
6733                                     foldbuf += numlen;
6734                                     if (numlen >= foldlen)
6735                                          break;
6736                                }
6737                                else
6738                                     break;
6739                           }
6740                      }
6741                      else {
6742                           const STRLEN unilen = reguni(pRExC_state, ender, s);
6743                           if (unilen > 0) {
6744                                s   += unilen;
6745                                len += unilen;
6746                           }
6747                      }
6748                      len--;
6749                 }
6750                 else
6751                     REGC((char)ender, s++);
6752             }
6753         loopdone:
6754             RExC_parse = p - 1;
6755             Set_Node_Cur_Length(ret); /* MJD */
6756             nextchar(pRExC_state);
6757             {
6758                 /* len is STRLEN which is unsigned, need to copy to signed */
6759                 IV iv = len;
6760                 if (iv < 0)
6761                     vFAIL("Internal disaster");
6762             }
6763             if (len > 0)
6764                 *flagp |= HASWIDTH;
6765             if (len == 1 && UNI_IS_INVARIANT(ender))
6766                 *flagp |= SIMPLE;
6767                 
6768             if (SIZE_ONLY)
6769                 RExC_size += STR_SZ(len);
6770             else {
6771                 STR_LEN(ret) = len;
6772                 RExC_emit += STR_SZ(len);
6773             }
6774         }
6775         break;
6776     }
6777
6778     return(ret);
6779 }
6780
6781 STATIC char *
6782 S_regwhite(char *p, const char *e)
6783 {
6784     while (p < e) {
6785         if (isSPACE(*p))
6786             ++p;
6787         else if (*p == '#') {
6788             do {
6789                 p++;
6790             } while (p < e && *p != '\n');
6791         }
6792         else
6793             break;
6794     }
6795     return p;
6796 }
6797
6798 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
6799    Character classes ([:foo:]) can also be negated ([:^foo:]).
6800    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
6801    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
6802    but trigger failures because they are currently unimplemented. */
6803
6804 #define POSIXCC_DONE(c)   ((c) == ':')
6805 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
6806 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
6807
6808 STATIC I32
6809 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
6810 {
6811     dVAR;
6812     I32 namedclass = OOB_NAMEDCLASS;
6813
6814     if (value == '[' && RExC_parse + 1 < RExC_end &&
6815         /* I smell either [: or [= or [. -- POSIX has been here, right? */
6816         POSIXCC(UCHARAT(RExC_parse))) {
6817         const char c = UCHARAT(RExC_parse);
6818         char* const s = RExC_parse++;
6819         
6820         while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
6821             RExC_parse++;
6822         if (RExC_parse == RExC_end)
6823             /* Grandfather lone [:, [=, [. */
6824             RExC_parse = s;
6825         else {
6826             const char* const t = RExC_parse++; /* skip over the c */
6827             assert(*t == c);
6828
6829             if (UCHARAT(RExC_parse) == ']') {
6830                 const char *posixcc = s + 1;
6831                 RExC_parse++; /* skip over the ending ] */
6832
6833                 if (*s == ':') {
6834                     const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
6835                     const I32 skip = t - posixcc;
6836
6837                     /* Initially switch on the length of the name.  */
6838                     switch (skip) {
6839                     case 4:
6840                         if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
6841                             namedclass = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
6842                         break;
6843                     case 5:
6844                         /* Names all of length 5.  */
6845                         /* alnum alpha ascii blank cntrl digit graph lower
6846                            print punct space upper  */
6847                         /* Offset 4 gives the best switch position.  */
6848                         switch (posixcc[4]) {
6849                         case 'a':
6850                             if (memEQ(posixcc, "alph", 4)) /* alpha */
6851                                 namedclass = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
6852                             break;
6853                         case 'e':
6854                             if (memEQ(posixcc, "spac", 4)) /* space */
6855                                 namedclass = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
6856                             break;
6857                         case 'h':
6858                             if (memEQ(posixcc, "grap", 4)) /* graph */
6859                                 namedclass = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
6860                             break;
6861                         case 'i':
6862                             if (memEQ(posixcc, "asci", 4)) /* ascii */
6863                                 namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII;
6864                             break;
6865                         case 'k':
6866                             if (memEQ(posixcc, "blan", 4)) /* blank */
6867                                 namedclass = complement ? ANYOF_NBLANK : ANYOF_BLANK;
6868                             break;
6869                         case 'l':
6870                             if (memEQ(posixcc, "cntr", 4)) /* cntrl */
6871                                 namedclass = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
6872                             break;
6873                         case 'm':
6874                             if (memEQ(posixcc, "alnu", 4)) /* alnum */
6875                                 namedclass = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
6876                             break;
6877                         case 'r':
6878                             if (memEQ(posixcc, "lowe", 4)) /* lower */
6879                                 namedclass = complement ? ANYOF_NLOWER : ANYOF_LOWER;
6880                             else if (memEQ(posixcc, "uppe", 4)) /* upper */
6881                                 namedclass = complement ? ANYOF_NUPPER : ANYOF_UPPER;
6882                             break;
6883                         case 't':
6884                             if (memEQ(posixcc, "digi", 4)) /* digit */
6885                                 namedclass = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
6886                             else if (memEQ(posixcc, "prin", 4)) /* print */
6887                                 namedclass = complement ? ANYOF_NPRINT : ANYOF_PRINT;
6888                             else if (memEQ(posixcc, "punc", 4)) /* punct */
6889                                 namedclass = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
6890                             break;
6891                         }
6892                         break;
6893                     case 6:
6894                         if (memEQ(posixcc, "xdigit", 6))
6895                             namedclass = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
6896                         break;
6897                     }
6898
6899                     if (namedclass == OOB_NAMEDCLASS)
6900                         Simple_vFAIL3("POSIX class [:%.*s:] unknown",
6901                                       t - s - 1, s + 1);
6902                     assert (posixcc[skip] == ':');
6903                     assert (posixcc[skip+1] == ']');
6904                 } else if (!SIZE_ONLY) {
6905                     /* [[=foo=]] and [[.foo.]] are still future. */
6906
6907                     /* adjust RExC_parse so the warning shows after
6908                        the class closes */
6909                     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
6910                         RExC_parse++;
6911                     Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
6912                 }
6913             } else {
6914                 /* Maternal grandfather:
6915                  * "[:" ending in ":" but not in ":]" */
6916                 RExC_parse = s;
6917             }
6918         }
6919     }
6920
6921     return namedclass;
6922 }
6923
6924 STATIC void
6925 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
6926 {
6927     dVAR;
6928     if (POSIXCC(UCHARAT(RExC_parse))) {
6929         const char *s = RExC_parse;
6930         const char  c = *s++;
6931
6932         while (isALNUM(*s))
6933             s++;
6934         if (*s && c == *s && s[1] == ']') {
6935             if (ckWARN(WARN_REGEXP))
6936                 vWARN3(s+2,
6937                         "POSIX syntax [%c %c] belongs inside character classes",
6938                         c, c);
6939
6940             /* [[=foo=]] and [[.foo.]] are still future. */
6941             if (POSIXCC_NOTYET(c)) {
6942                 /* adjust RExC_parse so the error shows after
6943                    the class closes */
6944                 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
6945                     NOOP;
6946                 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
6947             }
6948         }
6949     }
6950 }
6951
6952
6953 #define _C_C_T_(NAME,TEST,WORD)                         \
6954 ANYOF_##NAME:                                           \
6955     if (LOC)                                            \
6956         ANYOF_CLASS_SET(ret, ANYOF_##NAME);             \
6957     else {                                              \
6958         for (value = 0; value < 256; value++)           \
6959             if (TEST)                                   \
6960                 ANYOF_BITMAP_SET(ret, value);           \
6961     }                                                   \
6962     yesno = '+';                                        \
6963     what = WORD;                                        \
6964     break;                                              \
6965 case ANYOF_N##NAME:                                     \
6966     if (LOC)                                            \
6967         ANYOF_CLASS_SET(ret, ANYOF_N##NAME);            \
6968     else {                                              \
6969         for (value = 0; value < 256; value++)           \
6970             if (!TEST)                                  \
6971                 ANYOF_BITMAP_SET(ret, value);           \
6972     }                                                   \
6973     yesno = '!';                                        \
6974     what = WORD;                                        \
6975     break
6976
6977
6978 /*
6979    parse a class specification and produce either an ANYOF node that
6980    matches the pattern or if the pattern matches a single char only and
6981    that char is < 256 and we are case insensitive then we produce an 
6982    EXACT node instead.
6983 */
6984
6985 STATIC regnode *
6986 S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
6987 {
6988     dVAR;
6989     register UV value = 0;
6990     register UV nextvalue;
6991     register IV prevvalue = OOB_UNICODE;
6992     register IV range = 0;
6993     register regnode *ret;
6994     STRLEN numlen;
6995     IV namedclass;
6996     char *rangebegin = NULL;
6997     bool need_class = 0;
6998     SV *listsv = NULL;
6999     UV n;
7000     bool optimize_invert   = TRUE;
7001     AV* unicode_alternate  = NULL;
7002 #ifdef EBCDIC
7003     UV literal_endpoint = 0;
7004 #endif
7005     UV stored = 0;  /* number of chars stored in the class */
7006
7007     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
7008         case we need to change the emitted regop to an EXACT. */
7009     const char * orig_parse = RExC_parse;
7010     GET_RE_DEBUG_FLAGS_DECL;
7011 #ifndef DEBUGGING
7012     PERL_UNUSED_ARG(depth);
7013 #endif
7014
7015     DEBUG_PARSE("clas");
7016
7017     /* Assume we are going to generate an ANYOF node. */
7018     ret = reganode(pRExC_state, ANYOF, 0);
7019
7020     if (!SIZE_ONLY)
7021         ANYOF_FLAGS(ret) = 0;
7022
7023     if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
7024         RExC_naughty++;
7025         RExC_parse++;
7026         if (!SIZE_ONLY)
7027             ANYOF_FLAGS(ret) |= ANYOF_INVERT;
7028     }
7029
7030     if (SIZE_ONLY) {
7031         RExC_size += ANYOF_SKIP;
7032         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
7033     }
7034     else {
7035         RExC_emit += ANYOF_SKIP;
7036         if (FOLD)
7037             ANYOF_FLAGS(ret) |= ANYOF_FOLD;
7038         if (LOC)
7039             ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
7040         ANYOF_BITMAP_ZERO(ret);
7041         listsv = newSVpvs("# comment\n");
7042     }
7043
7044     nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
7045
7046     if (!SIZE_ONLY && POSIXCC(nextvalue))
7047         checkposixcc(pRExC_state);
7048
7049     /* allow 1st char to be ] (allowing it to be - is dealt with later) */
7050     if (UCHARAT(RExC_parse) == ']')
7051         goto charclassloop;
7052
7053 parseit:
7054     while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
7055
7056     charclassloop:
7057
7058         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
7059
7060         if (!range)
7061             rangebegin = RExC_parse;
7062         if (UTF) {
7063             value = utf8n_to_uvchr((U8*)RExC_parse,
7064                                    RExC_end - RExC_parse,
7065                                    &numlen, UTF8_ALLOW_DEFAULT);
7066             RExC_parse += numlen;
7067         }
7068         else
7069             value = UCHARAT(RExC_parse++);
7070
7071         nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
7072         if (value == '[' && POSIXCC(nextvalue))
7073             namedclass = regpposixcc(pRExC_state, value);
7074         else if (value == '\\') {
7075             if (UTF) {
7076                 value = utf8n_to_uvchr((U8*)RExC_parse,
7077                                    RExC_end - RExC_parse,
7078                                    &numlen, UTF8_ALLOW_DEFAULT);
7079                 RExC_parse += numlen;
7080             }
7081             else
7082                 value = UCHARAT(RExC_parse++);
7083             /* Some compilers cannot handle switching on 64-bit integer
7084              * values, therefore value cannot be an UV.  Yes, this will
7085              * be a problem later if we want switch on Unicode.
7086              * A similar issue a little bit later when switching on
7087              * namedclass. --jhi */
7088             switch ((I32)value) {
7089             case 'w':   namedclass = ANYOF_ALNUM;       break;
7090             case 'W':   namedclass = ANYOF_NALNUM;      break;
7091             case 's':   namedclass = ANYOF_SPACE;       break;
7092             case 'S':   namedclass = ANYOF_NSPACE;      break;
7093             case 'd':   namedclass = ANYOF_DIGIT;       break;
7094             case 'D':   namedclass = ANYOF_NDIGIT;      break;
7095             case 'N':  /* Handle \N{NAME} in class */
7096                 {
7097                     /* We only pay attention to the first char of 
7098                     multichar strings being returned. I kinda wonder
7099                     if this makes sense as it does change the behaviour
7100                     from earlier versions, OTOH that behaviour was broken
7101                     as well. */
7102                     UV v; /* value is register so we cant & it /grrr */
7103                     if (reg_namedseq(pRExC_state, &v)) {
7104                         goto parseit;
7105                     }
7106                     value= v; 
7107                 }
7108                 break;
7109             case 'p':
7110             case 'P':
7111                 {
7112                 char *e;
7113                 if (RExC_parse >= RExC_end)
7114                     vFAIL2("Empty \\%c{}", (U8)value);
7115                 if (*RExC_parse == '{') {
7116                     const U8 c = (U8)value;
7117                     e = strchr(RExC_parse++, '}');
7118                     if (!e)
7119                         vFAIL2("Missing right brace on \\%c{}", c);
7120                     while (isSPACE(UCHARAT(RExC_parse)))
7121                         RExC_parse++;
7122                     if (e == RExC_parse)
7123                         vFAIL2("Empty \\%c{}", c);
7124                     n = e - RExC_parse;
7125                     while (isSPACE(UCHARAT(RExC_parse + n - 1)))
7126                         n--;
7127                 }
7128                 else {
7129                     e = RExC_parse;
7130                     n = 1;
7131                 }
7132                 if (!SIZE_ONLY) {
7133                     if (UCHARAT(RExC_parse) == '^') {
7134                          RExC_parse++;
7135                          n--;
7136                          value = value == 'p' ? 'P' : 'p'; /* toggle */
7137                          while (isSPACE(UCHARAT(RExC_parse))) {
7138                               RExC_parse++;
7139                               n--;
7140                          }
7141                     }
7142                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%.*s\n",
7143                         (value=='p' ? '+' : '!'), (int)n, RExC_parse);
7144                 }
7145                 RExC_parse = e + 1;
7146                 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
7147                 namedclass = ANYOF_MAX;  /* no official name, but it's named */
7148                 }
7149                 break;
7150             case 'n':   value = '\n';                   break;
7151             case 'r':   value = '\r';                   break;
7152             case 't':   value = '\t';                   break;
7153             case 'f':   value = '\f';                   break;
7154             case 'b':   value = '\b';                   break;
7155             case 'e':   value = ASCII_TO_NATIVE('\033');break;
7156             case 'a':   value = ASCII_TO_NATIVE('\007');break;
7157             case 'x':
7158                 if (*RExC_parse == '{') {
7159                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
7160                         | PERL_SCAN_DISALLOW_PREFIX;
7161                     char * const e = strchr(RExC_parse++, '}');
7162                     if (!e)
7163                         vFAIL("Missing right brace on \\x{}");
7164
7165                     numlen = e - RExC_parse;
7166                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
7167                     RExC_parse = e + 1;
7168                 }
7169                 else {
7170                     I32 flags = PERL_SCAN_DISALLOW_PREFIX;
7171                     numlen = 2;
7172                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
7173                     RExC_parse += numlen;
7174                 }
7175                 if (PL_encoding && value < 0x100)
7176                     goto recode_encoding;
7177                 break;
7178             case 'c':
7179                 value = UCHARAT(RExC_parse++);
7180                 value = toCTRL(value);
7181                 break;
7182             case '0': case '1': case '2': case '3': case '4':
7183             case '5': case '6': case '7': case '8': case '9':
7184                 {
7185                     I32 flags = 0;
7186                     numlen = 3;
7187                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
7188                     RExC_parse += numlen;
7189                     if (PL_encoding && value < 0x100)
7190                         goto recode_encoding;
7191                     break;
7192                 }
7193             recode_encoding:
7194                 {
7195                     SV* enc = PL_encoding;
7196                     value = reg_recode((const char)(U8)value, &enc);
7197                     if (!enc && SIZE_ONLY && ckWARN(WARN_REGEXP))
7198                         vWARN(RExC_parse,
7199                               "Invalid escape in the specified encoding");
7200                     break;
7201                 }
7202             default:
7203                 if (!SIZE_ONLY && isALPHA(value) && ckWARN(WARN_REGEXP))
7204                     vWARN2(RExC_parse,
7205                            "Unrecognized escape \\%c in character class passed through",
7206                            (int)value);
7207                 break;
7208             }
7209         } /* end of \blah */
7210 #ifdef EBCDIC
7211         else
7212             literal_endpoint++;
7213 #endif
7214
7215         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
7216
7217             if (!SIZE_ONLY && !need_class)
7218                 ANYOF_CLASS_ZERO(ret);
7219
7220             need_class = 1;
7221
7222             /* a bad range like a-\d, a-[:digit:] ? */
7223             if (range) {
7224                 if (!SIZE_ONLY) {
7225                     if (ckWARN(WARN_REGEXP)) {
7226                         const int w =
7227                             RExC_parse >= rangebegin ?
7228                             RExC_parse - rangebegin : 0;
7229                         vWARN4(RExC_parse,
7230                                "False [] range \"%*.*s\"",
7231                                w, w, rangebegin);
7232                     }
7233                     if (prevvalue < 256) {
7234                         ANYOF_BITMAP_SET(ret, prevvalue);
7235                         ANYOF_BITMAP_SET(ret, '-');
7236                     }
7237                     else {
7238                         ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
7239                         Perl_sv_catpvf(aTHX_ listsv,
7240                                        "%04"UVxf"\n%04"UVxf"\n", (UV)prevvalue, (UV) '-');
7241                     }
7242                 }
7243
7244                 range = 0; /* this was not a true range */
7245             }
7246
7247
7248     
7249             if (!SIZE_ONLY) {
7250                 const char *what = NULL;
7251                 char yesno = 0;
7252
7253                 if (namedclass > OOB_NAMEDCLASS)
7254                     optimize_invert = FALSE;
7255                 /* Possible truncation here but in some 64-bit environments
7256                  * the compiler gets heartburn about switch on 64-bit values.
7257                  * A similar issue a little earlier when switching on value.
7258                  * --jhi */
7259                 switch ((I32)namedclass) {
7260                 case _C_C_T_(ALNUM, isALNUM(value), "Word");
7261                 case _C_C_T_(ALNUMC, isALNUMC(value), "Alnum");
7262                 case _C_C_T_(ALPHA, isALPHA(value), "Alpha");
7263                 case _C_C_T_(BLANK, isBLANK(value), "Blank");
7264                 case _C_C_T_(CNTRL, isCNTRL(value), "Cntrl");
7265                 case _C_C_T_(GRAPH, isGRAPH(value), "Graph");
7266                 case _C_C_T_(LOWER, isLOWER(value), "Lower");
7267                 case _C_C_T_(PRINT, isPRINT(value), "Print");
7268                 case _C_C_T_(PSXSPC, isPSXSPC(value), "Space");
7269                 case _C_C_T_(PUNCT, isPUNCT(value), "Punct");
7270                 case _C_C_T_(SPACE, isSPACE(value), "SpacePerl");
7271                 case _C_C_T_(UPPER, isUPPER(value), "Upper");
7272                 case _C_C_T_(XDIGIT, isXDIGIT(value), "XDigit");
7273                 case ANYOF_ASCII:
7274                     if (LOC)
7275                         ANYOF_CLASS_SET(ret, ANYOF_ASCII);
7276                     else {
7277 #ifndef EBCDIC
7278                         for (value = 0; value < 128; value++)
7279                             ANYOF_BITMAP_SET(ret, value);
7280 #else  /* EBCDIC */
7281                         for (value = 0; value < 256; value++) {
7282                             if (isASCII(value))
7283                                 ANYOF_BITMAP_SET(ret, value);
7284                         }
7285 #endif /* EBCDIC */
7286                     }
7287                     yesno = '+';
7288                     what = "ASCII";
7289                     break;
7290                 case ANYOF_NASCII:
7291                     if (LOC)
7292                         ANYOF_CLASS_SET(ret, ANYOF_NASCII);
7293                     else {
7294 #ifndef EBCDIC
7295                         for (value = 128; value < 256; value++)
7296                             ANYOF_BITMAP_SET(ret, value);
7297 #else  /* EBCDIC */
7298                         for (value = 0; value < 256; value++) {
7299                             if (!isASCII(value))
7300                                 ANYOF_BITMAP_SET(ret, value);
7301                         }
7302 #endif /* EBCDIC */
7303                     }
7304                     yesno = '!';
7305                     what = "ASCII";
7306                     break;              
7307                 case ANYOF_DIGIT:
7308                     if (LOC)
7309                         ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
7310                     else {
7311                         /* consecutive digits assumed */
7312                         for (value = '0'; value <= '9'; value++)
7313                             ANYOF_BITMAP_SET(ret, value);
7314                     }
7315                     yesno = '+';
7316                     what = "Digit";
7317                     break;
7318                 case ANYOF_NDIGIT:
7319                     if (LOC)
7320                         ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
7321                     else {
7322                         /* consecutive digits assumed */
7323                         for (value = 0; value < '0'; value++)
7324                             ANYOF_BITMAP_SET(ret, value);
7325                         for (value = '9' + 1; value < 256; value++)
7326                             ANYOF_BITMAP_SET(ret, value);
7327                     }
7328                     yesno = '!';
7329                     what = "Digit";
7330                     break;              
7331                 case ANYOF_MAX:
7332                     /* this is to handle \p and \P */
7333                     break;
7334                 default:
7335                     vFAIL("Invalid [::] class");
7336                     break;
7337                 }
7338                 if (what) {
7339                     /* Strings such as "+utf8::isWord\n" */
7340                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::Is%s\n", yesno, what);
7341                 }
7342                 if (LOC)
7343                     ANYOF_FLAGS(ret) |= ANYOF_CLASS;
7344                 continue;
7345             }
7346         } /* end of namedclass \blah */
7347
7348         if (range) {
7349             if (prevvalue > (IV)value) /* b-a */ {
7350                 const int w = RExC_parse - rangebegin;
7351                 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
7352                 range = 0; /* not a valid range */
7353             }
7354         }
7355         else {
7356             prevvalue = value; /* save the beginning of the range */
7357             if (*RExC_parse == '-' && RExC_parse+1 < RExC_end &&
7358                 RExC_parse[1] != ']') {
7359                 RExC_parse++;
7360
7361                 /* a bad range like \w-, [:word:]- ? */
7362                 if (namedclass > OOB_NAMEDCLASS) {
7363                     if (ckWARN(WARN_REGEXP)) {
7364                         const int w =
7365                             RExC_parse >= rangebegin ?
7366                             RExC_parse - rangebegin : 0;
7367                         vWARN4(RExC_parse,
7368                                "False [] range \"%*.*s\"",
7369                                w, w, rangebegin);
7370                     }
7371                     if (!SIZE_ONLY)
7372                         ANYOF_BITMAP_SET(ret, '-');
7373                 } else
7374                     range = 1;  /* yeah, it's a range! */
7375                 continue;       /* but do it the next time */
7376             }
7377         }
7378
7379         /* now is the next time */
7380         /*stored += (value - prevvalue + 1);*/
7381         if (!SIZE_ONLY) {
7382             if (prevvalue < 256) {
7383                 const IV ceilvalue = value < 256 ? value : 255;
7384                 IV i;
7385 #ifdef EBCDIC
7386                 /* In EBCDIC [\x89-\x91] should include
7387                  * the \x8e but [i-j] should not. */
7388                 if (literal_endpoint == 2 &&
7389                     ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
7390                      (isUPPER(prevvalue) && isUPPER(ceilvalue))))
7391                 {
7392                     if (isLOWER(prevvalue)) {
7393                         for (i = prevvalue; i <= ceilvalue; i++)
7394                             if (isLOWER(i))
7395                                 ANYOF_BITMAP_SET(ret, i);
7396                     } else {
7397                         for (i = prevvalue; i <= ceilvalue; i++)
7398                             if (isUPPER(i))
7399                                 ANYOF_BITMAP_SET(ret, i);
7400                     }
7401                 }
7402                 else
7403 #endif
7404                       for (i = prevvalue; i <= ceilvalue; i++) {
7405                         if (!ANYOF_BITMAP_TEST(ret,i)) {
7406                             stored++;  
7407                             ANYOF_BITMAP_SET(ret, i);
7408                         }
7409                       }
7410           }
7411           if (value > 255 || UTF) {
7412                 const UV prevnatvalue  = NATIVE_TO_UNI(prevvalue);
7413                 const UV natvalue      = NATIVE_TO_UNI(value);
7414                 stored+=2; /* can't optimize this class */
7415                 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
7416                 if (prevnatvalue < natvalue) { /* what about > ? */
7417                     Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
7418                                    prevnatvalue, natvalue);
7419                 }
7420                 else if (prevnatvalue == natvalue) {
7421                     Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", natvalue);
7422                     if (FOLD) {
7423                          U8 foldbuf[UTF8_MAXBYTES_CASE+1];
7424                          STRLEN foldlen;
7425                          const UV f = to_uni_fold(natvalue, foldbuf, &foldlen);
7426
7427 #ifdef EBCDIC /* RD t/uni/fold ff and 6b */
7428                          if (RExC_precomp[0] == ':' &&
7429                              RExC_precomp[1] == '[' &&
7430                              (f == 0xDF || f == 0x92)) {
7431                              f = NATIVE_TO_UNI(f);
7432                         }
7433 #endif
7434                          /* If folding and foldable and a single
7435                           * character, insert also the folded version
7436                           * to the charclass. */
7437                          if (f != value) {
7438 #ifdef EBCDIC /* RD tunifold ligatures s,t fb05, fb06 */
7439                              if ((RExC_precomp[0] == ':' &&
7440                                   RExC_precomp[1] == '[' &&
7441                                   (f == 0xA2 &&
7442                                    (value == 0xFB05 || value == 0xFB06))) ?
7443                                  foldlen == ((STRLEN)UNISKIP(f) - 1) :
7444                                  foldlen == (STRLEN)UNISKIP(f) )
7445 #else
7446                               if (foldlen == (STRLEN)UNISKIP(f))
7447 #endif
7448                                   Perl_sv_catpvf(aTHX_ listsv,
7449                                                  "%04"UVxf"\n", f);
7450                               else {
7451                                   /* Any multicharacter foldings
7452                                    * require the following transform:
7453                                    * [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst)
7454                                    * where E folds into "pq" and F folds
7455                                    * into "rst", all other characters
7456                                    * fold to single characters.  We save
7457                                    * away these multicharacter foldings,
7458                                    * to be later saved as part of the
7459                                    * additional "s" data. */
7460                                   SV *sv;
7461
7462                                   if (!unicode_alternate)
7463                                       unicode_alternate = newAV();
7464                                   sv = newSVpvn((char*)foldbuf, foldlen);
7465                                   SvUTF8_on(sv);
7466                                   av_push(unicode_alternate, sv);
7467                               }
7468                          }
7469
7470                          /* If folding and the value is one of the Greek
7471                           * sigmas insert a few more sigmas to make the
7472                           * folding rules of the sigmas to work right.
7473                           * Note that not all the possible combinations
7474                           * are handled here: some of them are handled
7475                           * by the standard folding rules, and some of
7476                           * them (literal or EXACTF cases) are handled
7477                           * during runtime in regexec.c:S_find_byclass(). */
7478                          if (value == UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) {
7479                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
7480                                              (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA);
7481                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
7482                                              (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
7483                          }
7484                          else if (value == UNICODE_GREEK_CAPITAL_LETTER_SIGMA)
7485                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
7486                                              (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
7487                     }
7488                 }
7489             }
7490 #ifdef EBCDIC
7491             literal_endpoint = 0;
7492 #endif
7493         }
7494
7495         range = 0; /* this range (if it was one) is done now */
7496     }
7497
7498     if (need_class) {
7499         ANYOF_FLAGS(ret) |= ANYOF_LARGE;
7500         if (SIZE_ONLY)
7501             RExC_size += ANYOF_CLASS_ADD_SKIP;
7502         else
7503             RExC_emit += ANYOF_CLASS_ADD_SKIP;
7504     }
7505
7506
7507     if (SIZE_ONLY)
7508         return ret;
7509     /****** !SIZE_ONLY AFTER HERE *********/
7510
7511     if( stored == 1 && value < 256
7512         && !( ANYOF_FLAGS(ret) & ( ANYOF_FLAGS_ALL ^ ANYOF_FOLD ) )
7513     ) {
7514         /* optimize single char class to an EXACT node
7515            but *only* when its not a UTF/high char  */
7516         const char * cur_parse= RExC_parse;
7517         RExC_emit = (regnode *)orig_emit;
7518         RExC_parse = (char *)orig_parse;
7519         ret = reg_node(pRExC_state,
7520                        (U8)((ANYOF_FLAGS(ret) & ANYOF_FOLD) ? EXACTF : EXACT));
7521         RExC_parse = (char *)cur_parse;
7522         *STRING(ret)= (char)value;
7523         STR_LEN(ret)= 1;
7524         RExC_emit += STR_SZ(1);
7525         return ret;
7526     }
7527     /* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */
7528     if ( /* If the only flag is folding (plus possibly inversion). */
7529         ((ANYOF_FLAGS(ret) & (ANYOF_FLAGS_ALL ^ ANYOF_INVERT)) == ANYOF_FOLD)
7530        ) {
7531         for (value = 0; value < 256; ++value) {
7532             if (ANYOF_BITMAP_TEST(ret, value)) {
7533                 UV fold = PL_fold[value];
7534
7535                 if (fold != value)
7536                     ANYOF_BITMAP_SET(ret, fold);
7537             }
7538         }
7539         ANYOF_FLAGS(ret) &= ~ANYOF_FOLD;
7540     }
7541
7542     /* optimize inverted simple patterns (e.g. [^a-z]) */
7543     if (optimize_invert &&
7544         /* If the only flag is inversion. */
7545         (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT) {
7546         for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
7547             ANYOF_BITMAP(ret)[value] ^= ANYOF_FLAGS_ALL;
7548         ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL;
7549     }
7550     {
7551         AV * const av = newAV();
7552         SV *rv;
7553         /* The 0th element stores the character class description
7554          * in its textual form: used later (regexec.c:Perl_regclass_swash())
7555          * to initialize the appropriate swash (which gets stored in
7556          * the 1st element), and also useful for dumping the regnode.
7557          * The 2nd element stores the multicharacter foldings,
7558          * used later (regexec.c:S_reginclass()). */
7559         av_store(av, 0, listsv);
7560         av_store(av, 1, NULL);
7561         av_store(av, 2, (SV*)unicode_alternate);
7562         rv = newRV_noinc((SV*)av);
7563         n = add_data(pRExC_state, 1, "s");
7564         RExC_rxi->data->data[n] = (void*)rv;
7565         ARG_SET(ret, n);
7566     }
7567     return ret;
7568 }
7569 #undef _C_C_T_
7570
7571
7572 STATIC char*
7573 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
7574 {
7575     char* const retval = RExC_parse++;
7576
7577     for (;;) {
7578         if (*RExC_parse == '(' && RExC_parse[1] == '?' &&
7579                 RExC_parse[2] == '#') {
7580             while (*RExC_parse != ')') {
7581                 if (RExC_parse == RExC_end)
7582                     FAIL("Sequence (?#... not terminated");
7583                 RExC_parse++;
7584             }
7585             RExC_parse++;
7586             continue;
7587         }
7588         if (RExC_flags & RXf_PMf_EXTENDED) {
7589             if (isSPACE(*RExC_parse)) {
7590                 RExC_parse++;
7591                 continue;
7592             }
7593             else if (*RExC_parse == '#') {
7594                 while (RExC_parse < RExC_end)
7595                     if (*RExC_parse++ == '\n') break;
7596                 continue;
7597             }
7598         }
7599         return retval;
7600     }
7601 }
7602
7603 /*
7604 - reg_node - emit a node
7605 */
7606 STATIC regnode *                        /* Location. */
7607 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
7608 {
7609     dVAR;
7610     register regnode *ptr;
7611     regnode * const ret = RExC_emit;
7612     GET_RE_DEBUG_FLAGS_DECL;
7613
7614     if (SIZE_ONLY) {
7615         SIZE_ALIGN(RExC_size);
7616         RExC_size += 1;
7617         return(ret);
7618     }
7619 #ifdef DEBUGGING
7620     if (OP(RExC_emit) == 255)
7621         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %s: %d ",
7622             reg_name[op], OP(RExC_emit));
7623 #endif  
7624     NODE_ALIGN_FILL(ret);
7625     ptr = ret;
7626     FILL_ADVANCE_NODE(ptr, op);
7627     if (RExC_offsets) {         /* MJD */
7628         MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n", 
7629               "reg_node", __LINE__, 
7630               reg_name[op],
7631               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] 
7632                 ? "Overwriting end of array!\n" : "OK",
7633               (UV)(RExC_emit - RExC_emit_start),
7634               (UV)(RExC_parse - RExC_start),
7635               (UV)RExC_offsets[0])); 
7636         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
7637     }
7638
7639     RExC_emit = ptr;
7640     return(ret);
7641 }
7642
7643 /*
7644 - reganode - emit a node with an argument
7645 */
7646 STATIC regnode *                        /* Location. */
7647 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
7648 {
7649     dVAR;
7650     register regnode *ptr;
7651     regnode * const ret = RExC_emit;
7652     GET_RE_DEBUG_FLAGS_DECL;
7653
7654     if (SIZE_ONLY) {
7655         SIZE_ALIGN(RExC_size);
7656         RExC_size += 2;
7657         /* 
7658            We can't do this:
7659            
7660            assert(2==regarglen[op]+1); 
7661         
7662            Anything larger than this has to allocate the extra amount.
7663            If we changed this to be:
7664            
7665            RExC_size += (1 + regarglen[op]);
7666            
7667            then it wouldn't matter. Its not clear what side effect
7668            might come from that so its not done so far.
7669            -- dmq
7670         */
7671         return(ret);
7672     }
7673 #ifdef DEBUGGING
7674     if (OP(RExC_emit) == 255)
7675         Perl_croak(aTHX_ "panic: reganode overwriting end of allocated program space");
7676 #endif 
7677     NODE_ALIGN_FILL(ret);
7678     ptr = ret;
7679     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
7680     if (RExC_offsets) {         /* MJD */
7681         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
7682               "reganode",
7683               __LINE__,
7684               reg_name[op],
7685               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? 
7686               "Overwriting end of array!\n" : "OK",
7687               (UV)(RExC_emit - RExC_emit_start),
7688               (UV)(RExC_parse - RExC_start),
7689               (UV)RExC_offsets[0])); 
7690         Set_Cur_Node_Offset;
7691     }
7692             
7693     RExC_emit = ptr;
7694     return(ret);
7695 }
7696
7697 /*
7698 - reguni - emit (if appropriate) a Unicode character
7699 */
7700 STATIC STRLEN
7701 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
7702 {
7703     dVAR;
7704     return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
7705 }
7706
7707 /*
7708 - reginsert - insert an operator in front of already-emitted operand
7709 *
7710 * Means relocating the operand.
7711 */
7712 STATIC void
7713 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
7714 {
7715     dVAR;
7716     register regnode *src;
7717     register regnode *dst;
7718     register regnode *place;
7719     const int offset = regarglen[(U8)op];
7720     const int size = NODE_STEP_REGNODE + offset;
7721     GET_RE_DEBUG_FLAGS_DECL;
7722 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
7723     DEBUG_PARSE_FMT("inst"," - %s",reg_name[op]);
7724     if (SIZE_ONLY) {
7725         RExC_size += size;
7726         return;
7727     }
7728
7729     src = RExC_emit;
7730     RExC_emit += size;
7731     dst = RExC_emit;
7732     if (RExC_open_parens) {
7733         int paren;
7734         DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);
7735         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
7736             if ( RExC_open_parens[paren] >= opnd ) {
7737                 DEBUG_PARSE_FMT("open"," - %d",size);
7738                 RExC_open_parens[paren] += size;
7739             } else {
7740                 DEBUG_PARSE_FMT("open"," - %s","ok");
7741             }
7742             if ( RExC_close_parens[paren] >= opnd ) {
7743                 DEBUG_PARSE_FMT("close"," - %d",size);
7744                 RExC_close_parens[paren] += size;
7745             } else {
7746                 DEBUG_PARSE_FMT("close"," - %s","ok");
7747             }
7748         }
7749     }
7750
7751     while (src > opnd) {
7752         StructCopy(--src, --dst, regnode);
7753         if (RExC_offsets) {     /* MJD 20010112 */
7754             MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
7755                   "reg_insert",
7756                   __LINE__,
7757                   reg_name[op],
7758                   (UV)(dst - RExC_emit_start) > RExC_offsets[0] 
7759                     ? "Overwriting end of array!\n" : "OK",
7760                   (UV)(src - RExC_emit_start),
7761                   (UV)(dst - RExC_emit_start),
7762                   (UV)RExC_offsets[0])); 
7763             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
7764             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
7765         }
7766     }
7767     
7768
7769     place = opnd;               /* Op node, where operand used to be. */
7770     if (RExC_offsets) {         /* MJD */
7771         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
7772               "reginsert",
7773               __LINE__,
7774               reg_name[op],
7775               (UV)(place - RExC_emit_start) > RExC_offsets[0] 
7776               ? "Overwriting end of array!\n" : "OK",
7777               (UV)(place - RExC_emit_start),
7778               (UV)(RExC_parse - RExC_start),
7779               (UV)RExC_offsets[0]));
7780         Set_Node_Offset(place, RExC_parse);
7781         Set_Node_Length(place, 1);
7782     }
7783     src = NEXTOPER(place);
7784     FILL_ADVANCE_NODE(place, op);
7785     Zero(src, offset, regnode);
7786 }
7787
7788 /*
7789 - regtail - set the next-pointer at the end of a node chain of p to val.
7790 - SEE ALSO: regtail_study
7791 */
7792 /* TODO: All three parms should be const */
7793 STATIC void
7794 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
7795 {
7796     dVAR;
7797     register regnode *scan;
7798     GET_RE_DEBUG_FLAGS_DECL;
7799 #ifndef DEBUGGING
7800     PERL_UNUSED_ARG(depth);
7801 #endif
7802
7803     if (SIZE_ONLY)
7804         return;
7805
7806     /* Find last node. */
7807     scan = p;
7808     for (;;) {
7809         regnode * const temp = regnext(scan);
7810         DEBUG_PARSE_r({
7811             SV * const mysv=sv_newmortal();
7812             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
7813             regprop(RExC_rx, mysv, scan);
7814             PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
7815                 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
7816                     (temp == NULL ? "->" : ""),
7817                     (temp == NULL ? reg_name[OP(val)] : "")
7818             );
7819         });
7820         if (temp == NULL)
7821             break;
7822         scan = temp;
7823     }
7824
7825     if (reg_off_by_arg[OP(scan)]) {
7826         ARG_SET(scan, val - scan);
7827     }
7828     else {
7829         NEXT_OFF(scan) = val - scan;
7830     }
7831 }
7832
7833 #ifdef DEBUGGING
7834 /*
7835 - regtail_study - set the next-pointer at the end of a node chain of p to val.
7836 - Look for optimizable sequences at the same time.
7837 - currently only looks for EXACT chains.
7838
7839 This is expermental code. The idea is to use this routine to perform 
7840 in place optimizations on branches and groups as they are constructed,
7841 with the long term intention of removing optimization from study_chunk so
7842 that it is purely analytical.
7843
7844 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
7845 to control which is which.
7846
7847 */
7848 /* TODO: All four parms should be const */
7849
7850 STATIC U8
7851 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
7852 {
7853     dVAR;
7854     register regnode *scan;
7855     U8 exact = PSEUDO;
7856 #ifdef EXPERIMENTAL_INPLACESCAN
7857     I32 min = 0;
7858 #endif
7859
7860     GET_RE_DEBUG_FLAGS_DECL;
7861
7862
7863     if (SIZE_ONLY)
7864         return exact;
7865
7866     /* Find last node. */
7867
7868     scan = p;
7869     for (;;) {
7870         regnode * const temp = regnext(scan);
7871 #ifdef EXPERIMENTAL_INPLACESCAN
7872         if (PL_regkind[OP(scan)] == EXACT)
7873             if (join_exact(pRExC_state,scan,&min,1,val,depth+1))
7874                 return EXACT;
7875 #endif
7876         if ( exact ) {
7877             switch (OP(scan)) {
7878                 case EXACT:
7879                 case EXACTF:
7880                 case EXACTFL:
7881                         if( exact == PSEUDO )
7882                             exact= OP(scan);
7883                         else if ( exact != OP(scan) )
7884                             exact= 0;
7885                 case NOTHING:
7886                     break;
7887                 default:
7888                     exact= 0;
7889             }
7890         }
7891         DEBUG_PARSE_r({
7892             SV * const mysv=sv_newmortal();
7893             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
7894             regprop(RExC_rx, mysv, scan);
7895             PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
7896                 SvPV_nolen_const(mysv),
7897                 REG_NODE_NUM(scan),
7898                 reg_name[exact]);
7899         });
7900         if (temp == NULL)
7901             break;
7902         scan = temp;
7903     }
7904     DEBUG_PARSE_r({
7905         SV * const mysv_val=sv_newmortal();
7906         DEBUG_PARSE_MSG("");
7907         regprop(RExC_rx, mysv_val, val);
7908         PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
7909                       SvPV_nolen_const(mysv_val),
7910                       (IV)REG_NODE_NUM(val),
7911                       (IV)(val - scan)
7912         );
7913     });
7914     if (reg_off_by_arg[OP(scan)]) {
7915         ARG_SET(scan, val - scan);
7916     }
7917     else {
7918         NEXT_OFF(scan) = val - scan;
7919     }
7920
7921     return exact;
7922 }
7923 #endif
7924
7925 /*
7926  - regcurly - a little FSA that accepts {\d+,?\d*}
7927  */
7928 STATIC I32
7929 S_regcurly(register const char *s)
7930 {
7931     if (*s++ != '{')
7932         return FALSE;
7933     if (!isDIGIT(*s))
7934         return FALSE;
7935     while (isDIGIT(*s))
7936         s++;
7937     if (*s == ',')
7938         s++;
7939     while (isDIGIT(*s))
7940         s++;
7941     if (*s != '}')
7942         return FALSE;
7943     return TRUE;
7944 }
7945
7946
7947 /*
7948  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
7949  */
7950 void
7951 Perl_regdump(pTHX_ const regexp *r)
7952 {
7953 #ifdef DEBUGGING
7954     dVAR;
7955     SV * const sv = sv_newmortal();
7956     SV *dsv= sv_newmortal();
7957     RXi_GET_DECL(r,ri);
7958
7959     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
7960
7961     /* Header fields of interest. */
7962     if (r->anchored_substr) {
7963         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr), 
7964             RE_SV_DUMPLEN(r->anchored_substr), 30);
7965         PerlIO_printf(Perl_debug_log,
7966                       "anchored %s%s at %"IVdf" ",
7967                       s, RE_SV_TAIL(r->anchored_substr),
7968                       (IV)r->anchored_offset);
7969     } else if (r->anchored_utf8) {
7970         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8), 
7971             RE_SV_DUMPLEN(r->anchored_utf8), 30);
7972         PerlIO_printf(Perl_debug_log,
7973                       "anchored utf8 %s%s at %"IVdf" ",
7974                       s, RE_SV_TAIL(r->anchored_utf8),
7975                       (IV)r->anchored_offset);
7976     }                 
7977     if (r->float_substr) {
7978         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr), 
7979             RE_SV_DUMPLEN(r->float_substr), 30);
7980         PerlIO_printf(Perl_debug_log,
7981                       "floating %s%s at %"IVdf"..%"UVuf" ",
7982                       s, RE_SV_TAIL(r->float_substr),
7983                       (IV)r->float_min_offset, (UV)r->float_max_offset);
7984     } else if (r->float_utf8) {
7985         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8), 
7986             RE_SV_DUMPLEN(r->float_utf8), 30);
7987         PerlIO_printf(Perl_debug_log,
7988                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
7989                       s, RE_SV_TAIL(r->float_utf8),
7990                       (IV)r->float_min_offset, (UV)r->float_max_offset);
7991     }
7992     if (r->check_substr || r->check_utf8)
7993         PerlIO_printf(Perl_debug_log,
7994                       (const char *)
7995                       (r->check_substr == r->float_substr
7996                        && r->check_utf8 == r->float_utf8
7997                        ? "(checking floating" : "(checking anchored"));
7998     if (r->extflags & RXf_NOSCAN)
7999         PerlIO_printf(Perl_debug_log, " noscan");
8000     if (r->extflags & RXf_CHECK_ALL)
8001         PerlIO_printf(Perl_debug_log, " isall");
8002     if (r->check_substr || r->check_utf8)
8003         PerlIO_printf(Perl_debug_log, ") ");
8004
8005     if (ri->regstclass) {
8006         regprop(r, sv, ri->regstclass);
8007         PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
8008     }
8009     if (r->extflags & RXf_ANCH) {
8010         PerlIO_printf(Perl_debug_log, "anchored");
8011         if (r->extflags & RXf_ANCH_BOL)
8012             PerlIO_printf(Perl_debug_log, "(BOL)");
8013         if (r->extflags & RXf_ANCH_MBOL)
8014             PerlIO_printf(Perl_debug_log, "(MBOL)");
8015         if (r->extflags & RXf_ANCH_SBOL)
8016             PerlIO_printf(Perl_debug_log, "(SBOL)");
8017         if (r->extflags & RXf_ANCH_GPOS)
8018             PerlIO_printf(Perl_debug_log, "(GPOS)");
8019         PerlIO_putc(Perl_debug_log, ' ');
8020     }
8021     if (r->extflags & RXf_GPOS_SEEN)
8022         PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
8023     if (r->intflags & PREGf_SKIP)
8024         PerlIO_printf(Perl_debug_log, "plus ");
8025     if (r->intflags & PREGf_IMPLICIT)
8026         PerlIO_printf(Perl_debug_log, "implicit ");
8027     PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
8028     if (r->extflags & RXf_EVAL_SEEN)
8029         PerlIO_printf(Perl_debug_log, "with eval ");
8030     PerlIO_printf(Perl_debug_log, "\n");
8031 #else
8032     PERL_UNUSED_CONTEXT;
8033     PERL_UNUSED_ARG(r);
8034 #endif  /* DEBUGGING */
8035 }
8036
8037 /*
8038 - regprop - printable representation of opcode
8039 */
8040 void
8041 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
8042 {
8043 #ifdef DEBUGGING
8044     dVAR;
8045     register int k;
8046     RXi_GET_DECL(prog,progi);
8047     GET_RE_DEBUG_FLAGS_DECL;
8048     
8049
8050     sv_setpvn(sv, "", 0);
8051
8052     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
8053         /* It would be nice to FAIL() here, but this may be called from
8054            regexec.c, and it would be hard to supply pRExC_state. */
8055         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
8056     sv_catpv(sv, reg_name[OP(o)]); /* Take off const! */
8057
8058     k = PL_regkind[OP(o)];
8059
8060     if (k == EXACT) {
8061         SV * const dsv = sv_2mortal(newSVpvs(""));
8062         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT) 
8063          * is a crude hack but it may be the best for now since 
8064          * we have no flag "this EXACTish node was UTF-8" 
8065          * --jhi */
8066         const char * const s = 
8067             pv_pretty(dsv, STRING(o), STR_LEN(o), 60, 
8068                 PL_colors[0], PL_colors[1],
8069                 PERL_PV_ESCAPE_UNI_DETECT |
8070                 PERL_PV_PRETTY_ELIPSES    |
8071                 PERL_PV_PRETTY_LTGT    
8072             ); 
8073         Perl_sv_catpvf(aTHX_ sv, " %s", s );
8074     } else if (k == TRIE) {
8075         /* print the details of the trie in dumpuntil instead, as
8076          * progi->data isn't available here */
8077         const char op = OP(o);
8078         const I32 n = ARG(o);
8079         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
8080                (reg_ac_data *)progi->data->data[n] :
8081                NULL;
8082         const reg_trie_data * const trie
8083             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
8084         
8085         Perl_sv_catpvf(aTHX_ sv, "-%s",reg_name[o->flags]);
8086         DEBUG_TRIE_COMPILE_r(
8087             Perl_sv_catpvf(aTHX_ sv,
8088                 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
8089                 (UV)trie->startstate,
8090                 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
8091                 (UV)trie->wordcount,
8092                 (UV)trie->minlen,
8093                 (UV)trie->maxlen,
8094                 (UV)TRIE_CHARCOUNT(trie),
8095                 (UV)trie->uniquecharcount
8096             )
8097         );
8098         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
8099             int i;
8100             int rangestart = -1;
8101             U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
8102             Perl_sv_catpvf(aTHX_ sv, "[");
8103             for (i = 0; i <= 256; i++) {
8104                 if (i < 256 && BITMAP_TEST(bitmap,i)) {
8105                     if (rangestart == -1)
8106                         rangestart = i;
8107                 } else if (rangestart != -1) {
8108                     if (i <= rangestart + 3)
8109                         for (; rangestart < i; rangestart++)
8110                             put_byte(sv, rangestart);
8111                     else {
8112                         put_byte(sv, rangestart);
8113                         sv_catpvs(sv, "-");
8114                         put_byte(sv, i - 1);
8115                     }
8116                     rangestart = -1;
8117                 }
8118             }
8119             Perl_sv_catpvf(aTHX_ sv, "]");
8120         } 
8121          
8122     } else if (k == CURLY) {
8123         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
8124             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
8125         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
8126     }
8127     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
8128         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
8129     else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
8130         Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
8131         if ( prog->paren_names ) {
8132             AV *list= (AV *)progi->data->data[progi->name_list_idx];
8133             SV **name= av_fetch(list, ARG(o), 0 );
8134             if (name)
8135                 Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", *name);
8136         }           
8137     } else if (k == NREF) {
8138         if ( prog->paren_names ) {
8139             AV *list= (AV *)progi->data->data[ progi->name_list_idx ];
8140             SV *sv_dat=(SV*)progi->data->data[ ARG( o ) ];
8141             I32 *nums=(I32*)SvPVX(sv_dat);
8142             SV **name= av_fetch(list, nums[0], 0 );
8143             I32 n;
8144             if (name) {
8145                 for ( n=0; n<SvIVX(sv_dat); n++ ) {
8146                     Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
8147                                    (n ? "," : ""), (IV)nums[n]);
8148                 }
8149                 Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", *name );
8150             }
8151         }
8152     } else if (k == GOSUB) 
8153         Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
8154     else if (k == VERB) {
8155         if (!o->flags) 
8156             Perl_sv_catpvf(aTHX_ sv, ":%"SVf, 
8157                 (SV*)progi->data->data[ ARG( o ) ]);
8158     } else if (k == LOGICAL)
8159         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);     /* 2: embedded, otherwise 1 */
8160     else if (k == ANYOF) {
8161         int i, rangestart = -1;
8162         const U8 flags = ANYOF_FLAGS(o);
8163
8164         /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
8165         static const char * const anyofs[] = {
8166             "\\w",
8167             "\\W",
8168             "\\s",
8169             "\\S",
8170             "\\d",
8171             "\\D",
8172             "[:alnum:]",
8173             "[:^alnum:]",
8174             "[:alpha:]",
8175             "[:^alpha:]",
8176             "[:ascii:]",
8177             "[:^ascii:]",
8178             "[:ctrl:]",
8179             "[:^ctrl:]",
8180             "[:graph:]",
8181             "[:^graph:]",
8182             "[:lower:]",
8183             "[:^lower:]",
8184             "[:print:]",
8185             "[:^print:]",
8186             "[:punct:]",
8187             "[:^punct:]",
8188             "[:upper:]",
8189             "[:^upper:]",
8190             "[:xdigit:]",
8191             "[:^xdigit:]",
8192             "[:space:]",
8193             "[:^space:]",
8194             "[:blank:]",
8195             "[:^blank:]"
8196         };
8197
8198         if (flags & ANYOF_LOCALE)
8199             sv_catpvs(sv, "{loc}");
8200         if (flags & ANYOF_FOLD)
8201             sv_catpvs(sv, "{i}");
8202         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
8203         if (flags & ANYOF_INVERT)
8204             sv_catpvs(sv, "^");
8205         for (i = 0; i <= 256; i++) {
8206             if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
8207                 if (rangestart == -1)
8208                     rangestart = i;
8209             } else if (rangestart != -1) {
8210                 if (i <= rangestart + 3)
8211                     for (; rangestart < i; rangestart++)
8212                         put_byte(sv, rangestart);
8213                 else {
8214                     put_byte(sv, rangestart);
8215                     sv_catpvs(sv, "-");
8216                     put_byte(sv, i - 1);
8217                 }
8218                 rangestart = -1;
8219             }
8220         }
8221
8222         if (o->flags & ANYOF_CLASS)
8223             for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
8224                 if (ANYOF_CLASS_TEST(o,i))
8225                     sv_catpv(sv, anyofs[i]);
8226
8227         if (flags & ANYOF_UNICODE)
8228             sv_catpvs(sv, "{unicode}");
8229         else if (flags & ANYOF_UNICODE_ALL)
8230             sv_catpvs(sv, "{unicode_all}");
8231
8232         {
8233             SV *lv;
8234             SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
8235         
8236             if (lv) {
8237                 if (sw) {
8238                     U8 s[UTF8_MAXBYTES_CASE+1];
8239                 
8240                     for (i = 0; i <= 256; i++) { /* just the first 256 */
8241                         uvchr_to_utf8(s, i);
8242                         
8243                         if (i < 256 && swash_fetch(sw, s, TRUE)) {
8244                             if (rangestart == -1)
8245                                 rangestart = i;
8246                         } else if (rangestart != -1) {
8247                             if (i <= rangestart + 3)
8248                                 for (; rangestart < i; rangestart++) {
8249                                     const U8 * const e = uvchr_to_utf8(s,rangestart);
8250                                     U8 *p;
8251                                     for(p = s; p < e; p++)
8252                                         put_byte(sv, *p);
8253                                 }
8254                             else {
8255                                 const U8 *e = uvchr_to_utf8(s,rangestart);
8256                                 U8 *p;
8257                                 for (p = s; p < e; p++)
8258                                     put_byte(sv, *p);
8259                                 sv_catpvs(sv, "-");
8260                                 e = uvchr_to_utf8(s, i-1);
8261                                 for (p = s; p < e; p++)
8262                                     put_byte(sv, *p);
8263                                 }
8264                                 rangestart = -1;
8265                             }
8266                         }
8267                         
8268                     sv_catpvs(sv, "..."); /* et cetera */
8269                 }
8270
8271                 {
8272                     char *s = savesvpv(lv);
8273                     char * const origs = s;
8274                 
8275                     while (*s && *s != '\n')
8276                         s++;
8277                 
8278                     if (*s == '\n') {
8279                         const char * const t = ++s;
8280                         
8281                         while (*s) {
8282                             if (*s == '\n')
8283                                 *s = ' ';
8284                             s++;
8285                         }
8286                         if (s[-1] == ' ')
8287                             s[-1] = 0;
8288                         
8289                         sv_catpv(sv, t);
8290                     }
8291                 
8292                     Safefree(origs);
8293                 }
8294             }
8295         }
8296
8297         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
8298     }
8299     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
8300         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
8301 #else
8302     PERL_UNUSED_CONTEXT;
8303     PERL_UNUSED_ARG(sv);
8304     PERL_UNUSED_ARG(o);
8305     PERL_UNUSED_ARG(prog);
8306 #endif  /* DEBUGGING */
8307 }
8308
8309 SV *
8310 Perl_re_intuit_string(pTHX_ regexp *prog)
8311 {                               /* Assume that RE_INTUIT is set */
8312     dVAR;
8313     GET_RE_DEBUG_FLAGS_DECL;
8314     PERL_UNUSED_CONTEXT;
8315
8316     DEBUG_COMPILE_r(
8317         {
8318             const char * const s = SvPV_nolen_const(prog->check_substr
8319                       ? prog->check_substr : prog->check_utf8);
8320
8321             if (!PL_colorset) reginitcolors();
8322             PerlIO_printf(Perl_debug_log,
8323                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
8324                       PL_colors[4],
8325                       prog->check_substr ? "" : "utf8 ",
8326                       PL_colors[5],PL_colors[0],
8327                       s,
8328                       PL_colors[1],
8329                       (strlen(s) > 60 ? "..." : ""));
8330         } );
8331
8332     return prog->check_substr ? prog->check_substr : prog->check_utf8;
8333 }
8334
8335 /* 
8336    pregfree() 
8337    
8338    handles refcounting and freeing the perl core regexp structure. When 
8339    it is necessary to actually free the structure the first thing it 
8340    does is call the 'free' method of the regexp_engine associated to to 
8341    the regexp, allowing the handling of the void *pprivate; member 
8342    first. (This routine is not overridable by extensions, which is why 
8343    the extensions free is called first.)
8344    
8345    See regdupe and regdupe_internal if you change anything here. 
8346 */
8347 #ifndef PERL_IN_XSUB_RE
8348 void
8349 Perl_pregfree(pTHX_ struct regexp *r)
8350 {
8351     dVAR;
8352     GET_RE_DEBUG_FLAGS_DECL;
8353
8354     if (!r || (--r->refcnt > 0))
8355         return;
8356         
8357     CALLREGFREE_PVT(r); /* free the private data */
8358     
8359     /* gcov results gave these as non-null 100% of the time, so there's no
8360        optimisation in checking them before calling Safefree  */
8361     Safefree(r->precomp);
8362     RX_MATCH_COPY_FREE(r);
8363 #ifdef PERL_OLD_COPY_ON_WRITE
8364     if (r->saved_copy)
8365         SvREFCNT_dec(r->saved_copy);
8366 #endif
8367     if (r->substrs) {
8368         if (r->anchored_substr)
8369             SvREFCNT_dec(r->anchored_substr);
8370         if (r->anchored_utf8)
8371             SvREFCNT_dec(r->anchored_utf8);
8372         if (r->float_substr)
8373             SvREFCNT_dec(r->float_substr);
8374         if (r->float_utf8)
8375             SvREFCNT_dec(r->float_utf8);
8376         Safefree(r->substrs);
8377     }
8378     if (r->paren_names)
8379             SvREFCNT_dec(r->paren_names);
8380     
8381     Safefree(r->startp);
8382     Safefree(r->endp);
8383     Safefree(r);
8384 }
8385 #endif
8386
8387 /* regfree_internal() 
8388
8389    Free the private data in a regexp. This is overloadable by 
8390    extensions. Perl takes care of the regexp structure in pregfree(), 
8391    this covers the *pprivate pointer which technically perldoesnt 
8392    know about, however of course we have to handle the 
8393    regexp_internal structure when no extension is in use. 
8394    
8395    Note this is called before freeing anything in the regexp 
8396    structure. 
8397  */
8398  
8399 void
8400 Perl_regfree_internal(pTHX_ struct regexp *r)
8401 {
8402     dVAR;
8403     RXi_GET_DECL(r,ri);
8404     GET_RE_DEBUG_FLAGS_DECL;
8405     
8406     DEBUG_COMPILE_r({
8407         if (!PL_colorset)
8408             reginitcolors();
8409         {
8410             SV *dsv= sv_newmortal();
8411             RE_PV_QUOTED_DECL(s, (r->extflags & RXf_UTF8),
8412                 dsv, r->precomp, r->prelen, 60);
8413             PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n", 
8414                 PL_colors[4],PL_colors[5],s);
8415         }
8416     });
8417
8418     Safefree(ri->offsets);             /* 20010421 MJD */
8419     if (ri->data) {
8420         int n = ri->data->count;
8421         PAD* new_comppad = NULL;
8422         PAD* old_comppad;
8423         PADOFFSET refcnt;
8424
8425         while (--n >= 0) {
8426           /* If you add a ->what type here, update the comment in regcomp.h */
8427             switch (ri->data->what[n]) {
8428             case 's':
8429             case 'S':
8430             case 'u':
8431                 SvREFCNT_dec((SV*)ri->data->data[n]);
8432                 break;
8433             case 'f':
8434                 Safefree(ri->data->data[n]);
8435                 break;
8436             case 'p':
8437                 new_comppad = (AV*)ri->data->data[n];
8438                 break;
8439             case 'o':
8440                 if (new_comppad == NULL)
8441                     Perl_croak(aTHX_ "panic: pregfree comppad");
8442                 PAD_SAVE_LOCAL(old_comppad,
8443                     /* Watch out for global destruction's random ordering. */
8444                     (SvTYPE(new_comppad) == SVt_PVAV) ? new_comppad : NULL
8445                 );
8446                 OP_REFCNT_LOCK;
8447                 refcnt = OpREFCNT_dec((OP_4tree*)ri->data->data[n]);
8448                 OP_REFCNT_UNLOCK;
8449                 if (!refcnt)
8450                     op_free((OP_4tree*)ri->data->data[n]);
8451
8452                 PAD_RESTORE_LOCAL(old_comppad);
8453                 SvREFCNT_dec((SV*)new_comppad);
8454                 new_comppad = NULL;
8455                 break;
8456             case 'n':
8457                 break;
8458             case 'T':           
8459                 { /* Aho Corasick add-on structure for a trie node.
8460                      Used in stclass optimization only */
8461                     U32 refcount;
8462                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
8463                     OP_REFCNT_LOCK;
8464                     refcount = --aho->refcount;
8465                     OP_REFCNT_UNLOCK;
8466                     if ( !refcount ) {
8467                         PerlMemShared_free(aho->states);
8468                         PerlMemShared_free(aho->fail);
8469                          /* do this last!!!! */
8470                         PerlMemShared_free(ri->data->data[n]);
8471                         PerlMemShared_free(ri->regstclass);
8472                     }
8473                 }
8474                 break;
8475             case 't':
8476                 {
8477                     /* trie structure. */
8478                     U32 refcount;
8479                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
8480                     OP_REFCNT_LOCK;
8481                     refcount = --trie->refcount;
8482                     OP_REFCNT_UNLOCK;
8483                     if ( !refcount ) {
8484                         PerlMemShared_free(trie->charmap);
8485                         PerlMemShared_free(trie->states);
8486                         PerlMemShared_free(trie->trans);
8487                         if (trie->bitmap)
8488                             PerlMemShared_free(trie->bitmap);
8489                         if (trie->wordlen)
8490                             PerlMemShared_free(trie->wordlen);
8491                         if (trie->jump)
8492                             PerlMemShared_free(trie->jump);
8493                         if (trie->nextword)
8494                             PerlMemShared_free(trie->nextword);
8495                         /* do this last!!!! */
8496                         PerlMemShared_free(ri->data->data[n]);
8497                     }
8498                 }
8499                 break;
8500             default:
8501                 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
8502             }
8503         }
8504         Safefree(ri->data->what);
8505         Safefree(ri->data);
8506     }
8507     if (ri->swap) {
8508         Safefree(ri->swap->startp);
8509         Safefree(ri->swap->endp);
8510         Safefree(ri->swap);
8511     }
8512     Safefree(ri);
8513 }
8514
8515 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
8516 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8517 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8518 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
8519
8520 /* 
8521    regdupe - duplicate a regexp. 
8522    
8523    This routine is called by sv.c's re_dup and is expected to clone a 
8524    given regexp structure. It is a no-op when not under USE_ITHREADS. 
8525    (Originally this *was* re_dup() for change history see sv.c)
8526    
8527    After all of the core data stored in struct regexp is duplicated
8528    the regexp_engine.dupe method is used to copy any private data
8529    stored in the *pprivate pointer. This allows extensions to handle
8530    any duplication it needs to do.
8531
8532    See pregfree() and regfree_internal() if you change anything here. 
8533 */
8534 #if defined(USE_ITHREADS)
8535 #ifndef PERL_IN_XSUB_RE
8536 regexp *
8537 Perl_re_dup(pTHX_ const regexp *r, CLONE_PARAMS *param)
8538 {
8539     dVAR;
8540     regexp *ret;
8541     int i, npar;
8542     struct reg_substr_datum *s;
8543
8544     if (!r)
8545         return (REGEXP *)NULL;
8546
8547     if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
8548         return ret;
8549
8550     
8551     npar = r->nparens+1;
8552     Newxz(ret, 1, regexp);
8553     Newx(ret->startp, npar, I32);
8554     Copy(r->startp, ret->startp, npar, I32);
8555     Newx(ret->endp, npar, I32);
8556     Copy(r->endp, ret->endp, npar, I32);
8557
8558     if (r->substrs) {
8559         Newx(ret->substrs, 1, struct reg_substr_data);
8560         for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
8561             s->min_offset = r->substrs->data[i].min_offset;
8562             s->max_offset = r->substrs->data[i].max_offset;
8563             s->end_shift  = r->substrs->data[i].end_shift;
8564             s->substr     = sv_dup_inc(r->substrs->data[i].substr, param);
8565             s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
8566         }
8567     } else 
8568         ret->substrs = NULL;    
8569
8570     ret->precomp        = SAVEPVN(r->precomp, r->prelen);
8571     ret->refcnt         = r->refcnt;
8572     ret->minlen         = r->minlen;
8573     ret->minlenret      = r->minlenret;
8574     ret->prelen         = r->prelen;
8575     ret->nparens        = r->nparens;
8576     ret->lastparen      = r->lastparen;
8577     ret->lastcloseparen = r->lastcloseparen;
8578     ret->intflags       = r->intflags;
8579     ret->extflags       = r->extflags;
8580
8581     ret->sublen         = r->sublen;
8582
8583     ret->engine         = r->engine;
8584     
8585     ret->paren_names    = hv_dup_inc(r->paren_names, param);
8586
8587     if (RX_MATCH_COPIED(ret))
8588         ret->subbeg  = SAVEPVN(r->subbeg, r->sublen);
8589     else
8590         ret->subbeg = NULL;
8591 #ifdef PERL_OLD_COPY_ON_WRITE
8592     ret->saved_copy = NULL;
8593 #endif
8594     
8595     ret->pprivate = r->pprivate;
8596     if (ret->pprivate) 
8597         RXi_SET(ret,CALLREGDUPE_PVT(ret,param));
8598     
8599     ptr_table_store(PL_ptr_table, r, ret);
8600     return ret;
8601 }
8602 #endif /* PERL_IN_XSUB_RE */
8603
8604 /*
8605    regdupe_internal()
8606    
8607    This is the internal complement to regdupe() which is used to copy
8608    the structure pointed to by the *pprivate pointer in the regexp.
8609    This is the core version of the extension overridable cloning hook.
8610    The regexp structure being duplicated will be copied by perl prior
8611    to this and will be provided as the regexp *r argument, however 
8612    with the /old/ structures pprivate pointer value. Thus this routine
8613    may override any copying normally done by perl.
8614    
8615    It returns a pointer to the new regexp_internal structure.
8616 */
8617
8618 void *
8619 Perl_regdupe_internal(pTHX_ const regexp *r, CLONE_PARAMS *param)
8620 {
8621     dVAR;
8622     regexp_internal *reti;
8623     int len, npar;
8624     RXi_GET_DECL(r,ri);
8625     
8626     npar = r->nparens+1;
8627     len = ri->offsets[0];
8628     
8629     Newxc(reti, sizeof(regexp_internal) + (len+1)*sizeof(regnode), char, regexp_internal);
8630     Copy(ri->program, reti->program, len+1, regnode);
8631     
8632     if(ri->swap) {
8633         Newx(reti->swap, 1, regexp_paren_ofs);
8634         /* no need to copy these */
8635         Newx(reti->swap->startp, npar, I32);
8636         Newx(reti->swap->endp, npar, I32);
8637     } else {
8638         reti->swap = NULL;
8639     }
8640
8641
8642     reti->regstclass = NULL;
8643     if (ri->data) {
8644         struct reg_data *d;
8645         const int count = ri->data->count;
8646         int i;
8647
8648         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
8649                 char, struct reg_data);
8650         Newx(d->what, count, U8);
8651
8652         d->count = count;
8653         for (i = 0; i < count; i++) {
8654             d->what[i] = ri->data->what[i];
8655             switch (d->what[i]) {
8656                 /* legal options are one of: sSfpontTu
8657                    see also regcomp.h and pregfree() */
8658             case 's':
8659             case 'S':
8660             case 'p': /* actually an AV, but the dup function is identical.  */
8661             case 'u': /* actually an HV, but the dup function is identical.  */
8662                 d->data[i] = sv_dup_inc((SV *)ri->data->data[i], param);
8663                 break;
8664             case 'f':
8665                 /* This is cheating. */
8666                 Newx(d->data[i], 1, struct regnode_charclass_class);
8667                 StructCopy(ri->data->data[i], d->data[i],
8668                             struct regnode_charclass_class);
8669                 reti->regstclass = (regnode*)d->data[i];
8670                 break;
8671             case 'o':
8672                 /* Compiled op trees are readonly and in shared memory,
8673                    and can thus be shared without duplication. */
8674                 OP_REFCNT_LOCK;
8675                 d->data[i] = (void*)OpREFCNT_inc((OP*)ri->data->data[i]);
8676                 OP_REFCNT_UNLOCK;
8677                 break;
8678             case 'T':
8679                 /* Trie stclasses are readonly and can thus be shared
8680                  * without duplication. We free the stclass in pregfree
8681                  * when the corresponding reg_ac_data struct is freed.
8682                  */
8683                 reti->regstclass= ri->regstclass;
8684                 /* Fall through */
8685             case 't':
8686                 OP_REFCNT_LOCK;
8687                 ((reg_trie_data*)ri->data->data[i])->refcount++;
8688                 OP_REFCNT_UNLOCK;
8689                 /* Fall through */
8690             case 'n':
8691                 d->data[i] = ri->data->data[i];
8692                 break;
8693             default:
8694                 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
8695             }
8696         }
8697
8698         reti->data = d;
8699     }
8700     else
8701         reti->data = NULL;
8702
8703     Newx(reti->offsets, 2*len+1, U32);
8704     Copy(ri->offsets, reti->offsets, 2*len+1, U32);
8705     
8706     return (void*)reti;
8707 }
8708
8709 #endif    /* USE_ITHREADS */
8710
8711 /* 
8712    reg_stringify() 
8713    
8714    converts a regexp embedded in a MAGIC struct to its stringified form, 
8715    caching the converted form in the struct and returns the cached 
8716    string. 
8717
8718    If lp is nonnull then it is used to return the length of the 
8719    resulting string
8720    
8721    If flags is nonnull and the returned string contains UTF8 then 
8722    (*flags & 1) will be true.
8723    
8724    If haseval is nonnull then it is used to return whether the pattern 
8725    contains evals.
8726    
8727    Normally called via macro: 
8728    
8729         CALLREG_STRINGIFY(mg,&len,&utf8);
8730         
8731    And internally with
8732    
8733         CALLREG_AS_STR(mg,&lp,&flags,&haseval)        
8734     
8735    See sv_2pv_flags() in sv.c for an example of internal usage.
8736     
8737  */
8738 #ifndef PERL_IN_XSUB_RE
8739 char *
8740 Perl_reg_stringify(pTHX_ MAGIC *mg, STRLEN *lp, U32 *flags, I32 *haseval ) {
8741     dVAR;
8742     const regexp * const re = (regexp *)mg->mg_obj;
8743
8744     if (!mg->mg_ptr) {
8745         const char *fptr = "msix";
8746         char reflags[6];
8747         char ch;
8748         int left = 0;
8749         int right = 4;
8750         bool need_newline = 0;
8751         U16 reganch = (U16)((re->extflags & RXf_PMf_COMPILETIME) >> 12);
8752
8753         while((ch = *fptr++)) {
8754             if(reganch & 1) {
8755                 reflags[left++] = ch;
8756             }
8757             else {
8758                 reflags[right--] = ch;
8759             }
8760             reganch >>= 1;
8761         }
8762         if(left != 4) {
8763             reflags[left] = '-';
8764             left = 5;
8765         }
8766
8767         mg->mg_len = re->prelen + 4 + left;
8768         /*
8769          * If /x was used, we have to worry about a regex ending with a
8770          * comment later being embedded within another regex. If so, we don't
8771          * want this regex's "commentization" to leak out to the right part of
8772          * the enclosing regex, we must cap it with a newline.
8773          *
8774          * So, if /x was used, we scan backwards from the end of the regex. If
8775          * we find a '#' before we find a newline, we need to add a newline
8776          * ourself. If we find a '\n' first (or if we don't find '#' or '\n'),
8777          * we don't need to add anything.  -jfriedl
8778          */
8779         if (PMf_EXTENDED & re->extflags) {
8780             const char *endptr = re->precomp + re->prelen;
8781             while (endptr >= re->precomp) {
8782                 const char c = *(endptr--);
8783                 if (c == '\n')
8784                     break; /* don't need another */
8785                 if (c == '#') {
8786                     /* we end while in a comment, so we need a newline */
8787                     mg->mg_len++; /* save space for it */
8788                     need_newline = 1; /* note to add it */
8789                     break;
8790                 }
8791             }
8792         }
8793
8794         Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
8795         mg->mg_ptr[0] = '(';
8796         mg->mg_ptr[1] = '?';
8797         Copy(reflags, mg->mg_ptr+2, left, char);
8798         *(mg->mg_ptr+left+2) = ':';
8799         Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
8800         if (need_newline)
8801             mg->mg_ptr[mg->mg_len - 2] = '\n';
8802         mg->mg_ptr[mg->mg_len - 1] = ')';
8803         mg->mg_ptr[mg->mg_len] = 0;
8804     }
8805     if (haseval) 
8806         *haseval = re->seen_evals;
8807     if (flags)    
8808         *flags = ((re->extflags & RXf_UTF8) ? 1 : 0);
8809     
8810     if (lp)
8811         *lp = mg->mg_len;
8812     return mg->mg_ptr;
8813 }
8814
8815 /*
8816  - regnext - dig the "next" pointer out of a node
8817  */
8818 regnode *
8819 Perl_regnext(pTHX_ register regnode *p)
8820 {
8821     dVAR;
8822     register I32 offset;
8823
8824     if (!p)
8825         return(NULL);
8826
8827     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
8828     if (offset == 0)
8829         return(NULL);
8830
8831     return(p+offset);
8832 }
8833 #endif
8834
8835 STATIC void     
8836 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
8837 {
8838     va_list args;
8839     STRLEN l1 = strlen(pat1);
8840     STRLEN l2 = strlen(pat2);
8841     char buf[512];
8842     SV *msv;
8843     const char *message;
8844
8845     if (l1 > 510)
8846         l1 = 510;
8847     if (l1 + l2 > 510)
8848         l2 = 510 - l1;
8849     Copy(pat1, buf, l1 , char);
8850     Copy(pat2, buf + l1, l2 , char);
8851     buf[l1 + l2] = '\n';
8852     buf[l1 + l2 + 1] = '\0';
8853 #ifdef I_STDARG
8854     /* ANSI variant takes additional second argument */
8855     va_start(args, pat2);
8856 #else
8857     va_start(args);
8858 #endif
8859     msv = vmess(buf, &args);
8860     va_end(args);
8861     message = SvPV_const(msv,l1);
8862     if (l1 > 512)
8863         l1 = 512;
8864     Copy(message, buf, l1 , char);
8865     buf[l1-1] = '\0';                   /* Overwrite \n */
8866     Perl_croak(aTHX_ "%s", buf);
8867 }
8868
8869 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
8870
8871 #ifndef PERL_IN_XSUB_RE
8872 void
8873 Perl_save_re_context(pTHX)
8874 {
8875     dVAR;
8876
8877     struct re_save_state *state;
8878
8879     SAVEVPTR(PL_curcop);
8880     SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
8881
8882     state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
8883     PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
8884     SSPUSHINT(SAVEt_RE_STATE);
8885
8886     Copy(&PL_reg_state, state, 1, struct re_save_state);
8887
8888     PL_reg_start_tmp = 0;
8889     PL_reg_start_tmpl = 0;
8890     PL_reg_oldsaved = NULL;
8891     PL_reg_oldsavedlen = 0;
8892     PL_reg_maxiter = 0;
8893     PL_reg_leftiter = 0;
8894     PL_reg_poscache = NULL;
8895     PL_reg_poscache_size = 0;
8896 #ifdef PERL_OLD_COPY_ON_WRITE
8897     PL_nrs = NULL;
8898 #endif
8899
8900     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
8901     if (PL_curpm) {
8902         const REGEXP * const rx = PM_GETRE(PL_curpm);
8903         if (rx) {
8904             U32 i;
8905             for (i = 1; i <= rx->nparens; i++) {
8906                 char digits[TYPE_CHARS(long)];
8907                 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
8908                 GV *const *const gvp
8909                     = (GV**)hv_fetch(PL_defstash, digits, len, 0);
8910
8911                 if (gvp) {
8912                     GV * const gv = *gvp;
8913                     if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
8914                         save_scalar(gv);
8915                 }
8916             }
8917         }
8918     }
8919 }
8920 #endif
8921
8922 static void
8923 clear_re(pTHX_ void *r)
8924 {
8925     dVAR;
8926     ReREFCNT_dec((regexp *)r);
8927 }
8928
8929 #ifdef DEBUGGING
8930
8931 STATIC void
8932 S_put_byte(pTHX_ SV *sv, int c)
8933 {
8934     if (isCNTRL(c) || c == 255 || !isPRINT(c))
8935         Perl_sv_catpvf(aTHX_ sv, "\\%o", c);
8936     else if (c == '-' || c == ']' || c == '\\' || c == '^')
8937         Perl_sv_catpvf(aTHX_ sv, "\\%c", c);
8938     else
8939         Perl_sv_catpvf(aTHX_ sv, "%c", c);
8940 }
8941
8942
8943 #define CLEAR_OPTSTART \
8944     if (optstart) STMT_START { \
8945             DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
8946             optstart=NULL; \
8947     } STMT_END
8948
8949 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
8950
8951 STATIC const regnode *
8952 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
8953             const regnode *last, const regnode *plast, 
8954             SV* sv, I32 indent, U32 depth)
8955 {
8956     dVAR;
8957     register U8 op = PSEUDO;    /* Arbitrary non-END op. */
8958     register const regnode *next;
8959     const regnode *optstart= NULL;
8960     
8961     RXi_GET_DECL(r,ri);
8962     GET_RE_DEBUG_FLAGS_DECL;
8963     
8964 #ifdef DEBUG_DUMPUNTIL
8965     PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
8966         last ? last-start : 0,plast ? plast-start : 0);
8967 #endif
8968             
8969     if (plast && plast < last) 
8970         last= plast;
8971
8972     while (PL_regkind[op] != END && (!last || node < last)) {
8973         /* While that wasn't END last time... */
8974         NODE_ALIGN(node);
8975         op = OP(node);
8976         if (op == CLOSE || op == WHILEM)
8977             indent--;
8978         next = regnext((regnode *)node);
8979
8980         /* Where, what. */
8981         if (OP(node) == OPTIMIZED) {
8982             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
8983                 optstart = node;
8984             else
8985                 goto after_print;
8986         } else
8987             CLEAR_OPTSTART;
8988         
8989         regprop(r, sv, node);
8990         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
8991                       (int)(2*indent + 1), "", SvPVX_const(sv));
8992         
8993         if (OP(node) != OPTIMIZED) {                  
8994             if (next == NULL)           /* Next ptr. */
8995                 PerlIO_printf(Perl_debug_log, " (0)");
8996             else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
8997                 PerlIO_printf(Perl_debug_log, " (FAIL)");
8998             else 
8999                 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
9000             (void)PerlIO_putc(Perl_debug_log, '\n'); 
9001         }
9002         
9003       after_print:
9004         if (PL_regkind[(U8)op] == BRANCHJ) {
9005             assert(next);
9006             {
9007                 register const regnode *nnode = (OP(next) == LONGJMP
9008                                              ? regnext((regnode *)next)
9009                                              : next);
9010                 if (last && nnode > last)
9011                     nnode = last;
9012                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
9013             }
9014         }
9015         else if (PL_regkind[(U8)op] == BRANCH) {
9016             assert(next);
9017             DUMPUNTIL(NEXTOPER(node), next);
9018         }
9019         else if ( PL_regkind[(U8)op]  == TRIE ) {
9020             const regnode *this_trie = node;
9021             const char op = OP(node);
9022             const I32 n = ARG(node);
9023             const reg_ac_data * const ac = op>=AHOCORASICK ?
9024                (reg_ac_data *)ri->data->data[n] :
9025                NULL;
9026             const reg_trie_data * const trie =
9027                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
9028 #ifdef DEBUGGING
9029             AV *const trie_words = (AV *) ri->data->data[n + TRIE_WORDS_OFFSET];
9030 #endif
9031             const regnode *nextbranch= NULL;
9032             I32 word_idx;
9033             sv_setpvn(sv, "", 0);
9034             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
9035                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
9036                 
9037                 PerlIO_printf(Perl_debug_log, "%*s%s ",
9038                    (int)(2*(indent+3)), "",
9039                     elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
9040                             PL_colors[0], PL_colors[1],
9041                             (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
9042                             PERL_PV_PRETTY_ELIPSES    |
9043                             PERL_PV_PRETTY_LTGT
9044                             )
9045                             : "???"
9046                 );
9047                 if (trie->jump) {
9048                     U16 dist= trie->jump[word_idx+1];
9049                     PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
9050                                   (UV)((dist ? this_trie + dist : next) - start));
9051                     if (dist) {
9052                         if (!nextbranch)
9053                             nextbranch= this_trie + trie->jump[0];    
9054                         DUMPUNTIL(this_trie + dist, nextbranch);
9055                     }
9056                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
9057                         nextbranch= regnext((regnode *)nextbranch);
9058                 } else {
9059                     PerlIO_printf(Perl_debug_log, "\n");
9060                 }
9061             }
9062             if (last && next > last)
9063                 node= last;
9064             else
9065                 node= next;
9066         }
9067         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
9068             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
9069                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
9070         }
9071         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
9072             assert(next);
9073             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
9074         }
9075         else if ( op == PLUS || op == STAR) {
9076             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
9077         }
9078         else if (op == ANYOF) {
9079             /* arglen 1 + class block */
9080             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_LARGE)
9081                     ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
9082             node = NEXTOPER(node);
9083         }
9084         else if (PL_regkind[(U8)op] == EXACT) {
9085             /* Literal string, where present. */
9086             node += NODE_SZ_STR(node) - 1;
9087             node = NEXTOPER(node);
9088         }
9089         else {
9090             node = NEXTOPER(node);
9091             node += regarglen[(U8)op];
9092         }
9093         if (op == CURLYX || op == OPEN)
9094             indent++;
9095     }
9096     CLEAR_OPTSTART;
9097 #ifdef DEBUG_DUMPUNTIL    
9098     PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
9099 #endif
9100     return node;
9101 }
9102
9103 #endif  /* DEBUGGING */
9104
9105 /*
9106  * Local variables:
9107  * c-indentation-style: bsd
9108  * c-basic-offset: 4
9109  * indent-tabs-mode: t
9110  * End:
9111  *
9112  * ex: set ts=8 sts=4 sw=4 noet:
9113  */