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