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