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