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