We can now remove DynaLoader from 1_compile.t
[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 #if ADD_TO_REGEXEC
122     char        *starttry;              /* -Dr: where regtry was called. */
123 #define RExC_starttry   (pRExC_state->starttry)
124 #endif
125 } RExC_state_t;
126
127 #define RExC_flags      (pRExC_state->flags)
128 #define RExC_precomp    (pRExC_state->precomp)
129 #define RExC_rx         (pRExC_state->rx)
130 #define RExC_start      (pRExC_state->start)
131 #define RExC_end        (pRExC_state->end)
132 #define RExC_parse      (pRExC_state->parse)
133 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
134 #define RExC_offsets    (pRExC_state->rx->offsets) /* I am not like the others */
135 #define RExC_emit       (pRExC_state->emit)
136 #define RExC_emit_start (pRExC_state->emit_start)
137 #define RExC_naughty    (pRExC_state->naughty)
138 #define RExC_sawback    (pRExC_state->sawback)
139 #define RExC_seen       (pRExC_state->seen)
140 #define RExC_size       (pRExC_state->size)
141 #define RExC_npar       (pRExC_state->npar)
142 #define RExC_extralen   (pRExC_state->extralen)
143 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
144 #define RExC_seen_evals (pRExC_state->seen_evals)
145 #define RExC_utf8       (pRExC_state->utf8)
146
147 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
148 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
149         ((*s) == '{' && regcurly(s)))
150
151 #ifdef SPSTART
152 #undef SPSTART          /* dratted cpp namespace... */
153 #endif
154 /*
155  * Flags to be passed up and down.
156  */
157 #define WORST           0       /* Worst case. */
158 #define HASWIDTH        0x1     /* Known to match non-null strings. */
159 #define SIMPLE          0x2     /* Simple enough to be STAR/PLUS operand. */
160 #define SPSTART         0x4     /* Starts with * or +. */
161 #define TRYAGAIN        0x8     /* Weeded out a declaration. */
162
163 /* Length of a variant. */
164
165 typedef struct scan_data_t {
166     I32 len_min;
167     I32 len_delta;
168     I32 pos_min;
169     I32 pos_delta;
170     SV *last_found;
171     I32 last_end;                       /* min value, <0 unless valid. */
172     I32 last_start_min;
173     I32 last_start_max;
174     SV **longest;                       /* Either &l_fixed, or &l_float. */
175     SV *longest_fixed;
176     I32 offset_fixed;
177     SV *longest_float;
178     I32 offset_float_min;
179     I32 offset_float_max;
180     I32 flags;
181     I32 whilem_c;
182     I32 *last_closep;
183     struct regnode_charclass_class *start_class;
184 } scan_data_t;
185
186 /*
187  * Forward declarations for pregcomp()'s friends.
188  */
189
190 static const scan_data_t zero_scan_data =
191   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
192
193 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
194 #define SF_BEFORE_SEOL          0x1
195 #define SF_BEFORE_MEOL          0x2
196 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
197 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
198
199 #ifdef NO_UNARY_PLUS
200 #  define SF_FIX_SHIFT_EOL      (0+2)
201 #  define SF_FL_SHIFT_EOL               (0+4)
202 #else
203 #  define SF_FIX_SHIFT_EOL      (+2)
204 #  define SF_FL_SHIFT_EOL               (+4)
205 #endif
206
207 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
208 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
209
210 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
211 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
212 #define SF_IS_INF               0x40
213 #define SF_HAS_PAR              0x80
214 #define SF_IN_PAR               0x100
215 #define SF_HAS_EVAL             0x200
216 #define SCF_DO_SUBSTR           0x400
217 #define SCF_DO_STCLASS_AND      0x0800
218 #define SCF_DO_STCLASS_OR       0x1000
219 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
220 #define SCF_WHILEM_VISITED_POS  0x2000
221
222 #define UTF (RExC_utf8 != 0)
223 #define LOC ((RExC_flags & PMf_LOCALE) != 0)
224 #define FOLD ((RExC_flags & PMf_FOLD) != 0)
225
226 #define OOB_UNICODE             12345678
227 #define OOB_NAMEDCLASS          -1
228
229 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
230 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
231
232
233 /* length of regex to show in messages that don't mark a position within */
234 #define RegexLengthToShowInErrorMessages 127
235
236 /*
237  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
238  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
239  * op/pragma/warn/regcomp.
240  */
241 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
242 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
243
244 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
245
246 /*
247  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
248  * arg. Show regex, up to a maximum length. If it's too long, chop and add
249  * "...".
250  */
251 #define FAIL(msg) STMT_START {                                          \
252     const char *ellipses = "";                                          \
253     IV len = RExC_end - RExC_precomp;                                   \
254                                                                         \
255     if (!SIZE_ONLY)                                                     \
256         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx);                      \
257     if (len > RegexLengthToShowInErrorMessages) {                       \
258         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
259         len = RegexLengthToShowInErrorMessages - 10;                    \
260         ellipses = "...";                                               \
261     }                                                                   \
262     Perl_croak(aTHX_ "%s in regex m/%.*s%s/",                           \
263             msg, (int)len, RExC_precomp, ellipses);                     \
264 } STMT_END
265
266 /*
267  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
268  */
269 #define Simple_vFAIL(m) STMT_START {                                    \
270     const IV offset = RExC_parse - RExC_precomp;                        \
271     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
272             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
273 } STMT_END
274
275 /*
276  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
277  */
278 #define vFAIL(m) STMT_START {                           \
279     if (!SIZE_ONLY)                                     \
280         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx);      \
281     Simple_vFAIL(m);                                    \
282 } STMT_END
283
284 /*
285  * Like Simple_vFAIL(), but accepts two arguments.
286  */
287 #define Simple_vFAIL2(m,a1) STMT_START {                        \
288     const IV offset = RExC_parse - RExC_precomp;                        \
289     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1,                   \
290             (int)offset, RExC_precomp, RExC_precomp + offset);  \
291 } STMT_END
292
293 /*
294  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
295  */
296 #define vFAIL2(m,a1) STMT_START {                       \
297     if (!SIZE_ONLY)                                     \
298         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx);      \
299     Simple_vFAIL2(m, a1);                               \
300 } STMT_END
301
302
303 /*
304  * Like Simple_vFAIL(), but accepts three arguments.
305  */
306 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
307     const IV offset = RExC_parse - RExC_precomp;                \
308     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2,               \
309             (int)offset, RExC_precomp, RExC_precomp + offset);  \
310 } STMT_END
311
312 /*
313  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
314  */
315 #define vFAIL3(m,a1,a2) STMT_START {                    \
316     if (!SIZE_ONLY)                                     \
317         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx);      \
318     Simple_vFAIL3(m, a1, a2);                           \
319 } STMT_END
320
321 /*
322  * Like Simple_vFAIL(), but accepts four arguments.
323  */
324 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
325     const IV offset = RExC_parse - RExC_precomp;                \
326     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3,           \
327             (int)offset, RExC_precomp, RExC_precomp + offset);  \
328 } STMT_END
329
330 #define vWARN(loc,m) STMT_START {                                       \
331     const IV offset = loc - RExC_precomp;                               \
332     Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s" REPORT_LOCATION,      \
333             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
334 } STMT_END
335
336 #define vWARNdep(loc,m) STMT_START {                                    \
337     const IV offset = loc - RExC_precomp;                               \
338     Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),          \
339             "%s" REPORT_LOCATION,                                       \
340             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
341 } STMT_END
342
343
344 #define vWARN2(loc, m, a1) STMT_START {                                 \
345     const IV offset = loc - RExC_precomp;                               \
346     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
347             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
348 } STMT_END
349
350 #define vWARN3(loc, m, a1, a2) STMT_START {                             \
351     const IV offset = loc - RExC_precomp;                               \
352     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
353             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
354 } STMT_END
355
356 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
357     const IV offset = loc - RExC_precomp;                               \
358     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
359             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
360 } STMT_END
361
362 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
363     const IV offset = loc - RExC_precomp;                               \
364     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
365             a1, a2, a3, a4, (int)offset, RExC_precomp, RExC_precomp + offset); \
366 } STMT_END
367
368
369 /* Allow for side effects in s */
370 #define REGC(c,s) STMT_START {                  \
371     if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
372 } STMT_END
373
374 /* Macros for recording node offsets.   20001227 mjd@plover.com 
375  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
376  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
377  * Element 0 holds the number n.
378  */
379
380 #define MJD_OFFSET_DEBUG(x)
381 /* #define MJD_OFFSET_DEBUG(x) DEBUG_r(Perl_warn_nocontext x) */
382
383
384 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
385     if (! SIZE_ONLY) {                                                  \
386         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
387                 __LINE__, (node), (byte)));                             \
388         if((node) < 0) {                                                \
389             Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \
390         } else {                                                        \
391             RExC_offsets[2*(node)-1] = (byte);                          \
392         }                                                               \
393     }                                                                   \
394 } STMT_END
395
396 #define Set_Node_Offset(node,byte) \
397     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
398 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
399
400 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
401     if (! SIZE_ONLY) {                                                  \
402         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
403                 __LINE__, (int)(node), (int)(len)));                    \
404         if((node) < 0) {                                                \
405             Perl_croak(aTHX_ "value of node is %d in Length macro", (int)(node)); \
406         } else {                                                        \
407             RExC_offsets[2*(node)] = (len);                             \
408         }                                                               \
409     }                                                                   \
410 } STMT_END
411
412 #define Set_Node_Length(node,len) \
413     Set_Node_Length_To_R((node)-RExC_emit_start, len)
414 #define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
415 #define Set_Node_Cur_Length(node) \
416     Set_Node_Length(node, RExC_parse - parse_start)
417
418 /* Get offsets and lengths */
419 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
420 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
421
422 static void clear_re(pTHX_ void *r);
423
424 /* Mark that we cannot extend a found fixed substring at this point.
425    Updata the longest found anchored substring and the longest found
426    floating substrings if needed. */
427
428 STATIC void
429 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data)
430 {
431     const STRLEN l = CHR_SVLEN(data->last_found);
432     const STRLEN old_l = CHR_SVLEN(*data->longest);
433
434     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
435         SvSetMagicSV(*data->longest, data->last_found);
436         if (*data->longest == data->longest_fixed) {
437             data->offset_fixed = l ? data->last_start_min : data->pos_min;
438             if (data->flags & SF_BEFORE_EOL)
439                 data->flags
440                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
441             else
442                 data->flags &= ~SF_FIX_BEFORE_EOL;
443         }
444         else {
445             data->offset_float_min = l ? data->last_start_min : data->pos_min;
446             data->offset_float_max = (l
447                                       ? data->last_start_max
448                                       : data->pos_min + data->pos_delta);
449             if ((U32)data->offset_float_max > (U32)I32_MAX)
450                 data->offset_float_max = I32_MAX;
451             if (data->flags & SF_BEFORE_EOL)
452                 data->flags
453                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
454             else
455                 data->flags &= ~SF_FL_BEFORE_EOL;
456         }
457     }
458     SvCUR_set(data->last_found, 0);
459     {
460         SV * const sv = data->last_found;
461         if (SvUTF8(sv) && SvMAGICAL(sv)) {
462             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
463             if (mg)
464                 mg->mg_len = 0;
465         }
466     }
467     data->last_end = -1;
468     data->flags &= ~SF_BEFORE_EOL;
469 }
470
471 /* Can match anything (initialization) */
472 STATIC void
473 S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
474 {
475     ANYOF_CLASS_ZERO(cl);
476     ANYOF_BITMAP_SETALL(cl);
477     cl->flags = ANYOF_EOS|ANYOF_UNICODE_ALL;
478     if (LOC)
479         cl->flags |= ANYOF_LOCALE;
480 }
481
482 /* Can match anything (initialization) */
483 STATIC int
484 S_cl_is_anything(const struct regnode_charclass_class *cl)
485 {
486     int value;
487
488     for (value = 0; value <= ANYOF_MAX; value += 2)
489         if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
490             return 1;
491     if (!(cl->flags & ANYOF_UNICODE_ALL))
492         return 0;
493     if (!ANYOF_BITMAP_TESTALLSET(cl))
494         return 0;
495     return 1;
496 }
497
498 /* Can match anything (initialization) */
499 STATIC void
500 S_cl_init(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
501 {
502     Zero(cl, 1, struct regnode_charclass_class);
503     cl->type = ANYOF;
504     cl_anything(pRExC_state, cl);
505 }
506
507 STATIC void
508 S_cl_init_zero(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
509 {
510     Zero(cl, 1, struct regnode_charclass_class);
511     cl->type = ANYOF;
512     cl_anything(pRExC_state, cl);
513     if (LOC)
514         cl->flags |= ANYOF_LOCALE;
515 }
516
517 /* 'And' a given class with another one.  Can create false positives */
518 /* We assume that cl is not inverted */
519 STATIC void
520 S_cl_and(struct regnode_charclass_class *cl,
521         const struct regnode_charclass_class *and_with)
522 {
523     if (!(and_with->flags & ANYOF_CLASS)
524         && !(cl->flags & ANYOF_CLASS)
525         && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
526         && !(and_with->flags & ANYOF_FOLD)
527         && !(cl->flags & ANYOF_FOLD)) {
528         int i;
529
530         if (and_with->flags & ANYOF_INVERT)
531             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
532                 cl->bitmap[i] &= ~and_with->bitmap[i];
533         else
534             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
535                 cl->bitmap[i] &= and_with->bitmap[i];
536     } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
537     if (!(and_with->flags & ANYOF_EOS))
538         cl->flags &= ~ANYOF_EOS;
539
540     if (cl->flags & ANYOF_UNICODE_ALL && and_with->flags & ANYOF_UNICODE &&
541         !(and_with->flags & ANYOF_INVERT)) {
542         cl->flags &= ~ANYOF_UNICODE_ALL;
543         cl->flags |= ANYOF_UNICODE;
544         ARG_SET(cl, ARG(and_with));
545     }
546     if (!(and_with->flags & ANYOF_UNICODE_ALL) &&
547         !(and_with->flags & ANYOF_INVERT))
548         cl->flags &= ~ANYOF_UNICODE_ALL;
549     if (!(and_with->flags & (ANYOF_UNICODE|ANYOF_UNICODE_ALL)) &&
550         !(and_with->flags & ANYOF_INVERT))
551         cl->flags &= ~ANYOF_UNICODE;
552 }
553
554 /* 'OR' a given class with another one.  Can create false positives */
555 /* We assume that cl is not inverted */
556 STATIC void
557 S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
558 {
559     if (or_with->flags & ANYOF_INVERT) {
560         /* We do not use
561          * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
562          *   <= (B1 | !B2) | (CL1 | !CL2)
563          * which is wasteful if CL2 is small, but we ignore CL2:
564          *   (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
565          * XXXX Can we handle case-fold?  Unclear:
566          *   (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
567          *   (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
568          */
569         if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
570              && !(or_with->flags & ANYOF_FOLD)
571              && !(cl->flags & ANYOF_FOLD) ) {
572             int i;
573
574             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
575                 cl->bitmap[i] |= ~or_with->bitmap[i];
576         } /* XXXX: logic is complicated otherwise */
577         else {
578             cl_anything(pRExC_state, cl);
579         }
580     } else {
581         /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
582         if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
583              && (!(or_with->flags & ANYOF_FOLD)
584                  || (cl->flags & ANYOF_FOLD)) ) {
585             int i;
586
587             /* OR char bitmap and class bitmap separately */
588             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
589                 cl->bitmap[i] |= or_with->bitmap[i];
590             if (or_with->flags & ANYOF_CLASS) {
591                 for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++)
592                     cl->classflags[i] |= or_with->classflags[i];
593                 cl->flags |= ANYOF_CLASS;
594             }
595         }
596         else { /* XXXX: logic is complicated, leave it along for a moment. */
597             cl_anything(pRExC_state, cl);
598         }
599     }
600     if (or_with->flags & ANYOF_EOS)
601         cl->flags |= ANYOF_EOS;
602
603     if (cl->flags & ANYOF_UNICODE && or_with->flags & ANYOF_UNICODE &&
604         ARG(cl) != ARG(or_with)) {
605         cl->flags |= ANYOF_UNICODE_ALL;
606         cl->flags &= ~ANYOF_UNICODE;
607     }
608     if (or_with->flags & ANYOF_UNICODE_ALL) {
609         cl->flags |= ANYOF_UNICODE_ALL;
610         cl->flags &= ~ANYOF_UNICODE;
611     }
612 }
613
614 /*
615
616  make_trie(startbranch,first,last,tail,flags)
617   startbranch: the first branch in the whole branch sequence
618   first      : start branch of sequence of branch-exact nodes.
619                May be the same as startbranch
620   last       : Thing following the last branch.
621                May be the same as tail.
622   tail       : item following the branch sequence
623   flags      : currently the OP() type we will be building one of /EXACT(|F|Fl)/
624
625 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
626
627 A trie is an N'ary tree where the branches are determined by digital
628 decomposition of the key. IE, at the root node you look up the 1st character and
629 follow that branch repeat until you find the end of the branches. Nodes can be
630 marked as "accepting" meaning they represent a complete word. Eg:
631
632   /he|she|his|hers/
633
634 would convert into the following structure. Numbers represent states, letters
635 following numbers represent valid transitions on the letter from that state, if
636 the number is in square brackets it represents an accepting state, otherwise it
637 will be in parenthesis.
638
639       +-h->+-e->[3]-+-r->(8)-+-s->[9]
640       |    |
641       |   (2)
642       |    |
643      (1)   +-i->(6)-+-s->[7]
644       |
645       +-s->(3)-+-h->(4)-+-e->[5]
646
647       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
648
649 This shows that when matching against the string 'hers' we will begin at state 1
650 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
651 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
652 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
653 single traverse. We store a mapping from accepting to state to which word was
654 matched, and then when we have multiple possibilities we try to complete the
655 rest of the regex in the order in which they occured in the alternation.
656
657 The only prior NFA like behaviour that would be changed by the TRIE support is
658 the silent ignoring of duplicate alternations which are of the form:
659
660  / (DUPE|DUPE) X? (?{ ... }) Y /x
661
662 Thus EVAL blocks follwing a trie may be called a different number of times with
663 and without the optimisation. With the optimisations dupes will be silently
664 ignored. This inconsistant behaviour of EVAL type nodes is well established as
665 the following demonstrates:
666
667  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
668
669 which prints out 'word' three times, but
670
671  'words'=~/(word|word|word)(?{ print $1 })S/
672
673 which doesnt print it out at all. This is due to other optimisations kicking in.
674
675 Example of what happens on a structural level:
676
677 The regexp /(ac|ad|ab)+/ will produce the folowing debug output:
678
679    1: CURLYM[1] {1,32767}(18)
680    5:   BRANCH(8)
681    6:     EXACT <ac>(16)
682    8:   BRANCH(11)
683    9:     EXACT <ad>(16)
684   11:   BRANCH(14)
685   12:     EXACT <ab>(16)
686   16:   SUCCEED(0)
687   17:   NOTHING(18)
688   18: END(0)
689
690 This would be optimizable with startbranch=5, first=5, last=16, tail=16
691 and should turn into:
692
693    1: CURLYM[1] {1,32767}(18)
694    5:   TRIE(16)
695         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
696           <ac>
697           <ad>
698           <ab>
699   16:   SUCCEED(0)
700   17:   NOTHING(18)
701   18: END(0)
702
703 Cases where tail != last would be like /(?foo|bar)baz/:
704
705    1: BRANCH(4)
706    2:   EXACT <foo>(8)
707    4: BRANCH(7)
708    5:   EXACT <bar>(8)
709    7: TAIL(8)
710    8: EXACT <baz>(10)
711   10: END(0)
712
713 which would be optimizable with startbranch=1, first=1, last=7, tail=8
714 and would end up looking like:
715
716     1: TRIE(8)
717       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
718         <foo>
719         <bar>
720    7: TAIL(8)
721    8: EXACT <baz>(10)
722   10: END(0)
723
724 */
725
726 #define TRIE_DEBUG_CHAR                                                    \
727     DEBUG_TRIE_COMPILE_r({                                                 \
728         SV *tmp;                                                           \
729         if ( UTF ) {                                                       \
730             tmp = newSVpvs( "" );                                          \
731             pv_uni_display( tmp, uc, len, 60, UNI_DISPLAY_REGEX );         \
732         } else {                                                           \
733             tmp = Perl_newSVpvf_nocontext( "%c", (int)uvc );               \
734         }                                                                  \
735         av_push( trie->revcharmap, tmp );                                  \
736     })
737
738 #define TRIE_READ_CHAR STMT_START {                                           \
739     if ( UTF ) {                                                              \
740         if ( folder ) {                                                       \
741             if ( foldlen > 0 ) {                                              \
742                uvc = utf8n_to_uvuni( scan, UTF8_MAXLEN, &len, uniflags );     \
743                foldlen -= len;                                                \
744                scan += len;                                                   \
745                len = 0;                                                       \
746             } else {                                                          \
747                 uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
748                 uvc = to_uni_fold( uvc, foldbuf, &foldlen );                  \
749                 foldlen -= UNISKIP( uvc );                                    \
750                 scan = foldbuf + UNISKIP( uvc );                              \
751             }                                                                 \
752         } else {                                                              \
753             uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
754         }                                                                     \
755     } else {                                                                  \
756         uvc = (U32)*uc;                                                       \
757         len = 1;                                                              \
758     }                                                                         \
759 } STMT_END
760
761
762 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
763 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
764 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
765 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list ? (TRIE_LIST_CUR( idx ) - 1) : 0 )
766
767 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
768     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
769         TRIE_LIST_LEN( state ) *= 2;                            \
770         Renew( trie->states[ state ].trans.list,                \
771                TRIE_LIST_LEN( state ), reg_trie_trans_le );     \
772     }                                                           \
773     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
774     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
775     TRIE_LIST_CUR( state )++;                                   \
776 } STMT_END
777
778 #define TRIE_LIST_NEW(state) STMT_START {                       \
779     Newxz( trie->states[ state ].trans.list,               \
780         4, reg_trie_trans_le );                                 \
781      TRIE_LIST_CUR( state ) = 1;                                \
782      TRIE_LIST_LEN( state ) = 4;                                \
783 } STMT_END
784
785 STATIC I32
786 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 flags)
787 {
788     dVAR;
789     /* first pass, loop through and scan words */
790     reg_trie_data *trie;
791     regnode *cur;
792     const U32 uniflags = UTF8_ALLOW_DEFAULT;
793     STRLEN len = 0;
794     UV uvc = 0;
795     U16 curword = 0;
796     U32 next_alloc = 0;
797     /* we just use folder as a flag in utf8 */
798     const U8 * const folder = ( flags == EXACTF
799                        ? PL_fold
800                        : ( flags == EXACTFL
801                            ? PL_fold_locale
802                            : NULL
803                          )
804                      );
805
806     const U32 data_slot = add_data( pRExC_state, 1, "t" );
807     SV *re_trie_maxbuff;
808
809     GET_RE_DEBUG_FLAGS_DECL;
810
811     Newxz( trie, 1, reg_trie_data );
812     trie->refcount = 1;
813     RExC_rx->data->data[ data_slot ] = (void*)trie;
814     Newxz( trie->charmap, 256, U16 );
815     DEBUG_r({
816         trie->words = newAV();
817         trie->revcharmap = newAV();
818     });
819
820
821     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
822     if (!SvIOK(re_trie_maxbuff)) {
823         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
824     }
825
826     /*  -- First loop and Setup --
827
828        We first traverse the branches and scan each word to determine if it
829        contains widechars, and how many unique chars there are, this is
830        important as we have to build a table with at least as many columns as we
831        have unique chars.
832
833        We use an array of integers to represent the character codes 0..255
834        (trie->charmap) and we use a an HV* to store unicode characters. We use the
835        native representation of the character value as the key and IV's for the
836        coded index.
837
838        *TODO* If we keep track of how many times each character is used we can
839        remap the columns so that the table compression later on is more
840        efficient in terms of memory by ensuring most common value is in the
841        middle and the least common are on the outside.  IMO this would be better
842        than a most to least common mapping as theres a decent chance the most
843        common letter will share a node with the least common, meaning the node
844        will not be compressable. With a middle is most common approach the worst
845        case is when we have the least common nodes twice.
846
847      */
848
849
850     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
851         regnode * const noper = NEXTOPER( cur );
852         const U8 *uc = (U8*)STRING( noper );
853         const U8 * const e  = uc + STR_LEN( noper );
854         STRLEN foldlen = 0;
855         U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
856         const U8 *scan = (U8*)NULL;
857
858         for ( ; uc < e ; uc += len ) {
859             trie->charcount++;
860             TRIE_READ_CHAR;
861             if ( uvc < 256 ) {
862                 if ( !trie->charmap[ uvc ] ) {
863                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
864                     if ( folder )
865                         trie->charmap[ folder[ uvc ] ] = trie->charmap[ uvc ];
866                     TRIE_DEBUG_CHAR;
867                 }
868             } else {
869                 SV** svpp;
870                 if ( !trie->widecharmap )
871                     trie->widecharmap = newHV();
872
873                 svpp = hv_fetch( trie->widecharmap, (char*)&uvc, sizeof( UV ), 1 );
874
875                 if ( !svpp )
876                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
877
878                 if ( !SvTRUE( *svpp ) ) {
879                     sv_setiv( *svpp, ++trie->uniquecharcount );
880                     TRIE_DEBUG_CHAR;
881                 }
882             }
883         }
884         trie->wordcount++;
885     } /* end first pass */
886     DEBUG_TRIE_COMPILE_r(
887         PerlIO_printf( Perl_debug_log, "TRIE(%s): W:%d C:%d Uq:%d \n",
888                 ( trie->widecharmap ? "UTF8" : "NATIVE" ), trie->wordcount,
889                 (int)trie->charcount, trie->uniquecharcount )
890     );
891
892
893     /*
894         We now know what we are dealing with in terms of unique chars and
895         string sizes so we can calculate how much memory a naive
896         representation using a flat table  will take. If it's over a reasonable
897         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
898         conservative but potentially much slower representation using an array
899         of lists.
900
901         At the end we convert both representations into the same compressed
902         form that will be used in regexec.c for matching with. The latter
903         is a form that cannot be used to construct with but has memory
904         properties similar to the list form and access properties similar
905         to the table form making it both suitable for fast searches and
906         small enough that its feasable to store for the duration of a program.
907
908         See the comment in the code where the compressed table is produced
909         inplace from the flat tabe representation for an explanation of how
910         the compression works.
911
912     */
913
914
915     if ( (IV)( ( trie->charcount + 1 ) * trie->uniquecharcount + 1) > SvIV(re_trie_maxbuff) ) {
916         /*
917             Second Pass -- Array Of Lists Representation
918
919             Each state will be represented by a list of charid:state records
920             (reg_trie_trans_le) the first such element holds the CUR and LEN
921             points of the allocated array. (See defines above).
922
923             We build the initial structure using the lists, and then convert
924             it into the compressed table form which allows faster lookups
925             (but cant be modified once converted).
926
927
928         */
929
930
931         STRLEN transcount = 1;
932
933         Newxz( trie->states, trie->charcount + 2, reg_trie_state );
934         TRIE_LIST_NEW(1);
935         next_alloc = 2;
936
937         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
938
939             regnode * const noper = NEXTOPER( cur );
940             U8 *uc           = (U8*)STRING( noper );
941             const U8 * const e = uc + STR_LEN( noper );
942             U32 state        = 1;         /* required init */
943             U16 charid       = 0;         /* sanity init */
944             U8 *scan         = (U8*)NULL; /* sanity init */
945             STRLEN foldlen   = 0;         /* required init */
946             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
947
948             for ( ; uc < e ; uc += len ) {
949
950                 TRIE_READ_CHAR;
951
952                 if ( uvc < 256 ) {
953                     charid = trie->charmap[ uvc ];
954                 } else {
955                     SV** const svpp = hv_fetch( trie->widecharmap, (char*)&uvc, sizeof( UV ), 0);
956                     if ( !svpp ) {
957                         charid = 0;
958                     } else {
959                         charid=(U16)SvIV( *svpp );
960                     }
961                 }
962                 if ( charid ) {
963
964                     U16 check;
965                     U32 newstate = 0;
966
967                     charid--;
968                     if ( !trie->states[ state ].trans.list ) {
969                         TRIE_LIST_NEW( state );
970                     }
971                     for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) {
972                         if ( TRIE_LIST_ITEM( state, check ).forid == charid ) {
973                             newstate = TRIE_LIST_ITEM( state, check ).newstate;
974                             break;
975                         }
976                     }
977                     if ( ! newstate ) {
978                         newstate = next_alloc++;
979                         TRIE_LIST_PUSH( state, charid, newstate );
980                         transcount++;
981                     }
982                     state = newstate;
983                 } else {
984                     Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
985                 }
986                 /* charid is now 0 if we dont know the char read, or nonzero if we do */
987             }
988
989             if ( !trie->states[ state ].wordnum ) {
990                 /* we havent inserted this word into the structure yet. */
991                 trie->states[ state ].wordnum = ++curword;
992
993                 DEBUG_r({
994                     /* store the word for dumping */
995                     SV* tmp = newSVpvn( STRING( noper ), STR_LEN( noper ) );
996                     if ( UTF ) SvUTF8_on( tmp );
997                     av_push( trie->words, tmp );
998                 });
999
1000             } else {
1001                 NOOP;   /* It's a dupe. So ignore it. */
1002             }
1003
1004         } /* end second pass */
1005
1006         trie->laststate = next_alloc;
1007         Renew( trie->states, next_alloc, reg_trie_state );
1008
1009         DEBUG_TRIE_COMPILE_MORE_r({
1010             U32 state;
1011
1012             /* print out the table precompression.  */
1013
1014             PerlIO_printf( Perl_debug_log, "\nState :Word | Transition Data\n" );
1015             PerlIO_printf( Perl_debug_log,   "------:-----+-----------------" );
1016
1017             for( state=1 ; state < next_alloc ; state ++ ) {
1018                 U16 charid;
1019
1020                 PerlIO_printf( Perl_debug_log, "\n %04"UVXf" :", (UV)state  );
1021                 if ( ! trie->states[ state ].wordnum ) {
1022                     PerlIO_printf( Perl_debug_log, "%5s| ","");
1023                 } else {
1024                     PerlIO_printf( Perl_debug_log, "W%04x| ",
1025                         trie->states[ state ].wordnum
1026                     );
1027                 }
1028                 for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
1029                     SV **tmp = av_fetch( trie->revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
1030                     PerlIO_printf( Perl_debug_log, "%s:%3X=%04"UVXf" | ",
1031                         SvPV_nolen_const( *tmp ),
1032                         TRIE_LIST_ITEM(state,charid).forid,
1033                         (UV)TRIE_LIST_ITEM(state,charid).newstate
1034                     );
1035                 }
1036
1037             }
1038             PerlIO_printf( Perl_debug_log, "\n\n" );
1039         });
1040
1041         Newxz( trie->trans, transcount ,reg_trie_trans );
1042         {
1043             U32 state;
1044             U32 tp = 0;
1045             U32 zp = 0;
1046
1047
1048             for( state=1 ; state < next_alloc ; state ++ ) {
1049                 U32 base=0;
1050
1051                 /*
1052                 DEBUG_TRIE_COMPILE_MORE_r(
1053                     PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
1054                 );
1055                 */
1056
1057                 if (trie->states[state].trans.list) {
1058                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
1059                     U16 maxid=minid;
1060                     U16 idx;
1061
1062                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1063                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
1064                         if ( forid < minid ) {
1065                             minid=forid;
1066                         } else if ( forid > maxid ) {
1067                             maxid=forid;
1068                         }
1069                     }
1070                     if ( transcount < tp + maxid - minid + 1) {
1071                         transcount *= 2;
1072                         Renew( trie->trans, transcount, reg_trie_trans );
1073                         Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans );
1074                     }
1075                     base = trie->uniquecharcount + tp - minid;
1076                     if ( maxid == minid ) {
1077                         U32 set = 0;
1078                         for ( ; zp < tp ; zp++ ) {
1079                             if ( ! trie->trans[ zp ].next ) {
1080                                 base = trie->uniquecharcount + zp - minid;
1081                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1082                                 trie->trans[ zp ].check = state;
1083                                 set = 1;
1084                                 break;
1085                             }
1086                         }
1087                         if ( !set ) {
1088                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1089                             trie->trans[ tp ].check = state;
1090                             tp++;
1091                             zp = tp;
1092                         }
1093                     } else {
1094                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1095                             const U32 tid = base -  trie->uniquecharcount + TRIE_LIST_ITEM( state, idx ).forid;
1096                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state, idx ).newstate;
1097                             trie->trans[ tid ].check = state;
1098                         }
1099                         tp += ( maxid - minid + 1 );
1100                     }
1101                     Safefree(trie->states[ state ].trans.list);
1102                 }
1103                 /*
1104                 DEBUG_TRIE_COMPILE_MORE_r(
1105                     PerlIO_printf( Perl_debug_log, " base: %d\n",base);
1106                 );
1107                 */
1108                 trie->states[ state ].trans.base=base;
1109             }
1110             trie->lasttrans = tp + 1;
1111         }
1112     } else {
1113         /*
1114            Second Pass -- Flat Table Representation.
1115
1116            we dont use the 0 slot of either trans[] or states[] so we add 1 to each.
1117            We know that we will need Charcount+1 trans at most to store the data
1118            (one row per char at worst case) So we preallocate both structures
1119            assuming worst case.
1120
1121            We then construct the trie using only the .next slots of the entry
1122            structs.
1123
1124            We use the .check field of the first entry of the node  temporarily to
1125            make compression both faster and easier by keeping track of how many non
1126            zero fields are in the node.
1127
1128            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
1129            transition.
1130
1131            There are two terms at use here: state as a TRIE_NODEIDX() which is a
1132            number representing the first entry of the node, and state as a
1133            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1) and
1134            TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3) if there
1135            are 2 entrys per node. eg:
1136
1137              A B       A B
1138           1. 2 4    1. 3 7
1139           2. 0 3    3. 0 5
1140           3. 0 0    5. 0 0
1141           4. 0 0    7. 0 0
1142
1143            The table is internally in the right hand, idx form. However as we also
1144            have to deal with the states array which is indexed by nodenum we have to
1145            use TRIE_NODENUM() to convert.
1146
1147         */
1148
1149         Newxz( trie->trans, ( trie->charcount + 1 ) * trie->uniquecharcount + 1,
1150               reg_trie_trans );
1151         Newxz( trie->states, trie->charcount + 2, reg_trie_state );
1152         next_alloc = trie->uniquecharcount + 1;
1153
1154         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1155
1156             regnode * const noper   = NEXTOPER( cur );
1157             const U8 *uc     = (U8*)STRING( noper );
1158             const U8 * const e = uc + STR_LEN( noper );
1159
1160             U32 state        = 1;         /* required init */
1161
1162             U16 charid       = 0;         /* sanity init */
1163             U32 accept_state = 0;         /* sanity init */
1164             U8 *scan         = (U8*)NULL; /* sanity init */
1165
1166             STRLEN foldlen   = 0;         /* required init */
1167             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1168
1169
1170             for ( ; uc < e ; uc += len ) {
1171
1172                 TRIE_READ_CHAR;
1173
1174                 if ( uvc < 256 ) {
1175                     charid = trie->charmap[ uvc ];
1176                 } else {
1177                     SV* const * const svpp = hv_fetch( trie->widecharmap, (char*)&uvc, sizeof( UV ), 0);
1178                     charid = svpp ? (U16)SvIV(*svpp) : 0;
1179                 }
1180                 if ( charid ) {
1181                     charid--;
1182                     if ( !trie->trans[ state + charid ].next ) {
1183                         trie->trans[ state + charid ].next = next_alloc;
1184                         trie->trans[ state ].check++;
1185                         next_alloc += trie->uniquecharcount;
1186                     }
1187                     state = trie->trans[ state + charid ].next;
1188                 } else {
1189                     Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1190                 }
1191                 /* charid is now 0 if we dont know the char read, or nonzero if we do */
1192             }
1193
1194             accept_state = TRIE_NODENUM( state );
1195             if ( !trie->states[ accept_state ].wordnum ) {
1196                 /* we havent inserted this word into the structure yet. */
1197                 trie->states[ accept_state ].wordnum = ++curword;
1198
1199                 DEBUG_r({
1200                     /* store the word for dumping */
1201                     SV* tmp = newSVpvn( STRING( noper ), STR_LEN( noper ) );
1202                     if ( UTF ) SvUTF8_on( tmp );
1203                     av_push( trie->words, tmp );
1204                 });
1205
1206             } else {
1207                 NOOP;  /* Its a dupe. So ignore it. */
1208             }
1209
1210         } /* end second pass */
1211
1212         DEBUG_TRIE_COMPILE_MORE_r({
1213             /*
1214                print out the table precompression so that we can do a visual check
1215                that they are identical.
1216              */
1217             U32 state;
1218             U16 charid;
1219             PerlIO_printf( Perl_debug_log, "\nChar : " );
1220
1221             for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1222                 SV **tmp = av_fetch( trie->revcharmap, charid, 0);
1223                 if ( tmp ) {
1224                   PerlIO_printf( Perl_debug_log, "%4.4s ", SvPV_nolen_const( *tmp ) );
1225                 }
1226             }
1227
1228             PerlIO_printf( Perl_debug_log, "\nState+-" );
1229
1230             for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
1231                 PerlIO_printf( Perl_debug_log, "%4s-", "----" );
1232             }
1233
1234             PerlIO_printf( Perl_debug_log, "\n" );
1235
1236             for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
1237
1238                 PerlIO_printf( Perl_debug_log, "%04"UVXf" : ", (UV)TRIE_NODENUM( state ) );
1239
1240                 for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1241                     PerlIO_printf( Perl_debug_log, "%04"UVXf" ",
1242                         (UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next ) );
1243                 }
1244                 if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1245                     PerlIO_printf( Perl_debug_log, " (%04"UVXf")\n", (UV)trie->trans[ state ].check );
1246                 } else {
1247                     PerlIO_printf( Perl_debug_log, " (%04"UVXf") W%04X\n", (UV)trie->trans[ state ].check,
1248                     trie->states[ TRIE_NODENUM( state ) ].wordnum );
1249                 }
1250             }
1251             PerlIO_printf( Perl_debug_log, "\n\n" );
1252         });
1253         {
1254         /*
1255            * Inplace compress the table.*
1256
1257            For sparse data sets the table constructed by the trie algorithm will
1258            be mostly 0/FAIL transitions or to put it another way mostly empty.
1259            (Note that leaf nodes will not contain any transitions.)
1260
1261            This algorithm compresses the tables by eliminating most such
1262            transitions, at the cost of a modest bit of extra work during lookup:
1263
1264            - Each states[] entry contains a .base field which indicates the
1265            index in the state[] array wheres its transition data is stored.
1266
1267            - If .base is 0 there are no  valid transitions from that node.
1268
1269            - If .base is nonzero then charid is added to it to find an entry in
1270            the trans array.
1271
1272            -If trans[states[state].base+charid].check!=state then the
1273            transition is taken to be a 0/Fail transition. Thus if there are fail
1274            transitions at the front of the node then the .base offset will point
1275            somewhere inside the previous nodes data (or maybe even into a node
1276            even earlier), but the .check field determines if the transition is
1277            valid.
1278
1279            The following process inplace converts the table to the compressed
1280            table: We first do not compress the root node 1,and mark its all its
1281            .check pointers as 1 and set its .base pointer as 1 as well. This
1282            allows to do a DFA construction from the compressed table later, and
1283            ensures that any .base pointers we calculate later are greater than
1284            0.
1285
1286            - We set 'pos' to indicate the first entry of the second node.
1287
1288            - We then iterate over the columns of the node, finding the first and
1289            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
1290            and set the .check pointers accordingly, and advance pos
1291            appropriately and repreat for the next node. Note that when we copy
1292            the next pointers we have to convert them from the original
1293            NODEIDX form to NODENUM form as the former is not valid post
1294            compression.
1295
1296            - If a node has no transitions used we mark its base as 0 and do not
1297            advance the pos pointer.
1298
1299            - If a node only has one transition we use a second pointer into the
1300            structure to fill in allocated fail transitions from other states.
1301            This pointer is independent of the main pointer and scans forward
1302            looking for null transitions that are allocated to a state. When it
1303            finds one it writes the single transition into the "hole".  If the
1304            pointer doesnt find one the single transition is appeneded as normal.
1305
1306            - Once compressed we can Renew/realloc the structures to release the
1307            excess space.
1308
1309            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
1310            specifically Fig 3.47 and the associated pseudocode.
1311
1312            demq
1313         */
1314         const U32 laststate = TRIE_NODENUM( next_alloc );
1315         U32 state, charid;
1316         U32 pos = 0, zp=0;
1317         trie->laststate = laststate;
1318
1319         for ( state = 1 ; state < laststate ; state++ ) {
1320             U8 flag = 0;
1321             const U32 stateidx = TRIE_NODEIDX( state );
1322             const U32 o_used = trie->trans[ stateidx ].check;
1323             U32 used = trie->trans[ stateidx ].check;
1324             trie->trans[ stateidx ].check = 0;
1325
1326             for ( charid = 0 ; used && charid < trie->uniquecharcount ; charid++ ) {
1327                 if ( flag || trie->trans[ stateidx + charid ].next ) {
1328                     if ( trie->trans[ stateidx + charid ].next ) {
1329                         if (o_used == 1) {
1330                             for ( ; zp < pos ; zp++ ) {
1331                                 if ( ! trie->trans[ zp ].next ) {
1332                                     break;
1333                                 }
1334                             }
1335                             trie->states[ state ].trans.base = zp + trie->uniquecharcount - charid ;
1336                             trie->trans[ zp ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
1337                             trie->trans[ zp ].check = state;
1338                             if ( ++zp > pos ) pos = zp;
1339                             break;
1340                         }
1341                         used--;
1342                     }
1343                     if ( !flag ) {
1344                         flag = 1;
1345                         trie->states[ state ].trans.base = pos + trie->uniquecharcount - charid ;
1346                     }
1347                     trie->trans[ pos ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
1348                     trie->trans[ pos ].check = state;
1349                     pos++;
1350                 }
1351             }
1352         }
1353         trie->lasttrans = pos + 1;
1354         Renew( trie->states, laststate + 1, reg_trie_state);
1355         DEBUG_TRIE_COMPILE_MORE_r(
1356                 PerlIO_printf( Perl_debug_log,
1357                     " Alloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
1358                     (int)( ( trie->charcount + 1 ) * trie->uniquecharcount + 1 ),
1359                     (IV)next_alloc,
1360                     (IV)pos,
1361                     ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
1362             );
1363
1364         } /* end table compress */
1365     }
1366     /* resize the trans array to remove unused space */
1367     Renew( trie->trans, trie->lasttrans, reg_trie_trans);
1368
1369     DEBUG_TRIE_COMPILE_r({
1370         U32 state;
1371         /*
1372            Now we print it out again, in a slightly different form as there is additional
1373            info we want to be able to see when its compressed. They are close enough for
1374            visual comparison though.
1375          */
1376         PerlIO_printf( Perl_debug_log, "\nChar : %-6s%-6s%-4s ","Match","Base","Ofs" );
1377
1378         for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1379             SV **tmp = av_fetch( trie->revcharmap, state, 0);
1380             if ( tmp ) {
1381               PerlIO_printf( Perl_debug_log, "%4.4s ", SvPV_nolen_const( *tmp ) );
1382             }
1383         }
1384         PerlIO_printf( Perl_debug_log, "\n-----:-----------------------");
1385
1386         for( state = 0 ; state < trie->uniquecharcount ; state++ )
1387             PerlIO_printf( Perl_debug_log, "-----");
1388         PerlIO_printf( Perl_debug_log, "\n");
1389
1390         for( state = 1 ; state < trie->laststate ; state++ ) {
1391             const U32 base = trie->states[ state ].trans.base;
1392
1393             PerlIO_printf( Perl_debug_log, "#%04"UVXf" ", (UV)state);
1394
1395             if ( trie->states[ state ].wordnum ) {
1396                 PerlIO_printf( Perl_debug_log, " W%04X", trie->states[ state ].wordnum );
1397             } else {
1398                 PerlIO_printf( Perl_debug_log, "%6s", "" );
1399             }
1400
1401             PerlIO_printf( Perl_debug_log, " @%04"UVXf" ", (UV)base );
1402
1403             if ( base ) {
1404                 U32 ofs = 0;
1405
1406                 while( ( base + ofs  < trie->uniquecharcount ) ||
1407                        ( base + ofs - trie->uniquecharcount < trie->lasttrans
1408                          && trie->trans[ base + ofs - trie->uniquecharcount ].check != state))
1409                         ofs++;
1410
1411                 PerlIO_printf( Perl_debug_log, "+%02"UVXf"[ ", (UV)ofs);
1412
1413                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
1414                     if ( ( base + ofs >= trie->uniquecharcount ) &&
1415                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
1416                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
1417                     {
1418                        PerlIO_printf( Perl_debug_log, "%04"UVXf" ",
1419                         (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
1420                     } else {
1421                         PerlIO_printf( Perl_debug_log, "%4s ","   0" );
1422                     }
1423                 }
1424
1425                 PerlIO_printf( Perl_debug_log, "]");
1426
1427             }
1428             PerlIO_printf( Perl_debug_log, "\n" );
1429         }
1430     });
1431
1432     {
1433         /* now finally we "stitch in" the new TRIE node
1434            This means we convert either the first branch or the first Exact,
1435            depending on whether the thing following (in 'last') is a branch
1436            or not and whther first is the startbranch (ie is it a sub part of
1437            the alternation or is it the whole thing.)
1438            Assuming its a sub part we conver the EXACT otherwise we convert
1439            the whole branch sequence, including the first.
1440         */
1441         regnode *convert;
1442
1443
1444
1445
1446         if ( first == startbranch && OP( last ) != BRANCH ) {
1447             convert = first;
1448         } else {
1449             convert = NEXTOPER( first );
1450             NEXT_OFF( first ) = (U16)(last - first);
1451         }
1452
1453         OP( convert ) = TRIE + (U8)( flags - EXACT );
1454         NEXT_OFF( convert ) = (U16)(tail - convert);
1455         ARG_SET( convert, data_slot );
1456
1457         /* tells us if we need to handle accept buffers specially */
1458         convert->flags = ( RExC_seen_evals ? 1 : 0 );
1459
1460
1461         /* needed for dumping*/
1462         DEBUG_r({
1463             regnode *optimize = convert + NODE_STEP_REGNODE + regarglen[ TRIE ];
1464             /* We now need to mark all of the space originally used by the
1465                branches as optimized away. This keeps the dumpuntil from
1466                throwing a wobbly as it doesnt use regnext() to traverse the
1467                opcodes.
1468              */
1469             while( optimize < last ) {
1470                 OP( optimize ) = OPTIMIZED;
1471                 optimize++;
1472             }
1473         });
1474     } /* end node insert */
1475     return 1;
1476 }
1477
1478
1479
1480 /*
1481  * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
1482  * These need to be revisited when a newer toolchain becomes available.
1483  */
1484 #if defined(__sparc64__) && defined(__GNUC__)
1485 #   if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
1486 #       undef  SPARC64_GCC_WORKAROUND
1487 #       define SPARC64_GCC_WORKAROUND 1
1488 #   endif
1489 #endif
1490
1491 /* REx optimizer.  Converts nodes into quickier variants "in place".
1492    Finds fixed substrings.  */
1493
1494 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
1495    to the position after last scanned or to NULL. */
1496
1497
1498 STATIC I32
1499 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap,
1500                         regnode *last, scan_data_t *data, U32 flags, U32 depth)
1501                         /* scanp: Start here (read-write). */
1502                         /* deltap: Write maxlen-minlen here. */
1503                         /* last: Stop before this one. */
1504 {
1505     dVAR;
1506     I32 min = 0, pars = 0, code;
1507     regnode *scan = *scanp, *next;
1508     I32 delta = 0;
1509     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
1510     int is_inf_internal = 0;            /* The studied chunk is infinite */
1511     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
1512     scan_data_t data_fake;
1513     struct regnode_charclass_class and_with; /* Valid if flags & SCF_DO_STCLASS_OR */
1514     SV *re_trie_maxbuff = NULL;
1515
1516     GET_RE_DEBUG_FLAGS_DECL;
1517
1518     while (scan && OP(scan) != END && scan < last) {
1519         /* Peephole optimizer: */
1520         DEBUG_OPTIMISE_r({
1521           SV * const mysv=sv_newmortal();
1522           regprop(RExC_rx, mysv, scan);
1523           PerlIO_printf(Perl_debug_log, "%*speep: %s (0x%08"UVXf")\n",
1524             (int)depth*2, "", SvPV_nolen_const(mysv), PTR2UV(scan));
1525         });
1526
1527         if (PL_regkind[(U8)OP(scan)] == EXACT) {
1528             /* Merge several consecutive EXACTish nodes into one. */
1529             regnode *n = regnext(scan);
1530             U32 stringok = 1;
1531 #ifdef DEBUGGING
1532             regnode *stop = scan;
1533 #endif
1534
1535             next = scan + NODE_SZ_STR(scan);
1536             /* Skip NOTHING, merge EXACT*. */
1537             while (n &&
1538                    ( PL_regkind[(U8)OP(n)] == NOTHING ||
1539                      (stringok && (OP(n) == OP(scan))))
1540                    && NEXT_OFF(n)
1541                    && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
1542                 if (OP(n) == TAIL || n > next)
1543                     stringok = 0;
1544                 if (PL_regkind[(U8)OP(n)] == NOTHING) {
1545                     NEXT_OFF(scan) += NEXT_OFF(n);
1546                     next = n + NODE_STEP_REGNODE;
1547 #ifdef DEBUGGING
1548                     if (stringok)
1549                         stop = n;
1550 #endif
1551                     n = regnext(n);
1552                 }
1553                 else if (stringok) {
1554                     const int oldl = STR_LEN(scan);
1555                     regnode * const nnext = regnext(n);
1556
1557                     if (oldl + STR_LEN(n) > U8_MAX)
1558                         break;
1559                     NEXT_OFF(scan) += NEXT_OFF(n);
1560                     STR_LEN(scan) += STR_LEN(n);
1561                     next = n + NODE_SZ_STR(n);
1562                     /* Now we can overwrite *n : */
1563                     Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
1564 #ifdef DEBUGGING
1565                     stop = next - 1;
1566 #endif
1567                     n = nnext;
1568                 }
1569             }
1570
1571             if (UTF && ( OP(scan) == EXACTF ) && ( STR_LEN(scan) >= 6 ) ) {
1572 /*
1573   Two problematic code points in Unicode casefolding of EXACT nodes:
1574
1575    U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
1576    U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
1577
1578    which casefold to
1579
1580    Unicode                      UTF-8
1581
1582    U+03B9 U+0308 U+0301         0xCE 0xB9 0xCC 0x88 0xCC 0x81
1583    U+03C5 U+0308 U+0301         0xCF 0x85 0xCC 0x88 0xCC 0x81
1584
1585    This means that in case-insensitive matching (or "loose matching",
1586    as Unicode calls it), an EXACTF of length six (the UTF-8 encoded byte
1587    length of the above casefolded versions) can match a target string
1588    of length two (the byte length of UTF-8 encoded U+0390 or U+03B0).
1589    This would rather mess up the minimum length computation.
1590
1591    What we'll do is to look for the tail four bytes, and then peek
1592    at the preceding two bytes to see whether we need to decrease
1593    the minimum length by four (six minus two).
1594
1595    Thanks to the design of UTF-8, there cannot be false matches:
1596    A sequence of valid UTF-8 bytes cannot be a subsequence of
1597    another valid sequence of UTF-8 bytes.
1598
1599 */
1600                  char * const s0 = STRING(scan), *s, *t;
1601                  char * const s1 = s0 + STR_LEN(scan) - 1;
1602                  char * const s2 = s1 - 4;
1603                  const char t0[] = "\xcc\x88\xcc\x81";
1604                  const char * const t1 = t0 + 3;
1605
1606                  for (s = s0 + 2;
1607                       s < s2 && (t = ninstr(s, s1, t0, t1));
1608                       s = t + 4) {
1609                       if (((U8)t[-1] == 0xB9 && (U8)t[-2] == 0xCE) ||
1610                           ((U8)t[-1] == 0x85 && (U8)t[-2] == 0xCF))
1611                            min -= 4;
1612                  }
1613             }
1614
1615 #ifdef DEBUGGING
1616             /* Allow dumping */
1617             n = scan + NODE_SZ_STR(scan);
1618             while (n <= stop) {
1619                 if (PL_regkind[(U8)OP(n)] != NOTHING || OP(n) == NOTHING) {
1620                     OP(n) = OPTIMIZED;
1621                     NEXT_OFF(n) = 0;
1622                 }
1623                 n++;
1624             }
1625 #endif
1626         }
1627
1628
1629
1630         /* Follow the next-chain of the current node and optimize
1631            away all the NOTHINGs from it.  */
1632         if (OP(scan) != CURLYX) {
1633             const int max = (reg_off_by_arg[OP(scan)]
1634                        ? I32_MAX
1635                        /* I32 may be smaller than U16 on CRAYs! */
1636                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
1637             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
1638             int noff;
1639             regnode *n = scan;
1640         
1641             /* Skip NOTHING and LONGJMP. */
1642             while ((n = regnext(n))
1643                    && ((PL_regkind[(U8)OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
1644                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
1645                    && off + noff < max)
1646                 off += noff;
1647             if (reg_off_by_arg[OP(scan)])
1648                 ARG(scan) = off;
1649             else
1650                 NEXT_OFF(scan) = off;
1651         }
1652
1653         /* The principal pseudo-switch.  Cannot be a switch, since we
1654            look into several different things.  */
1655         if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
1656                    || OP(scan) == IFTHEN || OP(scan) == SUSPEND) {
1657             next = regnext(scan);
1658             code = OP(scan);
1659             /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
1660         
1661             if (OP(next) == code || code == IFTHEN || code == SUSPEND) {
1662                 I32 max1 = 0, min1 = I32_MAX, num = 0;
1663                 struct regnode_charclass_class accum;
1664                 regnode * const startbranch=scan;
1665                 
1666                 if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
1667                     scan_commit(pRExC_state, data); /* Cannot merge strings after this. */
1668                 if (flags & SCF_DO_STCLASS)
1669                     cl_init_zero(pRExC_state, &accum);
1670
1671                 while (OP(scan) == code) {
1672                     I32 deltanext, minnext, f = 0, fake;
1673                     struct regnode_charclass_class this_class;
1674
1675                     num++;
1676                     data_fake.flags = 0;
1677                     if (data) {         
1678                         data_fake.whilem_c = data->whilem_c;
1679                         data_fake.last_closep = data->last_closep;
1680                     }
1681                     else
1682                         data_fake.last_closep = &fake;
1683                     next = regnext(scan);
1684                     scan = NEXTOPER(scan);
1685                     if (code != BRANCH)
1686                         scan = NEXTOPER(scan);
1687                     if (flags & SCF_DO_STCLASS) {
1688                         cl_init(pRExC_state, &this_class);
1689                         data_fake.start_class = &this_class;
1690                         f = SCF_DO_STCLASS_AND;
1691                     }           
1692                     if (flags & SCF_WHILEM_VISITED_POS)
1693                         f |= SCF_WHILEM_VISITED_POS;
1694
1695                     /* we suppose the run is continuous, last=next...*/
1696                     minnext = study_chunk(pRExC_state, &scan, &deltanext,
1697                                           next, &data_fake, f,depth+1);
1698                     if (min1 > minnext)
1699                         min1 = minnext;
1700                     if (max1 < minnext + deltanext)
1701                         max1 = minnext + deltanext;
1702                     if (deltanext == I32_MAX)
1703                         is_inf = is_inf_internal = 1;
1704                     scan = next;
1705                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
1706                         pars++;
1707                     if (data && (data_fake.flags & SF_HAS_EVAL))
1708                         data->flags |= SF_HAS_EVAL;
1709                     if (data)
1710                         data->whilem_c = data_fake.whilem_c;
1711                     if (flags & SCF_DO_STCLASS)
1712                         cl_or(pRExC_state, &accum, &this_class);
1713                     if (code == SUSPEND)
1714                         break;
1715                 }
1716                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
1717                     min1 = 0;
1718                 if (flags & SCF_DO_SUBSTR) {
1719                     data->pos_min += min1;
1720                     data->pos_delta += max1 - min1;
1721                     if (max1 != min1 || is_inf)
1722                         data->longest = &(data->longest_float);
1723                 }
1724                 min += min1;
1725                 delta += max1 - min1;
1726                 if (flags & SCF_DO_STCLASS_OR) {
1727                     cl_or(pRExC_state, data->start_class, &accum);
1728                     if (min1) {
1729                         cl_and(data->start_class, &and_with);
1730                         flags &= ~SCF_DO_STCLASS;
1731                     }
1732                 }
1733                 else if (flags & SCF_DO_STCLASS_AND) {
1734                     if (min1) {
1735                         cl_and(data->start_class, &accum);
1736                         flags &= ~SCF_DO_STCLASS;
1737                     }
1738                     else {
1739                         /* Switch to OR mode: cache the old value of
1740                          * data->start_class */
1741                         StructCopy(data->start_class, &and_with,
1742                                    struct regnode_charclass_class);
1743                         flags &= ~SCF_DO_STCLASS_AND;
1744                         StructCopy(&accum, data->start_class,
1745                                    struct regnode_charclass_class);
1746                         flags |= SCF_DO_STCLASS_OR;
1747                         data->start_class->flags |= ANYOF_EOS;
1748                     }
1749                 }
1750
1751                 /* demq.
1752
1753                    Assuming this was/is a branch we are dealing with: 'scan' now
1754                    points at the item that follows the branch sequence, whatever
1755                    it is. We now start at the beginning of the sequence and look
1756                    for subsequences of
1757
1758                    BRANCH->EXACT=>X
1759                    BRANCH->EXACT=>X
1760
1761                    which would be constructed from a pattern like /A|LIST|OF|WORDS/
1762
1763                    If we can find such a subseqence we need to turn the first
1764                    element into a trie and then add the subsequent branch exact
1765                    strings to the trie.
1766
1767                    We have two cases
1768
1769                      1. patterns where the whole set of branch can be converted to a trie,
1770
1771                      2. patterns where only a subset of the alternations can be
1772                      converted to a trie.
1773
1774                    In case 1 we can replace the whole set with a single regop
1775                    for the trie. In case 2 we need to keep the start and end
1776                    branchs so
1777
1778                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
1779                      becomes BRANCH TRIE; BRANCH X;
1780
1781                    Hypthetically when we know the regex isnt anchored we can
1782                    turn a case 1 into a DFA and let it rip... Every time it finds a match
1783                    it would just call its tail, no WHILEM/CURLY needed.
1784
1785                 */
1786                 if (DO_TRIE) {
1787                     if (!re_trie_maxbuff) {
1788                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
1789                         if (!SvIOK(re_trie_maxbuff))
1790                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
1791                     }
1792                     if ( SvIV(re_trie_maxbuff)>=0 && OP( startbranch )==BRANCH ) {
1793                         regnode *cur;
1794                         regnode *first = (regnode *)NULL;
1795                         regnode *last = (regnode *)NULL;
1796                         regnode *tail = scan;
1797                         U8 optype = 0;
1798                         U32 count=0;
1799
1800 #ifdef DEBUGGING
1801                         SV * const mysv = sv_newmortal();       /* for dumping */
1802 #endif
1803                         /* var tail is used because there may be a TAIL
1804                            regop in the way. Ie, the exacts will point to the
1805                            thing following the TAIL, but the last branch will
1806                            point at the TAIL. So we advance tail. If we
1807                            have nested (?:) we may have to move through several
1808                            tails.
1809                          */
1810
1811                         while ( OP( tail ) == TAIL ) {
1812                             /* this is the TAIL generated by (?:) */
1813                             tail = regnext( tail );
1814                         }
1815
1816                         DEBUG_OPTIMISE_r({
1817                             regprop(RExC_rx, mysv, tail );
1818                             PerlIO_printf( Perl_debug_log, "%*s%s%s%s\n",
1819                                 (int)depth * 2 + 2, "", "Tail node is:", SvPV_nolen_const( mysv ),
1820                                 (RExC_seen_evals) ? "[EVAL]" : ""
1821                             );
1822                         });
1823                         /*
1824
1825                            step through the branches, cur represents each
1826                            branch, noper is the first thing to be matched
1827                            as part of that branch and noper_next is the
1828                            regnext() of that node. if noper is an EXACT
1829                            and noper_next is the same as scan (our current
1830                            position in the regex) then the EXACT branch is
1831                            a possible optimization target. Once we have
1832                            two or more consequetive such branches we can
1833                            create a trie of the EXACT's contents and stich
1834                            it in place. If the sequence represents all of
1835                            the branches we eliminate the whole thing and
1836                            replace it with a single TRIE. If it is a
1837                            subsequence then we need to stitch it in. This
1838                            means the first branch has to remain, and needs
1839                            to be repointed at the item on the branch chain
1840                            following the last branch optimized. This could
1841                            be either a BRANCH, in which case the
1842                            subsequence is internal, or it could be the
1843                            item following the branch sequence in which
1844                            case the subsequence is at the end.
1845
1846                         */
1847
1848                         /* dont use tail as the end marker for this traverse */
1849                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
1850                             regnode * const noper = NEXTOPER( cur );
1851                             regnode * const noper_next = regnext( noper );
1852
1853                             DEBUG_OPTIMISE_r({
1854                                 regprop(RExC_rx, mysv, cur);
1855                                 PerlIO_printf( Perl_debug_log, "%*s%s",
1856                                    (int)depth * 2 + 2,"  ", SvPV_nolen_const( mysv ) );
1857
1858                                 regprop(RExC_rx, mysv, noper);
1859                                 PerlIO_printf( Perl_debug_log, " -> %s",
1860                                     SvPV_nolen_const(mysv));
1861
1862                                 if ( noper_next ) {
1863                                   regprop(RExC_rx, mysv, noper_next );
1864                                   PerlIO_printf( Perl_debug_log,"\t=> %s\t",
1865                                     SvPV_nolen_const(mysv));
1866                                 }
1867                                 PerlIO_printf( Perl_debug_log, "0x%p,0x%p,0x%p)\n",
1868                                    (void*)first, (void*)last, (void*)cur );
1869                             });
1870                             if ( ( first ? OP( noper ) == optype
1871                                          : PL_regkind[ (U8)OP( noper ) ] == EXACT )
1872                                   && noper_next == tail && count<U16_MAX)
1873                             {
1874                                 count++;
1875                                 if ( !first ) {
1876                                     first = cur;
1877                                     optype = OP( noper );
1878                                 } else {
1879                                     DEBUG_OPTIMISE_r(
1880                                         if (!last ) {
1881                                             regprop(RExC_rx, mysv, first);
1882                                             PerlIO_printf( Perl_debug_log, "%*s%s",
1883                                               (int)depth * 2 + 2, "F:", SvPV_nolen_const( mysv ) );
1884                                             regprop(RExC_rx, mysv, NEXTOPER(first) );
1885                                             PerlIO_printf( Perl_debug_log, " -> %s\n",
1886                                               SvPV_nolen_const( mysv ) );
1887                                         }
1888                                     );
1889                                     last = cur;
1890                                     DEBUG_OPTIMISE_r({
1891                                         regprop(RExC_rx, mysv, cur);
1892                                         PerlIO_printf( Perl_debug_log, "%*s%s",
1893                                           (int)depth * 2 + 2, "N:", SvPV_nolen_const( mysv ) );
1894                                         regprop(RExC_rx, mysv, noper );
1895                                         PerlIO_printf( Perl_debug_log, " -> %s\n",
1896                                           SvPV_nolen_const( mysv ) );
1897                                     });
1898                                 }
1899                             } else {
1900                                 if ( last ) {
1901                                     DEBUG_OPTIMISE_r(
1902                                         PerlIO_printf( Perl_debug_log, "%*s%s\n",
1903                                             (int)depth * 2 + 2, "E:", "**END**" );
1904                                     );
1905                                     make_trie( pRExC_state, startbranch, first, cur, tail, optype );
1906                                 }
1907                                 if ( PL_regkind[ (U8)OP( noper ) ] == EXACT
1908                                      && noper_next == tail )
1909                                 {
1910                                     count = 1;
1911                                     first = cur;
1912                                     optype = OP( noper );
1913                                 } else {
1914                                     count = 0;
1915                                     first = NULL;
1916                                     optype = 0;
1917                                 }
1918                                 last = NULL;
1919                             }
1920                         }
1921                         DEBUG_OPTIMISE_r({
1922                             regprop(RExC_rx, mysv, cur);
1923                             PerlIO_printf( Perl_debug_log,
1924                               "%*s%s\t(0x%p,0x%p,0x%p)\n", (int)depth * 2 + 2,
1925                               "  ", SvPV_nolen_const( mysv ), (void*)first, (void*)last, (void*)cur);
1926
1927                         });
1928                         if ( last ) {
1929                             DEBUG_OPTIMISE_r(
1930                                 PerlIO_printf( Perl_debug_log, "%*s%s\n",
1931                                     (int)depth * 2 + 2, "E:", "==END==" );
1932                             );
1933                             make_trie( pRExC_state, startbranch, first, scan, tail, optype );
1934                         }
1935                     }
1936                 }
1937             }
1938             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
1939                 scan = NEXTOPER(NEXTOPER(scan));
1940             } else                      /* single branch is optimized. */
1941                 scan = NEXTOPER(scan);
1942             continue;
1943         }
1944         else if (OP(scan) == EXACT) {
1945             I32 l = STR_LEN(scan);
1946             UV uc;
1947             if (UTF) {
1948                 const U8 * const s = (U8*)STRING(scan);
1949                 l = utf8_length(s, s + l);
1950                 uc = utf8_to_uvchr(s, NULL);
1951             } else {
1952                 uc = *((U8*)STRING(scan));
1953             }
1954             min += l;
1955             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
1956                 /* The code below prefers earlier match for fixed
1957                    offset, later match for variable offset.  */
1958                 if (data->last_end == -1) { /* Update the start info. */
1959                     data->last_start_min = data->pos_min;
1960                     data->last_start_max = is_inf
1961                         ? I32_MAX : data->pos_min + data->pos_delta;
1962                 }
1963                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
1964                 if (UTF)
1965                     SvUTF8_on(data->last_found);
1966                 {
1967                     SV * const sv = data->last_found;
1968                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
1969                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
1970                     if (mg && mg->mg_len >= 0)
1971                         mg->mg_len += utf8_length((U8*)STRING(scan),
1972                                                   (U8*)STRING(scan)+STR_LEN(scan));
1973                 }
1974                 data->last_end = data->pos_min + l;
1975                 data->pos_min += l; /* As in the first entry. */
1976                 data->flags &= ~SF_BEFORE_EOL;
1977             }
1978             if (flags & SCF_DO_STCLASS_AND) {
1979                 /* Check whether it is compatible with what we know already! */
1980                 int compat = 1;
1981
1982                 if (uc >= 0x100 ||
1983                     (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
1984                     && !ANYOF_BITMAP_TEST(data->start_class, uc)
1985                     && (!(data->start_class->flags & ANYOF_FOLD)
1986                         || !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
1987                     )
1988                     compat = 0;
1989                 ANYOF_CLASS_ZERO(data->start_class);
1990                 ANYOF_BITMAP_ZERO(data->start_class);
1991                 if (compat)
1992                     ANYOF_BITMAP_SET(data->start_class, uc);
1993                 data->start_class->flags &= ~ANYOF_EOS;
1994                 if (uc < 0x100)
1995                   data->start_class->flags &= ~ANYOF_UNICODE_ALL;
1996             }
1997             else if (flags & SCF_DO_STCLASS_OR) {
1998                 /* false positive possible if the class is case-folded */
1999                 if (uc < 0x100)
2000                     ANYOF_BITMAP_SET(data->start_class, uc);
2001                 else
2002                     data->start_class->flags |= ANYOF_UNICODE_ALL;
2003                 data->start_class->flags &= ~ANYOF_EOS;
2004                 cl_and(data->start_class, &and_with);
2005             }
2006             flags &= ~SCF_DO_STCLASS;
2007         }
2008         else if (PL_regkind[(U8)OP(scan)] == EXACT) { /* But OP != EXACT! */
2009             I32 l = STR_LEN(scan);
2010             UV uc = *((U8*)STRING(scan));
2011
2012             /* Search for fixed substrings supports EXACT only. */
2013             if (flags & SCF_DO_SUBSTR) {
2014                 assert(data);
2015                 scan_commit(pRExC_state, data);
2016             }
2017             if (UTF) {
2018                 const U8 * const s = (U8 *)STRING(scan);
2019                 l = utf8_length(s, s + l);
2020                 uc = utf8_to_uvchr(s, NULL);
2021             }
2022             min += l;
2023             if (flags & SCF_DO_SUBSTR)
2024                 data->pos_min += l;
2025             if (flags & SCF_DO_STCLASS_AND) {
2026                 /* Check whether it is compatible with what we know already! */
2027                 int compat = 1;
2028
2029                 if (uc >= 0x100 ||
2030                     (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
2031                     && !ANYOF_BITMAP_TEST(data->start_class, uc)
2032                      && !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
2033                     compat = 0;
2034                 ANYOF_CLASS_ZERO(data->start_class);
2035                 ANYOF_BITMAP_ZERO(data->start_class);
2036                 if (compat) {
2037                     ANYOF_BITMAP_SET(data->start_class, uc);
2038                     data->start_class->flags &= ~ANYOF_EOS;
2039                     data->start_class->flags |= ANYOF_FOLD;
2040                     if (OP(scan) == EXACTFL)
2041                         data->start_class->flags |= ANYOF_LOCALE;
2042                 }
2043             }
2044             else if (flags & SCF_DO_STCLASS_OR) {
2045                 if (data->start_class->flags & ANYOF_FOLD) {
2046                     /* false positive possible if the class is case-folded.
2047                        Assume that the locale settings are the same... */
2048                     if (uc < 0x100)
2049                         ANYOF_BITMAP_SET(data->start_class, uc);
2050                     data->start_class->flags &= ~ANYOF_EOS;
2051                 }
2052                 cl_and(data->start_class, &and_with);
2053             }
2054             flags &= ~SCF_DO_STCLASS;
2055         }
2056         else if (strchr((const char*)PL_varies,OP(scan))) {
2057             I32 mincount, maxcount, minnext, deltanext, fl = 0;
2058             I32 f = flags, pos_before = 0;
2059             regnode * const oscan = scan;
2060             struct regnode_charclass_class this_class;
2061             struct regnode_charclass_class *oclass = NULL;
2062             I32 next_is_eval = 0;
2063
2064             switch (PL_regkind[(U8)OP(scan)]) {
2065             case WHILEM:                /* End of (?:...)* . */
2066                 scan = NEXTOPER(scan);
2067                 goto finish;
2068             case PLUS:
2069                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
2070                     next = NEXTOPER(scan);
2071                     if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
2072                         mincount = 1;
2073                         maxcount = REG_INFTY;
2074                         next = regnext(scan);
2075                         scan = NEXTOPER(scan);
2076                         goto do_curly;
2077                     }
2078                 }
2079                 if (flags & SCF_DO_SUBSTR)
2080                     data->pos_min++;
2081                 min++;
2082                 /* Fall through. */
2083             case STAR:
2084                 if (flags & SCF_DO_STCLASS) {
2085                     mincount = 0;
2086                     maxcount = REG_INFTY;
2087                     next = regnext(scan);
2088                     scan = NEXTOPER(scan);
2089                     goto do_curly;
2090                 }
2091                 is_inf = is_inf_internal = 1;
2092                 scan = regnext(scan);
2093                 if (flags & SCF_DO_SUBSTR) {
2094                     scan_commit(pRExC_state, data); /* Cannot extend fixed substrings */
2095                     data->longest = &(data->longest_float);
2096                 }
2097                 goto optimize_curly_tail;
2098             case CURLY:
2099                 mincount = ARG1(scan);
2100                 maxcount = ARG2(scan);
2101                 next = regnext(scan);
2102                 if (OP(scan) == CURLYX) {
2103                     I32 lp = (data ? *(data->last_closep) : 0);
2104                     scan->flags = ((lp <= U8_MAX) ? (U8)lp : U8_MAX);
2105                 }
2106                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
2107                 next_is_eval = (OP(scan) == EVAL);
2108               do_curly:
2109                 if (flags & SCF_DO_SUBSTR) {
2110                     if (mincount == 0) scan_commit(pRExC_state,data); /* Cannot extend fixed substrings */
2111                     pos_before = data->pos_min;
2112                 }
2113                 if (data) {
2114                     fl = data->flags;
2115                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
2116                     if (is_inf)
2117                         data->flags |= SF_IS_INF;
2118                 }
2119                 if (flags & SCF_DO_STCLASS) {
2120                     cl_init(pRExC_state, &this_class);
2121                     oclass = data->start_class;
2122                     data->start_class = &this_class;
2123                     f |= SCF_DO_STCLASS_AND;
2124                     f &= ~SCF_DO_STCLASS_OR;
2125                 }
2126                 /* These are the cases when once a subexpression
2127                    fails at a particular position, it cannot succeed
2128                    even after backtracking at the enclosing scope.
2129                 
2130                    XXXX what if minimal match and we are at the
2131                         initial run of {n,m}? */
2132                 if ((mincount != maxcount - 1) && (maxcount != REG_INFTY))
2133                     f &= ~SCF_WHILEM_VISITED_POS;
2134
2135                 /* This will finish on WHILEM, setting scan, or on NULL: */
2136                 minnext = study_chunk(pRExC_state, &scan, &deltanext, last, data,
2137                                       (mincount == 0
2138                                         ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
2139
2140                 if (flags & SCF_DO_STCLASS)
2141                     data->start_class = oclass;
2142                 if (mincount == 0 || minnext == 0) {
2143                     if (flags & SCF_DO_STCLASS_OR) {
2144                         cl_or(pRExC_state, data->start_class, &this_class);
2145                     }
2146                     else if (flags & SCF_DO_STCLASS_AND) {
2147                         /* Switch to OR mode: cache the old value of
2148                          * data->start_class */
2149                         StructCopy(data->start_class, &and_with,
2150                                    struct regnode_charclass_class);
2151                         flags &= ~SCF_DO_STCLASS_AND;
2152                         StructCopy(&this_class, data->start_class,
2153                                    struct regnode_charclass_class);
2154                         flags |= SCF_DO_STCLASS_OR;
2155                         data->start_class->flags |= ANYOF_EOS;
2156                     }
2157                 } else {                /* Non-zero len */
2158                     if (flags & SCF_DO_STCLASS_OR) {
2159                         cl_or(pRExC_state, data->start_class, &this_class);
2160                         cl_and(data->start_class, &and_with);
2161                     }
2162                     else if (flags & SCF_DO_STCLASS_AND)
2163                         cl_and(data->start_class, &this_class);
2164                     flags &= ~SCF_DO_STCLASS;
2165                 }
2166                 if (!scan)              /* It was not CURLYX, but CURLY. */
2167                     scan = next;
2168                 if ( /* ? quantifier ok, except for (?{ ... }) */
2169                     (next_is_eval || !(mincount == 0 && maxcount == 1))
2170                     && (minnext == 0) && (deltanext == 0)
2171                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
2172                     && maxcount <= REG_INFTY/3 /* Complement check for big count */
2173                     && ckWARN(WARN_REGEXP))
2174                 {
2175                     vWARN(RExC_parse,
2176                           "Quantifier unexpected on zero-length expression");
2177                 }
2178
2179                 min += minnext * mincount;
2180                 is_inf_internal |= ((maxcount == REG_INFTY
2181                                      && (minnext + deltanext) > 0)
2182                                     || deltanext == I32_MAX);
2183                 is_inf |= is_inf_internal;
2184                 delta += (minnext + deltanext) * maxcount - minnext * mincount;
2185
2186                 /* Try powerful optimization CURLYX => CURLYN. */
2187                 if (  OP(oscan) == CURLYX && data
2188                       && data->flags & SF_IN_PAR
2189                       && !(data->flags & SF_HAS_EVAL)
2190                       && !deltanext && minnext == 1 ) {
2191                     /* Try to optimize to CURLYN.  */
2192                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
2193                     regnode * const nxt1 = nxt;
2194 #ifdef DEBUGGING
2195                     regnode *nxt2;
2196 #endif
2197
2198                     /* Skip open. */
2199                     nxt = regnext(nxt);
2200                     if (!strchr((const char*)PL_simple,OP(nxt))
2201                         && !(PL_regkind[(U8)OP(nxt)] == EXACT
2202                              && STR_LEN(nxt) == 1))
2203                         goto nogo;
2204 #ifdef DEBUGGING
2205                     nxt2 = nxt;
2206 #endif
2207                     nxt = regnext(nxt);
2208                     if (OP(nxt) != CLOSE)
2209                         goto nogo;
2210                     /* Now we know that nxt2 is the only contents: */
2211                     oscan->flags = (U8)ARG(nxt);
2212                     OP(oscan) = CURLYN;
2213                     OP(nxt1) = NOTHING; /* was OPEN. */
2214 #ifdef DEBUGGING
2215                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
2216                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistancy. */
2217                     NEXT_OFF(nxt2) = 0; /* just for consistancy with CURLY. */
2218                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
2219                     OP(nxt + 1) = OPTIMIZED; /* was count. */
2220                     NEXT_OFF(nxt+ 1) = 0; /* just for consistancy. */
2221 #endif
2222                 }
2223               nogo:
2224
2225                 /* Try optimization CURLYX => CURLYM. */
2226                 if (  OP(oscan) == CURLYX && data
2227                       && !(data->flags & SF_HAS_PAR)
2228                       && !(data->flags & SF_HAS_EVAL)
2229                       && !deltanext     /* atom is fixed width */
2230                       && minnext != 0   /* CURLYM can't handle zero width */
2231                 ) {
2232                     /* XXXX How to optimize if data == 0? */
2233                     /* Optimize to a simpler form.  */
2234                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
2235                     regnode *nxt2;
2236
2237                     OP(oscan) = CURLYM;
2238                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
2239                             && (OP(nxt2) != WHILEM))
2240                         nxt = nxt2;
2241                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
2242                     /* Need to optimize away parenths. */
2243                     if (data->flags & SF_IN_PAR) {
2244                         /* Set the parenth number.  */
2245                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
2246
2247                         if (OP(nxt) != CLOSE)
2248                             FAIL("Panic opt close");
2249                         oscan->flags = (U8)ARG(nxt);
2250                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
2251                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
2252 #ifdef DEBUGGING
2253                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
2254                         OP(nxt + 1) = OPTIMIZED; /* was count. */
2255                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistancy. */
2256                         NEXT_OFF(nxt + 1) = 0; /* just for consistancy. */
2257 #endif
2258 #if 0
2259                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
2260                             regnode *nnxt = regnext(nxt1);
2261                         
2262                             if (nnxt == nxt) {
2263                                 if (reg_off_by_arg[OP(nxt1)])
2264                                     ARG_SET(nxt1, nxt2 - nxt1);
2265                                 else if (nxt2 - nxt1 < U16_MAX)
2266                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
2267                                 else
2268                                     OP(nxt) = NOTHING;  /* Cannot beautify */
2269                             }
2270                             nxt1 = nnxt;
2271                         }
2272 #endif
2273                         /* Optimize again: */
2274                         study_chunk(pRExC_state, &nxt1, &deltanext, nxt,
2275                                     NULL, 0,depth+1);
2276                     }
2277                     else
2278                         oscan->flags = 0;
2279                 }
2280                 else if ((OP(oscan) == CURLYX)
2281                          && (flags & SCF_WHILEM_VISITED_POS)
2282                          /* See the comment on a similar expression above.
2283                             However, this time it not a subexpression
2284                             we care about, but the expression itself. */
2285                          && (maxcount == REG_INFTY)
2286                          && data && ++data->whilem_c < 16) {
2287                     /* This stays as CURLYX, we can put the count/of pair. */
2288                     /* Find WHILEM (as in regexec.c) */
2289                     regnode *nxt = oscan + NEXT_OFF(oscan);
2290
2291                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
2292                         nxt += ARG(nxt);
2293                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
2294                         | (RExC_whilem_seen << 4)); /* On WHILEM */
2295                 }
2296                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
2297                     pars++;
2298                 if (flags & SCF_DO_SUBSTR) {
2299                     SV *last_str = NULL;
2300                     int counted = mincount != 0;
2301
2302                     if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
2303 #if defined(SPARC64_GCC_WORKAROUND)
2304                         I32 b = 0;
2305                         STRLEN l = 0;
2306                         const char *s = NULL;
2307                         I32 old = 0;
2308
2309                         if (pos_before >= data->last_start_min)
2310                             b = pos_before;
2311                         else
2312                             b = data->last_start_min;
2313
2314                         l = 0;
2315                         s = SvPV_const(data->last_found, l);
2316                         old = b - data->last_start_min;
2317
2318 #else
2319                         I32 b = pos_before >= data->last_start_min
2320                             ? pos_before : data->last_start_min;
2321                         STRLEN l;
2322                         const char * const s = SvPV_const(data->last_found, l);
2323                         I32 old = b - data->last_start_min;
2324 #endif
2325
2326                         if (UTF)
2327                             old = utf8_hop((U8*)s, old) - (U8*)s;
2328                         
2329                         l -= old;
2330                         /* Get the added string: */
2331                         last_str = newSVpvn(s  + old, l);
2332                         if (UTF)
2333                             SvUTF8_on(last_str);
2334                         if (deltanext == 0 && pos_before == b) {
2335                             /* What was added is a constant string */
2336                             if (mincount > 1) {
2337                                 SvGROW(last_str, (mincount * l) + 1);
2338                                 repeatcpy(SvPVX(last_str) + l,
2339                                           SvPVX_const(last_str), l, mincount - 1);
2340                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
2341                                 /* Add additional parts. */
2342                                 SvCUR_set(data->last_found,
2343                                           SvCUR(data->last_found) - l);
2344                                 sv_catsv(data->last_found, last_str);
2345                                 {
2346                                     SV * sv = data->last_found;
2347                                     MAGIC *mg =
2348                                         SvUTF8(sv) && SvMAGICAL(sv) ?
2349                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
2350                                     if (mg && mg->mg_len >= 0)
2351                                         mg->mg_len += CHR_SVLEN(last_str);
2352                                 }
2353                                 data->last_end += l * (mincount - 1);
2354                             }
2355                         } else {
2356                             /* start offset must point into the last copy */
2357                             data->last_start_min += minnext * (mincount - 1);
2358                             data->last_start_max += is_inf ? I32_MAX
2359                                 : (maxcount - 1) * (minnext + data->pos_delta);
2360                         }
2361                     }
2362                     /* It is counted once already... */
2363                     data->pos_min += minnext * (mincount - counted);
2364                     data->pos_delta += - counted * deltanext +
2365                         (minnext + deltanext) * maxcount - minnext * mincount;
2366                     if (mincount != maxcount) {
2367                          /* Cannot extend fixed substrings found inside
2368                             the group.  */
2369                         scan_commit(pRExC_state,data);
2370                         if (mincount && last_str) {
2371                             SV * const sv = data->last_found;
2372                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
2373                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
2374
2375                             if (mg)
2376                                 mg->mg_len = -1;
2377                             sv_setsv(sv, last_str);
2378                             data->last_end = data->pos_min;
2379                             data->last_start_min =
2380                                 data->pos_min - CHR_SVLEN(last_str);
2381                             data->last_start_max = is_inf
2382                                 ? I32_MAX
2383                                 : data->pos_min + data->pos_delta
2384                                 - CHR_SVLEN(last_str);
2385                         }
2386                         data->longest = &(data->longest_float);
2387                     }
2388                     SvREFCNT_dec(last_str);
2389                 }
2390                 if (data && (fl & SF_HAS_EVAL))
2391                     data->flags |= SF_HAS_EVAL;
2392               optimize_curly_tail:
2393                 if (OP(oscan) != CURLYX) {
2394                     while (PL_regkind[(U8)OP(next = regnext(oscan))] == NOTHING
2395                            && NEXT_OFF(next))
2396                         NEXT_OFF(oscan) += NEXT_OFF(next);
2397                 }
2398                 continue;
2399             default:                    /* REF and CLUMP only? */
2400                 if (flags & SCF_DO_SUBSTR) {
2401                     scan_commit(pRExC_state,data);      /* Cannot expect anything... */
2402                     data->longest = &(data->longest_float);
2403                 }
2404                 is_inf = is_inf_internal = 1;
2405                 if (flags & SCF_DO_STCLASS_OR)
2406                     cl_anything(pRExC_state, data->start_class);
2407                 flags &= ~SCF_DO_STCLASS;
2408                 break;
2409             }
2410         }
2411         else if (strchr((const char*)PL_simple,OP(scan))) {
2412             int value = 0;
2413
2414             if (flags & SCF_DO_SUBSTR) {
2415                 scan_commit(pRExC_state,data);
2416                 data->pos_min++;
2417             }
2418             min++;
2419             if (flags & SCF_DO_STCLASS) {
2420                 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
2421
2422                 /* Some of the logic below assumes that switching
2423                    locale on will only add false positives. */
2424                 switch (PL_regkind[(U8)OP(scan)]) {
2425                 case SANY:
2426                 default:
2427                   do_default:
2428                     /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
2429                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
2430                         cl_anything(pRExC_state, data->start_class);
2431                     break;
2432                 case REG_ANY:
2433                     if (OP(scan) == SANY)
2434                         goto do_default;
2435                     if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
2436                         value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
2437                                  || (data->start_class->flags & ANYOF_CLASS));
2438                         cl_anything(pRExC_state, data->start_class);
2439                     }
2440                     if (flags & SCF_DO_STCLASS_AND || !value)
2441                         ANYOF_BITMAP_CLEAR(data->start_class,'\n');
2442                     break;
2443                 case ANYOF:
2444                     if (flags & SCF_DO_STCLASS_AND)
2445                         cl_and(data->start_class,
2446                                (struct regnode_charclass_class*)scan);
2447                     else
2448                         cl_or(pRExC_state, data->start_class,
2449                               (struct regnode_charclass_class*)scan);
2450                     break;
2451                 case ALNUM:
2452                     if (flags & SCF_DO_STCLASS_AND) {
2453                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
2454                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
2455                             for (value = 0; value < 256; value++)
2456                                 if (!isALNUM(value))
2457                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
2458                         }
2459                     }
2460                     else {
2461                         if (data->start_class->flags & ANYOF_LOCALE)
2462                             ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
2463                         else {
2464                             for (value = 0; value < 256; value++)
2465                                 if (isALNUM(value))
2466                                     ANYOF_BITMAP_SET(data->start_class, value);                 
2467                         }
2468                     }
2469                     break;
2470                 case ALNUML:
2471                     if (flags & SCF_DO_STCLASS_AND) {
2472                         if (data->start_class->flags & ANYOF_LOCALE)
2473                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
2474                     }
2475                     else {
2476                         ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
2477                         data->start_class->flags |= ANYOF_LOCALE;
2478                     }
2479                     break;
2480                 case NALNUM:
2481                     if (flags & SCF_DO_STCLASS_AND) {
2482                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
2483                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
2484                             for (value = 0; value < 256; value++)
2485                                 if (isALNUM(value))
2486                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
2487                         }
2488                     }
2489                     else {
2490                         if (data->start_class->flags & ANYOF_LOCALE)
2491                             ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
2492                         else {
2493                             for (value = 0; value < 256; value++)
2494                                 if (!isALNUM(value))
2495                                     ANYOF_BITMAP_SET(data->start_class, value);                 
2496                         }
2497                     }
2498                     break;
2499                 case NALNUML:
2500                     if (flags & SCF_DO_STCLASS_AND) {
2501                         if (data->start_class->flags & ANYOF_LOCALE)
2502                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
2503                     }
2504                     else {
2505                         data->start_class->flags |= ANYOF_LOCALE;
2506                         ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
2507                     }
2508                     break;
2509                 case SPACE:
2510                     if (flags & SCF_DO_STCLASS_AND) {
2511                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
2512                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
2513                             for (value = 0; value < 256; value++)
2514                                 if (!isSPACE(value))
2515                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
2516                         }
2517                     }
2518                     else {
2519                         if (data->start_class->flags & ANYOF_LOCALE)
2520                             ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
2521                         else {
2522                             for (value = 0; value < 256; value++)
2523                                 if (isSPACE(value))
2524                                     ANYOF_BITMAP_SET(data->start_class, value);                 
2525                         }
2526                     }
2527                     break;
2528                 case SPACEL:
2529                     if (flags & SCF_DO_STCLASS_AND) {
2530                         if (data->start_class->flags & ANYOF_LOCALE)
2531                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
2532                     }
2533                     else {
2534                         data->start_class->flags |= ANYOF_LOCALE;
2535                         ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
2536                     }
2537                     break;
2538                 case NSPACE:
2539                     if (flags & SCF_DO_STCLASS_AND) {
2540                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
2541                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
2542                             for (value = 0; value < 256; value++)
2543                                 if (isSPACE(value))
2544                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
2545                         }
2546                     }
2547                     else {
2548                         if (data->start_class->flags & ANYOF_LOCALE)
2549                             ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
2550                         else {
2551                             for (value = 0; value < 256; value++)
2552                                 if (!isSPACE(value))
2553                                     ANYOF_BITMAP_SET(data->start_class, value);                 
2554                         }
2555                     }
2556                     break;
2557                 case NSPACEL:
2558                     if (flags & SCF_DO_STCLASS_AND) {
2559                         if (data->start_class->flags & ANYOF_LOCALE) {
2560                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
2561                             for (value = 0; value < 256; value++)
2562                                 if (!isSPACE(value))
2563                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
2564                         }
2565                     }
2566                     else {
2567                         data->start_class->flags |= ANYOF_LOCALE;
2568                         ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
2569                     }
2570                     break;
2571                 case DIGIT:
2572                     if (flags & SCF_DO_STCLASS_AND) {
2573                         ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
2574                         for (value = 0; value < 256; value++)
2575                             if (!isDIGIT(value))
2576                                 ANYOF_BITMAP_CLEAR(data->start_class, value);
2577                     }
2578                     else {
2579                         if (data->start_class->flags & ANYOF_LOCALE)
2580                             ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
2581                         else {
2582                             for (value = 0; value < 256; value++)
2583                                 if (isDIGIT(value))
2584                                     ANYOF_BITMAP_SET(data->start_class, value);                 
2585                         }
2586                     }
2587                     break;
2588                 case NDIGIT:
2589                     if (flags & SCF_DO_STCLASS_AND) {
2590                         ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
2591                         for (value = 0; value < 256; value++)
2592                             if (isDIGIT(value))
2593                                 ANYOF_BITMAP_CLEAR(data->start_class, value);
2594                     }
2595                     else {
2596                         if (data->start_class->flags & ANYOF_LOCALE)
2597                             ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
2598                         else {
2599                             for (value = 0; value < 256; value++)
2600                                 if (!isDIGIT(value))
2601                                     ANYOF_BITMAP_SET(data->start_class, value);                 
2602                         }
2603                     }
2604                     break;
2605                 }
2606                 if (flags & SCF_DO_STCLASS_OR)
2607                     cl_and(data->start_class, &and_with);
2608                 flags &= ~SCF_DO_STCLASS;
2609             }
2610         }
2611         else if (PL_regkind[(U8)OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
2612             data->flags |= (OP(scan) == MEOL
2613                             ? SF_BEFORE_MEOL
2614                             : SF_BEFORE_SEOL);
2615         }
2616         else if (  PL_regkind[(U8)OP(scan)] == BRANCHJ
2617                  /* Lookbehind, or need to calculate parens/evals/stclass: */
2618                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
2619                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
2620             /* Lookahead/lookbehind */
2621             I32 deltanext, minnext, fake = 0;
2622             regnode *nscan;
2623             struct regnode_charclass_class intrnl;
2624             int f = 0;
2625
2626             data_fake.flags = 0;
2627             if (data) {         
2628                 data_fake.whilem_c = data->whilem_c;
2629                 data_fake.last_closep = data->last_closep;
2630             }
2631             else
2632                 data_fake.last_closep = &fake;
2633             if ( flags & SCF_DO_STCLASS && !scan->flags
2634                  && OP(scan) == IFMATCH ) { /* Lookahead */
2635                 cl_init(pRExC_state, &intrnl);
2636                 data_fake.start_class = &intrnl;
2637                 f |= SCF_DO_STCLASS_AND;
2638             }
2639             if (flags & SCF_WHILEM_VISITED_POS)
2640                 f |= SCF_WHILEM_VISITED_POS;
2641             next = regnext(scan);
2642             nscan = NEXTOPER(NEXTOPER(scan));
2643             minnext = study_chunk(pRExC_state, &nscan, &deltanext, last, &data_fake, f,depth+1);
2644             if (scan->flags) {
2645                 if (deltanext) {
2646                     vFAIL("Variable length lookbehind not implemented");
2647                 }
2648                 else if (minnext > U8_MAX) {
2649                     vFAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
2650                 }
2651                 scan->flags = (U8)minnext;
2652             }
2653             if (data && data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
2654                 pars++;
2655             if (data && (data_fake.flags & SF_HAS_EVAL))
2656                 data->flags |= SF_HAS_EVAL;
2657             if (data)
2658                 data->whilem_c = data_fake.whilem_c;
2659             if (f & SCF_DO_STCLASS_AND) {
2660                 const int was = (data->start_class->flags & ANYOF_EOS);
2661
2662                 cl_and(data->start_class, &intrnl);
2663                 if (was)
2664                     data->start_class->flags |= ANYOF_EOS;
2665             }
2666         }
2667         else if (OP(scan) == OPEN) {
2668             pars++;
2669         }
2670         else if (OP(scan) == CLOSE) {
2671             if ((I32)ARG(scan) == is_par) {
2672                 next = regnext(scan);
2673
2674                 if ( next && (OP(next) != WHILEM) && next < last)
2675                     is_par = 0;         /* Disable optimization */
2676             }
2677             if (data)
2678                 *(data->last_closep) = ARG(scan);
2679         }
2680         else if (OP(scan) == EVAL) {
2681                 if (data)
2682                     data->flags |= SF_HAS_EVAL;
2683         }
2684         else if (OP(scan) == LOGICAL && scan->flags == 2) { /* Embedded follows */
2685                 if (flags & SCF_DO_SUBSTR) {
2686                     scan_commit(pRExC_state,data);
2687                     data->longest = &(data->longest_float);
2688                 }
2689                 is_inf = is_inf_internal = 1;
2690                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
2691                     cl_anything(pRExC_state, data->start_class);
2692                 flags &= ~SCF_DO_STCLASS;
2693         }
2694         /* Else: zero-length, ignore. */
2695         scan = regnext(scan);
2696     }
2697
2698   finish:
2699     *scanp = scan;
2700     *deltap = is_inf_internal ? I32_MAX : delta;
2701     if (flags & SCF_DO_SUBSTR && is_inf)
2702         data->pos_delta = I32_MAX - data->pos_min;
2703     if (is_par > U8_MAX)
2704         is_par = 0;
2705     if (is_par && pars==1 && data) {
2706         data->flags |= SF_IN_PAR;
2707         data->flags &= ~SF_HAS_PAR;
2708     }
2709     else if (pars && data) {
2710         data->flags |= SF_HAS_PAR;
2711         data->flags &= ~SF_IN_PAR;
2712     }
2713     if (flags & SCF_DO_STCLASS_OR)
2714         cl_and(data->start_class, &and_with);
2715     return min;
2716 }
2717
2718 STATIC I32
2719 S_add_data(RExC_state_t *pRExC_state, I32 n, const char *s)
2720 {
2721     if (RExC_rx->data) {
2722         Renewc(RExC_rx->data,
2723                sizeof(*RExC_rx->data) + sizeof(void*) * (RExC_rx->data->count + n - 1),
2724                char, struct reg_data);
2725         Renew(RExC_rx->data->what, RExC_rx->data->count + n, U8);
2726         RExC_rx->data->count += n;
2727     }
2728     else {
2729         Newxc(RExC_rx->data, sizeof(*RExC_rx->data) + sizeof(void*) * (n - 1),
2730              char, struct reg_data);
2731         Newx(RExC_rx->data->what, n, U8);
2732         RExC_rx->data->count = n;
2733     }
2734     Copy(s, RExC_rx->data->what + RExC_rx->data->count - n, n, U8);
2735     return RExC_rx->data->count - n;
2736 }
2737
2738 #ifndef PERL_IN_XSUB_RE
2739 void
2740 Perl_reginitcolors(pTHX)
2741 {
2742     dVAR;
2743     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
2744     if (s) {
2745         char *t = savepv(s);
2746         int i = 0;
2747         PL_colors[0] = t;
2748         while (++i < 6) {
2749             t = strchr(t, '\t');
2750             if (t) {
2751                 *t = '\0';
2752                 PL_colors[i] = ++t;
2753             }
2754             else
2755                 PL_colors[i] = t = (char *)"";
2756         }
2757     } else {
2758         int i = 0;
2759         while (i < 6)
2760             PL_colors[i++] = (char *)"";
2761     }
2762     PL_colorset = 1;
2763 }
2764 #endif
2765
2766 /*
2767  - pregcomp - compile a regular expression into internal code
2768  *
2769  * We can't allocate space until we know how big the compiled form will be,
2770  * but we can't compile it (and thus know how big it is) until we've got a
2771  * place to put the code.  So we cheat:  we compile it twice, once with code
2772  * generation turned off and size counting turned on, and once "for real".
2773  * This also means that we don't allocate space until we are sure that the
2774  * thing really will compile successfully, and we never have to move the
2775  * code and thus invalidate pointers into it.  (Note that it has to be in
2776  * one piece because free() must be able to free it all.) [NB: not true in perl]
2777  *
2778  * Beware that the optimization-preparation code in here knows about some
2779  * of the structure of the compiled regexp.  [I'll say.]
2780  */
2781 regexp *
2782 Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
2783 {
2784     dVAR;
2785     register regexp *r;
2786     regnode *scan;
2787     regnode *first;
2788     I32 flags;
2789     I32 minlen = 0;
2790     I32 sawplus = 0;
2791     I32 sawopen = 0;
2792     scan_data_t data;
2793     RExC_state_t RExC_state;
2794     RExC_state_t *pRExC_state = &RExC_state;
2795
2796     GET_RE_DEBUG_FLAGS_DECL;
2797
2798     if (exp == NULL)
2799         FAIL("NULL regexp argument");
2800
2801     RExC_utf8 = pm->op_pmdynflags & PMdf_CMP_UTF8;
2802
2803     RExC_precomp = exp;
2804     DEBUG_r(if (!PL_colorset) reginitcolors());
2805     DEBUG_COMPILE_r({
2806          PerlIO_printf(Perl_debug_log, "%sCompiling REx%s \"%s%*s%s\"\n",
2807                        PL_colors[4],PL_colors[5],PL_colors[0],
2808                        (int)(xend - exp), RExC_precomp, PL_colors[1]);
2809     });
2810     RExC_flags = pm->op_pmflags;
2811     RExC_sawback = 0;
2812
2813     RExC_seen = 0;
2814     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
2815     RExC_seen_evals = 0;
2816     RExC_extralen = 0;
2817
2818     /* First pass: determine size, legality. */
2819     RExC_parse = exp;
2820     RExC_start = exp;
2821     RExC_end = xend;
2822     RExC_naughty = 0;
2823     RExC_npar = 1;
2824     RExC_size = 0L;
2825     RExC_emit = &PL_regdummy;
2826     RExC_whilem_seen = 0;
2827 #if 0 /* REGC() is (currently) a NOP at the first pass.
2828        * Clever compilers notice this and complain. --jhi */
2829     REGC((U8)REG_MAGIC, (char*)RExC_emit);
2830 #endif
2831     if (reg(pRExC_state, 0, &flags) == NULL) {
2832         RExC_precomp = NULL;
2833         return(NULL);
2834     }
2835     DEBUG_COMPILE_r(PerlIO_printf(Perl_debug_log, "size %"IVdf" ", (IV)RExC_size));
2836
2837     /* Small enough for pointer-storage convention?
2838        If extralen==0, this means that we will not need long jumps. */
2839     if (RExC_size >= 0x10000L && RExC_extralen)
2840         RExC_size += RExC_extralen;
2841     else
2842         RExC_extralen = 0;
2843     if (RExC_whilem_seen > 15)
2844         RExC_whilem_seen = 15;
2845
2846     /* Allocate space and initialize. */
2847     Newxc(r, sizeof(regexp) + (unsigned)RExC_size * sizeof(regnode),
2848          char, regexp);
2849     if (r == NULL)
2850         FAIL("Regexp out of space");
2851
2852 #ifdef DEBUGGING
2853     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
2854     Zero(r, sizeof(regexp) + (unsigned)RExC_size * sizeof(regnode), char);
2855 #endif
2856     r->refcnt = 1;
2857     r->prelen = xend - exp;
2858     r->precomp = savepvn(RExC_precomp, r->prelen);
2859     r->subbeg = NULL;
2860 #ifdef PERL_OLD_COPY_ON_WRITE
2861     r->saved_copy = NULL;
2862 #endif
2863     r->reganch = pm->op_pmflags & PMf_COMPILETIME;
2864     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
2865     r->lastparen = 0;                   /* mg.c reads this.  */
2866
2867     r->substrs = 0;                     /* Useful during FAIL. */
2868     r->startp = 0;                      /* Useful during FAIL. */
2869     r->endp = 0;                        /* Useful during FAIL. */
2870
2871     Newxz(r->offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
2872     if (r->offsets) {
2873         r->offsets[0] = RExC_size;
2874     }
2875     DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
2876                           "%s %"UVuf" bytes for offset annotations.\n",
2877                           r->offsets ? "Got" : "Couldn't get",
2878                           (UV)((2*RExC_size+1) * sizeof(U32))));
2879
2880     RExC_rx = r;
2881
2882     /* Second pass: emit code. */
2883     RExC_flags = pm->op_pmflags;        /* don't let top level (?i) bleed */
2884     RExC_parse = exp;
2885     RExC_end = xend;
2886     RExC_naughty = 0;
2887     RExC_npar = 1;
2888     RExC_emit_start = r->program;
2889     RExC_emit = r->program;
2890     /* Store the count of eval-groups for security checks: */
2891     RExC_emit->next_off = (U16)((RExC_seen_evals > U16_MAX) ? U16_MAX : RExC_seen_evals);
2892     REGC((U8)REG_MAGIC, (char*) RExC_emit++);
2893     r->data = 0;
2894     if (reg(pRExC_state, 0, &flags) == NULL)
2895         return(NULL);
2896
2897
2898     /* Dig out information for optimizations. */
2899     r->reganch = pm->op_pmflags & PMf_COMPILETIME; /* Again? */
2900     pm->op_pmflags = RExC_flags;
2901     if (UTF)
2902         r->reganch |= ROPT_UTF8;        /* Unicode in it? */
2903     r->regstclass = NULL;
2904     if (RExC_naughty >= 10)     /* Probably an expensive pattern. */
2905         r->reganch |= ROPT_NAUGHTY;
2906     scan = r->program + 1;              /* First BRANCH. */
2907
2908     /* XXXX To minimize changes to RE engine we always allocate
2909        3-units-long substrs field. */
2910     Newxz(r->substrs, 1, struct reg_substr_data);
2911
2912     StructCopy(&zero_scan_data, &data, scan_data_t);
2913     /* XXXX Should not we check for something else?  Usually it is OPEN1... */
2914     if (OP(scan) != BRANCH) {   /* Only one top-level choice. */
2915         I32 fake;
2916         STRLEN longest_float_length, longest_fixed_length;
2917         struct regnode_charclass_class ch_class;
2918         int stclass_flag;
2919         I32 last_close = 0;
2920
2921         first = scan;
2922         /* Skip introductions and multiplicators >= 1. */
2923         while ((OP(first) == OPEN && (sawopen = 1)) ||
2924                /* An OR of *one* alternative - should not happen now. */
2925             (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) ||
2926             (OP(first) == PLUS) ||
2927             (OP(first) == MINMOD) ||
2928                /* An {n,m} with n>0 */
2929             (PL_regkind[(U8)OP(first)] == CURLY && ARG1(first) > 0) ) {
2930                 if (OP(first) == PLUS)
2931                     sawplus = 1;
2932                 else
2933                     first += regarglen[(U8)OP(first)];
2934                 first = NEXTOPER(first);
2935         }
2936
2937         /* Starting-point info. */
2938       again:
2939         if (PL_regkind[(U8)OP(first)] == EXACT) {
2940             if (OP(first) == EXACT)
2941                 NOOP;   /* Empty, get anchored substr later. */
2942             else if ((OP(first) == EXACTF || OP(first) == EXACTFL))
2943                 r->regstclass = first;
2944         }
2945         else if (strchr((const char*)PL_simple,OP(first)))
2946             r->regstclass = first;
2947         else if (PL_regkind[(U8)OP(first)] == BOUND ||
2948                  PL_regkind[(U8)OP(first)] == NBOUND)
2949             r->regstclass = first;
2950         else if (PL_regkind[(U8)OP(first)] == BOL) {
2951             r->reganch |= (OP(first) == MBOL
2952                            ? ROPT_ANCH_MBOL
2953                            : (OP(first) == SBOL
2954                               ? ROPT_ANCH_SBOL
2955                               : ROPT_ANCH_BOL));
2956             first = NEXTOPER(first);
2957             goto again;
2958         }
2959         else if (OP(first) == GPOS) {
2960             r->reganch |= ROPT_ANCH_GPOS;
2961             first = NEXTOPER(first);
2962             goto again;
2963         }
2964         else if (!sawopen && (OP(first) == STAR &&
2965             PL_regkind[(U8)OP(NEXTOPER(first))] == REG_ANY) &&
2966             !(r->reganch & ROPT_ANCH) )
2967         {
2968             /* turn .* into ^.* with an implied $*=1 */
2969             const int type =
2970                 (OP(NEXTOPER(first)) == REG_ANY)
2971                     ? ROPT_ANCH_MBOL
2972                     : ROPT_ANCH_SBOL;
2973             r->reganch |= type | ROPT_IMPLICIT;
2974             first = NEXTOPER(first);
2975             goto again;
2976         }
2977         if (sawplus && (!sawopen || !RExC_sawback)
2978             && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
2979             /* x+ must match at the 1st pos of run of x's */
2980             r->reganch |= ROPT_SKIP;
2981
2982         /* Scan is after the zeroth branch, first is atomic matcher. */
2983         DEBUG_COMPILE_r(PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
2984                               (IV)(first - scan + 1)));
2985         /*
2986         * If there's something expensive in the r.e., find the
2987         * longest literal string that must appear and make it the
2988         * regmust.  Resolve ties in favor of later strings, since
2989         * the regstart check works with the beginning of the r.e.
2990         * and avoiding duplication strengthens checking.  Not a
2991         * strong reason, but sufficient in the absence of others.
2992         * [Now we resolve ties in favor of the earlier string if
2993         * it happens that c_offset_min has been invalidated, since the
2994         * earlier string may buy us something the later one won't.]
2995         */
2996         minlen = 0;
2997
2998         data.longest_fixed = newSVpvs("");
2999         data.longest_float = newSVpvs("");
3000         data.last_found = newSVpvs("");
3001         data.longest = &(data.longest_fixed);
3002         first = scan;
3003         if (!r->regstclass) {
3004             cl_init(pRExC_state, &ch_class);
3005             data.start_class = &ch_class;
3006             stclass_flag = SCF_DO_STCLASS_AND;
3007         } else                          /* XXXX Check for BOUND? */
3008             stclass_flag = 0;
3009         data.last_closep = &last_close;
3010
3011         minlen = study_chunk(pRExC_state, &first, &fake, scan + RExC_size, /* Up to end */
3012                              &data, SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
3013         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
3014              && data.last_start_min == 0 && data.last_end > 0
3015              && !RExC_seen_zerolen
3016              && (!(RExC_seen & REG_SEEN_GPOS) || (r->reganch & ROPT_ANCH_GPOS)))
3017             r->reganch |= ROPT_CHECK_ALL;
3018         scan_commit(pRExC_state, &data);
3019         SvREFCNT_dec(data.last_found);
3020
3021         longest_float_length = CHR_SVLEN(data.longest_float);
3022         if (longest_float_length
3023             || (data.flags & SF_FL_BEFORE_EOL
3024                 && (!(data.flags & SF_FL_BEFORE_MEOL)
3025                     || (RExC_flags & PMf_MULTILINE)))) {
3026             int t;
3027
3028             if (SvCUR(data.longest_fixed)                       /* ok to leave SvCUR */
3029                 && data.offset_fixed == data.offset_float_min
3030                 && SvCUR(data.longest_fixed) == SvCUR(data.longest_float))
3031                     goto remove_float;          /* As in (a)+. */
3032
3033             if (SvUTF8(data.longest_float)) {
3034                 r->float_utf8 = data.longest_float;
3035                 r->float_substr = NULL;
3036             } else {
3037                 r->float_substr = data.longest_float;
3038                 r->float_utf8 = NULL;
3039             }
3040             r->float_min_offset = data.offset_float_min;
3041             r->float_max_offset = data.offset_float_max;
3042             t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
3043                        && (!(data.flags & SF_FL_BEFORE_MEOL)
3044                            || (RExC_flags & PMf_MULTILINE)));
3045             fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0);
3046         }
3047         else {
3048           remove_float:
3049             r->float_substr = r->float_utf8 = NULL;
3050             SvREFCNT_dec(data.longest_float);
3051             longest_float_length = 0;
3052         }
3053
3054         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
3055         if (longest_fixed_length
3056             || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
3057                 && (!(data.flags & SF_FIX_BEFORE_MEOL)
3058                     || (RExC_flags & PMf_MULTILINE)))) {
3059             int t;
3060
3061             if (SvUTF8(data.longest_fixed)) {
3062                 r->anchored_utf8 = data.longest_fixed;
3063                 r->anchored_substr = NULL;
3064             } else {
3065                 r->anchored_substr = data.longest_fixed;
3066                 r->anchored_utf8 = NULL;
3067             }
3068             r->anchored_offset = data.offset_fixed;
3069             t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
3070                  && (!(data.flags & SF_FIX_BEFORE_MEOL)
3071                      || (RExC_flags & PMf_MULTILINE)));
3072             fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0);
3073         }
3074         else {
3075             r->anchored_substr = r->anchored_utf8 = NULL;
3076             SvREFCNT_dec(data.longest_fixed);
3077             longest_fixed_length = 0;
3078         }
3079         if (r->regstclass
3080             && (OP(r->regstclass) == REG_ANY || OP(r->regstclass) == SANY))
3081             r->regstclass = NULL;
3082         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
3083             && stclass_flag
3084             && !(data.start_class->flags & ANYOF_EOS)
3085             && !cl_is_anything(data.start_class))
3086         {
3087             const I32 n = add_data(pRExC_state, 1, "f");
3088
3089             Newx(RExC_rx->data->data[n], 1,
3090                 struct regnode_charclass_class);
3091             StructCopy(data.start_class,
3092                        (struct regnode_charclass_class*)RExC_rx->data->data[n],
3093                        struct regnode_charclass_class);
3094             r->regstclass = (regnode*)RExC_rx->data->data[n];
3095             r->reganch &= ~ROPT_SKIP;   /* Used in find_byclass(). */
3096             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
3097                       regprop(r, sv, (regnode*)data.start_class);
3098                       PerlIO_printf(Perl_debug_log,
3099                                     "synthetic stclass \"%s\".\n",
3100                                     SvPVX_const(sv));});
3101         }
3102
3103         /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
3104         if (longest_fixed_length > longest_float_length) {
3105             r->check_substr = r->anchored_substr;
3106             r->check_utf8 = r->anchored_utf8;
3107             r->check_offset_min = r->check_offset_max = r->anchored_offset;
3108             if (r->reganch & ROPT_ANCH_SINGLE)
3109                 r->reganch |= ROPT_NOSCAN;
3110         }
3111         else {
3112             r->check_substr = r->float_substr;
3113             r->check_utf8 = r->float_utf8;
3114             r->check_offset_min = data.offset_float_min;
3115             r->check_offset_max = data.offset_float_max;
3116         }
3117         /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
3118            This should be changed ASAP!  */
3119         if ((r->check_substr || r->check_utf8) && !(r->reganch & ROPT_ANCH_GPOS)) {
3120             r->reganch |= RE_USE_INTUIT;
3121             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
3122                 r->reganch |= RE_INTUIT_TAIL;
3123         }
3124     }
3125     else {
3126         /* Several toplevels. Best we can is to set minlen. */
3127         I32 fake;
3128         struct regnode_charclass_class ch_class;
3129         I32 last_close = 0;
3130         
3131         DEBUG_COMPILE_r(PerlIO_printf(Perl_debug_log, "\n"));
3132         scan = r->program + 1;
3133         cl_init(pRExC_state, &ch_class);
3134         data.start_class = &ch_class;
3135         data.last_closep = &last_close;
3136         minlen = study_chunk(pRExC_state, &scan, &fake, scan + RExC_size, &data, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
3137         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
3138                 = r->float_substr = r->float_utf8 = NULL;
3139         if (!(data.start_class->flags & ANYOF_EOS)
3140             && !cl_is_anything(data.start_class))
3141         {
3142             const I32 n = add_data(pRExC_state, 1, "f");
3143
3144             Newx(RExC_rx->data->data[n], 1,
3145                 struct regnode_charclass_class);
3146             StructCopy(data.start_class,
3147                        (struct regnode_charclass_class*)RExC_rx->data->data[n],
3148                        struct regnode_charclass_class);
3149             r->regstclass = (regnode*)RExC_rx->data->data[n];
3150             r->reganch &= ~ROPT_SKIP;   /* Used in find_byclass(). */
3151             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
3152                       regprop(r, sv, (regnode*)data.start_class);
3153                       PerlIO_printf(Perl_debug_log,
3154                                     "synthetic stclass \"%s\".\n",
3155                                     SvPVX_const(sv));});
3156         }
3157     }
3158
3159     r->minlen = minlen;
3160     if (RExC_seen & REG_SEEN_GPOS)
3161         r->reganch |= ROPT_GPOS_SEEN;
3162     if (RExC_seen & REG_SEEN_LOOKBEHIND)
3163         r->reganch |= ROPT_LOOKBEHIND_SEEN;
3164     if (RExC_seen & REG_SEEN_EVAL)
3165         r->reganch |= ROPT_EVAL_SEEN;
3166     if (RExC_seen & REG_SEEN_CANY)
3167         r->reganch |= ROPT_CANY_SEEN;
3168     Newxz(r->startp, RExC_npar, I32);
3169     Newxz(r->endp, RExC_npar, I32);
3170     DEBUG_COMPILE_r(regdump(r));
3171     return(r);
3172 }
3173
3174 /*
3175  - reg - regular expression, i.e. main body or parenthesized thing
3176  *
3177  * Caller must absorb opening parenthesis.
3178  *
3179  * Combining parenthesis handling with the base level of regular expression
3180  * is a trifle forced, but the need to tie the tails of the branches to what
3181  * follows makes it hard to avoid.
3182  */
3183 STATIC regnode *
3184 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp)
3185     /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
3186 {
3187     dVAR;
3188     register regnode *ret;              /* Will be the head of the group. */
3189     register regnode *br;
3190     register regnode *lastbr;
3191     register regnode *ender = NULL;
3192     register I32 parno = 0;
3193     I32 flags;
3194     const I32 oregflags = RExC_flags;
3195     bool have_branch = 0;
3196     bool is_open = 0;
3197
3198     /* for (?g), (?gc), and (?o) warnings; warning
3199        about (?c) will warn about (?g) -- japhy    */
3200
3201 #define WASTED_O  0x01
3202 #define WASTED_G  0x02
3203 #define WASTED_C  0x04
3204 #define WASTED_GC (0x02|0x04)
3205     I32 wastedflags = 0x00;
3206
3207     char * parse_start = RExC_parse; /* MJD */
3208     char * const oregcomp_parse = RExC_parse;
3209
3210     *flagp = 0;                         /* Tentatively. */
3211
3212
3213     /* Make an OPEN node, if parenthesized. */
3214     if (paren) {
3215         if (*RExC_parse == '?') { /* (?...) */
3216             U32 posflags = 0, negflags = 0;
3217             U32 *flagsp = &posflags;
3218             bool is_logical = 0;
3219             const char * const seqstart = RExC_parse;
3220
3221             RExC_parse++;
3222             paren = *RExC_parse++;
3223             ret = NULL;                 /* For look-ahead/behind. */
3224             switch (paren) {
3225             case '<':           /* (?<...) */
3226                 RExC_seen |= REG_SEEN_LOOKBEHIND;
3227                 if (*RExC_parse == '!')
3228                     paren = ',';
3229                 if (*RExC_parse != '=' && *RExC_parse != '!')
3230                     goto unknown;
3231                 RExC_parse++;
3232             case '=':           /* (?=...) */
3233             case '!':           /* (?!...) */
3234                 RExC_seen_zerolen++;
3235             case ':':           /* (?:...) */
3236             case '>':           /* (?>...) */
3237                 break;
3238             case '$':           /* (?$...) */
3239             case '@':           /* (?@...) */
3240                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
3241                 break;
3242             case '#':           /* (?#...) */
3243                 while (*RExC_parse && *RExC_parse != ')')
3244                     RExC_parse++;
3245                 if (*RExC_parse != ')')
3246                     FAIL("Sequence (?#... not terminated");
3247                 nextchar(pRExC_state);
3248                 *flagp = TRYAGAIN;
3249                 return NULL;
3250             case 'p':           /* (?p...) */
3251                 if (SIZE_ONLY && ckWARN2(WARN_DEPRECATED, WARN_REGEXP))
3252                     vWARNdep(RExC_parse, "(?p{}) is deprecated - use (??{})");
3253                 /* FALL THROUGH*/
3254             case '?':           /* (??...) */
3255                 is_logical = 1;
3256                 if (*RExC_parse != '{')
3257                     goto unknown;
3258                 paren = *RExC_parse++;
3259                 /* FALL THROUGH */
3260             case '{':           /* (?{...}) */
3261             {
3262                 I32 count = 1, n = 0;
3263                 char c;
3264                 char *s = RExC_parse;
3265
3266                 RExC_seen_zerolen++;
3267                 RExC_seen |= REG_SEEN_EVAL;
3268                 while (count && (c = *RExC_parse)) {
3269                     if (c == '\\') {
3270                         if (RExC_parse[1])
3271                             RExC_parse++;
3272                     }
3273                     else if (c == '{')
3274                         count++;
3275                     else if (c == '}')
3276                         count--;
3277                     RExC_parse++;
3278                 }
3279                 if (*RExC_parse != ')') {
3280                     RExC_parse = s;             
3281                     vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
3282                 }
3283                 if (!SIZE_ONLY) {
3284                     PAD *pad;
3285                     OP_4tree *sop, *rop;
3286                     SV * const sv = newSVpvn(s, RExC_parse - 1 - s);
3287
3288                     ENTER;
3289                     Perl_save_re_context(aTHX);
3290                     rop = sv_compile_2op(sv, &sop, "re", &pad);
3291                     sop->op_private |= OPpREFCOUNTED;
3292                     /* re_dup will OpREFCNT_inc */
3293                     OpREFCNT_set(sop, 1);
3294                     LEAVE;
3295
3296                     n = add_data(pRExC_state, 3, "nop");
3297                     RExC_rx->data->data[n] = (void*)rop;
3298                     RExC_rx->data->data[n+1] = (void*)sop;
3299                     RExC_rx->data->data[n+2] = (void*)pad;
3300                     SvREFCNT_dec(sv);
3301                 }
3302                 else {                                          /* First pass */
3303                     if (PL_reginterp_cnt < ++RExC_seen_evals
3304                         && IN_PERL_RUNTIME)
3305                         /* No compiled RE interpolated, has runtime
3306                            components ===> unsafe.  */
3307                         FAIL("Eval-group not allowed at runtime, use re 'eval'");
3308                     if (PL_tainting && PL_tainted)
3309                         FAIL("Eval-group in insecure regular expression");
3310 #if PERL_VERSION > 8
3311                     if (IN_PERL_COMPILETIME)
3312                         PL_cv_has_eval = 1;
3313 #endif
3314                 }
3315
3316                 nextchar(pRExC_state);
3317                 if (is_logical) {
3318                     ret = reg_node(pRExC_state, LOGICAL);
3319                     if (!SIZE_ONLY)
3320                         ret->flags = 2;
3321                     regtail(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
3322                     /* deal with the length of this later - MJD */
3323                     return ret;
3324                 }
3325                 ret = reganode(pRExC_state, EVAL, n);
3326                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
3327                 Set_Node_Offset(ret, parse_start);
3328                 return ret;
3329             }
3330             case '(':           /* (?(?{...})...) and (?(?=...)...) */
3331             {
3332                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
3333                     if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
3334                         || RExC_parse[1] == '<'
3335                         || RExC_parse[1] == '{') { /* Lookahead or eval. */
3336                         I32 flag;
3337                         
3338                         ret = reg_node(pRExC_state, LOGICAL);
3339                         if (!SIZE_ONLY)
3340                             ret->flags = 1;
3341                         regtail(pRExC_state, ret, reg(pRExC_state, 1, &flag));
3342                         goto insert_if;
3343                     }
3344                 }
3345                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
3346                     /* (?(1)...) */
3347                     char c;
3348                     parno = atoi(RExC_parse++);
3349
3350                     while (isDIGIT(*RExC_parse))
3351                         RExC_parse++;
3352                     ret = reganode(pRExC_state, GROUPP, parno);
3353
3354                     if ((c = *nextchar(pRExC_state)) != ')')
3355                         vFAIL("Switch condition not recognized");
3356                   insert_if:
3357                     regtail(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
3358                     br = regbranch(pRExC_state, &flags, 1);
3359                     if (br == NULL)
3360                         br = reganode(pRExC_state, LONGJMP, 0);
3361                     else
3362                         regtail(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
3363                     c = *nextchar(pRExC_state);
3364                     if (flags&HASWIDTH)
3365                         *flagp |= HASWIDTH;
3366                     if (c == '|') {
3367                         lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
3368                         regbranch(pRExC_state, &flags, 1);
3369                         regtail(pRExC_state, ret, lastbr);
3370                         if (flags&HASWIDTH)
3371                             *flagp |= HASWIDTH;
3372                         c = *nextchar(pRExC_state);
3373                     }
3374                     else
3375                         lastbr = NULL;
3376                     if (c != ')')
3377                         vFAIL("Switch (?(condition)... contains too many branches");
3378                     ender = reg_node(pRExC_state, TAIL);
3379                     regtail(pRExC_state, br, ender);
3380                     if (lastbr) {
3381                         regtail(pRExC_state, lastbr, ender);
3382                         regtail(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
3383                     }
3384                     else
3385                         regtail(pRExC_state, ret, ender);
3386                     return ret;
3387                 }
3388                 else {
3389                     vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
3390                 }
3391             }
3392             case 0:
3393                 RExC_parse--; /* for vFAIL to print correctly */
3394                 vFAIL("Sequence (? incomplete");
3395                 break;
3396             default:
3397                 --RExC_parse;
3398               parse_flags:      /* (?i) */
3399                 while (*RExC_parse && strchr("iogcmsx", *RExC_parse)) {
3400                     /* (?g), (?gc) and (?o) are useless here
3401                        and must be globally applied -- japhy */
3402
3403                     if (*RExC_parse == 'o' || *RExC_parse == 'g') {
3404                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
3405                             const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
3406                             if (! (wastedflags & wflagbit) ) {
3407                                 wastedflags |= wflagbit;
3408                                 vWARN5(
3409                                     RExC_parse + 1,
3410                                     "Useless (%s%c) - %suse /%c modifier",
3411                                     flagsp == &negflags ? "?-" : "?",
3412                                     *RExC_parse,
3413                                     flagsp == &negflags ? "don't " : "",
3414                                     *RExC_parse
3415                                 );
3416                             }
3417                         }
3418                     }
3419                     else if (*RExC_parse == 'c') {
3420                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
3421                             if (! (wastedflags & WASTED_C) ) {
3422                                 wastedflags |= WASTED_GC;
3423                                 vWARN3(
3424                                     RExC_parse + 1,
3425                                     "Useless (%sc) - %suse /gc modifier",
3426                                     flagsp == &negflags ? "?-" : "?",
3427                                     flagsp == &negflags ? "don't " : ""
3428                                 );
3429                             }
3430                         }
3431                     }
3432                     else { pmflag(flagsp, *RExC_parse); }
3433
3434                     ++RExC_parse;
3435                 }
3436                 if (*RExC_parse == '-') {
3437                     flagsp = &negflags;
3438                     wastedflags = 0;  /* reset so (?g-c) warns twice */
3439                     ++RExC_parse;
3440                     goto parse_flags;
3441                 }
3442                 RExC_flags |= posflags;
3443                 RExC_flags &= ~negflags;
3444                 if (*RExC_parse == ':') {
3445                     RExC_parse++;
3446                     paren = ':';
3447                     break;
3448                 }               
3449               unknown:
3450                 if (*RExC_parse != ')') {
3451                     RExC_parse++;
3452                     vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
3453                 }
3454                 nextchar(pRExC_state);
3455                 *flagp = TRYAGAIN;
3456                 return NULL;
3457             }
3458         }
3459         else {                  /* (...) */
3460             parno = RExC_npar;
3461             RExC_npar++;
3462             ret = reganode(pRExC_state, OPEN, parno);
3463             Set_Node_Length(ret, 1); /* MJD */
3464             Set_Node_Offset(ret, RExC_parse); /* MJD */
3465             is_open = 1;
3466         }
3467     }
3468     else                        /* ! paren */
3469         ret = NULL;
3470
3471     /* Pick up the branches, linking them together. */
3472     parse_start = RExC_parse;   /* MJD */
3473     br = regbranch(pRExC_state, &flags, 1);
3474     /*     branch_len = (paren != 0); */
3475
3476     if (br == NULL)
3477         return(NULL);
3478     if (*RExC_parse == '|') {
3479         if (!SIZE_ONLY && RExC_extralen) {
3480             reginsert(pRExC_state, BRANCHJ, br);
3481         }
3482         else {                  /* MJD */
3483             reginsert(pRExC_state, BRANCH, br);
3484             Set_Node_Length(br, paren != 0);
3485             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
3486         }
3487         have_branch = 1;
3488         if (SIZE_ONLY)
3489             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
3490     }
3491     else if (paren == ':') {
3492         *flagp |= flags&SIMPLE;
3493     }
3494     if (is_open) {                              /* Starts with OPEN. */
3495         regtail(pRExC_state, ret, br);          /* OPEN -> first. */
3496     }
3497     else if (paren != '?')              /* Not Conditional */
3498         ret = br;
3499     *flagp |= flags & (SPSTART | HASWIDTH);
3500     lastbr = br;
3501     while (*RExC_parse == '|') {
3502         if (!SIZE_ONLY && RExC_extralen) {
3503             ender = reganode(pRExC_state, LONGJMP,0);
3504             regtail(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
3505         }
3506         if (SIZE_ONLY)
3507             RExC_extralen += 2;         /* Account for LONGJMP. */
3508         nextchar(pRExC_state);
3509         br = regbranch(pRExC_state, &flags, 0);
3510
3511         if (br == NULL)
3512             return(NULL);
3513         regtail(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
3514         lastbr = br;
3515         if (flags&HASWIDTH)
3516             *flagp |= HASWIDTH;
3517         *flagp |= flags&SPSTART;
3518     }
3519
3520     if (have_branch || paren != ':') {
3521         /* Make a closing node, and hook it on the end. */
3522         switch (paren) {
3523         case ':':
3524             ender = reg_node(pRExC_state, TAIL);
3525             break;
3526         case 1:
3527             ender = reganode(pRExC_state, CLOSE, parno);
3528             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
3529             Set_Node_Length(ender,1); /* MJD */
3530             break;
3531         case '<':
3532         case ',':
3533         case '=':
3534         case '!':
3535             *flagp &= ~HASWIDTH;
3536             /* FALL THROUGH */
3537         case '>':
3538             ender = reg_node(pRExC_state, SUCCEED);
3539             break;
3540         case 0:
3541             ender = reg_node(pRExC_state, END);
3542             break;
3543         }
3544         regtail(pRExC_state, lastbr, ender);
3545
3546         if (have_branch && !SIZE_ONLY) {
3547             /* Hook the tails of the branches to the closing node. */
3548             for (br = ret; br; br = regnext(br)) {
3549                 const U8 op = PL_regkind[OP(br)];
3550                 if (op == BRANCH) {
3551                     regtail(pRExC_state, NEXTOPER(br), ender);
3552                 }
3553                 else if (op == BRANCHJ) {
3554                     regtail(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
3555                 }
3556             }
3557         }
3558     }
3559
3560     {
3561         const char *p;
3562         static const char parens[] = "=!<,>";
3563
3564         if (paren && (p = strchr(parens, paren))) {
3565             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
3566             int flag = (p - parens) > 1;
3567
3568             if (paren == '>')
3569                 node = SUSPEND, flag = 0;
3570             reginsert(pRExC_state, node,ret);
3571             Set_Node_Cur_Length(ret);
3572             Set_Node_Offset(ret, parse_start + 1);
3573             ret->flags = flag;
3574             regtail(pRExC_state, ret, reg_node(pRExC_state, TAIL));
3575         }
3576     }
3577
3578     /* Check for proper termination. */
3579     if (paren) {
3580         RExC_flags = oregflags;
3581         if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
3582             RExC_parse = oregcomp_parse;
3583             vFAIL("Unmatched (");
3584         }
3585     }
3586     else if (!paren && RExC_parse < RExC_end) {
3587         if (*RExC_parse == ')') {
3588             RExC_parse++;
3589             vFAIL("Unmatched )");
3590         }
3591         else
3592             FAIL("Junk on end of regexp");      /* "Can't happen". */
3593         /* NOTREACHED */
3594     }
3595
3596     return(ret);
3597 }
3598
3599 /*
3600  - regbranch - one alternative of an | operator
3601  *
3602  * Implements the concatenation operator.
3603  */
3604 STATIC regnode *
3605 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first)
3606 {
3607     dVAR;
3608     register regnode *ret;
3609     register regnode *chain = NULL;
3610     register regnode *latest;
3611     I32 flags = 0, c = 0;
3612
3613     if (first)
3614         ret = NULL;
3615     else {
3616         if (!SIZE_ONLY && RExC_extralen)
3617             ret = reganode(pRExC_state, BRANCHJ,0);
3618         else {
3619             ret = reg_node(pRExC_state, BRANCH);
3620             Set_Node_Length(ret, 1);
3621         }
3622     }
3623         
3624     if (!first && SIZE_ONLY)
3625         RExC_extralen += 1;                     /* BRANCHJ */
3626
3627     *flagp = WORST;                     /* Tentatively. */
3628
3629     RExC_parse--;
3630     nextchar(pRExC_state);
3631     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
3632         flags &= ~TRYAGAIN;
3633         latest = regpiece(pRExC_state, &flags);
3634         if (latest == NULL) {
3635             if (flags & TRYAGAIN)
3636                 continue;
3637             return(NULL);
3638         }
3639         else if (ret == NULL)
3640             ret = latest;
3641         *flagp |= flags&HASWIDTH;
3642         if (chain == NULL)      /* First piece. */
3643             *flagp |= flags&SPSTART;
3644         else {
3645             RExC_naughty++;
3646             regtail(pRExC_state, chain, latest);
3647         }
3648         chain = latest;
3649         c++;
3650     }
3651     if (chain == NULL) {        /* Loop ran zero times. */
3652         chain = reg_node(pRExC_state, NOTHING);
3653         if (ret == NULL)
3654             ret = chain;
3655     }
3656     if (c == 1) {
3657         *flagp |= flags&SIMPLE;
3658     }
3659
3660     return ret;
3661 }
3662
3663 /*
3664  - regpiece - something followed by possible [*+?]
3665  *
3666  * Note that the branching code sequences used for ? and the general cases
3667  * of * and + are somewhat optimized:  they use the same NOTHING node as
3668  * both the endmarker for their branch list and the body of the last branch.
3669  * It might seem that this node could be dispensed with entirely, but the
3670  * endmarker role is not redundant.
3671  */
3672 STATIC regnode *
3673 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp)
3674 {
3675     dVAR;
3676     register regnode *ret;
3677     register char op;
3678     register char *next;
3679     I32 flags;
3680     const char * const origparse = RExC_parse;
3681     char *maxpos;
3682     I32 min;
3683     I32 max = REG_INFTY;
3684     char *parse_start;
3685
3686     ret = regatom(pRExC_state, &flags);
3687     if (ret == NULL) {
3688         if (flags & TRYAGAIN)
3689             *flagp |= TRYAGAIN;
3690         return(NULL);
3691     }
3692
3693     op = *RExC_parse;
3694
3695     if (op == '{' && regcurly(RExC_parse)) {
3696         parse_start = RExC_parse; /* MJD */
3697         next = RExC_parse + 1;
3698         maxpos = NULL;
3699         while (isDIGIT(*next) || *next == ',') {
3700             if (*next == ',') {
3701                 if (maxpos)
3702                     break;
3703                 else
3704                     maxpos = next;
3705             }
3706             next++;
3707         }
3708         if (*next == '}') {             /* got one */
3709             if (!maxpos)
3710                 maxpos = next;
3711             RExC_parse++;
3712             min = atoi(RExC_parse);
3713             if (*maxpos == ',')
3714                 maxpos++;
3715             else
3716                 maxpos = RExC_parse;
3717             max = atoi(maxpos);
3718             if (!max && *maxpos != '0')
3719                 max = REG_INFTY;                /* meaning "infinity" */
3720             else if (max >= REG_INFTY)
3721                 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
3722             RExC_parse = next;
3723             nextchar(pRExC_state);
3724
3725         do_curly:
3726             if ((flags&SIMPLE)) {
3727                 RExC_naughty += 2 + RExC_naughty / 2;
3728                 reginsert(pRExC_state, CURLY, ret);
3729                 Set_Node_Offset(ret, parse_start+1); /* MJD */
3730                 Set_Node_Cur_Length(ret);
3731             }
3732             else {
3733                 regnode *w = reg_node(pRExC_state, WHILEM);
3734
3735                 w->flags = 0;
3736                 regtail(pRExC_state, ret, w);
3737                 if (!SIZE_ONLY && RExC_extralen) {
3738                     reginsert(pRExC_state, LONGJMP,ret);
3739                     reginsert(pRExC_state, NOTHING,ret);
3740                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
3741                 }
3742                 reginsert(pRExC_state, CURLYX,ret);
3743                                 /* MJD hk */
3744                 Set_Node_Offset(ret, parse_start+1);
3745                 Set_Node_Length(ret,
3746                                 op == '{' ? (RExC_parse - parse_start) : 1);
3747
3748                 if (!SIZE_ONLY && RExC_extralen)
3749                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
3750                 regtail(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
3751                 if (SIZE_ONLY)
3752                     RExC_whilem_seen++, RExC_extralen += 3;
3753                 RExC_naughty += 4 + RExC_naughty;       /* compound interest */
3754             }
3755             ret->flags = 0;
3756
3757             if (min > 0)
3758                 *flagp = WORST;
3759             if (max > 0)
3760                 *flagp |= HASWIDTH;
3761             if (max && max < min)
3762                 vFAIL("Can't do {n,m} with n > m");
3763             if (!SIZE_ONLY) {
3764                 ARG1_SET(ret, (U16)min);
3765                 ARG2_SET(ret, (U16)max);
3766             }
3767
3768             goto nest_check;
3769         }
3770     }
3771
3772     if (!ISMULT1(op)) {
3773         *flagp = flags;
3774         return(ret);
3775     }
3776
3777 #if 0                           /* Now runtime fix should be reliable. */
3778
3779     /* if this is reinstated, don't forget to put this back into perldiag:
3780
3781             =item Regexp *+ operand could be empty at {#} in regex m/%s/
3782
3783            (F) The part of the regexp subject to either the * or + quantifier
3784            could match an empty string. The {#} shows in the regular
3785            expression about where the problem was discovered.
3786
3787     */
3788
3789     if (!(flags&HASWIDTH) && op != '?')
3790       vFAIL("Regexp *+ operand could be empty");
3791 #endif
3792
3793     parse_start = RExC_parse;
3794     nextchar(pRExC_state);
3795
3796     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
3797
3798     if (op == '*' && (flags&SIMPLE)) {
3799         reginsert(pRExC_state, STAR, ret);
3800         ret->flags = 0;
3801         RExC_naughty += 4;
3802     }
3803     else if (op == '*') {
3804         min = 0;
3805         goto do_curly;
3806     }
3807     else if (op == '+' && (flags&SIMPLE)) {
3808         reginsert(pRExC_state, PLUS, ret);
3809         ret->flags = 0;
3810         RExC_naughty += 3;
3811     }
3812     else if (op == '+') {
3813         min = 1;
3814         goto do_curly;
3815     }
3816     else if (op == '?') {
3817         min = 0; max = 1;
3818         goto do_curly;
3819     }
3820   nest_check:
3821     if (!SIZE_ONLY && !(flags&HASWIDTH) && max > REG_INFTY/3 && ckWARN(WARN_REGEXP)) {
3822         vWARN3(RExC_parse,
3823                "%.*s matches null string many times",
3824                (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
3825                origparse);
3826     }
3827
3828     if (*RExC_parse == '?') {
3829         nextchar(pRExC_state);
3830         reginsert(pRExC_state, MINMOD, ret);
3831         regtail(pRExC_state, ret, ret + NODE_STEP_REGNODE);
3832     }
3833     if (ISMULT2(RExC_parse)) {
3834         RExC_parse++;
3835         vFAIL("Nested quantifiers");
3836     }
3837
3838     return(ret);
3839 }
3840
3841 /*
3842  - regatom - the lowest level
3843  *
3844  * Optimization:  gobbles an entire sequence of ordinary characters so that
3845  * it can turn them into a single node, which is smaller to store and
3846  * faster to run.  Backslashed characters are exceptions, each becoming a
3847  * separate node; the code is simpler that way and it's not worth fixing.
3848  *
3849  * [Yes, it is worth fixing, some scripts can run twice the speed.] */
3850 STATIC regnode *
3851 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp)
3852 {
3853     dVAR;
3854     register regnode *ret = NULL;
3855     I32 flags;
3856     char *parse_start = RExC_parse;
3857
3858     *flagp = WORST;             /* Tentatively. */
3859
3860 tryagain:
3861     switch (*RExC_parse) {
3862     case '^':
3863         RExC_seen_zerolen++;
3864         nextchar(pRExC_state);
3865         if (RExC_flags & PMf_MULTILINE)
3866             ret = reg_node(pRExC_state, MBOL);
3867         else if (RExC_flags & PMf_SINGLELINE)
3868             ret = reg_node(pRExC_state, SBOL);
3869         else
3870             ret = reg_node(pRExC_state, BOL);
3871         Set_Node_Length(ret, 1); /* MJD */
3872         break;
3873     case '$':
3874         nextchar(pRExC_state);
3875         if (*RExC_parse)
3876             RExC_seen_zerolen++;
3877         if (RExC_flags & PMf_MULTILINE)
3878             ret = reg_node(pRExC_state, MEOL);
3879         else if (RExC_flags & PMf_SINGLELINE)
3880             ret = reg_node(pRExC_state, SEOL);
3881         else
3882             ret = reg_node(pRExC_state, EOL);
3883         Set_Node_Length(ret, 1); /* MJD */
3884         break;
3885     case '.':
3886         nextchar(pRExC_state);
3887         if (RExC_flags & PMf_SINGLELINE)
3888             ret = reg_node(pRExC_state, SANY);
3889         else
3890             ret = reg_node(pRExC_state, REG_ANY);
3891         *flagp |= HASWIDTH|SIMPLE;
3892         RExC_naughty++;
3893         Set_Node_Length(ret, 1); /* MJD */
3894         break;
3895     case '[':
3896     {
3897         char *oregcomp_parse = ++RExC_parse;
3898         ret = regclass(pRExC_state);
3899         if (*RExC_parse != ']') {
3900             RExC_parse = oregcomp_parse;
3901             vFAIL("Unmatched [");
3902         }
3903         nextchar(pRExC_state);
3904         *flagp |= HASWIDTH|SIMPLE;
3905         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
3906         break;
3907     }
3908     case '(':
3909         nextchar(pRExC_state);
3910         ret = reg(pRExC_state, 1, &flags);
3911         if (ret == NULL) {
3912                 if (flags & TRYAGAIN) {
3913                     if (RExC_parse == RExC_end) {
3914                          /* Make parent create an empty node if needed. */
3915                         *flagp |= TRYAGAIN;
3916                         return(NULL);
3917                     }
3918                     goto tryagain;
3919                 }
3920                 return(NULL);
3921         }
3922         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE);
3923         break;
3924     case '|':
3925     case ')':
3926         if (flags & TRYAGAIN) {
3927             *flagp |= TRYAGAIN;
3928             return NULL;
3929         }
3930         vFAIL("Internal urp");
3931                                 /* Supposed to be caught earlier. */
3932         break;
3933     case '{':
3934         if (!regcurly(RExC_parse)) {
3935             RExC_parse++;
3936             goto defchar;
3937         }
3938         /* FALL THROUGH */
3939     case '?':
3940     case '+':
3941     case '*':
3942         RExC_parse++;
3943         vFAIL("Quantifier follows nothing");
3944         break;
3945     case '\\':
3946         switch (*++RExC_parse) {
3947         case 'A':
3948             RExC_seen_zerolen++;
3949             ret = reg_node(pRExC_state, SBOL);
3950             *flagp |= SIMPLE;
3951             nextchar(pRExC_state);
3952             Set_Node_Length(ret, 2); /* MJD */
3953             break;
3954         case 'G':
3955             ret = reg_node(pRExC_state, GPOS);
3956             RExC_seen |= REG_SEEN_GPOS;
3957             *flagp |= SIMPLE;
3958             nextchar(pRExC_state);
3959             Set_Node_Length(ret, 2); /* MJD */
3960             break;
3961         case 'Z':
3962             ret = reg_node(pRExC_state, SEOL);
3963             *flagp |= SIMPLE;
3964             RExC_seen_zerolen++;                /* Do not optimize RE away */
3965             nextchar(pRExC_state);
3966             break;
3967         case 'z':
3968             ret = reg_node(pRExC_state, EOS);
3969             *flagp |= SIMPLE;
3970             RExC_seen_zerolen++;                /* Do not optimize RE away */
3971             nextchar(pRExC_state);
3972             Set_Node_Length(ret, 2); /* MJD */
3973             break;
3974         case 'C':
3975             ret = reg_node(pRExC_state, CANY);
3976             RExC_seen |= REG_SEEN_CANY;
3977             *flagp |= HASWIDTH|SIMPLE;
3978             nextchar(pRExC_state);
3979             Set_Node_Length(ret, 2); /* MJD */
3980             break;
3981         case 'X':
3982             ret = reg_node(pRExC_state, CLUMP);
3983             *flagp |= HASWIDTH;
3984             nextchar(pRExC_state);
3985             Set_Node_Length(ret, 2); /* MJD */
3986             break;
3987         case 'w':
3988             ret = reg_node(pRExC_state, (U8)(LOC ? ALNUML     : ALNUM));
3989             *flagp |= HASWIDTH|SIMPLE;
3990             nextchar(pRExC_state);
3991             Set_Node_Length(ret, 2); /* MJD */
3992             break;
3993         case 'W':
3994             ret = reg_node(pRExC_state, (U8)(LOC ? NALNUML    : NALNUM));
3995             *flagp |= HASWIDTH|SIMPLE;
3996             nextchar(pRExC_state);
3997             Set_Node_Length(ret, 2); /* MJD */
3998             break;
3999         case 'b':
4000             RExC_seen_zerolen++;
4001             RExC_seen |= REG_SEEN_LOOKBEHIND;
4002             ret = reg_node(pRExC_state, (U8)(LOC ? BOUNDL     : BOUND));
4003             *flagp |= SIMPLE;
4004             nextchar(pRExC_state);
4005             Set_Node_Length(ret, 2); /* MJD */
4006             break;
4007         case 'B':
4008             RExC_seen_zerolen++;
4009             RExC_seen |= REG_SEEN_LOOKBEHIND;
4010             ret = reg_node(pRExC_state, (U8)(LOC ? NBOUNDL    : NBOUND));
4011             *flagp |= SIMPLE;
4012             nextchar(pRExC_state);
4013             Set_Node_Length(ret, 2); /* MJD */
4014             break;
4015         case 's':
4016             ret = reg_node(pRExC_state, (U8)(LOC ? SPACEL     : SPACE));
4017             *flagp |= HASWIDTH|SIMPLE;
4018             nextchar(pRExC_state);
4019             Set_Node_Length(ret, 2); /* MJD */
4020             break;
4021         case 'S':
4022             ret = reg_node(pRExC_state, (U8)(LOC ? NSPACEL    : NSPACE));
4023             *flagp |= HASWIDTH|SIMPLE;
4024             nextchar(pRExC_state);
4025             Set_Node_Length(ret, 2); /* MJD */
4026             break;
4027         case 'd':
4028             ret = reg_node(pRExC_state, DIGIT);
4029             *flagp |= HASWIDTH|SIMPLE;
4030             nextchar(pRExC_state);
4031             Set_Node_Length(ret, 2); /* MJD */
4032             break;
4033         case 'D':
4034             ret = reg_node(pRExC_state, NDIGIT);
4035             *flagp |= HASWIDTH|SIMPLE;
4036             nextchar(pRExC_state);
4037             Set_Node_Length(ret, 2); /* MJD */
4038             break;
4039         case 'p':
4040         case 'P':
4041             {   
4042                 char* oldregxend = RExC_end;
4043                 char* parse_start = RExC_parse - 2;
4044
4045                 if (RExC_parse[1] == '{') {
4046                   /* a lovely hack--pretend we saw [\pX] instead */
4047                     RExC_end = strchr(RExC_parse, '}');
4048                     if (!RExC_end) {
4049                         U8 c = (U8)*RExC_parse;
4050                         RExC_parse += 2;
4051                         RExC_end = oldregxend;
4052                         vFAIL2("Missing right brace on \\%c{}", c);
4053                     }
4054                     RExC_end++;
4055                 }
4056                 else {
4057                     RExC_end = RExC_parse + 2;
4058                     if (RExC_end > oldregxend)
4059                         RExC_end = oldregxend;
4060                 }
4061                 RExC_parse--;
4062
4063                 ret = regclass(pRExC_state);
4064
4065                 RExC_end = oldregxend;
4066                 RExC_parse--;
4067
4068                 Set_Node_Offset(ret, parse_start + 2);
4069                 Set_Node_Cur_Length(ret);
4070                 nextchar(pRExC_state);
4071                 *flagp |= HASWIDTH|SIMPLE;
4072             }
4073             break;
4074         case 'n':
4075         case 'r':
4076         case 't':
4077         case 'f':
4078         case 'e':
4079         case 'a':
4080         case 'x':
4081         case 'c':
4082         case '0':
4083             goto defchar;
4084         case '1': case '2': case '3': case '4':
4085         case '5': case '6': case '7': case '8': case '9':
4086             {
4087                 const I32 num = atoi(RExC_parse);
4088
4089                 if (num > 9 && num >= RExC_npar)
4090                     goto defchar;
4091                 else {
4092                     char * parse_start = RExC_parse - 1; /* MJD */
4093                     while (isDIGIT(*RExC_parse))
4094                         RExC_parse++;
4095
4096                     if (!SIZE_ONLY && num > (I32)RExC_rx->nparens)
4097                         vFAIL("Reference to nonexistent group");
4098                     RExC_sawback = 1;
4099                     ret = reganode(pRExC_state,
4100                                    (U8)(FOLD ? (LOC ? REFFL : REFF) : REF),
4101                                    num);
4102                     *flagp |= HASWIDTH;
4103
4104                     /* override incorrect value set in reganode MJD */
4105                     Set_Node_Offset(ret, parse_start+1);
4106                     Set_Node_Cur_Length(ret); /* MJD */
4107                     RExC_parse--;
4108                     nextchar(pRExC_state);
4109                 }
4110             }
4111             break;
4112         case '\0':
4113             if (RExC_parse >= RExC_end)
4114                 FAIL("Trailing \\");
4115             /* FALL THROUGH */
4116         default:
4117             /* Do not generate "unrecognized" warnings here, we fall
4118                back into the quick-grab loop below */
4119             parse_start--;
4120             goto defchar;
4121         }
4122         break;
4123
4124     case '#':
4125         if (RExC_flags & PMf_EXTENDED) {
4126             while (RExC_parse < RExC_end && *RExC_parse != '\n') RExC_parse++;
4127             if (RExC_parse < RExC_end)
4128                 goto tryagain;
4129         }
4130         /* FALL THROUGH */
4131
4132     default: {
4133             register STRLEN len;
4134             register UV ender;
4135             register char *p;
4136             char *oldp, *s;
4137             STRLEN foldlen;
4138             U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
4139
4140             parse_start = RExC_parse - 1;
4141
4142             RExC_parse++;
4143
4144         defchar:
4145             ender = 0;
4146             ret = reg_node(pRExC_state,
4147                            (U8)(FOLD ? (LOC ? EXACTFL : EXACTF) : EXACT));
4148             s = STRING(ret);
4149             for (len = 0, p = RExC_parse - 1;
4150               len < 127 && p < RExC_end;
4151               len++)
4152             {
4153                 oldp = p;
4154
4155                 if (RExC_flags & PMf_EXTENDED)
4156                     p = regwhite(p, RExC_end);
4157                 switch (*p) {
4158                 case '^':
4159                 case '$':
4160                 case '.':
4161                 case '[':
4162                 case '(':
4163                 case ')':
4164                 case '|':
4165                     goto loopdone;
4166                 case '\\':
4167                     switch (*++p) {
4168                     case 'A':
4169                     case 'C':
4170                     case 'X':
4171                     case 'G':
4172                     case 'Z':
4173                     case 'z':
4174                     case 'w':
4175                     case 'W':
4176                     case 'b':
4177                     case 'B':
4178                     case 's':
4179                     case 'S':
4180                     case 'd':
4181                     case 'D':
4182                     case 'p':
4183                     case 'P':
4184                         --p;
4185                         goto loopdone;
4186                     case 'n':
4187                         ender = '\n';
4188                         p++;
4189                         break;
4190                     case 'r':
4191                         ender = '\r';
4192                         p++;
4193                         break;
4194                     case 't':
4195                         ender = '\t';
4196                         p++;
4197                         break;
4198                     case 'f':
4199                         ender = '\f';
4200                         p++;
4201                         break;
4202                     case 'e':
4203                           ender = ASCII_TO_NATIVE('\033');
4204                         p++;
4205                         break;
4206                     case 'a':
4207                           ender = ASCII_TO_NATIVE('\007');
4208                         p++;
4209                         break;
4210                     case 'x':
4211                         if (*++p == '{') {
4212                             char* const e = strchr(p, '}');
4213         
4214                             if (!e) {
4215                                 RExC_parse = p + 1;
4216                                 vFAIL("Missing right brace on \\x{}");
4217                             }
4218                             else {
4219                                 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
4220                                     | PERL_SCAN_DISALLOW_PREFIX;
4221                                 STRLEN numlen = e - p - 1;
4222                                 ender = grok_hex(p + 1, &numlen, &flags, NULL);
4223                                 if (ender > 0xff)
4224                                     RExC_utf8 = 1;
4225                                 p = e + 1;
4226                             }
4227                         }
4228                         else {
4229                             I32 flags = PERL_SCAN_DISALLOW_PREFIX;
4230                             STRLEN numlen = 2;
4231                             ender = grok_hex(p, &numlen, &flags, NULL);
4232                             p += numlen;
4233                         }
4234                         break;
4235                     case 'c':
4236                         p++;
4237                         ender = UCHARAT(p++);
4238                         ender = toCTRL(ender);
4239                         break;
4240                     case '0': case '1': case '2': case '3':case '4':
4241                     case '5': case '6': case '7': case '8':case '9':
4242                         if (*p == '0' ||
4243                           (isDIGIT(p[1]) && atoi(p) >= RExC_npar) ) {
4244                             I32 flags = 0;
4245                             STRLEN numlen = 3;
4246                             ender = grok_oct(p, &numlen, &flags, NULL);
4247                             p += numlen;
4248                         }
4249                         else {
4250                             --p;
4251                             goto loopdone;
4252                         }
4253                         break;
4254                     case '\0':
4255                         if (p >= RExC_end)
4256                             FAIL("Trailing \\");
4257                         /* FALL THROUGH */
4258                     default:
4259                         if (!SIZE_ONLY&& isALPHA(*p) && ckWARN(WARN_REGEXP))
4260                             vWARN2(p + 1, "Unrecognized escape \\%c passed through", UCHARAT(p));
4261                         goto normal_default;
4262                     }
4263                     break;
4264                 default:
4265                   normal_default:
4266                     if (UTF8_IS_START(*p) && UTF) {
4267                         STRLEN numlen;
4268                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
4269                                                &numlen, UTF8_ALLOW_DEFAULT);
4270                         p += numlen;
4271                     }
4272                     else
4273                         ender = *p++;
4274                     break;
4275                 }
4276                 if (RExC_flags & PMf_EXTENDED)
4277                     p = regwhite(p, RExC_end);
4278                 if (UTF && FOLD) {
4279                     /* Prime the casefolded buffer. */
4280                     ender = toFOLD_uni(ender, tmpbuf, &foldlen);
4281                 }
4282                 if (ISMULT2(p)) { /* Back off on ?+*. */
4283                     if (len)
4284                         p = oldp;
4285                     else if (UTF) {
4286                          if (FOLD) {
4287                               /* Emit all the Unicode characters. */
4288                               STRLEN numlen;
4289                               for (foldbuf = tmpbuf;
4290                                    foldlen;
4291                                    foldlen -= numlen) {
4292                                    ender = utf8_to_uvchr(foldbuf, &numlen);
4293                                    if (numlen > 0) {
4294                                         const STRLEN unilen = reguni(pRExC_state, ender, s);
4295                                         s       += unilen;
4296                                         len     += unilen;
4297                                         /* In EBCDIC the numlen
4298                                          * and unilen can differ. */
4299                                         foldbuf += numlen;
4300                                         if (numlen >= foldlen)
4301                                              break;
4302                                    }
4303                                    else
4304                                         break; /* "Can't happen." */
4305                               }
4306                          }
4307                          else {
4308                               const STRLEN unilen = reguni(pRExC_state, ender, s);
4309                               if (unilen > 0) {
4310                                    s   += unilen;
4311                                    len += unilen;
4312                               }
4313                          }
4314                     }
4315                     else {
4316                         len++;
4317                         REGC((char)ender, s++);
4318                     }
4319                     break;
4320                 }
4321                 if (UTF) {
4322                      if (FOLD) {
4323                           /* Emit all the Unicode characters. */
4324                           STRLEN numlen;
4325                           for (foldbuf = tmpbuf;
4326                                foldlen;
4327                                foldlen -= numlen) {
4328                                ender = utf8_to_uvchr(foldbuf, &numlen);
4329                                if (numlen > 0) {
4330                                     const STRLEN unilen = reguni(pRExC_state, ender, s);
4331                                     len     += unilen;
4332                                     s       += unilen;
4333                                     /* In EBCDIC the numlen
4334                                      * and unilen can differ. */
4335                                     foldbuf += numlen;
4336                                     if (numlen >= foldlen)
4337                                          break;
4338                                }
4339                                else
4340                                     break;
4341                           }
4342                      }
4343                      else {
4344                           const STRLEN unilen = reguni(pRExC_state, ender, s);
4345                           if (unilen > 0) {
4346                                s   += unilen;
4347                                len += unilen;
4348                           }
4349                      }
4350                      len--;
4351                 }
4352                 else
4353                     REGC((char)ender, s++);
4354             }
4355         loopdone:
4356             RExC_parse = p - 1;
4357             Set_Node_Cur_Length(ret); /* MJD */
4358             nextchar(pRExC_state);
4359             {
4360                 /* len is STRLEN which is unsigned, need to copy to signed */
4361                 IV iv = len;
4362                 if (iv < 0)
4363                     vFAIL("Internal disaster");
4364             }
4365             if (len > 0)
4366                 *flagp |= HASWIDTH;
4367             if (len == 1 && UNI_IS_INVARIANT(ender))
4368                 *flagp |= SIMPLE;
4369             if (!SIZE_ONLY)
4370                 STR_LEN(ret) = len;
4371             if (SIZE_ONLY)
4372                 RExC_size += STR_SZ(len);
4373             else
4374                 RExC_emit += STR_SZ(len);
4375         }
4376         break;
4377     }
4378
4379     /* If the encoding pragma is in effect recode the text of
4380      * any EXACT-kind nodes. */
4381     if (PL_encoding && PL_regkind[(U8)OP(ret)] == EXACT) {
4382         STRLEN oldlen = STR_LEN(ret);
4383         SV *sv        = sv_2mortal(newSVpvn(STRING(ret), oldlen));
4384
4385         if (RExC_utf8)
4386             SvUTF8_on(sv);
4387         if (sv_utf8_downgrade(sv, TRUE)) {
4388             const char * const s = sv_recode_to_utf8(sv, PL_encoding);
4389             const STRLEN newlen = SvCUR(sv);
4390
4391             if (SvUTF8(sv))
4392                 RExC_utf8 = 1;
4393             if (!SIZE_ONLY) {
4394                 GET_RE_DEBUG_FLAGS_DECL;
4395                 DEBUG_COMPILE_r(PerlIO_printf(Perl_debug_log, "recode %*s to %*s\n",
4396                                       (int)oldlen, STRING(ret),
4397                                       (int)newlen, s));
4398                 Copy(s, STRING(ret), newlen, char);
4399                 STR_LEN(ret) += newlen - oldlen;
4400                 RExC_emit += STR_SZ(newlen) - STR_SZ(oldlen);
4401             } else
4402                 RExC_size += STR_SZ(newlen) - STR_SZ(oldlen);
4403         }
4404     }
4405
4406     return(ret);
4407 }
4408
4409 STATIC char *
4410 S_regwhite(char *p, const char *e)
4411 {
4412     while (p < e) {
4413         if (isSPACE(*p))
4414             ++p;
4415         else if (*p == '#') {
4416             do {
4417                 p++;
4418             } while (p < e && *p != '\n');
4419         }
4420         else
4421             break;
4422     }
4423     return p;
4424 }
4425
4426 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
4427    Character classes ([:foo:]) can also be negated ([:^foo:]).
4428    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
4429    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
4430    but trigger failures because they are currently unimplemented. */
4431
4432 #define POSIXCC_DONE(c)   ((c) == ':')
4433 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
4434 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
4435
4436 STATIC I32
4437 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
4438 {
4439     dVAR;
4440     I32 namedclass = OOB_NAMEDCLASS;
4441
4442     if (value == '[' && RExC_parse + 1 < RExC_end &&
4443         /* I smell either [: or [= or [. -- POSIX has been here, right? */
4444         POSIXCC(UCHARAT(RExC_parse))) {
4445         const char c = UCHARAT(RExC_parse);
4446         char* const s = RExC_parse++;
4447         
4448         while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
4449             RExC_parse++;
4450         if (RExC_parse == RExC_end)
4451             /* Grandfather lone [:, [=, [. */
4452             RExC_parse = s;
4453         else {
4454             const char* t = RExC_parse++; /* skip over the c */
4455             const char *posixcc;
4456
4457             assert(*t == c);
4458
4459             if (UCHARAT(RExC_parse) == ']') {
4460                 RExC_parse++; /* skip over the ending ] */
4461                 posixcc = s + 1;
4462                 if (*s == ':') {
4463                     const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
4464                     const I32 skip = t - posixcc;
4465
4466                     /* Initially switch on the length of the name.  */
4467                     switch (skip) {
4468                     case 4:
4469                         if (memEQ(posixcc, "word", 4)) {
4470                             /* this is not POSIX, this is the Perl \w */;
4471                             namedclass
4472                                 = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
4473                         }
4474                         break;
4475                     case 5:
4476                         /* Names all of length 5.  */
4477                         /* alnum alpha ascii blank cntrl digit graph lower
4478                            print punct space upper  */
4479                         /* Offset 4 gives the best switch position.  */
4480                         switch (posixcc[4]) {
4481                         case 'a':
4482                             if (memEQ(posixcc, "alph", 4)) {
4483                                 /*                  a     */
4484                                 namedclass
4485                                     = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
4486                             }
4487                             break;
4488                         case 'e':
4489                             if (memEQ(posixcc, "spac", 4)) {
4490                                 /*                  e     */
4491                                 namedclass
4492                                     = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
4493                             }
4494                             break;
4495                         case 'h':
4496                             if (memEQ(posixcc, "grap", 4)) {
4497                                 /*                  h     */
4498                                 namedclass
4499                                     = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
4500                             }
4501                             break;
4502                         case 'i':
4503                             if (memEQ(posixcc, "asci", 4)) {
4504                                 /*                  i     */
4505                                 namedclass
4506                                     = complement ? ANYOF_NASCII : ANYOF_ASCII;
4507                             }
4508                             break;
4509                         case 'k':
4510                             if (memEQ(posixcc, "blan", 4)) {
4511                                 /*                  k     */
4512                                 namedclass
4513                                     = complement ? ANYOF_NBLANK : ANYOF_BLANK;
4514                             }
4515                             break;
4516                         case 'l':
4517                             if (memEQ(posixcc, "cntr", 4)) {
4518                                 /*                  l     */
4519                                 namedclass
4520                                     = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
4521                             }
4522                             break;
4523                         case 'm':
4524                             if (memEQ(posixcc, "alnu", 4)) {
4525                                 /*                  m     */
4526                                 namedclass
4527                                     = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
4528                             }
4529                             break;
4530                         case 'r':
4531                             if (memEQ(posixcc, "lowe", 4)) {
4532                                 /*                  r     */
4533                                 namedclass
4534                                     = complement ? ANYOF_NLOWER : ANYOF_LOWER;
4535                             }
4536                             if (memEQ(posixcc, "uppe", 4)) {
4537                                 /*                  r     */
4538                                 namedclass
4539                                     = complement ? ANYOF_NUPPER : ANYOF_UPPER;
4540                             }
4541                             break;
4542                         case 't':
4543                             if (memEQ(posixcc, "digi", 4)) {
4544                                 /*                  t     */
4545                                 namedclass
4546                                     = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
4547                             }
4548                             if (memEQ(posixcc, "prin", 4)) {
4549                                 /*                  t     */
4550                                 namedclass
4551                                     = complement ? ANYOF_NPRINT : ANYOF_PRINT;
4552                             }
4553                             if (memEQ(posixcc, "punc", 4)) {
4554                                 /*                  t     */
4555                                 namedclass
4556                                     = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
4557                             }
4558                             break;
4559                         }
4560                         break;
4561                     case 6:
4562                         if (memEQ(posixcc, "xdigit", 6)) {
4563                             namedclass
4564                                 = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
4565                         }
4566                         break;
4567                     }
4568
4569                     if (namedclass == OOB_NAMEDCLASS)
4570                     {
4571                         Simple_vFAIL3("POSIX class [:%.*s:] unknown",
4572                                       t - s - 1, s + 1);
4573                     }
4574                     assert (posixcc[skip] == ':');
4575                     assert (posixcc[skip+1] == ']');
4576                 } else if (!SIZE_ONLY) {
4577                     /* [[=foo=]] and [[.foo.]] are still future. */
4578
4579                     /* adjust RExC_parse so the warning shows after
4580                        the class closes */
4581                     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
4582                         RExC_parse++;
4583                     Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
4584                 }
4585             } else {
4586                 /* Maternal grandfather:
4587                  * "[:" ending in ":" but not in ":]" */
4588                 RExC_parse = s;
4589             }
4590         }
4591     }
4592
4593     return namedclass;
4594 }
4595
4596 STATIC void
4597 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
4598 {
4599     dVAR;
4600     if (!SIZE_ONLY && POSIXCC(UCHARAT(RExC_parse))) {
4601         const char *s = RExC_parse;
4602         const char  c = *s++;
4603
4604         while(*s && isALNUM(*s))
4605             s++;
4606         if (*s && c == *s && s[1] == ']') {
4607             if (ckWARN(WARN_REGEXP))
4608                 vWARN3(s+2,
4609                         "POSIX syntax [%c %c] belongs inside character classes",
4610                         c, c);
4611
4612             /* [[=foo=]] and [[.foo.]] are still future. */
4613             if (POSIXCC_NOTYET(c)) {
4614                 /* adjust RExC_parse so the error shows after
4615                    the class closes */
4616                 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
4617                     ;
4618                 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
4619             }
4620         }
4621     }
4622 }
4623
4624 STATIC regnode *
4625 S_regclass(pTHX_ RExC_state_t *pRExC_state)
4626 {
4627     dVAR;
4628     register UV value;
4629     register UV nextvalue;
4630     register IV prevvalue = OOB_UNICODE;
4631     register IV range = 0;
4632     register regnode *ret;
4633     STRLEN numlen;
4634     IV namedclass;
4635     char *rangebegin = NULL;
4636     bool need_class = 0;
4637     SV *listsv = NULL;
4638     register char *e;
4639     UV n;
4640     bool optimize_invert   = TRUE;
4641     AV* unicode_alternate  = NULL;
4642 #ifdef EBCDIC
4643     UV literal_endpoint = 0;
4644 #endif
4645
4646     ret = reganode(pRExC_state, ANYOF, 0);
4647
4648     if (!SIZE_ONLY)
4649         ANYOF_FLAGS(ret) = 0;
4650
4651     if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
4652         RExC_naughty++;
4653         RExC_parse++;
4654         if (!SIZE_ONLY)
4655             ANYOF_FLAGS(ret) |= ANYOF_INVERT;
4656     }
4657
4658     if (SIZE_ONLY) {
4659         RExC_size += ANYOF_SKIP;
4660         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
4661     }
4662     else {
4663         RExC_emit += ANYOF_SKIP;
4664         if (FOLD)
4665             ANYOF_FLAGS(ret) |= ANYOF_FOLD;
4666         if (LOC)
4667             ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
4668         ANYOF_BITMAP_ZERO(ret);
4669         listsv = newSVpvs("# comment\n");
4670     }
4671
4672     nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
4673
4674     if (!SIZE_ONLY && POSIXCC(nextvalue))
4675         checkposixcc(pRExC_state);
4676
4677     /* allow 1st char to be ] (allowing it to be - is dealt with later) */
4678     if (UCHARAT(RExC_parse) == ']')
4679         goto charclassloop;
4680
4681     while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
4682
4683     charclassloop:
4684
4685         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
4686
4687         if (!range)
4688             rangebegin = RExC_parse;
4689         if (UTF) {
4690             value = utf8n_to_uvchr((U8*)RExC_parse,
4691                                    RExC_end - RExC_parse,
4692                                    &numlen, UTF8_ALLOW_DEFAULT);
4693             RExC_parse += numlen;
4694         }
4695         else
4696             value = UCHARAT(RExC_parse++);
4697         nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
4698         if (value == '[' && POSIXCC(nextvalue))
4699             namedclass = regpposixcc(pRExC_state, value);
4700         else if (value == '\\') {
4701             if (UTF) {
4702                 value = utf8n_to_uvchr((U8*)RExC_parse,
4703                                    RExC_end - RExC_parse,
4704                                    &numlen, UTF8_ALLOW_DEFAULT);
4705                 RExC_parse += numlen;
4706             }
4707             else
4708                 value = UCHARAT(RExC_parse++);
4709             /* Some compilers cannot handle switching on 64-bit integer
4710              * values, therefore value cannot be an UV.  Yes, this will
4711              * be a problem later if we want switch on Unicode.
4712              * A similar issue a little bit later when switching on
4713              * namedclass. --jhi */
4714             switch ((I32)value) {
4715             case 'w':   namedclass = ANYOF_ALNUM;       break;
4716             case 'W':   namedclass = ANYOF_NALNUM;      break;
4717             case 's':   namedclass = ANYOF_SPACE;       break;
4718             case 'S':   namedclass = ANYOF_NSPACE;      break;
4719             case 'd':   namedclass = ANYOF_DIGIT;       break;
4720             case 'D':   namedclass = ANYOF_NDIGIT;      break;
4721             case 'p':
4722             case 'P':
4723                 if (RExC_parse >= RExC_end)
4724                     vFAIL2("Empty \\%c{}", (U8)value);
4725                 if (*RExC_parse == '{') {
4726                     const U8 c = (U8)value;
4727                     e = strchr(RExC_parse++, '}');
4728                     if (!e)
4729                         vFAIL2("Missing right brace on \\%c{}", c);
4730                     while (isSPACE(UCHARAT(RExC_parse)))
4731                         RExC_parse++;
4732                     if (e == RExC_parse)
4733                         vFAIL2("Empty \\%c{}", c);
4734                     n = e - RExC_parse;
4735                     while (isSPACE(UCHARAT(RExC_parse + n - 1)))
4736                         n--;
4737                 }
4738                 else {
4739                     e = RExC_parse;
4740                     n = 1;
4741                 }
4742                 if (!SIZE_ONLY) {
4743                     if (UCHARAT(RExC_parse) == '^') {
4744                          RExC_parse++;
4745                          n--;
4746                          value = value == 'p' ? 'P' : 'p'; /* toggle */
4747                          while (isSPACE(UCHARAT(RExC_parse))) {
4748                               RExC_parse++;
4749                               n--;
4750                          }
4751                     }
4752                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%.*s\n",
4753                         (value=='p' ? '+' : '!'), (int)n, RExC_parse);
4754                 }
4755                 RExC_parse = e + 1;
4756                 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
4757                 namedclass = ANYOF_MAX;  /* no official name, but it's named */
4758                 break;
4759             case 'n':   value = '\n';                   break;
4760             case 'r':   value = '\r';                   break;
4761             case 't':   value = '\t';                   break;
4762             case 'f':   value = '\f';                   break;
4763             case 'b':   value = '\b';                   break;
4764             case 'e':   value = ASCII_TO_NATIVE('\033');break;
4765             case 'a':   value = ASCII_TO_NATIVE('\007');break;
4766             case 'x':
4767                 if (*RExC_parse == '{') {
4768                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
4769                         | PERL_SCAN_DISALLOW_PREFIX;
4770                     e = strchr(RExC_parse++, '}');
4771                     if (!e)
4772                         vFAIL("Missing right brace on \\x{}");
4773
4774                     numlen = e - RExC_parse;
4775                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
4776                     RExC_parse = e + 1;
4777                 }
4778                 else {
4779                     I32 flags = PERL_SCAN_DISALLOW_PREFIX;
4780                     numlen = 2;
4781                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
4782                     RExC_parse += numlen;
4783                 }
4784                 break;
4785             case 'c':
4786                 value = UCHARAT(RExC_parse++);
4787                 value = toCTRL(value);
4788                 break;
4789             case '0': case '1': case '2': case '3': case '4':
4790             case '5': case '6': case '7': case '8': case '9':
4791             {
4792                 I32 flags = 0;
4793                 numlen = 3;
4794                 value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
4795                 RExC_parse += numlen;
4796                 break;
4797             }
4798             default:
4799                 if (!SIZE_ONLY && isALPHA(value) && ckWARN(WARN_REGEXP))
4800                     vWARN2(RExC_parse,
4801                            "Unrecognized escape \\%c in character class passed through",
4802                            (int)value);
4803                 break;
4804             }
4805         } /* end of \blah */
4806 #ifdef EBCDIC
4807         else
4808             literal_endpoint++;
4809 #endif
4810
4811         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
4812
4813             if (!SIZE_ONLY && !need_class)
4814                 ANYOF_CLASS_ZERO(ret);
4815
4816             need_class = 1;
4817
4818             /* a bad range like a-\d, a-[:digit:] ? */
4819             if (range) {
4820                 if (!SIZE_ONLY) {
4821                     if (ckWARN(WARN_REGEXP)) {
4822                         const int w =
4823                             RExC_parse >= rangebegin ?
4824                             RExC_parse - rangebegin : 0;
4825                         vWARN4(RExC_parse,
4826                                "False [] range \"%*.*s\"",
4827                                w, w, rangebegin);
4828                     }
4829                     if (prevvalue < 256) {
4830                         ANYOF_BITMAP_SET(ret, prevvalue);
4831                         ANYOF_BITMAP_SET(ret, '-');
4832                     }
4833                     else {
4834                         ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
4835                         Perl_sv_catpvf(aTHX_ listsv,
4836                                        "%04"UVxf"\n%04"UVxf"\n", (UV)prevvalue, (UV) '-');
4837                     }
4838                 }
4839
4840                 range = 0; /* this was not a true range */
4841             }
4842
4843             if (!SIZE_ONLY) {
4844                 const char *what = NULL;
4845                 char yesno = 0;
4846
4847                 if (namedclass > OOB_NAMEDCLASS)
4848                     optimize_invert = FALSE;
4849                 /* Possible truncation here but in some 64-bit environments
4850                  * the compiler gets heartburn about switch on 64-bit values.
4851                  * A similar issue a little earlier when switching on value.
4852                  * --jhi */
4853                 switch ((I32)namedclass) {
4854                 case ANYOF_ALNUM:
4855                     if (LOC)
4856                         ANYOF_CLASS_SET(ret, ANYOF_ALNUM);
4857                     else {
4858                         for (value = 0; value < 256; value++)
4859                             if (isALNUM(value))
4860                                 ANYOF_BITMAP_SET(ret, value);
4861                     }
4862                     yesno = '+';
4863                     what = "Word";      
4864                     break;
4865                 case ANYOF_NALNUM:
4866                     if (LOC)
4867                         ANYOF_CLASS_SET(ret, ANYOF_NALNUM);
4868                     else {
4869                         for (value = 0; value < 256; value++)
4870                             if (!isALNUM(value))
4871                                 ANYOF_BITMAP_SET(ret, value);
4872                     }
4873                     yesno = '!';
4874                     what = "Word";
4875                     break;
4876                 case ANYOF_ALNUMC:
4877                     if (LOC)
4878                         ANYOF_CLASS_SET(ret, ANYOF_ALNUMC);
4879                     else {
4880                         for (value = 0; value < 256; value++)
4881                             if (isALNUMC(value))
4882                                 ANYOF_BITMAP_SET(ret, value);
4883                     }
4884                     yesno = '+';
4885                     what = "Alnum";
4886                     break;
4887                 case ANYOF_NALNUMC:
4888                     if (LOC)
4889                         ANYOF_CLASS_SET(ret, ANYOF_NALNUMC);
4890                     else {
4891                         for (value = 0; value < 256; value++)
4892                             if (!isALNUMC(value))
4893                                 ANYOF_BITMAP_SET(ret, value);
4894                     }
4895                     yesno = '!';
4896                     what = "Alnum";
4897                     break;
4898                 case ANYOF_ALPHA:
4899                     if (LOC)
4900                         ANYOF_CLASS_SET(ret, ANYOF_ALPHA);
4901                     else {
4902                         for (value = 0; value < 256; value++)
4903                             if (isALPHA(value))
4904                                 ANYOF_BITMAP_SET(ret, value);
4905                     }
4906                     yesno = '+';
4907                     what = "Alpha";
4908                     break;
4909                 case ANYOF_NALPHA:
4910                     if (LOC)
4911                         ANYOF_CLASS_SET(ret, ANYOF_NALPHA);
4912                     else {
4913                         for (value = 0; value < 256; value++)
4914                             if (!isALPHA(value))
4915                                 ANYOF_BITMAP_SET(ret, value);
4916                     }
4917                     yesno = '!';
4918                     what = "Alpha";
4919                     break;
4920                 case ANYOF_ASCII:
4921                     if (LOC)
4922                         ANYOF_CLASS_SET(ret, ANYOF_ASCII);
4923                     else {
4924 #ifndef EBCDIC
4925                         for (value = 0; value < 128; value++)
4926                             ANYOF_BITMAP_SET(ret, value);
4927 #else  /* EBCDIC */
4928                         for (value = 0; value < 256; value++) {
4929                             if (isASCII(value))
4930                                 ANYOF_BITMAP_SET(ret, value);
4931                         }
4932 #endif /* EBCDIC */
4933                     }
4934                     yesno = '+';
4935                     what = "ASCII";
4936                     break;
4937                 case ANYOF_NASCII:
4938                     if (LOC)
4939                         ANYOF_CLASS_SET(ret, ANYOF_NASCII);
4940                     else {
4941 #ifndef EBCDIC
4942                         for (value = 128; value < 256; value++)
4943                             ANYOF_BITMAP_SET(ret, value);
4944 #else  /* EBCDIC */
4945                         for (value = 0; value < 256; value++) {
4946                             if (!isASCII(value))
4947                                 ANYOF_BITMAP_SET(ret, value);
4948                         }
4949 #endif /* EBCDIC */
4950                     }
4951                     yesno = '!';
4952                     what = "ASCII";
4953                     break;
4954                 case ANYOF_BLANK:
4955                     if (LOC)
4956                         ANYOF_CLASS_SET(ret, ANYOF_BLANK);
4957                     else {
4958                         for (value = 0; value < 256; value++)
4959                             if (isBLANK(value))
4960                                 ANYOF_BITMAP_SET(ret, value);
4961                     }
4962                     yesno = '+';
4963                     what = "Blank";
4964                     break;
4965                 case ANYOF_NBLANK:
4966                     if (LOC)
4967                         ANYOF_CLASS_SET(ret, ANYOF_NBLANK);
4968                     else {
4969                         for (value = 0; value < 256; value++)
4970                             if (!isBLANK(value))
4971                                 ANYOF_BITMAP_SET(ret, value);
4972                     }
4973                     yesno = '!';
4974                     what = "Blank";
4975                     break;
4976                 case ANYOF_CNTRL:
4977                     if (LOC)
4978                         ANYOF_CLASS_SET(ret, ANYOF_CNTRL);
4979                     else {
4980                         for (value = 0; value < 256; value++)
4981                             if (isCNTRL(value))
4982                                 ANYOF_BITMAP_SET(ret, value);
4983                     }
4984                     yesno = '+';
4985                     what = "Cntrl";
4986                     break;
4987                 case ANYOF_NCNTRL:
4988                     if (LOC)
4989                         ANYOF_CLASS_SET(ret, ANYOF_NCNTRL);
4990                     else {
4991                         for (value = 0; value < 256; value++)
4992                             if (!isCNTRL(value))
4993                                 ANYOF_BITMAP_SET(ret, value);
4994                     }
4995                     yesno = '!';
4996                     what = "Cntrl";
4997                     break;
4998                 case ANYOF_DIGIT:
4999                     if (LOC)
5000                         ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
5001                     else {
5002                         /* consecutive digits assumed */
5003                         for (value = '0'; value <= '9'; value++)
5004                             ANYOF_BITMAP_SET(ret, value);
5005                     }
5006                     yesno = '+';
5007                     what = "Digit";
5008                     break;
5009                 case ANYOF_NDIGIT:
5010                     if (LOC)
5011                         ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
5012                     else {
5013                         /* consecutive digits assumed */
5014                         for (value = 0; value < '0'; value++)
5015                             ANYOF_BITMAP_SET(ret, value);
5016                         for (value = '9' + 1; value < 256; value++)
5017                             ANYOF_BITMAP_SET(ret, value);
5018                     }
5019                     yesno = '!';
5020                     what = "Digit";
5021                     break;
5022                 case ANYOF_GRAPH:
5023                     if (LOC)
5024                         ANYOF_CLASS_SET(ret, ANYOF_GRAPH);
5025                     else {
5026                         for (value = 0; value < 256; value++)
5027                             if (isGRAPH(value))
5028                                 ANYOF_BITMAP_SET(ret, value);
5029                     }
5030                     yesno = '+';
5031                     what = "Graph";
5032                     break;
5033                 case ANYOF_NGRAPH:
5034                     if (LOC)
5035                         ANYOF_CLASS_SET(ret, ANYOF_NGRAPH);
5036                     else {
5037                         for (value = 0; value < 256; value++)
5038                             if (!isGRAPH(value))
5039                                 ANYOF_BITMAP_SET(ret, value);
5040                     }
5041                     yesno = '!';
5042                     what = "Graph";
5043                     break;
5044                 case ANYOF_LOWER:
5045                     if (LOC)
5046                         ANYOF_CLASS_SET(ret, ANYOF_LOWER);
5047                     else {
5048                         for (value = 0; value < 256; value++)
5049                             if (isLOWER(value))
5050                                 ANYOF_BITMAP_SET(ret, value);
5051                     }
5052                     yesno = '+';
5053                     what = "Lower";
5054                     break;
5055                 case ANYOF_NLOWER:
5056                     if (LOC)
5057                         ANYOF_CLASS_SET(ret, ANYOF_NLOWER);
5058                     else {
5059                         for (value = 0; value < 256; value++)
5060                             if (!isLOWER(value))
5061                                 ANYOF_BITMAP_SET(ret, value);
5062                     }
5063                     yesno = '!';
5064                     what = "Lower";
5065                     break;
5066                 case ANYOF_PRINT:
5067                     if (LOC)
5068                         ANYOF_CLASS_SET(ret, ANYOF_PRINT);
5069                     else {
5070                         for (value = 0; value < 256; value++)
5071                             if (isPRINT(value))
5072                                 ANYOF_BITMAP_SET(ret, value);
5073                     }
5074                     yesno = '+';
5075                     what = "Print";
5076                     break;
5077                 case ANYOF_NPRINT:
5078                     if (LOC)
5079                         ANYOF_CLASS_SET(ret, ANYOF_NPRINT);
5080                     else {
5081                         for (value = 0; value < 256; value++)
5082                             if (!isPRINT(value))
5083                                 ANYOF_BITMAP_SET(ret, value);
5084                     }
5085                     yesno = '!';
5086                     what = "Print";
5087                     break;
5088                 case ANYOF_PSXSPC:
5089                     if (LOC)
5090                         ANYOF_CLASS_SET(ret, ANYOF_PSXSPC);
5091                     else {
5092                         for (value = 0; value < 256; value++)
5093                             if (isPSXSPC(value))
5094                                 ANYOF_BITMAP_SET(ret, value);
5095                     }
5096                     yesno = '+';
5097                     what = "Space";
5098                     break;
5099                 case ANYOF_NPSXSPC:
5100                     if (LOC)
5101                         ANYOF_CLASS_SET(ret, ANYOF_NPSXSPC);
5102                     else {
5103                         for (value = 0; value < 256; value++)
5104                             if (!isPSXSPC(value))
5105                                 ANYOF_BITMAP_SET(ret, value);
5106                     }
5107                     yesno = '!';
5108                     what = "Space";
5109                     break;
5110                 case ANYOF_PUNCT:
5111                     if (LOC)
5112                         ANYOF_CLASS_SET(ret, ANYOF_PUNCT);
5113                     else {
5114                         for (value = 0; value < 256; value++)
5115                             if (isPUNCT(value))
5116                                 ANYOF_BITMAP_SET(ret, value);
5117                     }
5118                     yesno = '+';
5119                     what = "Punct";
5120                     break;
5121                 case ANYOF_NPUNCT:
5122                     if (LOC)
5123                         ANYOF_CLASS_SET(ret, ANYOF_NPUNCT);
5124                     else {
5125                         for (value = 0; value < 256; value++)
5126                             if (!isPUNCT(value))
5127                                 ANYOF_BITMAP_SET(ret, value);
5128                     }
5129                     yesno = '!';
5130                     what = "Punct";
5131                     break;
5132                 case ANYOF_SPACE:
5133                     if (LOC)
5134                         ANYOF_CLASS_SET(ret, ANYOF_SPACE);
5135                     else {
5136                         for (value = 0; value < 256; value++)
5137                             if (isSPACE(value))
5138                                 ANYOF_BITMAP_SET(ret, value);
5139                     }
5140                     yesno = '+';
5141                     what = "SpacePerl";
5142                     break;
5143                 case ANYOF_NSPACE:
5144                     if (LOC)
5145                         ANYOF_CLASS_SET(ret, ANYOF_NSPACE);
5146                     else {
5147                         for (value = 0; value < 256; value++)
5148                             if (!isSPACE(value))
5149                                 ANYOF_BITMAP_SET(ret, value);
5150                     }
5151                     yesno = '!';
5152                     what = "SpacePerl";
5153                     break;
5154                 case ANYOF_UPPER:
5155                     if (LOC)
5156                         ANYOF_CLASS_SET(ret, ANYOF_UPPER);
5157                     else {
5158                         for (value = 0; value < 256; value++)
5159                             if (isUPPER(value))
5160                                 ANYOF_BITMAP_SET(ret, value);
5161                     }
5162                     yesno = '+';
5163                     what = "Upper";
5164                     break;
5165                 case ANYOF_NUPPER:
5166                     if (LOC)
5167                         ANYOF_CLASS_SET(ret, ANYOF_NUPPER);
5168                     else {
5169                         for (value = 0; value < 256; value++)
5170                             if (!isUPPER(value))
5171                                 ANYOF_BITMAP_SET(ret, value);
5172                     }
5173                     yesno = '!';
5174                     what = "Upper";
5175                     break;
5176                 case ANYOF_XDIGIT:
5177                     if (LOC)
5178                         ANYOF_CLASS_SET(ret, ANYOF_XDIGIT);
5179                     else {
5180                         for (value = 0; value < 256; value++)
5181                             if (isXDIGIT(value))
5182                                 ANYOF_BITMAP_SET(ret, value);
5183                     }
5184                     yesno = '+';
5185                     what = "XDigit";
5186                     break;
5187                 case ANYOF_NXDIGIT:
5188                     if (LOC)
5189                         ANYOF_CLASS_SET(ret, ANYOF_NXDIGIT);
5190                     else {
5191                         for (value = 0; value < 256; value++)
5192                             if (!isXDIGIT(value))
5193                                 ANYOF_BITMAP_SET(ret, value);
5194                     }
5195                     yesno = '!';
5196                     what = "XDigit";
5197                     break;
5198                 case ANYOF_MAX:
5199                     /* this is to handle \p and \P */
5200                     break;
5201                 default:
5202                     vFAIL("Invalid [::] class");
5203                     break;
5204                 }
5205                 if (what) {
5206                     /* Strings such as "+utf8::isWord\n" */
5207                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::Is%s\n", yesno, what);
5208                 }
5209                 if (LOC)
5210                     ANYOF_FLAGS(ret) |= ANYOF_CLASS;
5211                 continue;
5212             }
5213         } /* end of namedclass \blah */
5214
5215         if (range) {
5216             if (prevvalue > (IV)value) /* b-a */ {
5217                 const int w = RExC_parse - rangebegin;
5218                 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
5219                 range = 0; /* not a valid range */
5220             }
5221         }
5222         else {
5223             prevvalue = value; /* save the beginning of the range */
5224             if (*RExC_parse == '-' && RExC_parse+1 < RExC_end &&
5225                 RExC_parse[1] != ']') {
5226                 RExC_parse++;
5227
5228                 /* a bad range like \w-, [:word:]- ? */
5229                 if (namedclass > OOB_NAMEDCLASS) {
5230                     if (ckWARN(WARN_REGEXP)) {
5231                         const int w =
5232                             RExC_parse >= rangebegin ?
5233                             RExC_parse - rangebegin : 0;
5234                         vWARN4(RExC_parse,
5235                                "False [] range \"%*.*s\"",
5236                                w, w, rangebegin);
5237                     }
5238                     if (!SIZE_ONLY)
5239                         ANYOF_BITMAP_SET(ret, '-');
5240                 } else
5241                     range = 1;  /* yeah, it's a range! */
5242                 continue;       /* but do it the next time */
5243             }
5244         }
5245
5246         /* now is the next time */
5247         if (!SIZE_ONLY) {
5248             IV i;
5249
5250             if (prevvalue < 256) {
5251                 const IV ceilvalue = value < 256 ? value : 255;
5252
5253 #ifdef EBCDIC
5254                 /* In EBCDIC [\x89-\x91] should include
5255                  * the \x8e but [i-j] should not. */
5256                 if (literal_endpoint == 2 &&
5257                     ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
5258                      (isUPPER(prevvalue) && isUPPER(ceilvalue))))
5259                 {
5260                     if (isLOWER(prevvalue)) {
5261                         for (i = prevvalue; i <= ceilvalue; i++)
5262                             if (isLOWER(i))
5263                                 ANYOF_BITMAP_SET(ret, i);
5264                     } else {
5265                         for (i = prevvalue; i <= ceilvalue; i++)
5266                             if (isUPPER(i))
5267                                 ANYOF_BITMAP_SET(ret, i);
5268                     }
5269                 }
5270                 else
5271 #endif
5272                       for (i = prevvalue; i <= ceilvalue; i++)
5273                           ANYOF_BITMAP_SET(ret, i);
5274           }
5275           if (value > 255 || UTF) {
5276                 const UV prevnatvalue  = NATIVE_TO_UNI(prevvalue);
5277                 const UV natvalue      = NATIVE_TO_UNI(value);
5278
5279                 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
5280                 if (prevnatvalue < natvalue) { /* what about > ? */
5281                     Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
5282                                    prevnatvalue, natvalue);
5283                 }
5284                 else if (prevnatvalue == natvalue) {
5285                     Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", natvalue);
5286                     if (FOLD) {
5287                          U8 foldbuf[UTF8_MAXBYTES_CASE+1];
5288                          STRLEN foldlen;
5289                          const UV f = to_uni_fold(natvalue, foldbuf, &foldlen);
5290
5291                          /* If folding and foldable and a single
5292                           * character, insert also the folded version
5293                           * to the charclass. */
5294                          if (f != value) {
5295                               if (foldlen == (STRLEN)UNISKIP(f))
5296                                   Perl_sv_catpvf(aTHX_ listsv,
5297                                                  "%04"UVxf"\n", f);
5298                               else {
5299                                   /* Any multicharacter foldings
5300                                    * require the following transform:
5301                                    * [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst)
5302                                    * where E folds into "pq" and F folds
5303                                    * into "rst", all other characters
5304                                    * fold to single characters.  We save
5305                                    * away these multicharacter foldings,
5306                                    * to be later saved as part of the
5307                                    * additional "s" data. */
5308                                   SV *sv;
5309
5310                                   if (!unicode_alternate)
5311                                       unicode_alternate = newAV();
5312                                   sv = newSVpvn((char*)foldbuf, foldlen);
5313                                   SvUTF8_on(sv);
5314                                   av_push(unicode_alternate, sv);
5315                               }
5316                          }
5317
5318                          /* If folding and the value is one of the Greek
5319                           * sigmas insert a few more sigmas to make the
5320                           * folding rules of the sigmas to work right.
5321                           * Note that not all the possible combinations
5322                           * are handled here: some of them are handled
5323                           * by the standard folding rules, and some of
5324                           * them (literal or EXACTF cases) are handled
5325                           * during runtime in regexec.c:S_find_byclass(). */
5326                          if (value == UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) {
5327                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
5328                                              (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA);
5329                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
5330                                              (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
5331                          }
5332                          else if (value == UNICODE_GREEK_CAPITAL_LETTER_SIGMA)
5333                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
5334                                              (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
5335                     }
5336                 }
5337             }
5338 #ifdef EBCDIC
5339             literal_endpoint = 0;
5340 #endif
5341         }
5342
5343         range = 0; /* this range (if it was one) is done now */
5344     }
5345
5346     if (need_class) {
5347         ANYOF_FLAGS(ret) |= ANYOF_LARGE;
5348         if (SIZE_ONLY)
5349             RExC_size += ANYOF_CLASS_ADD_SKIP;
5350         else
5351             RExC_emit += ANYOF_CLASS_ADD_SKIP;
5352     }
5353
5354     /* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */
5355     if (!SIZE_ONLY &&
5356          /* If the only flag is folding (plus possibly inversion). */
5357         ((ANYOF_FLAGS(ret) & (ANYOF_FLAGS_ALL ^ ANYOF_INVERT)) == ANYOF_FOLD)
5358        ) {
5359         for (value = 0; value < 256; ++value) {
5360             if (ANYOF_BITMAP_TEST(ret, value)) {
5361                 UV fold = PL_fold[value];
5362
5363                 if (fold != value)
5364                     ANYOF_BITMAP_SET(ret, fold);
5365             }
5366         }
5367         ANYOF_FLAGS(ret) &= ~ANYOF_FOLD;
5368     }
5369
5370     /* optimize inverted simple patterns (e.g. [^a-z]) */
5371     if (!SIZE_ONLY && optimize_invert &&
5372         /* If the only flag is inversion. */
5373         (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT) {
5374         for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
5375             ANYOF_BITMAP(ret)[value] ^= ANYOF_FLAGS_ALL;
5376         ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL;
5377     }
5378
5379     if (!SIZE_ONLY) {
5380         AV * const av = newAV();
5381         SV *rv;
5382
5383         /* The 0th element stores the character class description
5384          * in its textual form: used later (regexec.c:Perl_regclass_swash())
5385          * to initialize the appropriate swash (which gets stored in
5386          * the 1st element), and also useful for dumping the regnode.
5387          * The 2nd element stores the multicharacter foldings,
5388          * used later (regexec.c:S_reginclass()). */
5389         av_store(av, 0, listsv);
5390         av_store(av, 1, NULL);
5391         av_store(av, 2, (SV*)unicode_alternate);
5392         rv = newRV_noinc((SV*)av);
5393         n = add_data(pRExC_state, 1, "s");
5394         RExC_rx->data->data[n] = (void*)rv;
5395         ARG_SET(ret, n);
5396     }
5397
5398     return ret;
5399 }
5400
5401 STATIC char*
5402 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
5403 {
5404     char* const retval = RExC_parse++;
5405
5406     for (;;) {
5407         if (*RExC_parse == '(' && RExC_parse[1] == '?' &&
5408                 RExC_parse[2] == '#') {
5409             while (*RExC_parse != ')') {
5410                 if (RExC_parse == RExC_end)
5411                     FAIL("Sequence (?#... not terminated");
5412                 RExC_parse++;
5413             }
5414             RExC_parse++;
5415             continue;
5416         }
5417         if (RExC_flags & PMf_EXTENDED) {
5418             if (isSPACE(*RExC_parse)) {
5419                 RExC_parse++;
5420                 continue;
5421             }
5422             else if (*RExC_parse == '#') {
5423                 while (RExC_parse < RExC_end)
5424                     if (*RExC_parse++ == '\n') break;
5425                 continue;
5426             }
5427         }
5428         return retval;
5429     }
5430 }
5431
5432 /*
5433 - reg_node - emit a node
5434 */
5435 STATIC regnode *                        /* Location. */
5436 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
5437 {
5438     dVAR;
5439     register regnode *ptr;
5440     regnode * const ret = RExC_emit;
5441
5442     if (SIZE_ONLY) {
5443         SIZE_ALIGN(RExC_size);
5444         RExC_size += 1;
5445         return(ret);
5446     }
5447
5448     NODE_ALIGN_FILL(ret);
5449     ptr = ret;
5450     FILL_ADVANCE_NODE(ptr, op);
5451     if (RExC_offsets) {         /* MJD */
5452         MJD_OFFSET_DEBUG(("%s:%u: (op %s) %s %u <- %u (len %u) (max %u).\n", 
5453               "reg_node", __LINE__, 
5454               reg_name[op],
5455               RExC_emit - RExC_emit_start > RExC_offsets[0] 
5456               ? "Overwriting end of array!\n" : "OK",
5457               RExC_emit - RExC_emit_start,
5458               RExC_parse - RExC_start,
5459               RExC_offsets[0])); 
5460         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
5461     }
5462             
5463     RExC_emit = ptr;
5464
5465     return(ret);
5466 }
5467
5468 /*
5469 - reganode - emit a node with an argument
5470 */
5471 STATIC regnode *                        /* Location. */
5472 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
5473 {
5474     dVAR;
5475     register regnode *ptr;
5476     regnode * const ret = RExC_emit;
5477
5478     if (SIZE_ONLY) {
5479         SIZE_ALIGN(RExC_size);
5480         RExC_size += 2;
5481         return(ret);
5482     }
5483
5484     NODE_ALIGN_FILL(ret);
5485     ptr = ret;
5486     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
5487     if (RExC_offsets) {         /* MJD */
5488         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %u <- %u (max %u).\n", 
5489               "reganode",
5490               __LINE__,
5491               reg_name[op],
5492               RExC_emit - RExC_emit_start > RExC_offsets[0] ? 
5493               "Overwriting end of array!\n" : "OK",
5494               RExC_emit - RExC_emit_start,
5495               RExC_parse - RExC_start,
5496               RExC_offsets[0])); 
5497         Set_Cur_Node_Offset;
5498     }
5499             
5500     RExC_emit = ptr;
5501
5502     return(ret);
5503 }
5504
5505 /*
5506 - reguni - emit (if appropriate) a Unicode character
5507 */
5508 STATIC STRLEN
5509 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
5510 {
5511     dVAR;
5512     return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
5513 }
5514
5515 /*
5516 - reginsert - insert an operator in front of already-emitted operand
5517 *
5518 * Means relocating the operand.
5519 */
5520 STATIC void
5521 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd)
5522 {
5523     dVAR;
5524     register regnode *src;
5525     register regnode *dst;
5526     register regnode *place;
5527     const int offset = regarglen[(U8)op];
5528
5529 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
5530
5531     if (SIZE_ONLY) {
5532         RExC_size += NODE_STEP_REGNODE + offset;
5533         return;
5534     }
5535
5536     src = RExC_emit;
5537     RExC_emit += NODE_STEP_REGNODE + offset;
5538     dst = RExC_emit;
5539     while (src > opnd) {
5540         StructCopy(--src, --dst, regnode);
5541         if (RExC_offsets) {     /* MJD 20010112 */
5542             MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %u -> %u (max %u).\n",
5543                   "reg_insert",
5544                   __LINE__,
5545                   reg_name[op],
5546                   dst - RExC_emit_start > RExC_offsets[0] 
5547                   ? "Overwriting end of array!\n" : "OK",
5548                   src - RExC_emit_start,
5549                   dst - RExC_emit_start,
5550                   RExC_offsets[0])); 
5551             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
5552             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
5553         }
5554     }
5555     
5556
5557     place = opnd;               /* Op node, where operand used to be. */
5558     if (RExC_offsets) {         /* MJD */
5559         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %u <- %u (max %u).\n", 
5560               "reginsert",
5561               __LINE__,
5562               reg_name[op],
5563               place - RExC_emit_start > RExC_offsets[0] 
5564               ? "Overwriting end of array!\n" : "OK",
5565               place - RExC_emit_start,
5566               RExC_parse - RExC_start,
5567               RExC_offsets[0])); 
5568         Set_Node_Offset(place, RExC_parse);
5569         Set_Node_Length(place, 1);
5570     }
5571     src = NEXTOPER(place);
5572     FILL_ADVANCE_NODE(place, op);
5573     Zero(src, offset, regnode);
5574 }
5575
5576 /*
5577 - regtail - set the next-pointer at the end of a node chain of p to val.
5578 */
5579 /* TODO: All three parms should be const */
5580 STATIC void
5581 S_regtail(pTHX_ const RExC_state_t *pRExC_state, regnode *p, const regnode *val)
5582 {
5583     dVAR;
5584     register regnode *scan;
5585
5586     if (SIZE_ONLY)
5587         return;
5588
5589     /* Find last node. */
5590     scan = p;
5591     for (;;) {
5592         regnode * const temp = regnext(scan);
5593         if (temp == NULL)
5594             break;
5595         scan = temp;
5596     }
5597
5598     if (reg_off_by_arg[OP(scan)]) {
5599         ARG_SET(scan, val - scan);
5600     }
5601     else {
5602         NEXT_OFF(scan) = val - scan;
5603     }
5604 }
5605
5606 /*
5607  - regcurly - a little FSA that accepts {\d+,?\d*}
5608  */
5609 STATIC I32
5610 S_regcurly(register const char *s)
5611 {
5612     if (*s++ != '{')
5613         return FALSE;
5614     if (!isDIGIT(*s))
5615         return FALSE;
5616     while (isDIGIT(*s))
5617         s++;
5618     if (*s == ',')
5619         s++;
5620     while (isDIGIT(*s))
5621         s++;
5622     if (*s != '}')
5623         return FALSE;
5624     return TRUE;
5625 }
5626
5627
5628 /*
5629  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
5630  */
5631 void
5632 Perl_regdump(pTHX_ const regexp *r)
5633 {
5634 #ifdef DEBUGGING
5635     dVAR;
5636     SV * const sv = sv_newmortal();
5637
5638     (void)dumpuntil(r, r->program, r->program + 1, NULL, sv, 0);
5639
5640     /* Header fields of interest. */
5641     if (r->anchored_substr)
5642         PerlIO_printf(Perl_debug_log,
5643                       "anchored \"%s%.*s%s\"%s at %"IVdf" ",
5644                       PL_colors[0],
5645                       (int)(SvCUR(r->anchored_substr) - (SvTAIL(r->anchored_substr)!=0)),
5646                       SvPVX_const(r->anchored_substr),
5647                       PL_colors[1],
5648                       SvTAIL(r->anchored_substr) ? "$" : "",
5649                       (IV)r->anchored_offset);
5650     else if (r->anchored_utf8)
5651         PerlIO_printf(Perl_debug_log,
5652                       "anchored utf8 \"%s%.*s%s\"%s at %"IVdf" ",
5653                       PL_colors[0],
5654                       (int)(SvCUR(r->anchored_utf8) - (SvTAIL(r->anchored_utf8)!=0)),
5655                       SvPVX_const(r->anchored_utf8),
5656                       PL_colors[1],
5657                       SvTAIL(r->anchored_utf8) ? "$" : "",
5658                       (IV)r->anchored_offset);
5659     if (r->float_substr)
5660         PerlIO_printf(Perl_debug_log,
5661                       "floating \"%s%.*s%s\"%s at %"IVdf"..%"UVuf" ",
5662                       PL_colors[0],
5663                       (int)(SvCUR(r->float_substr) - (SvTAIL(r->float_substr)!=0)),
5664                       SvPVX_const(r->float_substr),
5665                       PL_colors[1],
5666                       SvTAIL(r->float_substr) ? "$" : "",
5667                       (IV)r->float_min_offset, (UV)r->float_max_offset);
5668     else if (r->float_utf8)
5669         PerlIO_printf(Perl_debug_log,
5670                       "floating utf8 \"%s%.*s%s\"%s at %"IVdf"..%"UVuf" ",
5671                       PL_colors[0],
5672                       (int)(SvCUR(r->float_utf8) - (SvTAIL(r->float_utf8)!=0)),
5673                       SvPVX_const(r->float_utf8),
5674                       PL_colors[1],
5675                       SvTAIL(r->float_utf8) ? "$" : "",
5676                       (IV)r->float_min_offset, (UV)r->float_max_offset);
5677     if (r->check_substr || r->check_utf8)
5678         PerlIO_printf(Perl_debug_log,
5679                       r->check_substr == r->float_substr
5680                       && r->check_utf8 == r->float_utf8
5681                       ? "(checking floating" : "(checking anchored");
5682     if (r->reganch & ROPT_NOSCAN)
5683         PerlIO_printf(Perl_debug_log, " noscan");
5684     if (r->reganch & ROPT_CHECK_ALL)
5685         PerlIO_printf(Perl_debug_log, " isall");
5686     if (r->check_substr || r->check_utf8)
5687         PerlIO_printf(Perl_debug_log, ") ");
5688
5689     if (r->regstclass) {
5690         regprop(r, sv, r->regstclass);
5691         PerlIO_printf(Perl_debug_log, "stclass \"%s\" ", SvPVX_const(sv));
5692     }
5693     if (r->reganch & ROPT_ANCH) {
5694         PerlIO_printf(Perl_debug_log, "anchored");
5695         if (r->reganch & ROPT_ANCH_BOL)
5696             PerlIO_printf(Perl_debug_log, "(BOL)");
5697         if (r->reganch & ROPT_ANCH_MBOL)
5698             PerlIO_printf(Perl_debug_log, "(MBOL)");
5699         if (r->reganch & ROPT_ANCH_SBOL)
5700             PerlIO_printf(Perl_debug_log, "(SBOL)");
5701         if (r->reganch & ROPT_ANCH_GPOS)
5702             PerlIO_printf(Perl_debug_log, "(GPOS)");
5703         PerlIO_putc(Perl_debug_log, ' ');
5704     }
5705     if (r->reganch & ROPT_GPOS_SEEN)
5706         PerlIO_printf(Perl_debug_log, "GPOS ");
5707     if (r->reganch & ROPT_SKIP)
5708         PerlIO_printf(Perl_debug_log, "plus ");
5709     if (r->reganch & ROPT_IMPLICIT)
5710         PerlIO_printf(Perl_debug_log, "implicit ");
5711     PerlIO_printf(Perl_debug_log, "minlen %ld ", (long) r->minlen);
5712     if (r->reganch & ROPT_EVAL_SEEN)
5713         PerlIO_printf(Perl_debug_log, "with eval ");
5714     PerlIO_printf(Perl_debug_log, "\n");
5715     if (r->offsets) {
5716         const U32 len = r->offsets[0];
5717         GET_RE_DEBUG_FLAGS_DECL;
5718         DEBUG_OFFSETS_r({
5719             U32 i;
5720             PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)r->offsets[0]);
5721             for (i = 1; i <= len; i++)
5722                 PerlIO_printf(Perl_debug_log, "%"UVuf"[%"UVuf"] ", 
5723                     (UV)r->offsets[i*2-1], (UV)r->offsets[i*2]);
5724             PerlIO_printf(Perl_debug_log, "\n");
5725         });
5726     }
5727 #else
5728     PERL_UNUSED_CONTEXT;
5729     PERL_UNUSED_ARG(r);
5730 #endif  /* DEBUGGING */
5731 }
5732
5733 /*
5734 - regprop - printable representation of opcode
5735 */
5736 void
5737 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
5738 {
5739 #ifdef DEBUGGING
5740     dVAR;
5741     register int k;
5742
5743     sv_setpvn(sv, "", 0);
5744     if (OP(o) >= reg_num)               /* regnode.type is unsigned */
5745         /* It would be nice to FAIL() here, but this may be called from
5746            regexec.c, and it would be hard to supply pRExC_state. */
5747         Perl_croak(aTHX_ "Corrupted regexp opcode");
5748     sv_catpv(sv, reg_name[OP(o)]); /* Take off const! */
5749
5750     k = PL_regkind[(U8)OP(o)];
5751
5752     if (k == EXACT) {
5753         SV * const dsv = sv_2mortal(newSVpvs(""));
5754         /* Using is_utf8_string() is a crude hack but it may
5755          * be the best for now since we have no flag "this EXACTish
5756          * node was UTF-8" --jhi */
5757         const bool do_utf8 = is_utf8_string((U8*)STRING(o), STR_LEN(o));
5758         const char * const s = do_utf8 ?
5759           pv_uni_display(dsv, (U8*)STRING(o), STR_LEN(o), 60,
5760                          UNI_DISPLAY_REGEX) :
5761           STRING(o);
5762         const int len = do_utf8 ?
5763           strlen(s) :
5764           STR_LEN(o);
5765         Perl_sv_catpvf(aTHX_ sv, " <%s%.*s%s>",
5766                        PL_colors[0],
5767                        len, s,
5768                        PL_colors[1]);
5769     } else if (k == TRIE) {
5770         NOOP;
5771         /* print the details od the trie in dumpuntil instead, as
5772          * prog->data isn't available here */
5773     } else if (k == CURLY) {
5774         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
5775             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
5776         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
5777     }
5778     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
5779         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
5780     else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP )
5781         Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
5782     else if (k == LOGICAL)
5783         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);     /* 2: embedded, otherwise 1 */
5784     else if (k == ANYOF) {
5785         int i, rangestart = -1;
5786         const U8 flags = ANYOF_FLAGS(o);
5787
5788         /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
5789         static const char * const anyofs[] = {
5790             "\\w",
5791             "\\W",
5792             "\\s",
5793             "\\S",
5794             "\\d",
5795             "\\D",
5796             "[:alnum:]",
5797             "[:^alnum:]",
5798             "[:alpha:]",
5799             "[:^alpha:]",
5800             "[:ascii:]",
5801             "[:^ascii:]",
5802             "[:ctrl:]",
5803             "[:^ctrl:]",
5804             "[:graph:]",
5805             "[:^graph:]",
5806             "[:lower:]",
5807             "[:^lower:]",
5808             "[:print:]",
5809             "[:^print:]",
5810             "[:punct:]",
5811             "[:^punct:]",
5812             "[:upper:]",
5813             "[:^upper:]",
5814             "[:xdigit:]",
5815             "[:^xdigit:]",
5816             "[:space:]",
5817             "[:^space:]",
5818             "[:blank:]",
5819             "[:^blank:]"
5820         };
5821
5822         if (flags & ANYOF_LOCALE)
5823             sv_catpvs(sv, "{loc}");
5824         if (flags & ANYOF_FOLD)
5825             sv_catpvs(sv, "{i}");
5826         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
5827         if (flags & ANYOF_INVERT)
5828             sv_catpvs(sv, "^");
5829         for (i = 0; i <= 256; i++) {
5830             if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
5831                 if (rangestart == -1)
5832                     rangestart = i;
5833             } else if (rangestart != -1) {
5834                 if (i <= rangestart + 3)
5835                     for (; rangestart < i; rangestart++)
5836                         put_byte(sv, rangestart);
5837                 else {
5838                     put_byte(sv, rangestart);
5839                     sv_catpvs(sv, "-");
5840                     put_byte(sv, i - 1);
5841                 }
5842                 rangestart = -1;
5843             }
5844         }
5845
5846         if (o->flags & ANYOF_CLASS)
5847             for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
5848                 if (ANYOF_CLASS_TEST(o,i))
5849                     sv_catpv(sv, anyofs[i]);
5850
5851         if (flags & ANYOF_UNICODE)
5852             sv_catpvs(sv, "{unicode}");
5853         else if (flags & ANYOF_UNICODE_ALL)
5854             sv_catpvs(sv, "{unicode_all}");
5855
5856         {
5857             SV *lv;
5858             SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
5859         
5860             if (lv) {
5861                 if (sw) {
5862                     U8 s[UTF8_MAXBYTES_CASE+1];
5863                 
5864                     for (i = 0; i <= 256; i++) { /* just the first 256 */
5865                         uvchr_to_utf8(s, i);
5866                         
5867                         if (i < 256 && swash_fetch(sw, s, TRUE)) {
5868                             if (rangestart == -1)
5869                                 rangestart = i;
5870                         } else if (rangestart != -1) {
5871                             if (i <= rangestart + 3)
5872                                 for (; rangestart < i; rangestart++) {
5873                                     const U8 * const e = uvchr_to_utf8(s,rangestart);
5874                                     U8 *p;
5875                                     for(p = s; p < e; p++)
5876                                         put_byte(sv, *p);
5877                                 }
5878                             else {
5879                                 const U8 *e = uvchr_to_utf8(s,rangestart);
5880                                 U8 *p;
5881                                 for (p = s; p < e; p++)
5882                                     put_byte(sv, *p);
5883                                 sv_catpvs(sv, "-");
5884                                 e = uvchr_to_utf8(s, i-1);
5885                                 for (p = s; p < e; p++)
5886                                     put_byte(sv, *p);
5887                                 }
5888                                 rangestart = -1;
5889                             }
5890                         }
5891                         
5892                     sv_catpvs(sv, "..."); /* et cetera */
5893                 }
5894
5895                 {
5896                     char *s = savesvpv(lv);
5897                     char * const origs = s;
5898                 
5899                     while(*s && *s != '\n') s++;
5900                 
5901                     if (*s == '\n') {
5902                         const char * const t = ++s;
5903                         
5904                         while (*s) {
5905                             if (*s == '\n')
5906                                 *s = ' ';
5907                             s++;
5908                         }
5909                         if (s[-1] == ' ')
5910                             s[-1] = 0;
5911                         
5912                         sv_catpv(sv, t);
5913                     }
5914                 
5915                     Safefree(origs);
5916                 }
5917             }
5918         }
5919
5920         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
5921     }
5922     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
5923         Perl_sv_catpvf(aTHX_ sv, "[-%d]", o->flags);
5924 #else
5925     PERL_UNUSED_CONTEXT;
5926     PERL_UNUSED_ARG(sv);
5927     PERL_UNUSED_ARG(o);
5928 #endif  /* DEBUGGING */
5929 }
5930
5931 SV *
5932 Perl_re_intuit_string(pTHX_ regexp *prog)
5933 {                               /* Assume that RE_INTUIT is set */
5934     dVAR;
5935     GET_RE_DEBUG_FLAGS_DECL;
5936     PERL_UNUSED_CONTEXT;
5937
5938     DEBUG_COMPILE_r(
5939         {
5940             const char * const s = SvPV_nolen_const(prog->check_substr
5941                       ? prog->check_substr : prog->check_utf8);
5942
5943             if (!PL_colorset) reginitcolors();
5944             PerlIO_printf(Perl_debug_log,
5945                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
5946                       PL_colors[4],
5947                       prog->check_substr ? "" : "utf8 ",
5948                       PL_colors[5],PL_colors[0],
5949                       s,
5950                       PL_colors[1],
5951                       (strlen(s) > 60 ? "..." : ""));
5952         } );
5953
5954     return prog->check_substr ? prog->check_substr : prog->check_utf8;
5955 }
5956
5957 void
5958 Perl_pregfree(pTHX_ struct regexp *r)
5959 {
5960     dVAR;
5961 #ifdef DEBUGGING
5962     SV * const dsv = PERL_DEBUG_PAD_ZERO(0);
5963 #endif
5964     GET_RE_DEBUG_FLAGS_DECL;
5965
5966     if (!r || (--r->refcnt > 0))
5967         return;
5968     DEBUG_r(if (re_debug_flags && (SvIV(re_debug_flags) & RE_DEBUG_COMPILE)) {
5969         const char * const s = (r->reganch & ROPT_UTF8)
5970             ? pv_uni_display(dsv, (U8*)r->precomp, r->prelen, 60, UNI_DISPLAY_REGEX)
5971             : pv_display(dsv, r->precomp, r->prelen, 0, 60);
5972         const int len = SvCUR(dsv);
5973          if (!PL_colorset)
5974               reginitcolors();
5975          PerlIO_printf(Perl_debug_log,
5976                        "%sFreeing REx:%s %s%*.*s%s%s\n",
5977                        PL_colors[4],PL_colors[5],PL_colors[0],
5978                        len, len, s,
5979                        PL_colors[1],
5980                        len > 60 ? "..." : "");
5981     });
5982
5983     /* gcov results gave these as non-null 100% of the time, so there's no
5984        optimisation in checking them before calling Safefree  */
5985     Safefree(r->precomp);
5986     Safefree(r->offsets);             /* 20010421 MJD */
5987     RX_MATCH_COPY_FREE(r);
5988 #ifdef PERL_OLD_COPY_ON_WRITE
5989     if (r->saved_copy)
5990         SvREFCNT_dec(r->saved_copy);
5991 #endif
5992     if (r->substrs) {
5993         if (r->anchored_substr)
5994             SvREFCNT_dec(r->anchored_substr);
5995         if (r->anchored_utf8)
5996             SvREFCNT_dec(r->anchored_utf8);
5997         if (r->float_substr)
5998             SvREFCNT_dec(r->float_substr);
5999         if (r->float_utf8)
6000             SvREFCNT_dec(r->float_utf8);
6001         Safefree(r->substrs);
6002     }
6003     if (r->data) {
6004         int n = r->data->count;
6005         PAD* new_comppad = NULL;
6006         PAD* old_comppad;
6007         PADOFFSET refcnt;
6008
6009         while (--n >= 0) {
6010           /* If you add a ->what type here, update the comment in regcomp.h */
6011             switch (r->data->what[n]) {
6012             case 's':
6013                 SvREFCNT_dec((SV*)r->data->data[n]);
6014                 break;
6015             case 'f':
6016                 Safefree(r->data->data[n]);
6017                 break;
6018             case 'p':
6019                 new_comppad = (AV*)r->data->data[n];
6020                 break;
6021             case 'o':
6022                 if (new_comppad == NULL)
6023                     Perl_croak(aTHX_ "panic: pregfree comppad");
6024                 PAD_SAVE_LOCAL(old_comppad,
6025                     /* Watch out for global destruction's random ordering. */
6026                     (SvTYPE(new_comppad) == SVt_PVAV) ? new_comppad : NULL
6027                 );
6028                 OP_REFCNT_LOCK;
6029                 refcnt = OpREFCNT_dec((OP_4tree*)r->data->data[n]);
6030                 OP_REFCNT_UNLOCK;
6031                 if (!refcnt)
6032                     op_free((OP_4tree*)r->data->data[n]);
6033
6034                 PAD_RESTORE_LOCAL(old_comppad);
6035                 SvREFCNT_dec((SV*)new_comppad);
6036                 new_comppad = NULL;
6037                 break;
6038             case 'n':
6039                 break;
6040             case 't':
6041                     {
6042                         reg_trie_data * const trie=(reg_trie_data*)r->data->data[n];
6043                         U32 refcount;
6044                         OP_REFCNT_LOCK;
6045                         refcount = --trie->refcount;
6046                         OP_REFCNT_UNLOCK;
6047                         if ( !refcount ) {
6048                             Safefree(trie->charmap);
6049                             if (trie->widecharmap)
6050                                 SvREFCNT_dec((SV*)trie->widecharmap);
6051                             Safefree(trie->states);
6052                             Safefree(trie->trans);
6053 #ifdef DEBUGGING
6054                             if (trie->words)
6055                                 SvREFCNT_dec((SV*)trie->words);
6056                             if (trie->revcharmap)
6057                                 SvREFCNT_dec((SV*)trie->revcharmap);
6058 #endif
6059                             Safefree(r->data->data[n]); /* do this last!!!! */
6060                         }
6061                         break;
6062                     }
6063             default:
6064                 Perl_croak(aTHX_ "panic: regfree data code '%c'", r->data->what[n]);
6065             }
6066         }
6067         Safefree(r->data->what);
6068         Safefree(r->data);
6069     }
6070     Safefree(r->startp);
6071     Safefree(r->endp);
6072     Safefree(r);
6073 }
6074
6075 #ifndef PERL_IN_XSUB_RE
6076 /*
6077  - regnext - dig the "next" pointer out of a node
6078  */
6079 regnode *
6080 Perl_regnext(pTHX_ register regnode *p)
6081 {
6082     dVAR;
6083     register I32 offset;
6084
6085     if (p == &PL_regdummy)
6086         return(NULL);
6087
6088     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
6089     if (offset == 0)
6090         return(NULL);
6091
6092     return(p+offset);
6093 }
6094 #endif
6095
6096 STATIC void     
6097 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
6098 {
6099     va_list args;
6100     STRLEN l1 = strlen(pat1);
6101     STRLEN l2 = strlen(pat2);
6102     char buf[512];
6103     SV *msv;
6104     const char *message;
6105
6106     if (l1 > 510)
6107         l1 = 510;
6108     if (l1 + l2 > 510)
6109         l2 = 510 - l1;
6110     Copy(pat1, buf, l1 , char);
6111     Copy(pat2, buf + l1, l2 , char);
6112     buf[l1 + l2] = '\n';
6113     buf[l1 + l2 + 1] = '\0';
6114 #ifdef I_STDARG
6115     /* ANSI variant takes additional second argument */
6116     va_start(args, pat2);
6117 #else
6118     va_start(args);
6119 #endif
6120     msv = vmess(buf, &args);
6121     va_end(args);
6122     message = SvPV_const(msv,l1);
6123     if (l1 > 512)
6124         l1 = 512;
6125     Copy(message, buf, l1 , char);
6126     buf[l1-1] = '\0';                   /* Overwrite \n */
6127     Perl_croak(aTHX_ "%s", buf);
6128 }
6129
6130 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
6131
6132 #ifndef PERL_IN_XSUB_RE
6133 void
6134 Perl_save_re_context(pTHX)
6135 {
6136     dVAR;
6137
6138     struct re_save_state *state;
6139
6140     SAVEVPTR(PL_curcop);
6141     SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
6142
6143     state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
6144     PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
6145     SSPUSHINT(SAVEt_RE_STATE);
6146
6147     Copy(&PL_reg_state, state, 1, struct re_save_state);
6148
6149     PL_reg_start_tmp = 0;
6150     PL_reg_start_tmpl = 0;
6151     PL_reg_oldsaved = NULL;
6152     PL_reg_oldsavedlen = 0;
6153     PL_reg_maxiter = 0;
6154     PL_reg_leftiter = 0;
6155     PL_reg_poscache = NULL;
6156     PL_reg_poscache_size = 0;
6157 #ifdef PERL_OLD_COPY_ON_WRITE
6158     PL_nrs = NULL;
6159 #endif
6160
6161     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
6162     if (PL_curpm) {
6163         const REGEXP * const rx = PM_GETRE(PL_curpm);
6164         if (rx) {
6165             U32 i;
6166             for (i = 1; i <= rx->nparens; i++) {
6167                 char digits[TYPE_CHARS(long)];
6168                 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
6169                 GV *const *const gvp
6170                     = (GV**)hv_fetch(PL_defstash, digits, len, 0);
6171
6172                 if (gvp) {
6173                     GV * const gv = *gvp;
6174                     if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
6175                         save_scalar(gv);
6176                 }
6177             }
6178         }
6179     }
6180 }
6181 #endif
6182
6183 static void
6184 clear_re(pTHX_ void *r)
6185 {
6186     dVAR;
6187     ReREFCNT_dec((regexp *)r);
6188 }
6189
6190 #ifdef DEBUGGING
6191
6192 STATIC void
6193 S_put_byte(pTHX_ SV *sv, int c)
6194 {
6195     if (isCNTRL(c) || c == 255 || !isPRINT(c))
6196         Perl_sv_catpvf(aTHX_ sv, "\\%o", c);
6197     else if (c == '-' || c == ']' || c == '\\' || c == '^')
6198         Perl_sv_catpvf(aTHX_ sv, "\\%c", c);
6199     else
6200         Perl_sv_catpvf(aTHX_ sv, "%c", c);
6201 }
6202
6203
6204 STATIC const regnode *
6205 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
6206             const regnode *last, SV* sv, I32 l)
6207 {
6208     dVAR;
6209     register U8 op = EXACT;     /* Arbitrary non-END op. */
6210     register const regnode *next;
6211
6212     while (op != END && (!last || node < last)) {
6213         /* While that wasn't END last time... */
6214
6215         NODE_ALIGN(node);
6216         op = OP(node);
6217         if (op == CLOSE)
6218             l--;        
6219         next = regnext((regnode *)node);
6220         /* Where, what. */
6221         if (OP(node) == OPTIMIZED)
6222             goto after_print;
6223         regprop(r, sv, node);
6224         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
6225                       (int)(2*l + 1), "", SvPVX_const(sv));
6226         if (next == NULL)               /* Next ptr. */
6227             PerlIO_printf(Perl_debug_log, "(0)");
6228         else
6229             PerlIO_printf(Perl_debug_log, "(%"IVdf")", (IV)(next - start));
6230         (void)PerlIO_putc(Perl_debug_log, '\n');
6231       after_print:
6232         if (PL_regkind[(U8)op] == BRANCHJ) {
6233             register const regnode *nnode = (OP(next) == LONGJMP
6234                                              ? regnext((regnode *)next)
6235                                              : next);
6236             if (last && nnode > last)
6237                 nnode = last;
6238             node = dumpuntil(r, start, NEXTOPER(NEXTOPER(node)), nnode, sv, l + 1);
6239         }
6240         else if (PL_regkind[(U8)op] == BRANCH) {
6241             node = dumpuntil(r, start, NEXTOPER(node), next, sv, l + 1);
6242         }
6243         else if ( PL_regkind[(U8)op]  == TRIE ) {
6244             const I32 n = ARG(node);
6245             const reg_trie_data * const trie = (reg_trie_data*)r->data->data[n];
6246             const I32 arry_len = av_len(trie->words)+1;
6247             I32 word_idx;
6248             PerlIO_printf(Perl_debug_log,
6249                        "%*s[Words:%d Chars Stored:%d Unique Chars:%d States:%"IVdf"%s]\n",
6250                        (int)(2*(l+3)),
6251                        "",
6252                        trie->wordcount,
6253                        (int)trie->charcount,
6254                        trie->uniquecharcount,
6255                        (IV)trie->laststate-1,
6256                        node->flags ? " EVAL mode" : "");
6257
6258             for (word_idx=0; word_idx < arry_len; word_idx++) {
6259                 SV ** const elem_ptr = av_fetch(trie->words,word_idx,0);
6260                 if (elem_ptr) {
6261                     PerlIO_printf(Perl_debug_log, "%*s<%s%s%s>\n",
6262                        (int)(2*(l+4)), "",
6263                        PL_colors[0],
6264                        SvPV_nolen_const(*elem_ptr),
6265                        PL_colors[1]
6266                     );
6267                     /*
6268                     if (next == NULL)
6269                         PerlIO_printf(Perl_debug_log, "(0)\n");
6270                     else
6271                         PerlIO_printf(Perl_debug_log, "(%"IVdf")\n", (IV)(next - start));
6272                     */
6273                 }
6274
6275             }
6276
6277             node = NEXTOPER(node);
6278             node += regarglen[(U8)op];
6279
6280         }
6281         else if ( op == CURLY) {   /* "next" might be very big: optimizer */
6282             node = dumpuntil(r, start, NEXTOPER(node) + EXTRA_STEP_2ARGS,
6283                              NEXTOPER(node) + EXTRA_STEP_2ARGS + 1, sv, l + 1);
6284         }
6285         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
6286             node = dumpuntil(r, start, NEXTOPER(node) + EXTRA_STEP_2ARGS,
6287                              next, sv, l + 1);
6288         }
6289         else if ( op == PLUS || op == STAR) {
6290             node = dumpuntil(r, start, NEXTOPER(node), NEXTOPER(node) + 1, sv, l + 1);
6291         }
6292         else if (op == ANYOF) {
6293             /* arglen 1 + class block */
6294             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_LARGE)
6295                     ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
6296             node = NEXTOPER(node);
6297         }
6298         else if (PL_regkind[(U8)op] == EXACT) {
6299             /* Literal string, where present. */
6300             node += NODE_SZ_STR(node) - 1;
6301             node = NEXTOPER(node);
6302         }
6303         else {
6304             node = NEXTOPER(node);
6305             node += regarglen[(U8)op];
6306         }
6307         if (op == CURLYX || op == OPEN)
6308             l++;
6309         else if (op == WHILEM)
6310             l--;
6311     }
6312     return node;
6313 }
6314
6315 #endif  /* DEBUGGING */
6316
6317 /*
6318  * Local variables:
6319  * c-indentation-style: bsd
6320  * c-basic-offset: 4
6321  * indent-tabs-mode: t
6322  * End:
6323  *
6324  * ex: set ts=8 sts=4 sw=4 noet:
6325  */