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