18f432b8ea7bfbecaf0cd806606ba320cd039fbb
[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("cl_anything: ",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             while ( ++opt < optimize) {
2054                 Set_Node_Offset_Length(opt,0,0);
2055             }
2056             /* 
2057                 Try to clean up some of the debris left after the 
2058                 optimisation.
2059              */
2060             while( optimize < jumper ) {
2061                 mjd_nodelen += Node_Length((optimize));
2062                 OP( optimize ) = OPTIMIZED;
2063                 Set_Node_Offset_Length(optimize,0,0);
2064                 optimize++;
2065             }
2066             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
2067         });
2068     } /* end node insert */
2069     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
2070 #ifdef DEBUGGING
2071     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
2072     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
2073 #else
2074     SvREFCNT_dec(revcharmap);
2075 #endif
2076     return trie->jump 
2077            ? MADE_JUMP_TRIE 
2078            : trie->startstate>1 
2079              ? MADE_EXACT_TRIE 
2080              : MADE_TRIE;
2081 }
2082
2083 STATIC void
2084 S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source,  regnode *stclass, U32 depth)
2085 {
2086 /* The Trie is constructed and compressed now so we can build a fail array now if its needed
2087
2088    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
2089    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
2090    ISBN 0-201-10088-6
2091
2092    We find the fail state for each state in the trie, this state is the longest proper
2093    suffix of the current states 'word' that is also a proper prefix of another word in our
2094    trie. State 1 represents the word '' and is the thus the default fail state. This allows
2095    the DFA not to have to restart after its tried and failed a word at a given point, it
2096    simply continues as though it had been matching the other word in the first place.
2097    Consider
2098       'abcdgu'=~/abcdefg|cdgu/
2099    When we get to 'd' we are still matching the first word, we would encounter 'g' which would
2100    fail, which would bring use to the state representing 'd' in the second word where we would
2101    try 'g' and succeed, prodceding to match 'cdgu'.
2102  */
2103  /* add a fail transition */
2104     const U32 trie_offset = ARG(source);
2105     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
2106     U32 *q;
2107     const U32 ucharcount = trie->uniquecharcount;
2108     const U32 numstates = trie->statecount;
2109     const U32 ubound = trie->lasttrans + ucharcount;
2110     U32 q_read = 0;
2111     U32 q_write = 0;
2112     U32 charid;
2113     U32 base = trie->states[ 1 ].trans.base;
2114     U32 *fail;
2115     reg_ac_data *aho;
2116     const U32 data_slot = add_data( pRExC_state, 1, "T" );
2117     GET_RE_DEBUG_FLAGS_DECL;
2118 #ifndef DEBUGGING
2119     PERL_UNUSED_ARG(depth);
2120 #endif
2121
2122
2123     ARG_SET( stclass, data_slot );
2124     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
2125     RExC_rxi->data->data[ data_slot ] = (void*)aho;
2126     aho->trie=trie_offset;
2127     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
2128     Copy( trie->states, aho->states, numstates, reg_trie_state );
2129     Newxz( q, numstates, U32);
2130     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
2131     aho->refcount = 1;
2132     fail = aho->fail;
2133     /* initialize fail[0..1] to be 1 so that we always have
2134        a valid final fail state */
2135     fail[ 0 ] = fail[ 1 ] = 1;
2136
2137     for ( charid = 0; charid < ucharcount ; charid++ ) {
2138         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
2139         if ( newstate ) {
2140             q[ q_write ] = newstate;
2141             /* set to point at the root */
2142             fail[ q[ q_write++ ] ]=1;
2143         }
2144     }
2145     while ( q_read < q_write) {
2146         const U32 cur = q[ q_read++ % numstates ];
2147         base = trie->states[ cur ].trans.base;
2148
2149         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
2150             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
2151             if (ch_state) {
2152                 U32 fail_state = cur;
2153                 U32 fail_base;
2154                 do {
2155                     fail_state = fail[ fail_state ];
2156                     fail_base = aho->states[ fail_state ].trans.base;
2157                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
2158
2159                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
2160                 fail[ ch_state ] = fail_state;
2161                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
2162                 {
2163                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
2164                 }
2165                 q[ q_write++ % numstates] = ch_state;
2166             }
2167         }
2168     }
2169     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
2170        when we fail in state 1, this allows us to use the
2171        charclass scan to find a valid start char. This is based on the principle
2172        that theres a good chance the string being searched contains lots of stuff
2173        that cant be a start char.
2174      */
2175     fail[ 0 ] = fail[ 1 ] = 0;
2176     DEBUG_TRIE_COMPILE_r({
2177         PerlIO_printf(Perl_debug_log,
2178                       "%*sStclass Failtable (%"UVuf" states): 0", 
2179                       (int)(depth * 2), "", (UV)numstates
2180         );
2181         for( q_read=1; q_read<numstates; q_read++ ) {
2182             PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
2183         }
2184         PerlIO_printf(Perl_debug_log, "\n");
2185     });
2186     Safefree(q);
2187     /*RExC_seen |= REG_SEEN_TRIEDFA;*/
2188 }
2189
2190
2191 /*
2192  * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2193  * These need to be revisited when a newer toolchain becomes available.
2194  */
2195 #if defined(__sparc64__) && defined(__GNUC__)
2196 #   if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2197 #       undef  SPARC64_GCC_WORKAROUND
2198 #       define SPARC64_GCC_WORKAROUND 1
2199 #   endif
2200 #endif
2201
2202 #define DEBUG_PEEP(str,scan,depth) \
2203     DEBUG_OPTIMISE_r({if (scan){ \
2204        SV * const mysv=sv_newmortal(); \
2205        regnode *Next = regnext(scan); \
2206        regprop(RExC_rx, mysv, scan); \
2207        PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
2208        (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
2209        Next ? (REG_NODE_NUM(Next)) : 0 ); \
2210    }});
2211
2212
2213
2214
2215
2216 #define JOIN_EXACT(scan,min,flags) \
2217     if (PL_regkind[OP(scan)] == EXACT) \
2218         join_exact(pRExC_state,(scan),(min),(flags),NULL,depth+1)
2219
2220 STATIC U32
2221 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, I32 *min, U32 flags,regnode *val, U32 depth) {
2222     /* Merge several consecutive EXACTish nodes into one. */
2223     regnode *n = regnext(scan);
2224     U32 stringok = 1;
2225     regnode *next = scan + NODE_SZ_STR(scan);
2226     U32 merged = 0;
2227     U32 stopnow = 0;
2228 #ifdef DEBUGGING
2229     regnode *stop = scan;
2230     GET_RE_DEBUG_FLAGS_DECL;
2231 #else
2232     PERL_UNUSED_ARG(depth);
2233 #endif
2234 #ifndef EXPERIMENTAL_INPLACESCAN
2235     PERL_UNUSED_ARG(flags);
2236     PERL_UNUSED_ARG(val);
2237 #endif
2238     DEBUG_PEEP("join",scan,depth);
2239     
2240     /* Skip NOTHING, merge EXACT*. */
2241     while (n &&
2242            ( PL_regkind[OP(n)] == NOTHING ||
2243              (stringok && (OP(n) == OP(scan))))
2244            && NEXT_OFF(n)
2245            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
2246         
2247         if (OP(n) == TAIL || n > next)
2248             stringok = 0;
2249         if (PL_regkind[OP(n)] == NOTHING) {
2250             DEBUG_PEEP("skip:",n,depth);
2251             NEXT_OFF(scan) += NEXT_OFF(n);
2252             next = n + NODE_STEP_REGNODE;
2253 #ifdef DEBUGGING
2254             if (stringok)
2255                 stop = n;
2256 #endif
2257             n = regnext(n);
2258         }
2259         else if (stringok) {
2260             const unsigned int oldl = STR_LEN(scan);
2261             regnode * const nnext = regnext(n);
2262             
2263             DEBUG_PEEP("merg",n,depth);
2264             
2265             merged++;
2266             if (oldl + STR_LEN(n) > U8_MAX)
2267                 break;
2268             NEXT_OFF(scan) += NEXT_OFF(n);
2269             STR_LEN(scan) += STR_LEN(n);
2270             next = n + NODE_SZ_STR(n);
2271             /* Now we can overwrite *n : */
2272             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
2273 #ifdef DEBUGGING
2274             stop = next - 1;
2275 #endif
2276             n = nnext;
2277             if (stopnow) break;
2278         }
2279
2280 #ifdef EXPERIMENTAL_INPLACESCAN
2281         if (flags && !NEXT_OFF(n)) {
2282             DEBUG_PEEP("atch", val, depth);
2283             if (reg_off_by_arg[OP(n)]) {
2284                 ARG_SET(n, val - n);
2285             }
2286             else {
2287                 NEXT_OFF(n) = val - n;
2288             }
2289             stopnow = 1;
2290         }
2291 #endif
2292     }
2293     
2294     if (UTF && ( OP(scan) == EXACTF ) && ( STR_LEN(scan) >= 6 ) ) {
2295     /*
2296     Two problematic code points in Unicode casefolding of EXACT nodes:
2297     
2298     U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
2299     U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
2300     
2301     which casefold to
2302     
2303     Unicode                      UTF-8
2304     
2305     U+03B9 U+0308 U+0301         0xCE 0xB9 0xCC 0x88 0xCC 0x81
2306     U+03C5 U+0308 U+0301         0xCF 0x85 0xCC 0x88 0xCC 0x81
2307     
2308     This means that in case-insensitive matching (or "loose matching",
2309     as Unicode calls it), an EXACTF of length six (the UTF-8 encoded byte
2310     length of the above casefolded versions) can match a target string
2311     of length two (the byte length of UTF-8 encoded U+0390 or U+03B0).
2312     This would rather mess up the minimum length computation.
2313     
2314     What we'll do is to look for the tail four bytes, and then peek
2315     at the preceding two bytes to see whether we need to decrease
2316     the minimum length by four (six minus two).
2317     
2318     Thanks to the design of UTF-8, there cannot be false matches:
2319     A sequence of valid UTF-8 bytes cannot be a subsequence of
2320     another valid sequence of UTF-8 bytes.
2321     
2322     */
2323          char * const s0 = STRING(scan), *s, *t;
2324          char * const s1 = s0 + STR_LEN(scan) - 1;
2325          char * const s2 = s1 - 4;
2326 #ifdef EBCDIC /* RD tunifold greek 0390 and 03B0 */
2327          const char t0[] = "\xaf\x49\xaf\x42";
2328 #else
2329          const char t0[] = "\xcc\x88\xcc\x81";
2330 #endif
2331          const char * const t1 = t0 + 3;
2332     
2333          for (s = s0 + 2;
2334               s < s2 && (t = ninstr(s, s1, t0, t1));
2335               s = t + 4) {
2336 #ifdef EBCDIC
2337               if (((U8)t[-1] == 0x68 && (U8)t[-2] == 0xB4) ||
2338                   ((U8)t[-1] == 0x46 && (U8)t[-2] == 0xB5))
2339 #else
2340               if (((U8)t[-1] == 0xB9 && (U8)t[-2] == 0xCE) ||
2341                   ((U8)t[-1] == 0x85 && (U8)t[-2] == 0xCF))
2342 #endif
2343                    *min -= 4;
2344          }
2345     }
2346     
2347 #ifdef DEBUGGING
2348     /* Allow dumping */
2349     n = scan + NODE_SZ_STR(scan);
2350     while (n <= stop) {
2351         if (PL_regkind[OP(n)] != NOTHING || OP(n) == NOTHING) {
2352             OP(n) = OPTIMIZED;
2353             NEXT_OFF(n) = 0;
2354         }
2355         n++;
2356     }
2357 #endif
2358     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
2359     return stopnow;
2360 }
2361
2362 /* REx optimizer.  Converts nodes into quickier variants "in place".
2363    Finds fixed substrings.  */
2364
2365 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
2366    to the position after last scanned or to NULL. */
2367
2368 #define INIT_AND_WITHP \
2369     assert(!and_withp); \
2370     Newx(and_withp,1,struct regnode_charclass_class); \
2371     SAVEFREEPV(and_withp)
2372
2373 /* this is a chain of data about sub patterns we are processing that
2374    need to be handled seperately/specially in study_chunk. Its so
2375    we can simulate recursion without losing state.  */
2376 struct scan_frame;
2377 typedef struct scan_frame {
2378     regnode *last;  /* last node to process in this frame */
2379     regnode *next;  /* next node to process when last is reached */
2380     struct scan_frame *prev; /*previous frame*/
2381     I32 stop; /* what stopparen do we use */
2382 } scan_frame;
2383
2384
2385 #define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf)
2386
2387 STATIC I32
2388 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
2389                         I32 *minlenp, I32 *deltap,
2390                         regnode *last,
2391                         scan_data_t *data,
2392                         I32 stopparen,
2393                         U8* recursed,
2394                         struct regnode_charclass_class *and_withp,
2395                         U32 flags, U32 depth)
2396                         /* scanp: Start here (read-write). */
2397                         /* deltap: Write maxlen-minlen here. */
2398                         /* last: Stop before this one. */
2399                         /* data: string data about the pattern */
2400                         /* stopparen: treat close N as END */
2401                         /* recursed: which subroutines have we recursed into */
2402                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
2403 {
2404     dVAR;
2405     I32 min = 0, pars = 0, code;
2406     regnode *scan = *scanp, *next;
2407     I32 delta = 0;
2408     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
2409     int is_inf_internal = 0;            /* The studied chunk is infinite */
2410     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
2411     scan_data_t data_fake;
2412     SV *re_trie_maxbuff = NULL;
2413     regnode *first_non_open = scan;
2414     I32 stopmin = I32_MAX;
2415     scan_frame *frame = NULL;
2416
2417     GET_RE_DEBUG_FLAGS_DECL;
2418
2419 #ifdef DEBUGGING
2420     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
2421 #endif
2422
2423     if ( depth == 0 ) {
2424         while (first_non_open && OP(first_non_open) == OPEN)
2425             first_non_open=regnext(first_non_open);
2426     }
2427
2428
2429   fake_study_recurse:
2430     while ( scan && OP(scan) != END && scan < last ){
2431         /* Peephole optimizer: */
2432         DEBUG_STUDYDATA("Peep:", data,depth);
2433         DEBUG_PEEP("Peep",scan,depth);
2434         JOIN_EXACT(scan,&min,0);
2435
2436         /* Follow the next-chain of the current node and optimize
2437            away all the NOTHINGs from it.  */
2438         if (OP(scan) != CURLYX) {
2439             const int max = (reg_off_by_arg[OP(scan)]
2440                        ? I32_MAX
2441                        /* I32 may be smaller than U16 on CRAYs! */
2442                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
2443             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
2444             int noff;
2445             regnode *n = scan;
2446         
2447             /* Skip NOTHING and LONGJMP. */
2448             while ((n = regnext(n))
2449                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
2450                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
2451                    && off + noff < max)
2452                 off += noff;
2453             if (reg_off_by_arg[OP(scan)])
2454                 ARG(scan) = off;
2455             else
2456                 NEXT_OFF(scan) = off;
2457         }
2458
2459
2460
2461         /* The principal pseudo-switch.  Cannot be a switch, since we
2462            look into several different things.  */
2463         if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
2464                    || OP(scan) == IFTHEN) {
2465             next = regnext(scan);
2466             code = OP(scan);
2467             /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
2468         
2469             if (OP(next) == code || code == IFTHEN) {
2470                 /* NOTE - There is similar code to this block below for handling
2471                    TRIE nodes on a re-study.  If you change stuff here check there
2472                    too. */
2473                 I32 max1 = 0, min1 = I32_MAX, num = 0;
2474                 struct regnode_charclass_class accum;
2475                 regnode * const startbranch=scan;
2476                 
2477                 if (flags & SCF_DO_SUBSTR)
2478                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
2479                 if (flags & SCF_DO_STCLASS)
2480                     cl_init_zero(pRExC_state, &accum);
2481
2482                 while (OP(scan) == code) {
2483                     I32 deltanext, minnext, f = 0, fake;
2484                     struct regnode_charclass_class this_class;
2485
2486                     num++;
2487                     data_fake.flags = 0;
2488                     if (data) {
2489                         data_fake.whilem_c = data->whilem_c;
2490                         data_fake.last_closep = data->last_closep;
2491                     }
2492                     else
2493                         data_fake.last_closep = &fake;
2494
2495                     data_fake.pos_delta = delta;
2496                     next = regnext(scan);
2497                     scan = NEXTOPER(scan);
2498                     if (code != BRANCH)
2499                         scan = NEXTOPER(scan);
2500                     if (flags & SCF_DO_STCLASS) {
2501                         cl_init(pRExC_state, &this_class);
2502                         data_fake.start_class = &this_class;
2503                         f = SCF_DO_STCLASS_AND;
2504                     }
2505                     if (flags & SCF_WHILEM_VISITED_POS)
2506                         f |= SCF_WHILEM_VISITED_POS;
2507
2508                     /* we suppose the run is continuous, last=next...*/
2509                     minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
2510                                           next, &data_fake,
2511                                           stopparen, recursed, NULL, f,depth+1);
2512                     if (min1 > minnext)
2513                         min1 = minnext;
2514                     if (max1 < minnext + deltanext)
2515                         max1 = minnext + deltanext;
2516                     if (deltanext == I32_MAX)
2517                         is_inf = is_inf_internal = 1;
2518                     scan = next;
2519                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
2520                         pars++;
2521                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
2522                         if ( stopmin > minnext) 
2523                             stopmin = min + min1;
2524                         flags &= ~SCF_DO_SUBSTR;
2525                         if (data)
2526                             data->flags |= SCF_SEEN_ACCEPT;
2527                     }
2528                     if (data) {
2529                         if (data_fake.flags & SF_HAS_EVAL)
2530                             data->flags |= SF_HAS_EVAL;
2531                         data->whilem_c = data_fake.whilem_c;
2532                     }
2533                     if (flags & SCF_DO_STCLASS)
2534                         cl_or(pRExC_state, &accum, &this_class);
2535                 }
2536                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
2537                     min1 = 0;
2538                 if (flags & SCF_DO_SUBSTR) {
2539                     data->pos_min += min1;
2540                     data->pos_delta += max1 - min1;
2541                     if (max1 != min1 || is_inf)
2542                         data->longest = &(data->longest_float);
2543                 }
2544                 min += min1;
2545                 delta += max1 - min1;
2546                 if (flags & SCF_DO_STCLASS_OR) {
2547                     cl_or(pRExC_state, data->start_class, &accum);
2548                     if (min1) {
2549                         cl_and(data->start_class, and_withp);
2550                         flags &= ~SCF_DO_STCLASS;
2551                     }
2552                 }
2553                 else if (flags & SCF_DO_STCLASS_AND) {
2554                     if (min1) {
2555                         cl_and(data->start_class, &accum);
2556                         flags &= ~SCF_DO_STCLASS;
2557                     }
2558                     else {
2559                         /* Switch to OR mode: cache the old value of
2560                          * data->start_class */
2561                         INIT_AND_WITHP;
2562                         StructCopy(data->start_class, and_withp,
2563                                    struct regnode_charclass_class);
2564                         flags &= ~SCF_DO_STCLASS_AND;
2565                         StructCopy(&accum, data->start_class,
2566                                    struct regnode_charclass_class);
2567                         flags |= SCF_DO_STCLASS_OR;
2568                         data->start_class->flags |= ANYOF_EOS;
2569                     }
2570                 }
2571
2572                 if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) == BRANCH ) {
2573                 /* demq.
2574
2575                    Assuming this was/is a branch we are dealing with: 'scan' now
2576                    points at the item that follows the branch sequence, whatever
2577                    it is. We now start at the beginning of the sequence and look
2578                    for subsequences of
2579
2580                    BRANCH->EXACT=>x1
2581                    BRANCH->EXACT=>x2
2582                    tail
2583
2584                    which would be constructed from a pattern like /A|LIST|OF|WORDS/
2585
2586                    If we can find such a subseqence we need to turn the first
2587                    element into a trie and then add the subsequent branch exact
2588                    strings to the trie.
2589
2590                    We have two cases
2591
2592                      1. patterns where the whole set of branch can be converted. 
2593
2594                      2. patterns where only a subset can be converted.
2595
2596                    In case 1 we can replace the whole set with a single regop
2597                    for the trie. In case 2 we need to keep the start and end
2598                    branchs so
2599
2600                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
2601                      becomes BRANCH TRIE; BRANCH X;
2602
2603                   There is an additional case, that being where there is a 
2604                   common prefix, which gets split out into an EXACT like node
2605                   preceding the TRIE node.
2606
2607                   If x(1..n)==tail then we can do a simple trie, if not we make
2608                   a "jump" trie, such that when we match the appropriate word
2609                   we "jump" to the appopriate tail node. Essentailly we turn
2610                   a nested if into a case structure of sorts.
2611
2612                 */
2613                 
2614                     int made=0;
2615                     if (!re_trie_maxbuff) {
2616                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2617                         if (!SvIOK(re_trie_maxbuff))
2618                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2619                     }
2620                     if ( SvIV(re_trie_maxbuff)>=0  ) {
2621                         regnode *cur;
2622                         regnode *first = (regnode *)NULL;
2623                         regnode *last = (regnode *)NULL;
2624                         regnode *tail = scan;
2625                         U8 optype = 0;
2626                         U32 count=0;
2627
2628 #ifdef DEBUGGING
2629                         SV * const mysv = sv_newmortal();       /* for dumping */
2630 #endif
2631                         /* var tail is used because there may be a TAIL
2632                            regop in the way. Ie, the exacts will point to the
2633                            thing following the TAIL, but the last branch will
2634                            point at the TAIL. So we advance tail. If we
2635                            have nested (?:) we may have to move through several
2636                            tails.
2637                          */
2638
2639                         while ( OP( tail ) == TAIL ) {
2640                             /* this is the TAIL generated by (?:) */
2641                             tail = regnext( tail );
2642                         }
2643
2644                         
2645                         DEBUG_OPTIMISE_r({
2646                             regprop(RExC_rx, mysv, tail );
2647                             PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
2648                                 (int)depth * 2 + 2, "", 
2649                                 "Looking for TRIE'able sequences. Tail node is: ", 
2650                                 SvPV_nolen_const( mysv )
2651                             );
2652                         });
2653                         
2654                         /*
2655
2656                            step through the branches, cur represents each
2657                            branch, noper is the first thing to be matched
2658                            as part of that branch and noper_next is the
2659                            regnext() of that node. if noper is an EXACT
2660                            and noper_next is the same as scan (our current
2661                            position in the regex) then the EXACT branch is
2662                            a possible optimization target. Once we have
2663                            two or more consequetive such branches we can
2664                            create a trie of the EXACT's contents and stich
2665                            it in place. If the sequence represents all of
2666                            the branches we eliminate the whole thing and
2667                            replace it with a single TRIE. If it is a
2668                            subsequence then we need to stitch it in. This
2669                            means the first branch has to remain, and needs
2670                            to be repointed at the item on the branch chain
2671                            following the last branch optimized. This could
2672                            be either a BRANCH, in which case the
2673                            subsequence is internal, or it could be the
2674                            item following the branch sequence in which
2675                            case the subsequence is at the end.
2676
2677                         */
2678
2679                         /* dont use tail as the end marker for this traverse */
2680                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
2681                             regnode * const noper = NEXTOPER( cur );
2682 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
2683                             regnode * const noper_next = regnext( noper );
2684 #endif
2685
2686                             DEBUG_OPTIMISE_r({
2687                                 regprop(RExC_rx, mysv, cur);
2688                                 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
2689                                    (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
2690
2691                                 regprop(RExC_rx, mysv, noper);
2692                                 PerlIO_printf( Perl_debug_log, " -> %s",
2693                                     SvPV_nolen_const(mysv));
2694
2695                                 if ( noper_next ) {
2696                                   regprop(RExC_rx, mysv, noper_next );
2697                                   PerlIO_printf( Perl_debug_log,"\t=> %s\t",
2698                                     SvPV_nolen_const(mysv));
2699                                 }
2700                                 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d)\n",
2701                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur) );
2702                             });
2703                             if ( (((first && optype!=NOTHING) ? OP( noper ) == optype
2704                                          : PL_regkind[ OP( noper ) ] == EXACT )
2705                                   || OP(noper) == NOTHING )
2706 #ifdef NOJUMPTRIE
2707                                   && noper_next == tail
2708 #endif
2709                                   && count < U16_MAX)
2710                             {
2711                                 count++;
2712                                 if ( !first || optype == NOTHING ) {
2713                                     if (!first) first = cur;
2714                                     optype = OP( noper );
2715                                 } else {
2716                                     last = cur;
2717                                 }
2718                             } else {
2719                                 if ( last ) {
2720                                     make_trie( pRExC_state, 
2721                                             startbranch, first, cur, tail, count, 
2722                                             optype, depth+1 );
2723                                 }
2724                                 if ( PL_regkind[ OP( noper ) ] == EXACT
2725 #ifdef NOJUMPTRIE
2726                                      && noper_next == tail
2727 #endif
2728                                 ){
2729                                     count = 1;
2730                                     first = cur;
2731                                     optype = OP( noper );
2732                                 } else {
2733                                     count = 0;
2734                                     first = NULL;
2735                                     optype = 0;
2736                                 }
2737                                 last = NULL;
2738                             }
2739                         }
2740                         DEBUG_OPTIMISE_r({
2741                             regprop(RExC_rx, mysv, cur);
2742                             PerlIO_printf( Perl_debug_log,
2743                               "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
2744                               "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
2745
2746                         });
2747                         if ( last ) {
2748                             made= make_trie( pRExC_state, startbranch, first, scan, tail, count, optype, depth+1 );
2749 #ifdef TRIE_STUDY_OPT   
2750                             if ( ((made == MADE_EXACT_TRIE && 
2751                                  startbranch == first) 
2752                                  || ( first_non_open == first )) && 
2753                                  depth==0 ) {
2754                                 flags |= SCF_TRIE_RESTUDY;
2755                                 if ( startbranch == first 
2756                                      && scan == tail ) 
2757                                 {
2758                                     RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
2759                                 }
2760                             }
2761 #endif
2762                         }
2763                     }
2764                     
2765                 } /* do trie */
2766                 
2767             }
2768             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
2769                 scan = NEXTOPER(NEXTOPER(scan));
2770             } else                      /* single branch is optimized. */
2771                 scan = NEXTOPER(scan);
2772             continue;
2773         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
2774             scan_frame *newframe = NULL;
2775             I32 paren;
2776             regnode *start;
2777             regnode *end;
2778
2779             if (OP(scan) != SUSPEND) {
2780             /* set the pointer */
2781                 if (OP(scan) == GOSUB) {
2782                     paren = ARG(scan);
2783                     RExC_recurse[ARG2L(scan)] = scan;
2784                     start = RExC_open_parens[paren-1];
2785                     end   = RExC_close_parens[paren-1];
2786                 } else {
2787                     paren = 0;
2788                     start = RExC_rxi->program + 1;
2789                     end   = RExC_opend;
2790                 }
2791                 if (!recursed) {
2792                     Newxz(recursed, (((RExC_npar)>>3) +1), U8);
2793                     SAVEFREEPV(recursed);
2794                 }
2795                 if (!PAREN_TEST(recursed,paren+1)) {
2796                     PAREN_SET(recursed,paren+1);
2797                     Newx(newframe,1,scan_frame);
2798                 } else {
2799                     if (flags & SCF_DO_SUBSTR) {
2800                         SCAN_COMMIT(pRExC_state,data,minlenp);
2801                         data->longest = &(data->longest_float);
2802                     }
2803                     is_inf = is_inf_internal = 1;
2804                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
2805                         cl_anything(pRExC_state, data->start_class);
2806                     flags &= ~SCF_DO_STCLASS;
2807                 }
2808             } else {
2809                 Newx(newframe,1,scan_frame);
2810                 paren = stopparen;
2811                 start = scan+2;
2812                 end = regnext(scan);
2813             }
2814             if (newframe) {
2815                 assert(start);
2816                 assert(end);
2817                 SAVEFREEPV(newframe);
2818                 newframe->next = regnext(scan);
2819                 newframe->last = last;
2820                 newframe->stop = stopparen;
2821                 newframe->prev = frame;
2822
2823                 frame = newframe;
2824                 scan =  start;
2825                 stopparen = paren;
2826                 last = end;
2827
2828                 continue;
2829             }
2830         }
2831         else if (OP(scan) == EXACT) {
2832             I32 l = STR_LEN(scan);
2833             UV uc;
2834             if (UTF) {
2835                 const U8 * const s = (U8*)STRING(scan);
2836                 l = utf8_length(s, s + l);
2837                 uc = utf8_to_uvchr(s, NULL);
2838             } else {
2839                 uc = *((U8*)STRING(scan));
2840             }
2841             min += l;
2842             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
2843                 /* The code below prefers earlier match for fixed
2844                    offset, later match for variable offset.  */
2845                 if (data->last_end == -1) { /* Update the start info. */
2846                     data->last_start_min = data->pos_min;
2847                     data->last_start_max = is_inf
2848                         ? I32_MAX : data->pos_min + data->pos_delta;
2849                 }
2850                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
2851                 if (UTF)
2852                     SvUTF8_on(data->last_found);
2853                 {
2854                     SV * const sv = data->last_found;
2855                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
2856                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
2857                     if (mg && mg->mg_len >= 0)
2858                         mg->mg_len += utf8_length((U8*)STRING(scan),
2859                                                   (U8*)STRING(scan)+STR_LEN(scan));
2860                 }
2861                 data->last_end = data->pos_min + l;
2862                 data->pos_min += l; /* As in the first entry. */
2863                 data->flags &= ~SF_BEFORE_EOL;
2864             }
2865             if (flags & SCF_DO_STCLASS_AND) {
2866                 /* Check whether it is compatible with what we know already! */
2867                 int compat = 1;
2868
2869                 if (uc >= 0x100 ||
2870                     (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
2871                     && !ANYOF_BITMAP_TEST(data->start_class, uc)
2872                     && (!(data->start_class->flags & ANYOF_FOLD)
2873                         || !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
2874                     )
2875                     compat = 0;
2876                 ANYOF_CLASS_ZERO(data->start_class);
2877                 ANYOF_BITMAP_ZERO(data->start_class);
2878                 if (compat)
2879                     ANYOF_BITMAP_SET(data->start_class, uc);
2880                 data->start_class->flags &= ~ANYOF_EOS;
2881                 if (uc < 0x100)
2882                   data->start_class->flags &= ~ANYOF_UNICODE_ALL;
2883             }
2884             else if (flags & SCF_DO_STCLASS_OR) {
2885                 /* false positive possible if the class is case-folded */
2886                 if (uc < 0x100)
2887                     ANYOF_BITMAP_SET(data->start_class, uc);
2888                 else
2889                     data->start_class->flags |= ANYOF_UNICODE_ALL;
2890                 data->start_class->flags &= ~ANYOF_EOS;
2891                 cl_and(data->start_class, and_withp);
2892             }
2893             flags &= ~SCF_DO_STCLASS;
2894         }
2895         else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
2896             I32 l = STR_LEN(scan);
2897             UV uc = *((U8*)STRING(scan));
2898
2899             /* Search for fixed substrings supports EXACT only. */
2900             if (flags & SCF_DO_SUBSTR) {
2901                 assert(data);
2902                 SCAN_COMMIT(pRExC_state, data, minlenp);
2903             }
2904             if (UTF) {
2905                 const U8 * const s = (U8 *)STRING(scan);
2906                 l = utf8_length(s, s + l);
2907                 uc = utf8_to_uvchr(s, NULL);
2908             }
2909             min += l;
2910             if (flags & SCF_DO_SUBSTR)
2911                 data->pos_min += l;
2912             if (flags & SCF_DO_STCLASS_AND) {
2913                 /* Check whether it is compatible with what we know already! */
2914                 int compat = 1;
2915
2916                 if (uc >= 0x100 ||
2917                     (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
2918                     && !ANYOF_BITMAP_TEST(data->start_class, uc)
2919                      && !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
2920                     compat = 0;
2921                 ANYOF_CLASS_ZERO(data->start_class);
2922                 ANYOF_BITMAP_ZERO(data->start_class);
2923                 if (compat) {
2924                     ANYOF_BITMAP_SET(data->start_class, uc);
2925                     data->start_class->flags &= ~ANYOF_EOS;
2926                     data->start_class->flags |= ANYOF_FOLD;
2927                     if (OP(scan) == EXACTFL)
2928                         data->start_class->flags |= ANYOF_LOCALE;
2929                 }
2930             }
2931             else if (flags & SCF_DO_STCLASS_OR) {
2932                 if (data->start_class->flags & ANYOF_FOLD) {
2933                     /* false positive possible if the class is case-folded.
2934                        Assume that the locale settings are the same... */
2935                     if (uc < 0x100)
2936                         ANYOF_BITMAP_SET(data->start_class, uc);
2937                     data->start_class->flags &= ~ANYOF_EOS;
2938                 }
2939                 cl_and(data->start_class, and_withp);
2940             }
2941             flags &= ~SCF_DO_STCLASS;
2942         }
2943         else if (strchr((const char*)PL_varies,OP(scan))) {
2944             I32 mincount, maxcount, minnext, deltanext, fl = 0;
2945             I32 f = flags, pos_before = 0;
2946             regnode * const oscan = scan;
2947             struct regnode_charclass_class this_class;
2948             struct regnode_charclass_class *oclass = NULL;
2949             I32 next_is_eval = 0;
2950
2951             switch (PL_regkind[OP(scan)]) {
2952             case WHILEM:                /* End of (?:...)* . */
2953                 scan = NEXTOPER(scan);
2954                 goto finish;
2955             case PLUS:
2956                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
2957                     next = NEXTOPER(scan);
2958                     if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
2959                         mincount = 1;
2960                         maxcount = REG_INFTY;
2961                         next = regnext(scan);
2962                         scan = NEXTOPER(scan);
2963                         goto do_curly;
2964                     }
2965                 }
2966                 if (flags & SCF_DO_SUBSTR)
2967                     data->pos_min++;
2968                 min++;
2969                 /* Fall through. */
2970             case STAR:
2971                 if (flags & SCF_DO_STCLASS) {
2972                     mincount = 0;
2973                     maxcount = REG_INFTY;
2974                     next = regnext(scan);
2975                     scan = NEXTOPER(scan);
2976                     goto do_curly;
2977                 }
2978                 is_inf = is_inf_internal = 1;
2979                 scan = regnext(scan);
2980                 if (flags & SCF_DO_SUBSTR) {
2981                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
2982                     data->longest = &(data->longest_float);
2983                 }
2984                 goto optimize_curly_tail;
2985             case CURLY:
2986                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
2987                     && (scan->flags == stopparen))
2988                 {
2989                     mincount = 1;
2990                     maxcount = 1;
2991                 } else {
2992                     mincount = ARG1(scan);
2993                     maxcount = ARG2(scan);
2994                 }
2995                 next = regnext(scan);
2996                 if (OP(scan) == CURLYX) {
2997                     I32 lp = (data ? *(data->last_closep) : 0);
2998                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
2999                 }
3000                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3001                 next_is_eval = (OP(scan) == EVAL);
3002               do_curly:
3003                 if (flags & SCF_DO_SUBSTR) {
3004                     if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
3005                     pos_before = data->pos_min;
3006                 }
3007                 if (data) {
3008                     fl = data->flags;
3009                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
3010                     if (is_inf)
3011                         data->flags |= SF_IS_INF;
3012                 }
3013                 if (flags & SCF_DO_STCLASS) {
3014                     cl_init(pRExC_state, &this_class);
3015                     oclass = data->start_class;
3016                     data->start_class = &this_class;
3017                     f |= SCF_DO_STCLASS_AND;
3018                     f &= ~SCF_DO_STCLASS_OR;
3019                 }
3020                 /* These are the cases when once a subexpression
3021                    fails at a particular position, it cannot succeed
3022                    even after backtracking at the enclosing scope.
3023                 
3024                    XXXX what if minimal match and we are at the
3025                         initial run of {n,m}? */
3026                 if ((mincount != maxcount - 1) && (maxcount != REG_INFTY))
3027                     f &= ~SCF_WHILEM_VISITED_POS;
3028
3029                 /* This will finish on WHILEM, setting scan, or on NULL: */
3030                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, 
3031                                       last, data, stopparen, recursed, NULL,
3032                                       (mincount == 0
3033                                         ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
3034
3035                 if (flags & SCF_DO_STCLASS)
3036                     data->start_class = oclass;
3037                 if (mincount == 0 || minnext == 0) {
3038                     if (flags & SCF_DO_STCLASS_OR) {
3039                         cl_or(pRExC_state, data->start_class, &this_class);
3040                     }
3041                     else if (flags & SCF_DO_STCLASS_AND) {
3042                         /* Switch to OR mode: cache the old value of
3043                          * data->start_class */
3044                         INIT_AND_WITHP;
3045                         StructCopy(data->start_class, and_withp,
3046                                    struct regnode_charclass_class);
3047                         flags &= ~SCF_DO_STCLASS_AND;
3048                         StructCopy(&this_class, data->start_class,
3049                                    struct regnode_charclass_class);
3050                         flags |= SCF_DO_STCLASS_OR;
3051                         data->start_class->flags |= ANYOF_EOS;
3052                     }
3053                 } else {                /* Non-zero len */
3054                     if (flags & SCF_DO_STCLASS_OR) {
3055                         cl_or(pRExC_state, data->start_class, &this_class);
3056                         cl_and(data->start_class, and_withp);
3057                     }
3058                     else if (flags & SCF_DO_STCLASS_AND)
3059                         cl_and(data->start_class, &this_class);
3060                     flags &= ~SCF_DO_STCLASS;
3061                 }
3062                 if (!scan)              /* It was not CURLYX, but CURLY. */
3063                     scan = next;
3064                 if ( /* ? quantifier ok, except for (?{ ... }) */
3065                     (next_is_eval || !(mincount == 0 && maxcount == 1))
3066                     && (minnext == 0) && (deltanext == 0)
3067                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
3068                     && maxcount <= REG_INFTY/3 /* Complement check for big count */
3069                     && ckWARN(WARN_REGEXP))
3070                 {
3071                     vWARN(RExC_parse,
3072                           "Quantifier unexpected on zero-length expression");
3073                 }
3074
3075                 min += minnext * mincount;
3076                 is_inf_internal |= ((maxcount == REG_INFTY
3077                                      && (minnext + deltanext) > 0)
3078                                     || deltanext == I32_MAX);
3079                 is_inf |= is_inf_internal;
3080                 delta += (minnext + deltanext) * maxcount - minnext * mincount;
3081
3082                 /* Try powerful optimization CURLYX => CURLYN. */
3083                 if (  OP(oscan) == CURLYX && data
3084                       && data->flags & SF_IN_PAR
3085                       && !(data->flags & SF_HAS_EVAL)
3086                       && !deltanext && minnext == 1 ) {
3087                     /* Try to optimize to CURLYN.  */
3088                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
3089                     regnode * const nxt1 = nxt;
3090 #ifdef DEBUGGING
3091                     regnode *nxt2;
3092 #endif
3093
3094                     /* Skip open. */
3095                     nxt = regnext(nxt);
3096                     if (!strchr((const char*)PL_simple,OP(nxt))
3097                         && !(PL_regkind[OP(nxt)] == EXACT
3098                              && STR_LEN(nxt) == 1))
3099                         goto nogo;
3100 #ifdef DEBUGGING
3101                     nxt2 = nxt;
3102 #endif
3103                     nxt = regnext(nxt);
3104                     if (OP(nxt) != CLOSE)
3105                         goto nogo;
3106                     if (RExC_open_parens) {
3107                         RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3108                         RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
3109                     }
3110                     /* Now we know that nxt2 is the only contents: */
3111                     oscan->flags = (U8)ARG(nxt);
3112                     OP(oscan) = CURLYN;
3113                     OP(nxt1) = NOTHING; /* was OPEN. */
3114
3115 #ifdef DEBUGGING
3116                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3117                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistancy. */
3118                     NEXT_OFF(nxt2) = 0; /* just for consistancy with CURLY. */
3119                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
3120                     OP(nxt + 1) = OPTIMIZED; /* was count. */
3121                     NEXT_OFF(nxt+ 1) = 0; /* just for consistancy. */
3122 #endif
3123                 }
3124               nogo:
3125
3126                 /* Try optimization CURLYX => CURLYM. */
3127                 if (  OP(oscan) == CURLYX && data
3128                       && !(data->flags & SF_HAS_PAR)
3129                       && !(data->flags & SF_HAS_EVAL)
3130                       && !deltanext     /* atom is fixed width */
3131                       && minnext != 0   /* CURLYM can't handle zero width */
3132                 ) {
3133                     /* XXXX How to optimize if data == 0? */
3134                     /* Optimize to a simpler form.  */
3135                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
3136                     regnode *nxt2;
3137
3138                     OP(oscan) = CURLYM;
3139                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
3140                             && (OP(nxt2) != WHILEM))
3141                         nxt = nxt2;
3142                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
3143                     /* Need to optimize away parenths. */
3144                     if (data->flags & SF_IN_PAR) {
3145                         /* Set the parenth number.  */
3146                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
3147
3148                         if (OP(nxt) != CLOSE)
3149                             FAIL("Panic opt close");
3150                         oscan->flags = (U8)ARG(nxt);
3151                         if (RExC_open_parens) {
3152                             RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3153                             RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
3154                         }
3155                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
3156                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
3157
3158 #ifdef DEBUGGING
3159                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3160                         OP(nxt + 1) = OPTIMIZED; /* was count. */
3161                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistancy. */
3162                         NEXT_OFF(nxt + 1) = 0; /* just for consistancy. */
3163 #endif
3164 #if 0
3165                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
3166                             regnode *nnxt = regnext(nxt1);
3167                         
3168                             if (nnxt == nxt) {
3169                                 if (reg_off_by_arg[OP(nxt1)])
3170                                     ARG_SET(nxt1, nxt2 - nxt1);
3171                                 else if (nxt2 - nxt1 < U16_MAX)
3172                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
3173                                 else
3174                                     OP(nxt) = NOTHING;  /* Cannot beautify */
3175                             }
3176                             nxt1 = nnxt;
3177                         }
3178 #endif
3179                         /* Optimize again: */
3180                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
3181                                     NULL, stopparen, recursed, NULL, 0,depth+1);
3182                     }
3183                     else
3184                         oscan->flags = 0;
3185                 }
3186                 else if ((OP(oscan) == CURLYX)
3187                          && (flags & SCF_WHILEM_VISITED_POS)
3188                          /* See the comment on a similar expression above.
3189                             However, this time it not a subexpression
3190                             we care about, but the expression itself. */
3191                          && (maxcount == REG_INFTY)
3192                          && data && ++data->whilem_c < 16) {
3193                     /* This stays as CURLYX, we can put the count/of pair. */
3194                     /* Find WHILEM (as in regexec.c) */
3195                     regnode *nxt = oscan + NEXT_OFF(oscan);
3196
3197                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
3198                         nxt += ARG(nxt);
3199                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
3200                         | (RExC_whilem_seen << 4)); /* On WHILEM */
3201                 }
3202                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
3203                     pars++;
3204                 if (flags & SCF_DO_SUBSTR) {
3205                     SV *last_str = NULL;
3206                     int counted = mincount != 0;
3207
3208                     if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
3209 #if defined(SPARC64_GCC_WORKAROUND)
3210                         I32 b = 0;
3211                         STRLEN l = 0;
3212                         const char *s = NULL;
3213                         I32 old = 0;
3214
3215                         if (pos_before >= data->last_start_min)
3216                             b = pos_before;
3217                         else
3218                             b = data->last_start_min;
3219
3220                         l = 0;
3221                         s = SvPV_const(data->last_found, l);
3222                         old = b - data->last_start_min;
3223
3224 #else
3225                         I32 b = pos_before >= data->last_start_min
3226                             ? pos_before : data->last_start_min;
3227                         STRLEN l;
3228                         const char * const s = SvPV_const(data->last_found, l);
3229                         I32 old = b - data->last_start_min;
3230 #endif
3231
3232                         if (UTF)
3233                             old = utf8_hop((U8*)s, old) - (U8*)s;
3234                         
3235                         l -= old;
3236                         /* Get the added string: */
3237                         last_str = newSVpvn(s  + old, l);
3238                         if (UTF)
3239                             SvUTF8_on(last_str);
3240                         if (deltanext == 0 && pos_before == b) {
3241                             /* What was added is a constant string */
3242                             if (mincount > 1) {
3243                                 SvGROW(last_str, (mincount * l) + 1);
3244                                 repeatcpy(SvPVX(last_str) + l,
3245                                           SvPVX_const(last_str), l, mincount - 1);
3246                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
3247                                 /* Add additional parts. */
3248                                 SvCUR_set(data->last_found,
3249                                           SvCUR(data->last_found) - l);
3250                                 sv_catsv(data->last_found, last_str);
3251                                 {
3252                                     SV * sv = data->last_found;
3253                                     MAGIC *mg =
3254                                         SvUTF8(sv) && SvMAGICAL(sv) ?
3255                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
3256                                     if (mg && mg->mg_len >= 0)
3257                                         mg->mg_len += CHR_SVLEN(last_str);
3258                                 }
3259                                 data->last_end += l * (mincount - 1);
3260                             }
3261                         } else {
3262                             /* start offset must point into the last copy */
3263                             data->last_start_min += minnext * (mincount - 1);
3264                             data->last_start_max += is_inf ? I32_MAX
3265                                 : (maxcount - 1) * (minnext + data->pos_delta);
3266                         }
3267                     }
3268                     /* It is counted once already... */
3269                     data->pos_min += minnext * (mincount - counted);
3270                     data->pos_delta += - counted * deltanext +
3271                         (minnext + deltanext) * maxcount - minnext * mincount;
3272                     if (mincount != maxcount) {
3273                          /* Cannot extend fixed substrings found inside
3274                             the group.  */
3275                         SCAN_COMMIT(pRExC_state,data,minlenp);
3276                         if (mincount && last_str) {
3277                             SV * const sv = data->last_found;
3278                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3279                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
3280
3281                             if (mg)
3282                                 mg->mg_len = -1;
3283                             sv_setsv(sv, last_str);
3284                             data->last_end = data->pos_min;
3285                             data->last_start_min =
3286                                 data->pos_min - CHR_SVLEN(last_str);
3287                             data->last_start_max = is_inf
3288                                 ? I32_MAX
3289                                 : data->pos_min + data->pos_delta
3290                                 - CHR_SVLEN(last_str);
3291                         }
3292                         data->longest = &(data->longest_float);
3293                     }
3294                     SvREFCNT_dec(last_str);
3295                 }
3296                 if (data && (fl & SF_HAS_EVAL))
3297                     data->flags |= SF_HAS_EVAL;
3298               optimize_curly_tail:
3299                 if (OP(oscan) != CURLYX) {
3300                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
3301                            && NEXT_OFF(next))
3302                         NEXT_OFF(oscan) += NEXT_OFF(next);
3303                 }
3304                 continue;
3305             default:                    /* REF and CLUMP only? */
3306                 if (flags & SCF_DO_SUBSTR) {
3307                     SCAN_COMMIT(pRExC_state,data,minlenp);      /* Cannot expect anything... */
3308                     data->longest = &(data->longest_float);
3309                 }
3310                 is_inf = is_inf_internal = 1;
3311                 if (flags & SCF_DO_STCLASS_OR)
3312                     cl_anything(pRExC_state, data->start_class);
3313                 flags &= ~SCF_DO_STCLASS;
3314                 break;
3315             }
3316         }
3317         else if (strchr((const char*)PL_simple,OP(scan))) {
3318             int value = 0;
3319
3320             if (flags & SCF_DO_SUBSTR) {
3321                 SCAN_COMMIT(pRExC_state,data,minlenp);
3322                 data->pos_min++;
3323             }
3324             min++;
3325             if (flags & SCF_DO_STCLASS) {
3326                 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
3327
3328                 /* Some of the logic below assumes that switching
3329                    locale on will only add false positives. */
3330                 switch (PL_regkind[OP(scan)]) {
3331                 case SANY:
3332                 default:
3333                   do_default:
3334                     /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
3335                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3336                         cl_anything(pRExC_state, data->start_class);
3337                     break;
3338                 case REG_ANY:
3339                     if (OP(scan) == SANY)
3340                         goto do_default;
3341                     if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
3342                         value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
3343                                  || (data->start_class->flags & ANYOF_CLASS));
3344                         cl_anything(pRExC_state, data->start_class);
3345                     }
3346                     if (flags & SCF_DO_STCLASS_AND || !value)
3347                         ANYOF_BITMAP_CLEAR(data->start_class,'\n');
3348                     break;
3349                 case ANYOF:
3350                     if (flags & SCF_DO_STCLASS_AND)
3351                         cl_and(data->start_class,
3352                                (struct regnode_charclass_class*)scan);
3353                     else
3354                         cl_or(pRExC_state, data->start_class,
3355                               (struct regnode_charclass_class*)scan);
3356                     break;
3357                 case ALNUM:
3358                     if (flags & SCF_DO_STCLASS_AND) {
3359                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3360                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
3361                             for (value = 0; value < 256; value++)
3362                                 if (!isALNUM(value))
3363                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
3364                         }
3365                     }
3366                     else {
3367                         if (data->start_class->flags & ANYOF_LOCALE)
3368                             ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
3369                         else {
3370                             for (value = 0; value < 256; value++)
3371                                 if (isALNUM(value))
3372                                     ANYOF_BITMAP_SET(data->start_class, value);                 
3373                         }
3374                     }
3375                     break;
3376                 case ALNUML:
3377                     if (flags & SCF_DO_STCLASS_AND) {
3378                         if (data->start_class->flags & ANYOF_LOCALE)
3379                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
3380                     }
3381                     else {
3382                         ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
3383                         data->start_class->flags |= ANYOF_LOCALE;
3384                     }
3385                     break;
3386                 case NALNUM:
3387                     if (flags & SCF_DO_STCLASS_AND) {
3388                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3389                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
3390                             for (value = 0; value < 256; value++)
3391                                 if (isALNUM(value))
3392                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
3393                         }
3394                     }
3395                     else {
3396                         if (data->start_class->flags & ANYOF_LOCALE)
3397                             ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
3398                         else {
3399                             for (value = 0; value < 256; value++)
3400                                 if (!isALNUM(value))
3401                                     ANYOF_BITMAP_SET(data->start_class, value);                 
3402                         }
3403                     }
3404                     break;
3405                 case NALNUML:
3406                     if (flags & SCF_DO_STCLASS_AND) {
3407                         if (data->start_class->flags & ANYOF_LOCALE)
3408                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
3409                     }
3410                     else {
3411                         data->start_class->flags |= ANYOF_LOCALE;
3412                         ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
3413                     }
3414                     break;
3415                 case SPACE:
3416                     if (flags & SCF_DO_STCLASS_AND) {
3417                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3418                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
3419                             for (value = 0; value < 256; value++)
3420                                 if (!isSPACE(value))
3421                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
3422                         }
3423                     }
3424                     else {
3425                         if (data->start_class->flags & ANYOF_LOCALE)
3426                             ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
3427                         else {
3428                             for (value = 0; value < 256; value++)
3429                                 if (isSPACE(value))
3430                                     ANYOF_BITMAP_SET(data->start_class, value);                 
3431                         }
3432                     }
3433                     break;
3434                 case SPACEL:
3435                     if (flags & SCF_DO_STCLASS_AND) {
3436                         if (data->start_class->flags & ANYOF_LOCALE)
3437                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
3438                     }
3439                     else {
3440                         data->start_class->flags |= ANYOF_LOCALE;
3441                         ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
3442                     }
3443                     break;
3444                 case NSPACE:
3445                     if (flags & SCF_DO_STCLASS_AND) {
3446                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3447                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
3448                             for (value = 0; value < 256; value++)
3449                                 if (isSPACE(value))
3450                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
3451                         }
3452                     }
3453                     else {
3454                         if (data->start_class->flags & ANYOF_LOCALE)
3455                             ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
3456                         else {
3457                             for (value = 0; value < 256; value++)
3458                                 if (!isSPACE(value))
3459                                     ANYOF_BITMAP_SET(data->start_class, value);                 
3460                         }
3461                     }
3462                     break;
3463                 case NSPACEL:
3464                     if (flags & SCF_DO_STCLASS_AND) {
3465                         if (data->start_class->flags & ANYOF_LOCALE) {
3466                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
3467                             for (value = 0; value < 256; value++)
3468                                 if (!isSPACE(value))
3469                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
3470                         }
3471                     }
3472                     else {
3473                         data->start_class->flags |= ANYOF_LOCALE;
3474                         ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
3475                     }
3476                     break;
3477                 case DIGIT:
3478                     if (flags & SCF_DO_STCLASS_AND) {
3479                         ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
3480                         for (value = 0; value < 256; value++)
3481                             if (!isDIGIT(value))
3482                                 ANYOF_BITMAP_CLEAR(data->start_class, value);
3483                     }
3484                     else {
3485                         if (data->start_class->flags & ANYOF_LOCALE)
3486                             ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
3487                         else {
3488                             for (value = 0; value < 256; value++)
3489                                 if (isDIGIT(value))
3490                                     ANYOF_BITMAP_SET(data->start_class, value);                 
3491                         }
3492                     }
3493                     break;
3494                 case NDIGIT:
3495                     if (flags & SCF_DO_STCLASS_AND) {
3496                         ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
3497                         for (value = 0; value < 256; value++)
3498                             if (isDIGIT(value))
3499                                 ANYOF_BITMAP_CLEAR(data->start_class, value);
3500                     }
3501                     else {
3502                         if (data->start_class->flags & ANYOF_LOCALE)
3503                             ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
3504                         else {
3505                             for (value = 0; value < 256; value++)
3506                                 if (!isDIGIT(value))
3507                                     ANYOF_BITMAP_SET(data->start_class, value);                 
3508                         }
3509                     }
3510                     break;
3511                 }
3512                 if (flags & SCF_DO_STCLASS_OR)
3513                     cl_and(data->start_class, and_withp);
3514                 flags &= ~SCF_DO_STCLASS;
3515             }
3516         }
3517         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
3518             data->flags |= (OP(scan) == MEOL
3519                             ? SF_BEFORE_MEOL
3520                             : SF_BEFORE_SEOL);
3521         }
3522         else if (  PL_regkind[OP(scan)] == BRANCHJ
3523                  /* Lookbehind, or need to calculate parens/evals/stclass: */
3524                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
3525                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
3526             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY 
3527                 || OP(scan) == UNLESSM )
3528             {
3529                 /* Negative Lookahead/lookbehind
3530                    In this case we can't do fixed string optimisation.
3531                 */
3532
3533                 I32 deltanext, minnext, fake = 0;
3534                 regnode *nscan;
3535                 struct regnode_charclass_class intrnl;
3536                 int f = 0;
3537
3538                 data_fake.flags = 0;
3539                 if (data) {
3540                     data_fake.whilem_c = data->whilem_c;
3541                     data_fake.last_closep = data->last_closep;
3542                 }
3543                 else
3544                     data_fake.last_closep = &fake;
3545                 data_fake.pos_delta = delta;
3546                 if ( flags & SCF_DO_STCLASS && !scan->flags
3547                      && OP(scan) == IFMATCH ) { /* Lookahead */
3548                     cl_init(pRExC_state, &intrnl);
3549                     data_fake.start_class = &intrnl;
3550                     f |= SCF_DO_STCLASS_AND;
3551                 }
3552                 if (flags & SCF_WHILEM_VISITED_POS)
3553                     f |= SCF_WHILEM_VISITED_POS;
3554                 next = regnext(scan);
3555                 nscan = NEXTOPER(NEXTOPER(scan));
3556                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext, 
3557                     last, &data_fake, stopparen, recursed, NULL, f, depth+1);
3558                 if (scan->flags) {
3559                     if (deltanext) {
3560                         FAIL("Variable length lookbehind not implemented");
3561                     }
3562                     else if (minnext > (I32)U8_MAX) {
3563                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
3564                     }
3565                     scan->flags = (U8)minnext;
3566                 }
3567                 if (data) {
3568                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3569                         pars++;
3570                     if (data_fake.flags & SF_HAS_EVAL)
3571                         data->flags |= SF_HAS_EVAL;
3572                     data->whilem_c = data_fake.whilem_c;
3573                 }
3574                 if (f & SCF_DO_STCLASS_AND) {
3575                     const int was = (data->start_class->flags & ANYOF_EOS);
3576
3577                     cl_and(data->start_class, &intrnl);
3578                     if (was)
3579                         data->start_class->flags |= ANYOF_EOS;
3580                 }
3581             }
3582 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
3583             else {
3584                 /* Positive Lookahead/lookbehind
3585                    In this case we can do fixed string optimisation,
3586                    but we must be careful about it. Note in the case of
3587                    lookbehind the positions will be offset by the minimum
3588                    length of the pattern, something we won't know about
3589                    until after the recurse.
3590                 */
3591                 I32 deltanext, fake = 0;
3592                 regnode *nscan;
3593                 struct regnode_charclass_class intrnl;
3594                 int f = 0;
3595                 /* We use SAVEFREEPV so that when the full compile 
3596                     is finished perl will clean up the allocated 
3597                     minlens when its all done. This was we don't
3598                     have to worry about freeing them when we know
3599                     they wont be used, which would be a pain.
3600                  */
3601                 I32 *minnextp;
3602                 Newx( minnextp, 1, I32 );
3603                 SAVEFREEPV(minnextp);
3604
3605                 if (data) {
3606                     StructCopy(data, &data_fake, scan_data_t);
3607                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
3608                         f |= SCF_DO_SUBSTR;
3609                         if (scan->flags) 
3610                             SCAN_COMMIT(pRExC_state, &data_fake,minlenp);
3611                         data_fake.last_found=newSVsv(data->last_found);
3612                     }
3613                 }
3614                 else
3615                     data_fake.last_closep = &fake;
3616                 data_fake.flags = 0;
3617                 data_fake.pos_delta = delta;
3618                 if (is_inf)
3619                     data_fake.flags |= SF_IS_INF;
3620                 if ( flags & SCF_DO_STCLASS && !scan->flags
3621                      && OP(scan) == IFMATCH ) { /* Lookahead */
3622                     cl_init(pRExC_state, &intrnl);
3623                     data_fake.start_class = &intrnl;
3624                     f |= SCF_DO_STCLASS_AND;
3625                 }
3626                 if (flags & SCF_WHILEM_VISITED_POS)
3627                     f |= SCF_WHILEM_VISITED_POS;
3628                 next = regnext(scan);
3629                 nscan = NEXTOPER(NEXTOPER(scan));
3630
3631                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext, 
3632                     last, &data_fake, stopparen, recursed, NULL, f,depth+1);
3633                 if (scan->flags) {
3634                     if (deltanext) {
3635                         FAIL("Variable length lookbehind not implemented");
3636                     }
3637                     else if (*minnextp > (I32)U8_MAX) {
3638                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
3639                     }
3640                     scan->flags = (U8)*minnextp;
3641                 }
3642
3643                 *minnextp += min;
3644
3645                 if (f & SCF_DO_STCLASS_AND) {
3646                     const int was = (data->start_class->flags & ANYOF_EOS);
3647
3648                     cl_and(data->start_class, &intrnl);
3649                     if (was)
3650                         data->start_class->flags |= ANYOF_EOS;
3651                 }
3652                 if (data) {
3653                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3654                         pars++;
3655                     if (data_fake.flags & SF_HAS_EVAL)
3656                         data->flags |= SF_HAS_EVAL;
3657                     data->whilem_c = data_fake.whilem_c;
3658                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
3659                         if (RExC_rx->minlen<*minnextp)
3660                             RExC_rx->minlen=*minnextp;
3661                         SCAN_COMMIT(pRExC_state, &data_fake, minnextp);
3662                         SvREFCNT_dec(data_fake.last_found);
3663                         
3664                         if ( data_fake.minlen_fixed != minlenp ) 
3665                         {
3666                             data->offset_fixed= data_fake.offset_fixed;
3667                             data->minlen_fixed= data_fake.minlen_fixed;
3668                             data->lookbehind_fixed+= scan->flags;
3669                         }
3670                         if ( data_fake.minlen_float != minlenp )
3671                         {
3672                             data->minlen_float= data_fake.minlen_float;
3673                             data->offset_float_min=data_fake.offset_float_min;
3674                             data->offset_float_max=data_fake.offset_float_max;
3675                             data->lookbehind_float+= scan->flags;
3676                         }
3677                     }
3678                 }
3679
3680
3681             }
3682 #endif
3683         }
3684         else if (OP(scan) == OPEN) {
3685             if (stopparen != (I32)ARG(scan))
3686                 pars++;
3687         }
3688         else if (OP(scan) == CLOSE) {
3689             if (stopparen == (I32)ARG(scan)) {
3690                 break;
3691             }
3692             if ((I32)ARG(scan) == is_par) {
3693                 next = regnext(scan);
3694
3695                 if ( next && (OP(next) != WHILEM) && next < last)
3696                     is_par = 0;         /* Disable optimization */
3697             }
3698             if (data)
3699                 *(data->last_closep) = ARG(scan);
3700         }
3701         else if (OP(scan) == EVAL) {
3702                 if (data)
3703                     data->flags |= SF_HAS_EVAL;
3704         }
3705         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
3706             if (flags & SCF_DO_SUBSTR) {
3707                 SCAN_COMMIT(pRExC_state,data,minlenp);
3708                 flags &= ~SCF_DO_SUBSTR;
3709             }
3710             if (data && OP(scan)==ACCEPT) {
3711                 data->flags |= SCF_SEEN_ACCEPT;
3712                 if (stopmin > min)
3713                     stopmin = min;
3714             }
3715         }
3716         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
3717         {
3718                 if (flags & SCF_DO_SUBSTR) {
3719                     SCAN_COMMIT(pRExC_state,data,minlenp);
3720                     data->longest = &(data->longest_float);
3721                 }
3722                 is_inf = is_inf_internal = 1;
3723                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3724                     cl_anything(pRExC_state, data->start_class);
3725                 flags &= ~SCF_DO_STCLASS;
3726         }
3727         else if (OP(scan) == GPOS) {
3728             if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) &&
3729                 !(delta || is_inf || (data && data->pos_delta))) 
3730             {
3731                 if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR))
3732                     RExC_rx->extflags |= RXf_ANCH_GPOS;
3733                 if (RExC_rx->gofs < (U32)min)
3734                     RExC_rx->gofs = min;
3735             } else {
3736                 RExC_rx->extflags |= RXf_GPOS_FLOAT;
3737                 RExC_rx->gofs = 0;
3738             }       
3739         }
3740 #ifdef TRIE_STUDY_OPT
3741 #ifdef FULL_TRIE_STUDY
3742         else if (PL_regkind[OP(scan)] == TRIE) {
3743             /* NOTE - There is similar code to this block above for handling
3744                BRANCH nodes on the initial study.  If you change stuff here
3745                check there too. */
3746             regnode *trie_node= scan;
3747             regnode *tail= regnext(scan);
3748             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
3749             I32 max1 = 0, min1 = I32_MAX;
3750             struct regnode_charclass_class accum;
3751
3752             if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
3753                 SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
3754             if (flags & SCF_DO_STCLASS)
3755                 cl_init_zero(pRExC_state, &accum);
3756                 
3757             if (!trie->jump) {
3758                 min1= trie->minlen;
3759                 max1= trie->maxlen;
3760             } else {
3761                 const regnode *nextbranch= NULL;
3762                 U32 word;
3763                 
3764                 for ( word=1 ; word <= trie->wordcount ; word++) 
3765                 {
3766                     I32 deltanext=0, minnext=0, f = 0, fake;
3767                     struct regnode_charclass_class this_class;
3768                     
3769                     data_fake.flags = 0;
3770                     if (data) {
3771                         data_fake.whilem_c = data->whilem_c;
3772                         data_fake.last_closep = data->last_closep;
3773                     }
3774                     else
3775                         data_fake.last_closep = &fake;
3776                     data_fake.pos_delta = delta;
3777                     if (flags & SCF_DO_STCLASS) {
3778                         cl_init(pRExC_state, &this_class);
3779                         data_fake.start_class = &this_class;
3780                         f = SCF_DO_STCLASS_AND;
3781                     }
3782                     if (flags & SCF_WHILEM_VISITED_POS)
3783                         f |= SCF_WHILEM_VISITED_POS;
3784     
3785                     if (trie->jump[word]) {
3786                         if (!nextbranch)
3787                             nextbranch = trie_node + trie->jump[0];
3788                         scan= trie_node + trie->jump[word];
3789                         /* We go from the jump point to the branch that follows
3790                            it. Note this means we need the vestigal unused branches
3791                            even though they arent otherwise used.
3792                          */
3793                         minnext = study_chunk(pRExC_state, &scan, minlenp, 
3794                             &deltanext, (regnode *)nextbranch, &data_fake, 
3795                             stopparen, recursed, NULL, f,depth+1);
3796                     }
3797                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
3798                         nextbranch= regnext((regnode*)nextbranch);
3799                     
3800                     if (min1 > (I32)(minnext + trie->minlen))
3801                         min1 = minnext + trie->minlen;
3802                     if (max1 < (I32)(minnext + deltanext + trie->maxlen))
3803                         max1 = minnext + deltanext + trie->maxlen;
3804                     if (deltanext == I32_MAX)
3805                         is_inf = is_inf_internal = 1;
3806                     
3807                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3808                         pars++;
3809                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
3810                         if ( stopmin > min + min1) 
3811                             stopmin = min + min1;
3812                         flags &= ~SCF_DO_SUBSTR;
3813                         if (data)
3814                             data->flags |= SCF_SEEN_ACCEPT;
3815                     }
3816                     if (data) {
3817                         if (data_fake.flags & SF_HAS_EVAL)
3818                             data->flags |= SF_HAS_EVAL;
3819                         data->whilem_c = data_fake.whilem_c;
3820                     }
3821                     if (flags & SCF_DO_STCLASS)
3822                         cl_or(pRExC_state, &accum, &this_class);
3823                 }
3824             }
3825             if (flags & SCF_DO_SUBSTR) {
3826                 data->pos_min += min1;
3827                 data->pos_delta += max1 - min1;
3828                 if (max1 != min1 || is_inf)
3829                     data->longest = &(data->longest_float);
3830             }
3831             min += min1;
3832             delta += max1 - min1;
3833             if (flags & SCF_DO_STCLASS_OR) {
3834                 cl_or(pRExC_state, data->start_class, &accum);
3835                 if (min1) {
3836                     cl_and(data->start_class, and_withp);
3837                     flags &= ~SCF_DO_STCLASS;
3838                 }
3839             }
3840             else if (flags & SCF_DO_STCLASS_AND) {
3841                 if (min1) {
3842                     cl_and(data->start_class, &accum);
3843                     flags &= ~SCF_DO_STCLASS;
3844                 }
3845                 else {
3846                     /* Switch to OR mode: cache the old value of
3847                      * data->start_class */
3848                     INIT_AND_WITHP;
3849                     StructCopy(data->start_class, and_withp,
3850                                struct regnode_charclass_class);
3851                     flags &= ~SCF_DO_STCLASS_AND;
3852                     StructCopy(&accum, data->start_class,
3853                                struct regnode_charclass_class);
3854                     flags |= SCF_DO_STCLASS_OR;
3855                     data->start_class->flags |= ANYOF_EOS;
3856                 }
3857             }
3858             scan= tail;
3859             continue;
3860         }
3861 #else
3862         else if (PL_regkind[OP(scan)] == TRIE) {
3863             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
3864             U8*bang=NULL;
3865             
3866             min += trie->minlen;
3867             delta += (trie->maxlen - trie->minlen);
3868             flags &= ~SCF_DO_STCLASS; /* xxx */
3869             if (flags & SCF_DO_SUBSTR) {
3870                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
3871                 data->pos_min += trie->minlen;
3872                 data->pos_delta += (trie->maxlen - trie->minlen);
3873                 if (trie->maxlen != trie->minlen)
3874                     data->longest = &(data->longest_float);
3875             }
3876             if (trie->jump) /* no more substrings -- for now /grr*/
3877                 flags &= ~SCF_DO_SUBSTR; 
3878         }
3879 #endif /* old or new */
3880 #endif /* TRIE_STUDY_OPT */     
3881         /* Else: zero-length, ignore. */
3882         scan = regnext(scan);
3883     }
3884     if (frame) {
3885         last = frame->last;
3886         scan = frame->next;
3887         stopparen = frame->stop;
3888         frame = frame->prev;
3889         goto fake_study_recurse;
3890     }
3891
3892   finish:
3893     assert(!frame);
3894     DEBUG_STUDYDATA("pre-fin:",data,depth);
3895
3896     *scanp = scan;
3897     *deltap = is_inf_internal ? I32_MAX : delta;
3898     if (flags & SCF_DO_SUBSTR && is_inf)
3899         data->pos_delta = I32_MAX - data->pos_min;
3900     if (is_par > (I32)U8_MAX)
3901         is_par = 0;
3902     if (is_par && pars==1 && data) {
3903         data->flags |= SF_IN_PAR;
3904         data->flags &= ~SF_HAS_PAR;
3905     }
3906     else if (pars && data) {
3907         data->flags |= SF_HAS_PAR;
3908         data->flags &= ~SF_IN_PAR;
3909     }
3910     if (flags & SCF_DO_STCLASS_OR)
3911         cl_and(data->start_class, and_withp);
3912     if (flags & SCF_TRIE_RESTUDY)
3913         data->flags |=  SCF_TRIE_RESTUDY;
3914     
3915     DEBUG_STUDYDATA("post-fin:",data,depth);
3916     
3917     return min < stopmin ? min : stopmin;
3918 }
3919
3920 STATIC U32
3921 S_add_data(RExC_state_t *pRExC_state, U32 n, const char *s)
3922 {
3923     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
3924
3925     Renewc(RExC_rxi->data,
3926            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
3927            char, struct reg_data);
3928     if(count)
3929         Renew(RExC_rxi->data->what, count + n, U8);
3930     else
3931         Newx(RExC_rxi->data->what, n, U8);
3932     RExC_rxi->data->count = count + n;
3933     Copy(s, RExC_rxi->data->what + count, n, U8);
3934     return count;
3935 }
3936
3937 /*XXX: todo make this not included in a non debugging perl */
3938 #ifndef PERL_IN_XSUB_RE
3939 void
3940 Perl_reginitcolors(pTHX)
3941 {
3942     dVAR;
3943     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
3944     if (s) {
3945         char *t = savepv(s);
3946         int i = 0;
3947         PL_colors[0] = t;
3948         while (++i < 6) {
3949             t = strchr(t, '\t');
3950             if (t) {
3951                 *t = '\0';
3952                 PL_colors[i] = ++t;
3953             }
3954             else
3955                 PL_colors[i] = t = (char *)"";
3956         }
3957     } else {
3958         int i = 0;
3959         while (i < 6)
3960             PL_colors[i++] = (char *)"";
3961     }
3962     PL_colorset = 1;
3963 }
3964 #endif
3965
3966
3967 #ifdef TRIE_STUDY_OPT
3968 #define CHECK_RESTUDY_GOTO                                  \
3969         if (                                                \
3970               (data.flags & SCF_TRIE_RESTUDY)               \
3971               && ! restudied++                              \
3972         )     goto reStudy
3973 #else
3974 #define CHECK_RESTUDY_GOTO
3975 #endif        
3976
3977 /*
3978  - pregcomp - compile a regular expression into internal code
3979  *
3980  * We can't allocate space until we know how big the compiled form will be,
3981  * but we can't compile it (and thus know how big it is) until we've got a
3982  * place to put the code.  So we cheat:  we compile it twice, once with code
3983  * generation turned off and size counting turned on, and once "for real".
3984  * This also means that we don't allocate space until we are sure that the
3985  * thing really will compile successfully, and we never have to move the
3986  * code and thus invalidate pointers into it.  (Note that it has to be in
3987  * one piece because free() must be able to free it all.) [NB: not true in perl]
3988  *
3989  * Beware that the optimization-preparation code in here knows about some
3990  * of the structure of the compiled regexp.  [I'll say.]
3991  */
3992
3993
3994
3995 #ifndef PERL_IN_XSUB_RE
3996 #define RE_ENGINE_PTR &PL_core_reg_engine
3997 #else
3998 extern const struct regexp_engine my_reg_engine;
3999 #define RE_ENGINE_PTR &my_reg_engine
4000 #endif
4001
4002 #ifndef PERL_IN_XSUB_RE 
4003 regexp *
4004 Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
4005 {
4006     dVAR;
4007     HV * const table = GvHV(PL_hintgv);
4008     /* Dispatch a request to compile a regexp to correct 
4009        regexp engine. */
4010     if (table) {
4011         SV **ptr= hv_fetchs(table, "regcomp", FALSE);
4012         GET_RE_DEBUG_FLAGS_DECL;
4013         if (ptr && SvIOK(*ptr) && SvIV(*ptr)) {
4014             const regexp_engine *eng=INT2PTR(regexp_engine*,SvIV(*ptr));
4015             DEBUG_COMPILE_r({
4016                 PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
4017                     SvIV(*ptr));
4018             });            
4019             return CALLREGCOMP_ENG(eng, exp, xend, pm);
4020         } 
4021     }
4022     return Perl_re_compile(aTHX_ exp, xend, pm);
4023 }
4024 #endif
4025
4026 regexp *
4027 Perl_re_compile(pTHX_ char *exp, char *xend, PMOP *pm)
4028 {
4029     dVAR;
4030     register regexp *r;
4031     register regexp_internal *ri;
4032     regnode *scan;
4033     regnode *first;
4034     I32 flags;
4035     I32 minlen = 0;
4036     I32 sawplus = 0;
4037     I32 sawopen = 0;
4038     scan_data_t data;
4039     RExC_state_t RExC_state;
4040     RExC_state_t * const pRExC_state = &RExC_state;
4041 #ifdef TRIE_STUDY_OPT    
4042     int restudied= 0;
4043     RExC_state_t copyRExC_state;
4044 #endif    
4045     GET_RE_DEBUG_FLAGS_DECL;
4046     DEBUG_r(if (!PL_colorset) reginitcolors());
4047         
4048     if (exp == NULL)
4049         FAIL("NULL regexp argument");
4050
4051     RExC_utf8 = pm->op_pmdynflags & PMdf_CMP_UTF8;
4052
4053     RExC_precomp = exp;
4054     DEBUG_COMPILE_r({
4055         SV *dsv= sv_newmortal();
4056         RE_PV_QUOTED_DECL(s, RExC_utf8,
4057             dsv, RExC_precomp, (xend - exp), 60);
4058         PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
4059                        PL_colors[4],PL_colors[5],s);
4060     });
4061     RExC_flags = pm->op_pmflags;
4062     RExC_sawback = 0;
4063
4064     RExC_seen = 0;
4065     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
4066     RExC_seen_evals = 0;
4067     RExC_extralen = 0;
4068
4069     /* First pass: determine size, legality. */
4070     RExC_parse = exp;
4071     RExC_start = exp;
4072     RExC_end = xend;
4073     RExC_naughty = 0;
4074     RExC_npar = 1;
4075     RExC_nestroot = 0;
4076     RExC_size = 0L;
4077     RExC_emit = &PL_regdummy;
4078     RExC_whilem_seen = 0;
4079     RExC_charnames = NULL;
4080     RExC_open_parens = NULL;
4081     RExC_close_parens = NULL;
4082     RExC_opend = NULL;
4083     RExC_paren_names = NULL;
4084 #ifdef DEBUGGING
4085     RExC_paren_name_list = NULL;
4086 #endif
4087     RExC_recurse = NULL;
4088     RExC_recurse_count = 0;
4089
4090 #if 0 /* REGC() is (currently) a NOP at the first pass.
4091        * Clever compilers notice this and complain. --jhi */
4092     REGC((U8)REG_MAGIC, (char*)RExC_emit);
4093 #endif
4094     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n"));
4095     if (reg(pRExC_state, 0, &flags,1) == NULL) {
4096         RExC_precomp = NULL;
4097         return(NULL);
4098     }
4099     DEBUG_PARSE_r({
4100         PerlIO_printf(Perl_debug_log, 
4101             "Required size %"IVdf" nodes\n"
4102             "Starting second pass (creation)\n", 
4103             (IV)RExC_size);
4104         RExC_lastnum=0; 
4105         RExC_lastparse=NULL; 
4106     });
4107     /* Small enough for pointer-storage convention?
4108        If extralen==0, this means that we will not need long jumps. */
4109     if (RExC_size >= 0x10000L && RExC_extralen)
4110         RExC_size += RExC_extralen;
4111     else
4112         RExC_extralen = 0;
4113     if (RExC_whilem_seen > 15)
4114         RExC_whilem_seen = 15;
4115
4116 #ifdef DEBUGGING
4117     /* Make room for a sentinel value at the end of the program */
4118     RExC_size++;
4119 #endif
4120
4121     /* Allocate space and zero-initialize. Note, the two step process 
4122        of zeroing when in debug mode, thus anything assigned has to 
4123        happen after that */
4124     Newxz(r, 1, regexp);
4125     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
4126          char, regexp_internal);
4127     if ( r == NULL || ri == NULL )
4128         FAIL("Regexp out of space");
4129 #ifdef DEBUGGING
4130     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
4131     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char);
4132 #else 
4133     /* bulk initialize base fields with 0. */
4134     Zero(ri, sizeof(regexp_internal), char);        
4135 #endif
4136
4137     /* non-zero initialization begins here */
4138     RXi_SET( r, ri );
4139     r->engine= RE_ENGINE_PTR;
4140     r->refcnt = 1;
4141     r->prelen = xend - exp;
4142     r->precomp = savepvn(RExC_precomp, r->prelen);
4143     r->extflags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4144     r->intflags = 0;
4145     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
4146     
4147     if (RExC_seen & REG_SEEN_RECURSE) {
4148         Newxz(RExC_open_parens, RExC_npar,regnode *);
4149         SAVEFREEPV(RExC_open_parens);
4150         Newxz(RExC_close_parens,RExC_npar,regnode *);
4151         SAVEFREEPV(RExC_close_parens);
4152     }
4153
4154     /* Useful during FAIL. */
4155 #ifdef RE_TRACK_PATTERN_OFFSETS
4156     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
4157     DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
4158                           "%s %"UVuf" bytes for offset annotations.\n",
4159                           ri->u.offsets ? "Got" : "Couldn't get",
4160                           (UV)((2*RExC_size+1) * sizeof(U32))));
4161 #endif
4162     SetProgLen(ri,RExC_size);
4163     RExC_rx = r;
4164     RExC_rxi = ri;
4165
4166     /* Second pass: emit code. */
4167     RExC_flags = pm->op_pmflags;        /* don't let top level (?i) bleed */
4168     RExC_parse = exp;
4169     RExC_end = xend;
4170     RExC_naughty = 0;
4171     RExC_npar = 1;
4172     RExC_emit_start = ri->program;
4173     RExC_emit = ri->program;
4174 #ifdef DEBUGGING
4175     /* put a sentinal on the end of the program so we can check for
4176        overwrites */
4177     ri->program[RExC_size].type = 255;
4178 #endif
4179     /* Store the count of eval-groups for security checks: */
4180     RExC_rx->seen_evals = RExC_seen_evals;
4181     REGC((U8)REG_MAGIC, (char*) RExC_emit++);
4182     if (reg(pRExC_state, 0, &flags,1) == NULL)
4183         return(NULL);
4184
4185     /* XXXX To minimize changes to RE engine we always allocate
4186        3-units-long substrs field. */
4187     Newx(r->substrs, 1, struct reg_substr_data);
4188     if (RExC_recurse_count) {
4189         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
4190         SAVEFREEPV(RExC_recurse);
4191     }
4192
4193 reStudy:
4194     r->minlen = minlen = sawplus = sawopen = 0;
4195     Zero(r->substrs, 1, struct reg_substr_data);
4196
4197 #ifdef TRIE_STUDY_OPT
4198     if ( restudied ) {
4199         U32 seen=RExC_seen;
4200         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
4201         
4202         RExC_state = copyRExC_state;
4203         if (seen & REG_TOP_LEVEL_BRANCHES) 
4204             RExC_seen |= REG_TOP_LEVEL_BRANCHES;
4205         else
4206             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES;
4207         if (data.last_found) {
4208             SvREFCNT_dec(data.longest_fixed);
4209             SvREFCNT_dec(data.longest_float);
4210             SvREFCNT_dec(data.last_found);
4211         }
4212         StructCopy(&zero_scan_data, &data, scan_data_t);
4213     } else {
4214         StructCopy(&zero_scan_data, &data, scan_data_t);
4215         copyRExC_state = RExC_state;
4216     }
4217 #else
4218     StructCopy(&zero_scan_data, &data, scan_data_t);
4219 #endif    
4220
4221     /* Dig out information for optimizations. */
4222     r->extflags = pm->op_pmflags & RXf_PMf_COMPILETIME; /* Again? */
4223     pm->op_pmflags = RExC_flags;
4224     if (UTF)
4225         r->extflags |= RXf_UTF8;        /* Unicode in it? */
4226     ri->regstclass = NULL;
4227     if (RExC_naughty >= 10)     /* Probably an expensive pattern. */
4228         r->intflags |= PREGf_NAUGHTY;
4229     scan = ri->program + 1;             /* First BRANCH. */
4230
4231     /* testing for BRANCH here tells us whether there is "must appear"
4232        data in the pattern. If there is then we can use it for optimisations */
4233     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /*  Only one top-level choice. */
4234         I32 fake;
4235         STRLEN longest_float_length, longest_fixed_length;
4236         struct regnode_charclass_class ch_class; /* pointed to by data */
4237         int stclass_flag;
4238         I32 last_close = 0; /* pointed to by data */
4239
4240         first = scan;
4241         /* Skip introductions and multiplicators >= 1. */
4242         while ((OP(first) == OPEN && (sawopen = 1)) ||
4243                /* An OR of *one* alternative - should not happen now. */
4244             (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) ||
4245             /* for now we can't handle lookbehind IFMATCH*/
4246             (OP(first) == IFMATCH && !first->flags) || 
4247             (OP(first) == PLUS) ||
4248             (OP(first) == MINMOD) ||
4249                /* An {n,m} with n>0 */
4250             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ) 
4251         {
4252                 
4253                 if (OP(first) == PLUS)
4254                     sawplus = 1;
4255                 else
4256                     first += regarglen[OP(first)];
4257                 if (OP(first) == IFMATCH) {
4258                     first = NEXTOPER(first);
4259                     first += EXTRA_STEP_2ARGS;
4260                 } else  /* XXX possible optimisation for /(?=)/  */
4261                     first = NEXTOPER(first);
4262         }
4263
4264         /* Starting-point info. */
4265       again:
4266         DEBUG_PEEP("first:",first,0);
4267         /* Ignore EXACT as we deal with it later. */
4268         if (PL_regkind[OP(first)] == EXACT) {
4269             if (OP(first) == EXACT)
4270                 NOOP;   /* Empty, get anchored substr later. */
4271             else if ((OP(first) == EXACTF || OP(first) == EXACTFL))
4272                 ri->regstclass = first;
4273         }
4274 #ifdef TRIE_STCLASS     
4275         else if (PL_regkind[OP(first)] == TRIE &&
4276                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0) 
4277         {
4278             regnode *trie_op;
4279             /* this can happen only on restudy */
4280             if ( OP(first) == TRIE ) {
4281                 struct regnode_1 *trieop = (struct regnode_1 *)
4282                     PerlMemShared_calloc(1, sizeof(struct regnode_1));
4283                 StructCopy(first,trieop,struct regnode_1);
4284                 trie_op=(regnode *)trieop;
4285             } else {
4286                 struct regnode_charclass *trieop = (struct regnode_charclass *)
4287                     PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
4288                 StructCopy(first,trieop,struct regnode_charclass);
4289                 trie_op=(regnode *)trieop;
4290             }
4291             OP(trie_op)+=2;
4292             make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
4293             ri->regstclass = trie_op;
4294         }
4295 #endif  
4296         else if (strchr((const char*)PL_simple,OP(first)))
4297             ri->regstclass = first;
4298         else if (PL_regkind[OP(first)] == BOUND ||
4299                  PL_regkind[OP(first)] == NBOUND)
4300             ri->regstclass = first;
4301         else if (PL_regkind[OP(first)] == BOL) {
4302             r->extflags |= (OP(first) == MBOL
4303                            ? RXf_ANCH_MBOL
4304                            : (OP(first) == SBOL
4305                               ? RXf_ANCH_SBOL
4306                               : RXf_ANCH_BOL));
4307             first = NEXTOPER(first);
4308             goto again;
4309         }
4310         else if (OP(first) == GPOS) {
4311             r->extflags |= RXf_ANCH_GPOS;
4312             first = NEXTOPER(first);
4313             goto again;
4314         }
4315         else if ((!sawopen || !RExC_sawback) &&
4316             (OP(first) == STAR &&
4317             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
4318             !(r->extflags & RXf_ANCH) && !(RExC_seen & REG_SEEN_EVAL))
4319         {
4320             /* turn .* into ^.* with an implied $*=1 */
4321             const int type =
4322                 (OP(NEXTOPER(first)) == REG_ANY)
4323                     ? RXf_ANCH_MBOL
4324                     : RXf_ANCH_SBOL;
4325             r->extflags |= type;
4326             r->intflags |= PREGf_IMPLICIT;
4327             first = NEXTOPER(first);
4328             goto again;
4329         }
4330         if (sawplus && (!sawopen || !RExC_sawback)
4331             && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
4332             /* x+ must match at the 1st pos of run of x's */
4333             r->intflags |= PREGf_SKIP;
4334
4335         /* Scan is after the zeroth branch, first is atomic matcher. */
4336 #ifdef TRIE_STUDY_OPT
4337         DEBUG_PARSE_r(
4338             if (!restudied)
4339                 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
4340                               (IV)(first - scan + 1))
4341         );
4342 #else
4343         DEBUG_PARSE_r(
4344             PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
4345                 (IV)(first - scan + 1))
4346         );
4347 #endif
4348
4349
4350         /*
4351         * If there's something expensive in the r.e., find the
4352         * longest literal string that must appear and make it the
4353         * regmust.  Resolve ties in favor of later strings, since
4354         * the regstart check works with the beginning of the r.e.
4355         * and avoiding duplication strengthens checking.  Not a
4356         * strong reason, but sufficient in the absence of others.
4357         * [Now we resolve ties in favor of the earlier string if
4358         * it happens that c_offset_min has been invalidated, since the
4359         * earlier string may buy us something the later one won't.]
4360         */
4361         
4362         data.longest_fixed = newSVpvs("");
4363         data.longest_float = newSVpvs("");
4364         data.last_found = newSVpvs("");
4365         data.longest = &(data.longest_fixed);
4366         first = scan;
4367         if (!ri->regstclass) {
4368             cl_init(pRExC_state, &ch_class);
4369             data.start_class = &ch_class;
4370             stclass_flag = SCF_DO_STCLASS_AND;
4371         } else                          /* XXXX Check for BOUND? */
4372             stclass_flag = 0;
4373         data.last_closep = &last_close;
4374         
4375         minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */
4376             &data, -1, NULL, NULL,
4377             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
4378
4379         
4380         CHECK_RESTUDY_GOTO;
4381
4382
4383         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
4384              && data.last_start_min == 0 && data.last_end > 0
4385              && !RExC_seen_zerolen
4386              && !(RExC_seen & REG_SEEN_VERBARG)
4387              && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
4388             r->extflags |= RXf_CHECK_ALL;
4389         scan_commit(pRExC_state, &data,&minlen,0);
4390         SvREFCNT_dec(data.last_found);
4391
4392         /* Note that code very similar to this but for anchored string 
4393            follows immediately below, changes may need to be made to both. 
4394            Be careful. 
4395          */
4396         longest_float_length = CHR_SVLEN(data.longest_float);
4397         if (longest_float_length
4398             || (data.flags & SF_FL_BEFORE_EOL
4399                 && (!(data.flags & SF_FL_BEFORE_MEOL)
4400                     || (RExC_flags & RXf_PMf_MULTILINE)))) 
4401         {
4402             I32 t,ml;
4403
4404             if (SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
4405                 && data.offset_fixed == data.offset_float_min
4406                 && SvCUR(data.longest_fixed) == SvCUR(data.longest_float))
4407                     goto remove_float;          /* As in (a)+. */
4408
4409             /* copy the information about the longest float from the reg_scan_data
4410                over to the program. */
4411             if (SvUTF8(data.longest_float)) {
4412                 r->float_utf8 = data.longest_float;
4413                 r->float_substr = NULL;
4414             } else {
4415                 r->float_substr = data.longest_float;
4416                 r->float_utf8 = NULL;
4417             }
4418             /* float_end_shift is how many chars that must be matched that 
4419                follow this item. We calculate it ahead of time as once the
4420                lookbehind offset is added in we lose the ability to correctly
4421                calculate it.*/
4422             ml = data.minlen_float ? *(data.minlen_float) 
4423                                    : (I32)longest_float_length;
4424             r->float_end_shift = ml - data.offset_float_min
4425                 - longest_float_length + (SvTAIL(data.longest_float) != 0)
4426                 + data.lookbehind_float;
4427             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
4428             r->float_max_offset = data.offset_float_max;
4429             if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
4430                 r->float_max_offset -= data.lookbehind_float;
4431             
4432             t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
4433                        && (!(data.flags & SF_FL_BEFORE_MEOL)
4434                            || (RExC_flags & RXf_PMf_MULTILINE)));
4435             fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0);
4436         }
4437         else {
4438           remove_float:
4439             r->float_substr = r->float_utf8 = NULL;
4440             SvREFCNT_dec(data.longest_float);
4441             longest_float_length = 0;
4442         }
4443
4444         /* Note that code very similar to this but for floating string 
4445            is immediately above, changes may need to be made to both. 
4446            Be careful. 
4447          */
4448         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
4449         if (longest_fixed_length
4450             || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
4451                 && (!(data.flags & SF_FIX_BEFORE_MEOL)
4452                     || (RExC_flags & RXf_PMf_MULTILINE)))) 
4453         {
4454             I32 t,ml;
4455
4456             /* copy the information about the longest fixed 
4457                from the reg_scan_data over to the program. */
4458             if (SvUTF8(data.longest_fixed)) {
4459                 r->anchored_utf8 = data.longest_fixed;
4460                 r->anchored_substr = NULL;
4461             } else {
4462                 r->anchored_substr = data.longest_fixed;
4463                 r->anchored_utf8 = NULL;
4464             }
4465             /* fixed_end_shift is how many chars that must be matched that 
4466                follow this item. We calculate it ahead of time as once the
4467                lookbehind offset is added in we lose the ability to correctly
4468                calculate it.*/
4469             ml = data.minlen_fixed ? *(data.minlen_fixed) 
4470                                    : (I32)longest_fixed_length;
4471             r->anchored_end_shift = ml - data.offset_fixed
4472                 - longest_fixed_length + (SvTAIL(data.longest_fixed) != 0)
4473                 + data.lookbehind_fixed;
4474             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
4475
4476             t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
4477                  && (!(data.flags & SF_FIX_BEFORE_MEOL)
4478                      || (RExC_flags & RXf_PMf_MULTILINE)));
4479             fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0);
4480         }
4481         else {
4482             r->anchored_substr = r->anchored_utf8 = NULL;
4483             SvREFCNT_dec(data.longest_fixed);
4484             longest_fixed_length = 0;
4485         }
4486         if (ri->regstclass
4487             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
4488             ri->regstclass = NULL;
4489         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
4490             && stclass_flag
4491             && !(data.start_class->flags & ANYOF_EOS)
4492             && !cl_is_anything(data.start_class))
4493         {
4494             const U32 n = add_data(pRExC_state, 1, "f");
4495
4496             Newx(RExC_rxi->data->data[n], 1,
4497                 struct regnode_charclass_class);
4498             StructCopy(data.start_class,
4499                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
4500                        struct regnode_charclass_class);
4501             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
4502             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
4503             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
4504                       regprop(r, sv, (regnode*)data.start_class);
4505                       PerlIO_printf(Perl_debug_log,
4506                                     "synthetic stclass \"%s\".\n",
4507                                     SvPVX_const(sv));});
4508         }
4509
4510         /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
4511         if (longest_fixed_length > longest_float_length) {
4512             r->check_end_shift = r->anchored_end_shift;
4513             r->check_substr = r->anchored_substr;
4514             r->check_utf8 = r->anchored_utf8;
4515             r->check_offset_min = r->check_offset_max = r->anchored_offset;
4516             if (r->extflags & RXf_ANCH_SINGLE)
4517                 r->extflags |= RXf_NOSCAN;
4518         }
4519         else {
4520             r->check_end_shift = r->float_end_shift;
4521             r->check_substr = r->float_substr;
4522             r->check_utf8 = r->float_utf8;
4523             r->check_offset_min = r->float_min_offset;
4524             r->check_offset_max = r->float_max_offset;
4525         }
4526         /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
4527            This should be changed ASAP!  */
4528         if ((r->check_substr || r->check_utf8) && !(r->extflags & RXf_ANCH_GPOS)) {
4529             r->extflags |= RXf_USE_INTUIT;
4530             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
4531                 r->extflags |= RXf_INTUIT_TAIL;
4532         }
4533         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
4534         if ( (STRLEN)minlen < longest_float_length )
4535             minlen= longest_float_length;
4536         if ( (STRLEN)minlen < longest_fixed_length )
4537             minlen= longest_fixed_length;     
4538         */
4539     }
4540     else {
4541         /* Several toplevels. Best we can is to set minlen. */
4542         I32 fake;
4543         struct regnode_charclass_class ch_class;
4544         I32 last_close = 0;
4545         
4546         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
4547
4548         scan = ri->program + 1;
4549         cl_init(pRExC_state, &ch_class);
4550         data.start_class = &ch_class;
4551         data.last_closep = &last_close;
4552
4553         
4554         minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
4555             &data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
4556         
4557         CHECK_RESTUDY_GOTO;
4558
4559         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
4560                 = r->float_substr = r->float_utf8 = NULL;
4561         if (!(data.start_class->flags & ANYOF_EOS)
4562             && !cl_is_anything(data.start_class))
4563         {
4564             const U32 n = add_data(pRExC_state, 1, "f");
4565
4566             Newx(RExC_rxi->data->data[n], 1,
4567                 struct regnode_charclass_class);
4568             StructCopy(data.start_class,
4569                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
4570                        struct regnode_charclass_class);
4571             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
4572             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
4573             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
4574                       regprop(r, sv, (regnode*)data.start_class);
4575                       PerlIO_printf(Perl_debug_log,
4576                                     "synthetic stclass \"%s\".\n",
4577                                     SvPVX_const(sv));});
4578         }
4579     }
4580
4581     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
4582        the "real" pattern. */
4583     DEBUG_OPTIMISE_r({
4584         PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n",
4585                       (IV)minlen, (IV)r->minlen);
4586     });
4587     r->minlenret = minlen;
4588     if (r->minlen < minlen) 
4589         r->minlen = minlen;
4590     
4591     if (RExC_seen & REG_SEEN_GPOS)
4592         r->extflags |= RXf_GPOS_SEEN;
4593     if (RExC_seen & REG_SEEN_LOOKBEHIND)
4594         r->extflags |= RXf_LOOKBEHIND_SEEN;
4595     if (RExC_seen & REG_SEEN_EVAL)
4596         r->extflags |= RXf_EVAL_SEEN;
4597     if (RExC_seen & REG_SEEN_CANY)
4598         r->extflags |= RXf_CANY_SEEN;
4599     if (RExC_seen & REG_SEEN_VERBARG)
4600         r->intflags |= PREGf_VERBARG_SEEN;
4601     if (RExC_seen & REG_SEEN_CUTGROUP)
4602         r->intflags |= PREGf_CUTGROUP_SEEN;
4603     if (RExC_paren_names)
4604         r->paren_names = (HV*)SvREFCNT_inc(RExC_paren_names);
4605     else
4606         r->paren_names = NULL;
4607     if (r->prelen == 3 && strEQ("\\s+", r->precomp))
4608         r->extflags |= RXf_WHITE;
4609     else if (r->prelen == 1 && r->precomp[0] == '^')
4610         r->extflags |= RXf_START_ONLY;
4611
4612 #ifdef DEBUGGING
4613     if (RExC_paren_names) {
4614         ri->name_list_idx = add_data( pRExC_state, 1, "p" );
4615         ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list);
4616     } else
4617 #endif
4618         ri->name_list_idx = 0;
4619
4620     if (RExC_recurse_count) {
4621         for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
4622             const regnode *scan = RExC_recurse[RExC_recurse_count-1];
4623             ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
4624         }
4625     }
4626     Newxz(r->startp, RExC_npar, I32);
4627     Newxz(r->endp, RExC_npar, I32);
4628     /* assume we don't need to swap parens around before we match */
4629
4630     DEBUG_DUMP_r({
4631         PerlIO_printf(Perl_debug_log,"Final program:\n");
4632         regdump(r);
4633     });
4634 #ifdef RE_TRACK_PATTERN_OFFSETS
4635     DEBUG_OFFSETS_r(if (ri->u.offsets) {
4636         const U32 len = ri->u.offsets[0];
4637         U32 i;
4638         GET_RE_DEBUG_FLAGS_DECL;
4639         PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
4640         for (i = 1; i <= len; i++) {
4641             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
4642                 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
4643                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
4644             }
4645         PerlIO_printf(Perl_debug_log, "\n");
4646     });
4647 #endif
4648     return(r);
4649 }
4650
4651 #undef CORE_ONLY_BLOCK
4652 #undef RE_ENGINE_PTR
4653
4654 #ifndef PERL_IN_XSUB_RE
4655 SV*
4656 Perl_reg_named_buff_get(pTHX_ SV* namesv, const REGEXP * const from_re, U32 flags)
4657 {
4658     AV *retarray = NULL;
4659     SV *ret;
4660     if (flags & 1) 
4661         retarray=newAV();
4662     
4663     if (from_re || PL_curpm) {
4664         const REGEXP * const rx = from_re ? from_re : PM_GETRE(PL_curpm);
4665         if (rx && rx->paren_names) {            
4666             HE *he_str = hv_fetch_ent( rx->paren_names, namesv, 0, 0 );
4667             if (he_str) {
4668                 IV i;
4669                 SV* sv_dat=HeVAL(he_str);
4670                 I32 *nums=(I32*)SvPVX(sv_dat);
4671                 for ( i=0; i<SvIVX(sv_dat); i++ ) {
4672                     if ((I32)(rx->nparens) >= nums[i]
4673                         && rx->startp[nums[i]] != -1
4674                         && rx->endp[nums[i]] != -1)
4675                     {
4676                         ret = reg_numbered_buff_get(nums[i],rx,NULL,0);
4677                         if (!retarray) 
4678                             return ret;
4679                     } else {
4680                         ret = newSVsv(&PL_sv_undef);
4681                     }
4682                     if (retarray) {
4683                         SvREFCNT_inc(ret); 
4684                         av_push(retarray, ret);
4685                     }
4686                 }
4687                 if (retarray)
4688                     return (SV*)retarray;
4689             }
4690         }
4691     }
4692     return NULL;
4693 }
4694
4695 SV*
4696 Perl_reg_numbered_buff_get(pTHX_ I32 paren, const REGEXP * const rx, SV* usesv, U32 flags)
4697 {
4698     char *s = NULL;
4699     I32 i = 0;
4700     I32 s1, t1;
4701     SV *sv = usesv ? usesv : newSVpvs("");
4702     PERL_UNUSED_ARG(flags);
4703         
4704     if (!rx->subbeg) {
4705         sv_setsv(sv,&PL_sv_undef);
4706         return sv;
4707     } 
4708     else               
4709     if (paren == -2 && rx->startp[0] != -1) {
4710         /* $` */
4711         i = rx->startp[0];
4712         s = rx->subbeg;
4713     }
4714     else 
4715     if (paren == -1 && rx->endp[0] != -1) {
4716         /* $' */
4717         s = rx->subbeg + rx->endp[0];
4718         i = rx->sublen - rx->endp[0];
4719     } 
4720     else
4721     if ( 0 <= paren && paren <= (I32)rx->nparens &&
4722         (s1 = rx->startp[paren]) != -1 &&
4723         (t1 = rx->endp[paren]) != -1)
4724     {
4725         /* $& $1 ... */
4726         i = t1 - s1;
4727         s = rx->subbeg + s1;
4728     } else {
4729         sv_setsv(sv,&PL_sv_undef);
4730         return sv;
4731     }          
4732     assert(rx->sublen >= (s - rx->subbeg) + i );
4733     if (i >= 0) {
4734         const int oldtainted = PL_tainted;
4735         TAINT_NOT;
4736         sv_setpvn(sv, s, i);
4737         PL_tainted = oldtainted;
4738         if ( (rx->extflags & RXf_CANY_SEEN)
4739             ? (RX_MATCH_UTF8(rx)
4740                         && (!i || is_utf8_string((U8*)s, i)))
4741             : (RX_MATCH_UTF8(rx)) )
4742         {
4743             SvUTF8_on(sv);
4744         }
4745         else
4746             SvUTF8_off(sv);
4747         if (PL_tainting) {
4748             if (RX_MATCH_TAINTED(rx)) {
4749                 if (SvTYPE(sv) >= SVt_PVMG) {
4750                     MAGIC* const mg = SvMAGIC(sv);
4751                     MAGIC* mgt;
4752                     PL_tainted = 1;
4753                     SvMAGIC_set(sv, mg->mg_moremagic);
4754                     SvTAINT(sv);
4755                     if ((mgt = SvMAGIC(sv))) {
4756                         mg->mg_moremagic = mgt;
4757                         SvMAGIC_set(sv, mg);
4758                     }
4759                 } else {
4760                     PL_tainted = 1;
4761                     SvTAINT(sv);
4762                 }
4763             } else 
4764                 SvTAINTED_off(sv);
4765         }
4766     } else {
4767         sv_setsv(sv,&PL_sv_undef);
4768     }
4769     return sv;
4770 }
4771 #endif
4772
4773 /* Scans the name of a named buffer from the pattern.
4774  * If flags is REG_RSN_RETURN_NULL returns null.
4775  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
4776  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
4777  * to the parsed name as looked up in the RExC_paren_names hash.
4778  * If there is an error throws a vFAIL().. type exception.
4779  */
4780
4781 #define REG_RSN_RETURN_NULL    0
4782 #define REG_RSN_RETURN_NAME    1
4783 #define REG_RSN_RETURN_DATA    2
4784
4785 STATIC SV*
4786 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags) {
4787     char *name_start = RExC_parse;
4788
4789     if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
4790          /* skip IDFIRST by using do...while */
4791         if (UTF)
4792             do {
4793                 RExC_parse += UTF8SKIP(RExC_parse);
4794             } while (isALNUM_utf8((U8*)RExC_parse));
4795         else
4796             do {
4797                 RExC_parse++;
4798             } while (isALNUM(*RExC_parse));
4799     }
4800
4801     if ( flags ) {
4802         SV* sv_name = sv_2mortal(Perl_newSVpvn(aTHX_ name_start,
4803             (int)(RExC_parse - name_start)));
4804         if (UTF)
4805             SvUTF8_on(sv_name);
4806         if ( flags == REG_RSN_RETURN_NAME)
4807             return sv_name;
4808         else if (flags==REG_RSN_RETURN_DATA) {
4809             HE *he_str = NULL;
4810             SV *sv_dat = NULL;
4811             if ( ! sv_name )      /* should not happen*/
4812                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
4813             if (RExC_paren_names)
4814                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
4815             if ( he_str )
4816                 sv_dat = HeVAL(he_str);
4817             if ( ! sv_dat )
4818                 vFAIL("Reference to nonexistent named group");
4819             return sv_dat;
4820         }
4821         else {
4822             Perl_croak(aTHX_ "panic: bad flag in reg_scan_name");
4823         }
4824         /* NOT REACHED */
4825     }
4826     return NULL;
4827 }
4828
4829 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
4830     int rem=(int)(RExC_end - RExC_parse);                       \
4831     int cut;                                                    \
4832     int num;                                                    \
4833     int iscut=0;                                                \
4834     if (rem>10) {                                               \
4835         rem=10;                                                 \
4836         iscut=1;                                                \
4837     }                                                           \
4838     cut=10-rem;                                                 \
4839     if (RExC_lastparse!=RExC_parse)                             \
4840         PerlIO_printf(Perl_debug_log," >%.*s%-*s",              \
4841             rem, RExC_parse,                                    \
4842             cut + 4,                                            \
4843             iscut ? "..." : "<"                                 \
4844         );                                                      \
4845     else                                                        \
4846         PerlIO_printf(Perl_debug_log,"%16s","");                \
4847                                                                 \
4848     if (SIZE_ONLY)                                              \
4849        num=RExC_size;                                           \
4850     else                                                        \
4851        num=REG_NODE_NUM(RExC_emit);                             \
4852     if (RExC_lastnum!=num)                                      \
4853        PerlIO_printf(Perl_debug_log,"|%4d",num);                \
4854     else                                                        \
4855        PerlIO_printf(Perl_debug_log,"|%4s","");                 \
4856     PerlIO_printf(Perl_debug_log,"|%*s%-4s",                    \
4857         (int)((depth*2)), "",                                   \
4858         (funcname)                                              \
4859     );                                                          \
4860     RExC_lastnum=num;                                           \
4861     RExC_lastparse=RExC_parse;                                  \
4862 })
4863
4864
4865
4866 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
4867     DEBUG_PARSE_MSG((funcname));                            \
4868     PerlIO_printf(Perl_debug_log,"%4s","\n");               \
4869 })
4870 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({           \
4871     DEBUG_PARSE_MSG((funcname));                            \
4872     PerlIO_printf(Perl_debug_log,fmt "\n",args);               \
4873 })
4874 /*
4875  - reg - regular expression, i.e. main body or parenthesized thing
4876  *
4877  * Caller must absorb opening parenthesis.
4878  *
4879  * Combining parenthesis handling with the base level of regular expression
4880  * is a trifle forced, but the need to tie the tails of the branches to what
4881  * follows makes it hard to avoid.
4882  */
4883 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
4884 #ifdef DEBUGGING
4885 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
4886 #else
4887 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
4888 #endif
4889
4890 /* this idea is borrowed from STR_WITH_LEN in handy.h */
4891 #define CHECK_WORD(s,v,l)  \
4892     (((sizeof(s)-1)==(l)) && (strnEQ(start_verb, (s ""), (sizeof(s)-1))))
4893
4894 STATIC regnode *
4895 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
4896     /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
4897 {
4898     dVAR;
4899     register regnode *ret;              /* Will be the head of the group. */
4900     register regnode *br;
4901     register regnode *lastbr;
4902     register regnode *ender = NULL;
4903     register I32 parno = 0;
4904     I32 flags;
4905     const I32 oregflags = RExC_flags;
4906     bool have_branch = 0;
4907     bool is_open = 0;
4908
4909     /* for (?g), (?gc), and (?o) warnings; warning
4910        about (?c) will warn about (?g) -- japhy    */
4911
4912 #define WASTED_O  0x01
4913 #define WASTED_G  0x02
4914 #define WASTED_C  0x04
4915 #define WASTED_GC (0x02|0x04)
4916     I32 wastedflags = 0x00;
4917
4918     char * parse_start = RExC_parse; /* MJD */
4919     char * const oregcomp_parse = RExC_parse;
4920
4921     GET_RE_DEBUG_FLAGS_DECL;
4922     DEBUG_PARSE("reg ");
4923
4924
4925     *flagp = 0;                         /* Tentatively. */
4926
4927
4928     /* Make an OPEN node, if parenthesized. */
4929     if (paren) {
4930         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
4931             char *start_verb = RExC_parse;
4932             STRLEN verb_len = 0;
4933             char *start_arg = NULL;
4934             unsigned char op = 0;
4935             int argok = 1;
4936             int internal_argval = 0; /* internal_argval is only useful if !argok */
4937             while ( *RExC_parse && *RExC_parse != ')' ) {
4938                 if ( *RExC_parse == ':' ) {
4939                     start_arg = RExC_parse + 1;
4940                     break;
4941                 }
4942                 RExC_parse++;
4943             }
4944             ++start_verb;
4945             verb_len = RExC_parse - start_verb;
4946             if ( start_arg ) {
4947                 RExC_parse++;
4948                 while ( *RExC_parse && *RExC_parse != ')' ) 
4949                     RExC_parse++;
4950                 if ( *RExC_parse != ')' ) 
4951                     vFAIL("Unterminated verb pattern argument");
4952                 if ( RExC_parse == start_arg )
4953                     start_arg = NULL;
4954             } else {
4955                 if ( *RExC_parse != ')' )
4956                     vFAIL("Unterminated verb pattern");
4957             }
4958             
4959             switch ( *start_verb ) {
4960             case 'A':  /* (*ACCEPT) */
4961                 if ( CHECK_WORD("ACCEPT",start_verb,verb_len) ) {
4962                     op = ACCEPT;
4963                     internal_argval = RExC_nestroot;
4964                 }
4965                 break;
4966             case 'C':  /* (*COMMIT) */
4967                 if ( CHECK_WORD("COMMIT",start_verb,verb_len) )
4968                     op = COMMIT;
4969                 break;
4970             case 'F':  /* (*FAIL) */
4971                 if ( verb_len==1 || CHECK_WORD("FAIL",start_verb,verb_len) ) {
4972                     op = OPFAIL;
4973                     argok = 0;
4974                 }
4975                 break;
4976             case ':':  /* (*:NAME) */
4977             case 'M':  /* (*MARK:NAME) */
4978                 if ( verb_len==0 || CHECK_WORD("MARK",start_verb,verb_len) ) {
4979                     op = MARKPOINT;
4980                     argok = -1;
4981                 }
4982                 break;
4983             case 'P':  /* (*PRUNE) */
4984                 if ( CHECK_WORD("PRUNE",start_verb,verb_len) )
4985                     op = PRUNE;
4986                 break;
4987             case 'S':   /* (*SKIP) */  
4988                 if ( CHECK_WORD("SKIP",start_verb,verb_len) ) 
4989                     op = SKIP;
4990                 break;
4991             case 'T':  /* (*THEN) */
4992                 /* [19:06] <TimToady> :: is then */
4993                 if ( CHECK_WORD("THEN",start_verb,verb_len) ) {
4994                     op = CUTGROUP;
4995                     RExC_seen |= REG_SEEN_CUTGROUP;
4996                 }
4997                 break;
4998             }
4999             if ( ! op ) {
5000                 RExC_parse++;
5001                 vFAIL3("Unknown verb pattern '%.*s'",
5002                     verb_len, start_verb);
5003             }
5004             if ( argok ) {
5005                 if ( start_arg && internal_argval ) {
5006                     vFAIL3("Verb pattern '%.*s' may not have an argument",
5007                         verb_len, start_verb); 
5008                 } else if ( argok < 0 && !start_arg ) {
5009                     vFAIL3("Verb pattern '%.*s' has a mandatory argument",
5010                         verb_len, start_verb);    
5011                 } else {
5012                     ret = reganode(pRExC_state, op, internal_argval);
5013                     if ( ! internal_argval && ! SIZE_ONLY ) {
5014                         if (start_arg) {
5015                             SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
5016                             ARG(ret) = add_data( pRExC_state, 1, "S" );
5017                             RExC_rxi->data->data[ARG(ret)]=(void*)sv;
5018                             ret->flags = 0;
5019                         } else {
5020                             ret->flags = 1; 
5021                         }
5022                     }               
5023                 }
5024                 if (!internal_argval)
5025                     RExC_seen |= REG_SEEN_VERBARG;
5026             } else if ( start_arg ) {
5027                 vFAIL3("Verb pattern '%.*s' may not have an argument",
5028                         verb_len, start_verb);    
5029             } else {
5030                 ret = reg_node(pRExC_state, op);
5031             }
5032             nextchar(pRExC_state);
5033             return ret;
5034         } else 
5035         if (*RExC_parse == '?') { /* (?...) */
5036             bool is_logical = 0;
5037             const char * const seqstart = RExC_parse;
5038
5039             RExC_parse++;
5040             paren = *RExC_parse++;
5041             ret = NULL;                 /* For look-ahead/behind. */
5042             switch (paren) {
5043
5044             case 'P':   /* (?P...) variants for those used to PCRE/Python */
5045                 paren = *RExC_parse++;
5046                 if ( paren == '<')         /* (?P<...>) named capture */
5047                     goto named_capture;
5048                 else if (paren == '>') {   /* (?P>name) named recursion */
5049                     goto named_recursion;
5050                 }
5051                 else if (paren == '=') {   /* (?P=...)  named backref */
5052                     /* this pretty much dupes the code for \k<NAME> in regatom(), if
5053                        you change this make sure you change that */
5054                     char* name_start = RExC_parse;
5055                     U32 num = 0;
5056                     SV *sv_dat = reg_scan_name(pRExC_state,
5057                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
5058                     if (RExC_parse == name_start || *RExC_parse != ')')
5059                         vFAIL2("Sequence %.3s... not terminated",parse_start);
5060
5061                     if (!SIZE_ONLY) {
5062                         num = add_data( pRExC_state, 1, "S" );
5063                         RExC_rxi->data->data[num]=(void*)sv_dat;
5064                         SvREFCNT_inc(sv_dat);
5065                     }
5066                     RExC_sawback = 1;
5067                     ret = reganode(pRExC_state,
5068                            (U8)(FOLD ? (LOC ? NREFFL : NREFF) : NREF),
5069                            num);
5070                     *flagp |= HASWIDTH;
5071
5072                     Set_Node_Offset(ret, parse_start+1);
5073                     Set_Node_Cur_Length(ret); /* MJD */
5074
5075                     nextchar(pRExC_state);
5076                     return ret;
5077                 }
5078                 goto unknown;
5079             case '<':           /* (?<...) */
5080                 if (*RExC_parse == '!')
5081                     paren = ',';
5082                 else if (*RExC_parse != '=') 
5083               named_capture:
5084                 {               /* (?<...>) */
5085                     char *name_start;
5086                     SV *svname;
5087                     paren= '>';
5088             case '\'':          /* (?'...') */
5089                     name_start= RExC_parse;
5090                     svname = reg_scan_name(pRExC_state,
5091                         SIZE_ONLY ?  /* reverse test from the others */
5092                         REG_RSN_RETURN_NAME : 
5093                         REG_RSN_RETURN_NULL);
5094                     if (RExC_parse == name_start)
5095                         goto unknown;
5096                     if (*RExC_parse != paren)
5097                         vFAIL2("Sequence (?%c... not terminated",
5098                             paren=='>' ? '<' : paren);
5099                     if (SIZE_ONLY) {
5100                         HE *he_str;
5101                         SV *sv_dat = NULL;
5102                         if (!svname) /* shouldnt happen */
5103                             Perl_croak(aTHX_
5104                                 "panic: reg_scan_name returned NULL");
5105                         if (!RExC_paren_names) {
5106                             RExC_paren_names= newHV();
5107                             sv_2mortal((SV*)RExC_paren_names);
5108 #ifdef DEBUGGING
5109                             RExC_paren_name_list= newAV();
5110                             sv_2mortal((SV*)RExC_paren_name_list);
5111 #endif
5112                         }
5113                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
5114                         if ( he_str )
5115                             sv_dat = HeVAL(he_str);
5116                         if ( ! sv_dat ) {
5117                             /* croak baby croak */
5118                             Perl_croak(aTHX_
5119                                 "panic: paren_name hash element allocation failed");
5120                         } else if ( SvPOK(sv_dat) ) {
5121                             IV count=SvIV(sv_dat);
5122                             I32 *pv=(I32*)SvGROW(sv_dat,SvCUR(sv_dat)+sizeof(I32)+1);
5123                             SvCUR_set(sv_dat,SvCUR(sv_dat)+sizeof(I32));
5124                             pv[count]=RExC_npar;
5125                             SvIVX(sv_dat)++;
5126                         } else {
5127                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
5128                             sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
5129                             SvIOK_on(sv_dat);
5130                             SvIVX(sv_dat)= 1;
5131                         }
5132 #ifdef DEBUGGING
5133                         if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
5134                             SvREFCNT_dec(svname);
5135 #endif
5136
5137                         /*sv_dump(sv_dat);*/
5138                     }
5139                     nextchar(pRExC_state);
5140                     paren = 1;
5141                     goto capturing_parens;
5142                 }
5143                 RExC_seen |= REG_SEEN_LOOKBEHIND;
5144                 RExC_parse++;
5145             case '=':           /* (?=...) */
5146             case '!':           /* (?!...) */
5147                 RExC_seen_zerolen++;
5148                 if (*RExC_parse == ')') {
5149                     ret=reg_node(pRExC_state, OPFAIL);
5150                     nextchar(pRExC_state);
5151                     return ret;
5152                 }
5153             case ':':           /* (?:...) */
5154             case '>':           /* (?>...) */
5155                 break;
5156             case '$':           /* (?$...) */
5157             case '@':           /* (?@...) */
5158                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
5159                 break;
5160             case '#':           /* (?#...) */
5161                 while (*RExC_parse && *RExC_parse != ')')
5162                     RExC_parse++;
5163                 if (*RExC_parse != ')')
5164                     FAIL("Sequence (?#... not terminated");
5165                 nextchar(pRExC_state);
5166                 *flagp = TRYAGAIN;
5167                 return NULL;
5168             case '0' :           /* (?0) */
5169             case 'R' :           /* (?R) */
5170                 if (*RExC_parse != ')')
5171                     FAIL("Sequence (?R) not terminated");
5172                 ret = reg_node(pRExC_state, GOSTART);
5173                 nextchar(pRExC_state);
5174                 return ret;
5175                 /*notreached*/
5176             { /* named and numeric backreferences */
5177                 I32 num;
5178             case '&':            /* (?&NAME) */
5179                 parse_start = RExC_parse - 1;
5180               named_recursion:
5181                 {
5182                     SV *sv_dat = reg_scan_name(pRExC_state,
5183                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
5184                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
5185                 }
5186                 goto gen_recurse_regop;
5187                 /* NOT REACHED */
5188             case '+':
5189                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
5190                     RExC_parse++;
5191                     vFAIL("Illegal pattern");
5192                 }
5193                 goto parse_recursion;
5194                 /* NOT REACHED*/
5195             case '-': /* (?-1) */
5196                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
5197                     RExC_parse--; /* rewind to let it be handled later */
5198                     goto parse_flags;
5199                 } 
5200                 /*FALLTHROUGH */
5201             case '1': case '2': case '3': case '4': /* (?1) */
5202             case '5': case '6': case '7': case '8': case '9':
5203                 RExC_parse--;
5204               parse_recursion:
5205                 num = atoi(RExC_parse);
5206                 parse_start = RExC_parse - 1; /* MJD */
5207                 if (*RExC_parse == '-')
5208                     RExC_parse++;
5209                 while (isDIGIT(*RExC_parse))
5210                         RExC_parse++;
5211                 if (*RExC_parse!=')') 
5212                     vFAIL("Expecting close bracket");
5213                         
5214               gen_recurse_regop:
5215                 if ( paren == '-' ) {
5216                     /*
5217                     Diagram of capture buffer numbering.
5218                     Top line is the normal capture buffer numbers
5219                     Botton line is the negative indexing as from
5220                     the X (the (?-2))
5221
5222                     +   1 2    3 4 5 X          6 7
5223                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
5224                     -   5 4    3 2 1 X          x x
5225
5226                     */
5227                     num = RExC_npar + num;
5228                     if (num < 1)  {
5229                         RExC_parse++;
5230                         vFAIL("Reference to nonexistent group");
5231                     }
5232                 } else if ( paren == '+' ) {
5233                     num = RExC_npar + num - 1;
5234                 }
5235
5236                 ret = reganode(pRExC_state, GOSUB, num);
5237                 if (!SIZE_ONLY) {
5238                     if (num > (I32)RExC_rx->nparens) {
5239                         RExC_parse++;
5240                         vFAIL("Reference to nonexistent group");
5241                     }
5242                     ARG2L_SET( ret, RExC_recurse_count++);
5243                     RExC_emit++;
5244                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
5245                         "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
5246                 } else {
5247                     RExC_size++;
5248                 }
5249                 RExC_seen |= REG_SEEN_RECURSE;
5250                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
5251                 Set_Node_Offset(ret, parse_start); /* MJD */
5252
5253                 nextchar(pRExC_state);
5254                 return ret;
5255             } /* named and numeric backreferences */
5256             /* NOT REACHED */
5257
5258             case 'p':           /* (?p...) */
5259                 if (SIZE_ONLY && ckWARN2(WARN_DEPRECATED, WARN_REGEXP))
5260                     vWARNdep(RExC_parse, "(?p{}) is deprecated - use (??{})");
5261                 /* FALL THROUGH*/
5262             case '?':           /* (??...) */
5263                 is_logical = 1;
5264                 if (*RExC_parse != '{')
5265                     goto unknown;
5266                 paren = *RExC_parse++;
5267                 /* FALL THROUGH */
5268             case '{':           /* (?{...}) */
5269             {
5270                 I32 count = 1;
5271                 U32 n = 0;
5272                 char c;
5273                 char *s = RExC_parse;
5274
5275                 RExC_seen_zerolen++;
5276                 RExC_seen |= REG_SEEN_EVAL;
5277                 while (count && (c = *RExC_parse)) {
5278                     if (c == '\\') {
5279                         if (RExC_parse[1])
5280                             RExC_parse++;
5281                     }
5282                     else if (c == '{')
5283                         count++;
5284                     else if (c == '}')
5285                         count--;
5286                     RExC_parse++;
5287                 }
5288                 if (*RExC_parse != ')') {
5289                     RExC_parse = s;             
5290                     vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
5291                 }
5292                 if (!SIZE_ONLY) {
5293                     PAD *pad;
5294                     OP_4tree *sop, *rop;
5295                     SV * const sv = newSVpvn(s, RExC_parse - 1 - s);
5296
5297                     ENTER;
5298                     Perl_save_re_context(aTHX);
5299                     rop = sv_compile_2op(sv, &sop, "re", &pad);
5300                     sop->op_private |= OPpREFCOUNTED;
5301                     /* re_dup will OpREFCNT_inc */
5302                     OpREFCNT_set(sop, 1);
5303                     LEAVE;
5304
5305                     n = add_data(pRExC_state, 3, "nop");
5306                     RExC_rxi->data->data[n] = (void*)rop;
5307                     RExC_rxi->data->data[n+1] = (void*)sop;
5308                     RExC_rxi->data->data[n+2] = (void*)pad;
5309                     SvREFCNT_dec(sv);
5310                 }
5311                 else {                                          /* First pass */
5312                     if (PL_reginterp_cnt < ++RExC_seen_evals
5313                         && IN_PERL_RUNTIME)
5314                         /* No compiled RE interpolated, has runtime
5315                            components ===> unsafe.  */
5316                         FAIL("Eval-group not allowed at runtime, use re 'eval'");
5317                     if (PL_tainting && PL_tainted)
5318                         FAIL("Eval-group in insecure regular expression");
5319 #if PERL_VERSION > 8
5320                     if (IN_PERL_COMPILETIME)
5321                         PL_cv_has_eval = 1;
5322 #endif
5323                 }
5324
5325                 nextchar(pRExC_state);
5326                 if (is_logical) {
5327                     ret = reg_node(pRExC_state, LOGICAL);
5328                     if (!SIZE_ONLY)
5329                         ret->flags = 2;
5330                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
5331                     /* deal with the length of this later - MJD */
5332                     return ret;
5333                 }
5334                 ret = reganode(pRExC_state, EVAL, n);
5335                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
5336                 Set_Node_Offset(ret, parse_start);
5337                 return ret;
5338             }
5339             case '(':           /* (?(?{...})...) and (?(?=...)...) */
5340             {
5341                 int is_define= 0;
5342                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
5343                     if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
5344                         || RExC_parse[1] == '<'
5345                         || RExC_parse[1] == '{') { /* Lookahead or eval. */
5346                         I32 flag;
5347                         
5348                         ret = reg_node(pRExC_state, LOGICAL);
5349                         if (!SIZE_ONLY)
5350                             ret->flags = 1;
5351                         REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
5352                         goto insert_if;
5353                     }
5354                 }
5355                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
5356                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
5357                 {
5358                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
5359                     char *name_start= RExC_parse++;
5360                     U32 num = 0;
5361                     SV *sv_dat=reg_scan_name(pRExC_state,
5362                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
5363                     if (RExC_parse == name_start || *RExC_parse != ch)
5364                         vFAIL2("Sequence (?(%c... not terminated",
5365                             (ch == '>' ? '<' : ch));
5366                     RExC_parse++;
5367                     if (!SIZE_ONLY) {
5368                         num = add_data( pRExC_state, 1, "S" );
5369                         RExC_rxi->data->data[num]=(void*)sv_dat;
5370                         SvREFCNT_inc(sv_dat);
5371                     }
5372                     ret = reganode(pRExC_state,NGROUPP,num);
5373                     goto insert_if_check_paren;
5374                 }
5375                 else if (RExC_parse[0] == 'D' &&
5376                          RExC_parse[1] == 'E' &&
5377                          RExC_parse[2] == 'F' &&
5378                          RExC_parse[3] == 'I' &&
5379                          RExC_parse[4] == 'N' &&
5380                          RExC_parse[5] == 'E')
5381                 {
5382                     ret = reganode(pRExC_state,DEFINEP,0);
5383                     RExC_parse +=6 ;
5384                     is_define = 1;
5385                     goto insert_if_check_paren;
5386                 }
5387                 else if (RExC_parse[0] == 'R') {
5388                     RExC_parse++;
5389                     parno = 0;
5390                     if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
5391                         parno = atoi(RExC_parse++);
5392                         while (isDIGIT(*RExC_parse))
5393                             RExC_parse++;
5394                     } else if (RExC_parse[0] == '&') {
5395                         SV *sv_dat;
5396                         RExC_parse++;
5397                         sv_dat = reg_scan_name(pRExC_state,
5398                             SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
5399                         parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
5400                     }
5401                     ret = reganode(pRExC_state,INSUBP,parno); 
5402                     goto insert_if_check_paren;
5403                 }
5404                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
5405                     /* (?(1)...) */
5406                     char c;
5407                     parno = atoi(RExC_parse++);
5408
5409                     while (isDIGIT(*RExC_parse))
5410                         RExC_parse++;
5411                     ret = reganode(pRExC_state, GROUPP, parno);
5412
5413                  insert_if_check_paren:
5414                     if ((c = *nextchar(pRExC_state)) != ')')
5415                         vFAIL("Switch condition not recognized");
5416                   insert_if:
5417                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
5418                     br = regbranch(pRExC_state, &flags, 1,depth+1);
5419                     if (br == NULL)
5420                         br = reganode(pRExC_state, LONGJMP, 0);
5421                     else
5422                         REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
5423                     c = *nextchar(pRExC_state);
5424                     if (flags&HASWIDTH)
5425                         *flagp |= HASWIDTH;
5426                     if (c == '|') {
5427                         if (is_define) 
5428                             vFAIL("(?(DEFINE)....) does not allow branches");
5429                         lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
5430                         regbranch(pRExC_state, &flags, 1,depth+1);
5431                         REGTAIL(pRExC_state, ret, lastbr);
5432                         if (flags&HASWIDTH)
5433                             *flagp |= HASWIDTH;
5434                         c = *nextchar(pRExC_state);
5435                     }
5436                     else
5437                         lastbr = NULL;
5438                     if (c != ')')
5439                         vFAIL("Switch (?(condition)... contains too many branches");
5440                     ender = reg_node(pRExC_state, TAIL);
5441                     REGTAIL(pRExC_state, br, ender);
5442                     if (lastbr) {
5443                         REGTAIL(pRExC_state, lastbr, ender);
5444                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
5445                     }
5446                     else
5447                         REGTAIL(pRExC_state, ret, ender);
5448                     return ret;
5449                 }
5450                 else {
5451                     vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
5452                 }
5453             }
5454             case 0:
5455                 RExC_parse--; /* for vFAIL to print correctly */
5456                 vFAIL("Sequence (? incomplete");
5457                 break;
5458             default:
5459                 --RExC_parse;
5460                 parse_flags:      /* (?i) */  
5461             {
5462                 U32 posflags = 0, negflags = 0;
5463                 U32 *flagsp = &posflags;
5464
5465                 while (*RExC_parse) {
5466                     /* && strchr("iogcmsx", *RExC_parse) */
5467                     /* (?g), (?gc) and (?o) are useless here
5468                        and must be globally applied -- japhy */
5469                     switch (*RExC_parse) {
5470                     CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
5471                     case 'o':
5472                     case 'g':
5473                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
5474                             const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
5475                             if (! (wastedflags & wflagbit) ) {
5476                                 wastedflags |= wflagbit;
5477                                 vWARN5(
5478                                     RExC_parse + 1,
5479                                     "Useless (%s%c) - %suse /%c modifier",
5480                                     flagsp == &negflags ? "?-" : "?",
5481                                     *RExC_parse,
5482                                     flagsp == &negflags ? "don't " : "",
5483                                     *RExC_parse
5484                                 );
5485                             }
5486                         }
5487                         break;
5488                         
5489                     case 'c':
5490                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
5491                             if (! (wastedflags & WASTED_C) ) {
5492                                 wastedflags |= WASTED_GC;
5493                                 vWARN3(
5494                                     RExC_parse + 1,
5495                                     "Useless (%sc) - %suse /gc modifier",
5496                                     flagsp == &negflags ? "?-" : "?",
5497                                     flagsp == &negflags ? "don't " : ""
5498                                 );
5499                             }
5500                         }
5501                         break;
5502                     case 'k':
5503                         if (flagsp == &negflags) {
5504                             if (SIZE_ONLY && ckWARN(WARN_REGEXP))
5505                                 vWARN(RExC_parse + 1,"Useless use of (?-k)");
5506                         } else {
5507                             *flagsp |= RXf_PMf_KEEPCOPY;
5508                         }
5509                         break;
5510                     case '-':
5511                         if (flagsp == &negflags)
5512                             goto unknown;
5513                         flagsp = &negflags;
5514                         wastedflags = 0;  /* reset so (?g-c) warns twice */
5515                         break;
5516                     case ':':
5517                         paren = ':';
5518                         /*FALLTHROUGH*/
5519                     case ')':
5520                         RExC_flags |= posflags;
5521                         RExC_flags &= ~negflags;
5522                         nextchar(pRExC_state);
5523                         if (paren != ':') {
5524                             *flagp = TRYAGAIN;
5525                             return NULL;
5526                         } else {
5527                             ret = NULL;
5528                             goto parse_rest;
5529                         }
5530                         /*NOTREACHED*/
5531                     default:
5532                     unknown:
5533                         RExC_parse++;
5534                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
5535                         /*NOTREACHED*/
5536                     }                           
5537                     ++RExC_parse;
5538                 }
5539             }} /* one for the default block, one for the switch */
5540         }
5541         else {                  /* (...) */
5542           capturing_parens:
5543             parno = RExC_npar;
5544             RExC_npar++;
5545             
5546             ret = reganode(pRExC_state, OPEN, parno);
5547             if (!SIZE_ONLY ){
5548                 if (!RExC_nestroot) 
5549                     RExC_nestroot = parno;
5550                 if (RExC_seen & REG_SEEN_RECURSE) {
5551                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
5552                         "Setting open paren #%"IVdf" to %d\n", 
5553                         (IV)parno, REG_NODE_NUM(ret)));
5554                     RExC_open_parens[parno-1]= ret;
5555                 }
5556             }
5557             Set_Node_Length(ret, 1); /* MJD */
5558             Set_Node_Offset(ret, RExC_parse); /* MJD */
5559             is_open = 1;
5560         }
5561     }
5562     else                        /* ! paren */
5563         ret = NULL;
5564    
5565    parse_rest:
5566     /* Pick up the branches, linking them together. */
5567     parse_start = RExC_parse;   /* MJD */
5568     br = regbranch(pRExC_state, &flags, 1,depth+1);
5569     /*     branch_len = (paren != 0); */
5570
5571     if (br == NULL)
5572         return(NULL);
5573     if (*RExC_parse == '|') {
5574         if (!SIZE_ONLY && RExC_extralen) {
5575             reginsert(pRExC_state, BRANCHJ, br, depth+1);
5576         }
5577         else {                  /* MJD */
5578             reginsert(pRExC_state, BRANCH, br, depth+1);
5579             Set_Node_Length(br, paren != 0);
5580             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
5581         }
5582         have_branch = 1;
5583         if (SIZE_ONLY)
5584             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
5585     }
5586     else if (paren == ':') {
5587         *flagp |= flags&SIMPLE;
5588     }
5589     if (is_open) {                              /* Starts with OPEN. */
5590         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
5591     }
5592     else if (paren != '?')              /* Not Conditional */
5593         ret = br;
5594     *flagp |= flags & (SPSTART | HASWIDTH);
5595     lastbr = br;
5596     while (*RExC_parse == '|') {
5597         if (!SIZE_ONLY && RExC_extralen) {
5598             ender = reganode(pRExC_state, LONGJMP,0);
5599             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
5600         }
5601         if (SIZE_ONLY)
5602             RExC_extralen += 2;         /* Account for LONGJMP. */
5603         nextchar(pRExC_state);
5604         br = regbranch(pRExC_state, &flags, 0, depth+1);
5605
5606         if (br == NULL)
5607             return(NULL);
5608         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
5609         lastbr = br;
5610         if (flags&HASWIDTH)
5611             *flagp |= HASWIDTH;
5612         *flagp |= flags&SPSTART;
5613     }
5614
5615     if (have_branch || paren != ':') {
5616         /* Make a closing node, and hook it on the end. */
5617         switch (paren) {
5618         case ':':
5619             ender = reg_node(pRExC_state, TAIL);
5620             break;
5621         case 1:
5622             ender = reganode(pRExC_state, CLOSE, parno);
5623             if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
5624                 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
5625                         "Setting close paren #%"IVdf" to %d\n", 
5626                         (IV)parno, REG_NODE_NUM(ender)));
5627                 RExC_close_parens[parno-1]= ender;
5628                 if (RExC_nestroot == parno) 
5629                     RExC_nestroot = 0;
5630             }       
5631             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
5632             Set_Node_Length(ender,1); /* MJD */
5633             break;
5634         case '<':
5635         case ',':
5636         case '=':
5637         case '!':
5638             *flagp &= ~HASWIDTH;
5639             /* FALL THROUGH */
5640         case '>':
5641             ender = reg_node(pRExC_state, SUCCEED);
5642             break;
5643         case 0:
5644             ender = reg_node(pRExC_state, END);
5645             if (!SIZE_ONLY) {
5646                 assert(!RExC_opend); /* there can only be one! */
5647                 RExC_opend = ender;
5648             }
5649             break;
5650         }
5651         REGTAIL(pRExC_state, lastbr, ender);
5652
5653         if (have_branch && !SIZE_ONLY) {
5654             if (depth==1)
5655                 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
5656
5657             /* Hook the tails of the branches to the closing node. */
5658             for (br = ret; br; br = regnext(br)) {
5659                 const U8 op = PL_regkind[OP(br)];
5660                 if (op == BRANCH) {
5661                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
5662                 }
5663                 else if (op == BRANCHJ) {
5664                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
5665                 }
5666             }
5667         }
5668     }
5669
5670     {
5671         const char *p;
5672         static const char parens[] = "=!<,>";
5673
5674         if (paren && (p = strchr(parens, paren))) {
5675             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
5676             int flag = (p - parens) > 1;
5677
5678             if (paren == '>')
5679                 node = SUSPEND, flag = 0;
5680             reginsert(pRExC_state, node,ret, depth+1);
5681             Set_Node_Cur_Length(ret);
5682             Set_Node_Offset(ret, parse_start + 1);
5683             ret->flags = flag;
5684             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
5685         }
5686     }
5687
5688     /* Check for proper termination. */
5689     if (paren) {
5690         RExC_flags = oregflags;
5691         if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
5692             RExC_parse = oregcomp_parse;
5693             vFAIL("Unmatched (");
5694         }
5695     }
5696     else if (!paren && RExC_parse < RExC_end) {
5697         if (*RExC_parse == ')') {
5698             RExC_parse++;
5699             vFAIL("Unmatched )");
5700         }
5701         else
5702             FAIL("Junk on end of regexp");      /* "Can't happen". */
5703         /* NOTREACHED */
5704     }
5705
5706     return(ret);
5707 }
5708
5709 /*
5710  - regbranch - one alternative of an | operator
5711  *
5712  * Implements the concatenation operator.
5713  */
5714 STATIC regnode *
5715 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
5716 {
5717     dVAR;
5718     register regnode *ret;
5719     register regnode *chain = NULL;
5720     register regnode *latest;
5721     I32 flags = 0, c = 0;
5722     GET_RE_DEBUG_FLAGS_DECL;
5723     DEBUG_PARSE("brnc");
5724     if (first)
5725         ret = NULL;
5726     else {
5727         if (!SIZE_ONLY && RExC_extralen)
5728             ret = reganode(pRExC_state, BRANCHJ,0);
5729         else {
5730             ret = reg_node(pRExC_state, BRANCH);
5731             Set_Node_Length(ret, 1);
5732         }
5733     }
5734         
5735     if (!first && SIZE_ONLY)
5736         RExC_extralen += 1;                     /* BRANCHJ */
5737
5738     *flagp = WORST;                     /* Tentatively. */
5739
5740     RExC_parse--;
5741     nextchar(pRExC_state);
5742     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
5743         flags &= ~TRYAGAIN;
5744         latest = regpiece(pRExC_state, &flags,depth+1);
5745         if (latest == NULL) {
5746             if (flags & TRYAGAIN)
5747                 continue;
5748             return(NULL);
5749         }
5750         else if (ret == NULL)
5751             ret = latest;
5752         *flagp |= flags&HASWIDTH;
5753         if (chain == NULL)      /* First piece. */
5754             *flagp |= flags&SPSTART;
5755         else {
5756             RExC_naughty++;
5757             REGTAIL(pRExC_state, chain, latest);
5758         }
5759         chain = latest;
5760         c++;
5761     }
5762     if (chain == NULL) {        /* Loop ran zero times. */
5763         chain = reg_node(pRExC_state, NOTHING);
5764         if (ret == NULL)
5765             ret = chain;
5766     }
5767     if (c == 1) {
5768         *flagp |= flags&SIMPLE;
5769     }
5770
5771     return ret;
5772 }
5773
5774 /*
5775  - regpiece - something followed by possible [*+?]
5776  *
5777  * Note that the branching code sequences used for ? and the general cases
5778  * of * and + are somewhat optimized:  they use the same NOTHING node as
5779  * both the endmarker for their branch list and the body of the last branch.
5780  * It might seem that this node could be dispensed with entirely, but the
5781  * endmarker role is not redundant.
5782  */
5783 STATIC regnode *
5784 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
5785 {
5786     dVAR;
5787     register regnode *ret;
5788     register char op;
5789     register char *next;
5790     I32 flags;
5791     const char * const origparse = RExC_parse;
5792     I32 min;
5793     I32 max = REG_INFTY;
5794     char *parse_start;
5795     const char *maxpos = NULL;
5796     GET_RE_DEBUG_FLAGS_DECL;
5797     DEBUG_PARSE("piec");
5798
5799     ret = regatom(pRExC_state, &flags,depth+1);
5800     if (ret == NULL) {
5801         if (flags & TRYAGAIN)
5802             *flagp |= TRYAGAIN;
5803         return(NULL);
5804     }
5805
5806     op = *RExC_parse;
5807
5808     if (op == '{' && regcurly(RExC_parse)) {
5809         maxpos = NULL;
5810         parse_start = RExC_parse; /* MJD */
5811         next = RExC_parse + 1;
5812         while (isDIGIT(*next) || *next == ',') {
5813             if (*next == ',') {
5814                 if (maxpos)
5815                     break;
5816                 else
5817                     maxpos = next;
5818             }
5819             next++;
5820         }
5821         if (*next == '}') {             /* got one */
5822             if (!maxpos)
5823                 maxpos = next;
5824             RExC_parse++;
5825             min = atoi(RExC_parse);
5826             if (*maxpos == ',')
5827                 maxpos++;
5828             else
5829                 maxpos = RExC_parse;
5830             max = atoi(maxpos);
5831             if (!max && *maxpos != '0')
5832                 max = REG_INFTY;                /* meaning "infinity" */
5833             else if (max >= REG_INFTY)
5834                 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
5835             RExC_parse = next;
5836             nextchar(pRExC_state);
5837
5838         do_curly:
5839             if ((flags&SIMPLE)) {
5840                 RExC_naughty += 2 + RExC_naughty / 2;
5841                 reginsert(pRExC_state, CURLY, ret, depth+1);
5842                 Set_Node_Offset(ret, parse_start+1); /* MJD */
5843                 Set_Node_Cur_Length(ret);
5844             }
5845             else {
5846                 regnode * const w = reg_node(pRExC_state, WHILEM);
5847
5848                 w->flags = 0;
5849                 REGTAIL(pRExC_state, ret, w);
5850                 if (!SIZE_ONLY && RExC_extralen) {
5851                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
5852                     reginsert(pRExC_state, NOTHING,ret, depth+1);
5853                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
5854                 }
5855                 reginsert(pRExC_state, CURLYX,ret, depth+1);
5856                                 /* MJD hk */
5857                 Set_Node_Offset(ret, parse_start+1);
5858                 Set_Node_Length(ret,
5859                                 op == '{' ? (RExC_parse - parse_start) : 1);
5860
5861                 if (!SIZE_ONLY && RExC_extralen)
5862                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
5863                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
5864                 if (SIZE_ONLY)
5865                     RExC_whilem_seen++, RExC_extralen += 3;
5866                 RExC_naughty += 4 + RExC_naughty;       /* compound interest */
5867             }
5868             ret->flags = 0;
5869
5870             if (min > 0)
5871                 *flagp = WORST;
5872             if (max > 0)
5873                 *flagp |= HASWIDTH;
5874             if (max && max < min)
5875                 vFAIL("Can't do {n,m} with n > m");
5876             if (!SIZE_ONLY) {
5877                 ARG1_SET(ret, (U16)min);
5878                 ARG2_SET(ret, (U16)max);
5879             }
5880
5881             goto nest_check;
5882         }
5883     }
5884
5885     if (!ISMULT1(op)) {
5886         *flagp = flags;
5887         return(ret);
5888     }
5889
5890 #if 0                           /* Now runtime fix should be reliable. */
5891
5892     /* if this is reinstated, don't forget to put this back into perldiag:
5893
5894             =item Regexp *+ operand could be empty at {#} in regex m/%s/
5895
5896            (F) The part of the regexp subject to either the * or + quantifier
5897            could match an empty string. The {#} shows in the regular
5898            expression about where the problem was discovered.
5899
5900     */
5901
5902     if (!(flags&HASWIDTH) && op != '?')
5903       vFAIL("Regexp *+ operand could be empty");
5904 #endif
5905
5906     parse_start = RExC_parse;
5907     nextchar(pRExC_state);
5908
5909     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
5910
5911     if (op == '*' && (flags&SIMPLE)) {
5912         reginsert(pRExC_state, STAR, ret, depth+1);
5913         ret->flags = 0;
5914         RExC_naughty += 4;
5915     }
5916     else if (op == '*') {
5917         min = 0;
5918         goto do_curly;
5919     }
5920     else if (op == '+' && (flags&SIMPLE)) {
5921         reginsert(pRExC_state, PLUS, ret, depth+1);
5922         ret->flags = 0;
5923         RExC_naughty += 3;
5924     }
5925     else if (op == '+') {
5926         min = 1;
5927         goto do_curly;
5928     }
5929     else if (op == '?') {
5930         min = 0; max = 1;
5931         goto do_curly;
5932     }
5933   nest_check:
5934     if (!SIZE_ONLY && !(flags&HASWIDTH) && max > REG_INFTY/3 && ckWARN(WARN_REGEXP)) {
5935         vWARN3(RExC_parse,
5936                "%.*s matches null string many times",
5937                (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
5938                origparse);
5939     }
5940
5941     if (RExC_parse < RExC_end && *RExC_parse == '?') {
5942         nextchar(pRExC_state);
5943         reginsert(pRExC_state, MINMOD, ret, depth+1);
5944         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
5945     }
5946 #ifndef REG_ALLOW_MINMOD_SUSPEND
5947     else
5948 #endif
5949     if (RExC_parse < RExC_end && *RExC_parse == '+') {
5950         regnode *ender;
5951         nextchar(pRExC_state);
5952         ender = reg_node(pRExC_state, SUCCEED);
5953         REGTAIL(pRExC_state, ret, ender);
5954         reginsert(pRExC_state, SUSPEND, ret, depth+1);
5955         ret->flags = 0;
5956         ender = reg_node(pRExC_state, TAIL);
5957         REGTAIL(pRExC_state, ret, ender);
5958         /*ret= ender;*/
5959     }
5960
5961     if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
5962         RExC_parse++;
5963         vFAIL("Nested quantifiers");
5964     }
5965
5966     return(ret);
5967 }
5968
5969
5970 /* reg_namedseq(pRExC_state,UVp)
5971    
5972    This is expected to be called by a parser routine that has 
5973    recognized'\N' and needs to handle the rest. RExC_parse is 
5974    expected to point at the first char following the N at the time
5975    of the call.
5976    
5977    If valuep is non-null then it is assumed that we are parsing inside 
5978    of a charclass definition and the first codepoint in the resolved
5979    string is returned via *valuep and the routine will return NULL. 
5980    In this mode if a multichar string is returned from the charnames 
5981    handler a warning will be issued, and only the first char in the 
5982    sequence will be examined. If the string returned is zero length
5983    then the value of *valuep is undefined and NON-NULL will 
5984    be returned to indicate failure. (This will NOT be a valid pointer 
5985    to a regnode.)
5986    
5987    If value is null then it is assumed that we are parsing normal text
5988    and inserts a new EXACT node into the program containing the resolved
5989    string and returns a pointer to the new node. If the string is 
5990    zerolength a NOTHING node is emitted.
5991    
5992    On success RExC_parse is set to the char following the endbrace.
5993    Parsing failures will generate a fatal errorvia vFAIL(...)
5994    
5995    NOTE: We cache all results from the charnames handler locally in 
5996    the RExC_charnames hash (created on first use) to prevent a charnames 
5997    handler from playing silly-buggers and returning a short string and 
5998    then a long string for a given pattern. Since the regexp program 
5999    size is calculated during an initial parse this would result
6000    in a buffer overrun so we cache to prevent the charname result from
6001    changing during the course of the parse.
6002    
6003  */
6004 STATIC regnode *
6005 S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep) 
6006 {
6007     char * name;        /* start of the content of the name */
6008     char * endbrace;    /* endbrace following the name */
6009     SV *sv_str = NULL;  
6010     SV *sv_name = NULL;
6011     STRLEN len; /* this has various purposes throughout the code */
6012     bool cached = 0; /* if this is true then we shouldn't refcount dev sv_str */
6013     regnode *ret = NULL;
6014     
6015     if (*RExC_parse != '{') {
6016         vFAIL("Missing braces on \\N{}");
6017     }
6018     name = RExC_parse+1;
6019     endbrace = strchr(RExC_parse, '}');
6020     if ( ! endbrace ) {
6021         RExC_parse++;
6022         vFAIL("Missing right brace on \\N{}");
6023     } 
6024     RExC_parse = endbrace + 1;  
6025     
6026     
6027     /* RExC_parse points at the beginning brace, 
6028        endbrace points at the last */
6029     if ( name[0]=='U' && name[1]=='+' ) {
6030         /* its a "unicode hex" notation {U+89AB} */
6031         I32 fl = PERL_SCAN_ALLOW_UNDERSCORES
6032             | PERL_SCAN_DISALLOW_PREFIX
6033             | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
6034         UV cp;
6035         len = (STRLEN)(endbrace - name - 2);
6036         cp = grok_hex(name + 2, &len, &fl, NULL);
6037         if ( len != (STRLEN)(endbrace - name - 2) ) {
6038             cp = 0xFFFD;
6039         }    
6040         if (cp > 0xff)
6041             RExC_utf8 = 1;
6042         if ( valuep ) {
6043             *valuep = cp;
6044             return NULL;
6045         }
6046         sv_str= Perl_newSVpvf_nocontext("%c",(int)cp);
6047     } else {
6048         /* fetch the charnames handler for this scope */
6049         HV * const table = GvHV(PL_hintgv);
6050         SV **cvp= table ? 
6051             hv_fetchs(table, "charnames", FALSE) :
6052             NULL;
6053         SV *cv= cvp ? *cvp : NULL;
6054         HE *he_str;
6055         int count;
6056         /* create an SV with the name as argument */
6057         sv_name = newSVpvn(name, endbrace - name);
6058         
6059         if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
6060             vFAIL2("Constant(\\N{%s}) unknown: "
6061                   "(possibly a missing \"use charnames ...\")",
6062                   SvPVX(sv_name));
6063         }
6064         if (!cvp || !SvOK(*cvp)) { /* when $^H{charnames} = undef; */
6065             vFAIL2("Constant(\\N{%s}): "
6066                   "$^H{charnames} is not defined",SvPVX(sv_name));
6067         }
6068         
6069         
6070         
6071         if (!RExC_charnames) {
6072             /* make sure our cache is allocated */
6073             RExC_charnames = newHV();
6074             sv_2mortal((SV*)RExC_charnames);
6075         } 
6076             /* see if we have looked this one up before */
6077         he_str = hv_fetch_ent( RExC_charnames, sv_name, 0, 0 );
6078         if ( he_str ) {
6079             sv_str = HeVAL(he_str);
6080             cached = 1;
6081         } else {
6082             dSP ;
6083
6084             ENTER ;
6085             SAVETMPS ;
6086             PUSHMARK(SP) ;
6087             
6088             XPUSHs(sv_name);
6089             
6090             PUTBACK ;
6091             
6092             count= call_sv(cv, G_SCALAR);
6093             
6094             if (count == 1) { /* XXXX is this right? dmq */
6095                 sv_str = POPs;
6096                 SvREFCNT_inc_simple_void(sv_str);
6097             } 
6098             
6099             SPAGAIN ;
6100             PUTBACK ;
6101             FREETMPS ;
6102             LEAVE ;
6103             
6104             if ( !sv_str || !SvOK(sv_str) ) {
6105                 vFAIL2("Constant(\\N{%s}): Call to &{$^H{charnames}} "
6106                       "did not return a defined value",SvPVX(sv_name));
6107             }
6108             if (hv_store_ent( RExC_charnames, sv_name, sv_str, 0))
6109                 cached = 1;
6110         }
6111     }
6112     if (valuep) {
6113         char *p = SvPV(sv_str, len);
6114         if (len) {
6115             STRLEN numlen = 1;
6116             if ( SvUTF8(sv_str) ) {
6117                 *valuep = utf8_to_uvchr((U8*)p, &numlen);
6118                 if (*valuep > 0x7F)
6119                     RExC_utf8 = 1; 
6120                 /* XXXX
6121                   We have to turn on utf8 for high bit chars otherwise
6122                   we get failures with
6123                   
6124                    "ss" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i
6125                    "SS" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i
6126                 
6127                   This is different from what \x{} would do with the same
6128                   codepoint, where the condition is > 0xFF.
6129                   - dmq
6130                 */
6131                 
6132                 
6133             } else {
6134                 *valuep = (UV)*p;
6135                 /* warn if we havent used the whole string? */
6136             }
6137             if (numlen<len && SIZE_ONLY && ckWARN(WARN_REGEXP)) {
6138                 vWARN2(RExC_parse,
6139                     "Ignoring excess chars from \\N{%s} in character class",
6140                     SvPVX(sv_name)
6141                 );
6142             }        
6143         } else if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
6144             vWARN2(RExC_parse,
6145                     "Ignoring zero length \\N{%s} in character class",
6146                     SvPVX(sv_name)
6147                 );
6148         }
6149         if (sv_name)    
6150             SvREFCNT_dec(sv_name);    
6151         if (!cached)
6152             SvREFCNT_dec(sv_str);    
6153         return len ? NULL : (regnode *)&len;
6154     } else if(SvCUR(sv_str)) {     
6155         
6156         char *s; 
6157         char *p, *pend;        
6158         STRLEN charlen = 1;
6159 #ifdef DEBUGGING
6160         char * parse_start = name-3; /* needed for the offsets */
6161 #endif
6162         GET_RE_DEBUG_FLAGS_DECL;     /* needed for the offsets */
6163         
6164         ret = reg_node(pRExC_state,
6165             (U8)(FOLD ? (LOC ? EXACTFL : EXACTF) : EXACT));
6166         s= STRING(ret);
6167         
6168         if ( RExC_utf8 && !SvUTF8(sv_str) ) {
6169             sv_utf8_upgrade(sv_str);
6170         } else if ( !RExC_utf8 && SvUTF8(sv_str) ) {
6171             RExC_utf8= 1;
6172         }
6173         
6174         p = SvPV(sv_str, len);
6175         pend = p + len;
6176         /* len is the length written, charlen is the size the char read */
6177         for ( len = 0; p < pend; p += charlen ) {
6178             if (UTF) {
6179                 UV uvc = utf8_to_uvchr((U8*)p, &charlen);
6180                 if (FOLD) {
6181                     STRLEN foldlen,numlen;
6182                     U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
6183                     uvc = toFOLD_uni(uvc, tmpbuf, &foldlen);
6184                     /* Emit all the Unicode characters. */
6185                     
6186                     for (foldbuf = tmpbuf;
6187                         foldlen;
6188                         foldlen -= numlen) 
6189                     {
6190                         uvc = utf8_to_uvchr(foldbuf, &numlen);
6191                         if (numlen > 0) {
6192                             const STRLEN unilen = reguni(pRExC_state, uvc, s);
6193                             s       += unilen;
6194                             len     += unilen;
6195                             /* In EBCDIC the numlen
6196                             * and unilen can differ. */
6197                             foldbuf += numlen;
6198                             if (numlen >= foldlen)
6199                                 break;
6200                         }
6201                         else
6202                             break; /* "Can't happen." */
6203                     }                          
6204                 } else {
6205                     const STRLEN unilen = reguni(pRExC_state, uvc, s);
6206                     if (unilen > 0) {
6207                        s   += unilen;
6208                        len += unilen;
6209                     }
6210                 }
6211             } else {
6212                 len++;
6213                 REGC(*p, s++);
6214             }
6215         }
6216         if (SIZE_ONLY) {
6217             RExC_size += STR_SZ(len);
6218         } else {
6219             STR_LEN(ret) = len;
6220             RExC_emit += STR_SZ(len);
6221         }
6222         Set_Node_Cur_Length(ret); /* MJD */
6223         RExC_parse--; 
6224         nextchar(pRExC_state);
6225     } else {
6226         ret = reg_node(pRExC_state,NOTHING);
6227     }
6228     if (!cached) {
6229         SvREFCNT_dec(sv_str);
6230     }
6231     if (sv_name) {
6232         SvREFCNT_dec(sv_name); 
6233     }
6234     return ret;
6235
6236 }
6237
6238
6239 /*
6240  * reg_recode
6241  *
6242  * It returns the code point in utf8 for the value in *encp.
6243  *    value: a code value in the source encoding
6244  *    encp:  a pointer to an Encode object
6245  *
6246  * If the result from Encode is not a single character,
6247  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
6248  */
6249 STATIC UV
6250 S_reg_recode(pTHX_ const char value, SV **encp)
6251 {
6252     STRLEN numlen = 1;
6253     SV * const sv = sv_2mortal(newSVpvn(&value, numlen));
6254     const char * const s = encp && *encp ? sv_recode_to_utf8(sv, *encp)
6255                                          : SvPVX(sv);
6256     const STRLEN newlen = SvCUR(sv);
6257     UV uv = UNICODE_REPLACEMENT;
6258
6259     if (newlen)
6260         uv = SvUTF8(sv)
6261              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
6262              : *(U8*)s;
6263
6264     if (!newlen || numlen != newlen) {
6265         uv = UNICODE_REPLACEMENT;
6266         if (encp)
6267             *encp = NULL;
6268     }
6269     return uv;
6270 }
6271
6272
6273 /*
6274  - regatom - the lowest level
6275
6276    Try to identify anything special at the start of the pattern. If there
6277    is, then handle it as required. This may involve generating a single regop,
6278    such as for an assertion; or it may involve recursing, such as to
6279    handle a () structure.
6280
6281    If the string doesn't start with something special then we gobble up
6282    as much literal text as we can.
6283
6284    Once we have been able to handle whatever type of thing started the
6285    sequence, we return.
6286
6287    Note: we have to be careful with escapes, as they can be both literal
6288    and special, and in the case of \10 and friends can either, depending
6289    on context. Specifically there are two seperate switches for handling
6290    escape sequences, with the one for handling literal escapes requiring
6291    a dummy entry for all of the special escapes that are actually handled
6292    by the other.
6293 */
6294
6295 STATIC regnode *
6296 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
6297 {
6298     dVAR;
6299     register regnode *ret = NULL;
6300     I32 flags;
6301     char *parse_start = RExC_parse;
6302     GET_RE_DEBUG_FLAGS_DECL;
6303     DEBUG_PARSE("atom");
6304     *flagp = WORST;             /* Tentatively. */
6305
6306
6307 tryagain:
6308     switch (*RExC_parse) {
6309     case '^':
6310         RExC_seen_zerolen++;
6311         nextchar(pRExC_state);
6312         if (RExC_flags & RXf_PMf_MULTILINE)
6313             ret = reg_node(pRExC_state, MBOL);
6314         else if (RExC_flags & RXf_PMf_SINGLELINE)
6315             ret = reg_node(pRExC_state, SBOL);
6316         else
6317             ret = reg_node(pRExC_state, BOL);
6318         Set_Node_Length(ret, 1); /* MJD */
6319         break;
6320     case '$':
6321         nextchar(pRExC_state);
6322         if (*RExC_parse)
6323             RExC_seen_zerolen++;
6324         if (RExC_flags & RXf_PMf_MULTILINE)
6325             ret = reg_node(pRExC_state, MEOL);
6326         else if (RExC_flags & RXf_PMf_SINGLELINE)
6327             ret = reg_node(pRExC_state, SEOL);
6328         else
6329             ret = reg_node(pRExC_state, EOL);
6330         Set_Node_Length(ret, 1); /* MJD */
6331         break;
6332     case '.':
6333         nextchar(pRExC_state);
6334         if (RExC_flags & RXf_PMf_SINGLELINE)
6335             ret = reg_node(pRExC_state, SANY);
6336         else
6337             ret = reg_node(pRExC_state, REG_ANY);
6338         *flagp |= HASWIDTH|SIMPLE;
6339         RExC_naughty++;
6340         Set_Node_Length(ret, 1); /* MJD */
6341         break;
6342     case '[':
6343     {
6344         char * const oregcomp_parse = ++RExC_parse;
6345         ret = regclass(pRExC_state,depth+1);
6346         if (*RExC_parse != ']') {
6347             RExC_parse = oregcomp_parse;
6348             vFAIL("Unmatched [");
6349         }
6350         nextchar(pRExC_state);
6351         *flagp |= HASWIDTH|SIMPLE;
6352         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
6353         break;
6354     }
6355     case '(':
6356         nextchar(pRExC_state);
6357         ret = reg(pRExC_state, 1, &flags,depth+1);
6358         if (ret == NULL) {
6359                 if (flags & TRYAGAIN) {
6360                     if (RExC_parse == RExC_end) {
6361                          /* Make parent create an empty node if needed. */
6362                         *flagp |= TRYAGAIN;
6363                         return(NULL);
6364                     }
6365                     goto tryagain;
6366                 }
6367                 return(NULL);
6368         }
6369         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE);
6370         break;
6371     case '|':
6372     case ')':
6373         if (flags & TRYAGAIN) {
6374             *flagp |= TRYAGAIN;
6375             return NULL;
6376         }
6377         vFAIL("Internal urp");
6378                                 /* Supposed to be caught earlier. */
6379         break;
6380     case '{':
6381         if (!regcurly(RExC_parse)) {
6382             RExC_parse++;
6383             goto defchar;
6384         }
6385         /* FALL THROUGH */
6386     case '?':
6387     case '+':
6388     case '*':
6389         RExC_parse++;
6390         vFAIL("Quantifier follows nothing");
6391         break;
6392     case '\\':
6393         /* Special Escapes
6394
6395            This switch handles escape sequences that resolve to some kind
6396            of special regop and not to literal text. Escape sequnces that
6397            resolve to literal text are handled below in the switch marked
6398            "Literal Escapes".
6399
6400            Every entry in this switch *must* have a corresponding entry
6401            in the literal escape switch. However, the opposite is not
6402            required, as the default for this switch is to jump to the
6403            literal text handling code.
6404         */
6405         switch (*++RExC_parse) {
6406         /* Special Escapes */
6407         case 'A':
6408             RExC_seen_zerolen++;
6409             ret = reg_node(pRExC_state, SBOL);
6410             *flagp |= SIMPLE;
6411             goto finish_meta_pat;
6412         case 'G':
6413             ret = reg_node(pRExC_state, GPOS);
6414             RExC_seen |= REG_SEEN_GPOS;
6415             *flagp |= SIMPLE;
6416             goto finish_meta_pat;
6417         case 'K':
6418             RExC_seen_zerolen++;
6419             ret = reg_node(pRExC_state, KEEPS);
6420             *flagp |= SIMPLE;
6421             goto finish_meta_pat;
6422         case 'Z':
6423             ret = reg_node(pRExC_state, SEOL);
6424             *flagp |= SIMPLE;
6425             RExC_seen_zerolen++;                /* Do not optimize RE away */
6426             goto finish_meta_pat;
6427         case 'z':
6428             ret = reg_node(pRExC_state, EOS);
6429             *flagp |= SIMPLE;
6430             RExC_seen_zerolen++;                /* Do not optimize RE away */
6431             goto finish_meta_pat;
6432         case 'C':
6433             ret = reg_node(pRExC_state, CANY);
6434             RExC_seen |= REG_SEEN_CANY;
6435             *flagp |= HASWIDTH|SIMPLE;
6436             goto finish_meta_pat;
6437         case 'X':
6438             ret = reg_node(pRExC_state, CLUMP);
6439             *flagp |= HASWIDTH;
6440             goto finish_meta_pat;
6441         case 'w':
6442             ret = reg_node(pRExC_state, (U8)(LOC ? ALNUML     : ALNUM));
6443             *flagp |= HASWIDTH|SIMPLE;
6444             goto finish_meta_pat;
6445         case 'W':
6446             ret = reg_node(pRExC_state, (U8)(LOC ? NALNUML    : NALNUM));
6447             *flagp |= HASWIDTH|SIMPLE;
6448             goto finish_meta_pat;
6449         case 'b':
6450             RExC_seen_zerolen++;
6451             RExC_seen |= REG_SEEN_LOOKBEHIND;
6452             ret = reg_node(pRExC_state, (U8)(LOC ? BOUNDL     : BOUND));
6453             *flagp |= SIMPLE;
6454             goto finish_meta_pat;
6455         case 'B':
6456             RExC_seen_zerolen++;
6457             RExC_seen |= REG_SEEN_LOOKBEHIND;
6458             ret = reg_node(pRExC_state, (U8)(LOC ? NBOUNDL    : NBOUND));
6459             *flagp |= SIMPLE;
6460             goto finish_meta_pat;
6461         case 's':
6462             ret = reg_node(pRExC_state, (U8)(LOC ? SPACEL     : SPACE));
6463             *flagp |= HASWIDTH|SIMPLE;
6464             goto finish_meta_pat;
6465         case 'S':
6466             ret = reg_node(pRExC_state, (U8)(LOC ? NSPACEL    : NSPACE));
6467             *flagp |= HASWIDTH|SIMPLE;
6468             goto finish_meta_pat;
6469         case 'd':
6470             ret = reg_node(pRExC_state, DIGIT);
6471             *flagp |= HASWIDTH|SIMPLE;
6472             goto finish_meta_pat;
6473         case 'D':
6474             ret = reg_node(pRExC_state, NDIGIT);
6475             *flagp |= HASWIDTH|SIMPLE;
6476             goto finish_meta_pat;
6477         case 'v':
6478             ret = reganode(pRExC_state, PRUNE, 0);
6479             ret->flags = 1;
6480             *flagp |= SIMPLE;
6481             goto finish_meta_pat;
6482         case 'V':
6483             ret = reganode(pRExC_state, SKIP, 0);
6484             ret->flags = 1;
6485             *flagp |= SIMPLE;
6486          finish_meta_pat:           
6487             nextchar(pRExC_state);
6488             Set_Node_Length(ret, 2); /* MJD */
6489             break;          
6490         case 'p':
6491         case 'P':
6492             {   
6493                 char* const oldregxend = RExC_end;
6494 #ifdef DEBUGGING
6495                 char* parse_start = RExC_parse - 2;
6496 #endif
6497
6498                 if (RExC_parse[1] == '{') {
6499                   /* a lovely hack--pretend we saw [\pX] instead */
6500                     RExC_end = strchr(RExC_parse, '}');
6501                     if (!RExC_end) {
6502                         const U8 c = (U8)*RExC_parse;
6503                         RExC_parse += 2;
6504                         RExC_end = oldregxend;
6505                         vFAIL2("Missing right brace on \\%c{}", c);
6506                     }
6507                     RExC_end++;
6508                 }
6509                 else {
6510                     RExC_end = RExC_parse + 2;
6511                     if (RExC_end > oldregxend)
6512                         RExC_end = oldregxend;
6513                 }
6514                 RExC_parse--;
6515
6516                 ret = regclass(pRExC_state,depth+1);
6517
6518                 RExC_end = oldregxend;
6519                 RExC_parse--;
6520
6521                 Set_Node_Offset(ret, parse_start + 2);
6522                 Set_Node_Cur_Length(ret);
6523                 nextchar(pRExC_state);
6524                 *flagp |= HASWIDTH|SIMPLE;
6525             }
6526             break;
6527         case 'N': 
6528             /* Handle \N{NAME} here and not below because it can be 
6529             multicharacter. join_exact() will join them up later on. 
6530             Also this makes sure that things like /\N{BLAH}+/ and 
6531             \N{BLAH} being multi char Just Happen. dmq*/
6532             ++RExC_parse;
6533             ret= reg_namedseq(pRExC_state, NULL); 
6534             break;
6535         case 'k':    /* Handle \k<NAME> and \k'NAME' */
6536         parse_named_seq:
6537         {   
6538             char ch= RExC_parse[1];         
6539             if (ch != '<' && ch != '\'' && ch != '{') {
6540                 RExC_parse++;
6541                 vFAIL2("Sequence %.2s... not terminated",parse_start);
6542             } else {
6543                 /* this pretty much dupes the code for (?P=...) in reg(), if
6544                    you change this make sure you change that */
6545                 char* name_start = (RExC_parse += 2);
6546                 U32 num = 0;
6547                 SV *sv_dat = reg_scan_name(pRExC_state,
6548                     SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6549                 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
6550                 if (RExC_parse == name_start || *RExC_parse != ch)
6551                     vFAIL2("Sequence %.3s... not terminated",parse_start);
6552
6553                 if (!SIZE_ONLY) {
6554                     num = add_data( pRExC_state, 1, "S" );
6555                     RExC_rxi->data->data[num]=(void*)sv_dat;
6556                     SvREFCNT_inc(sv_dat);
6557                 }
6558
6559                 RExC_sawback = 1;
6560                 ret = reganode(pRExC_state,
6561                            (U8)(FOLD ? (LOC ? NREFFL : NREFF) : NREF),
6562                            num);
6563                 *flagp |= HASWIDTH;
6564
6565                 /* override incorrect value set in reganode MJD */
6566                 Set_Node_Offset(ret, parse_start+1);
6567                 Set_Node_Cur_Length(ret); /* MJD */
6568                 nextchar(pRExC_state);
6569
6570             }
6571             break;
6572         }
6573         case 'g': 
6574         case '1': case '2': case '3': case '4':
6575         case '5': case '6': case '7': case '8': case '9':
6576             {
6577                 I32 num;
6578                 bool isg = *RExC_parse == 'g';
6579                 bool isrel = 0; 
6580                 bool hasbrace = 0;
6581                 if (isg) {
6582                     RExC_parse++;
6583                     if (*RExC_parse == '{') {
6584                         RExC_parse++;
6585                         hasbrace = 1;
6586                     }
6587                     if (*RExC_parse == '-') {
6588                         RExC_parse++;
6589                         isrel = 1;
6590                     }
6591                     if (hasbrace && !isDIGIT(*RExC_parse)) {
6592                         if (isrel) RExC_parse--;
6593                         RExC_parse -= 2;                            
6594                         goto parse_named_seq;
6595                 }   }
6596                 num = atoi(RExC_parse);
6597                 if (isrel) {
6598                     num = RExC_npar - num;
6599                     if (num < 1)
6600                         vFAIL("Reference to nonexistent or unclosed group");
6601                 }
6602                 if (!isg && num > 9 && num >= RExC_npar)
6603                     goto defchar;
6604                 else {
6605                     char * const parse_start = RExC_parse - 1; /* MJD */
6606                     while (isDIGIT(*RExC_parse))
6607                         RExC_parse++;
6608                     if (parse_start == RExC_parse - 1) 
6609                         vFAIL("Unterminated \\g... pattern");
6610                     if (hasbrace) {
6611                         if (*RExC_parse != '}') 
6612                             vFAIL("Unterminated \\g{...} pattern");
6613                         RExC_parse++;
6614                     }    
6615                     if (!SIZE_ONLY) {
6616                         if (num > (I32)RExC_rx->nparens)
6617                             vFAIL("Reference to nonexistent group");
6618                     }
6619                     RExC_sawback = 1;
6620                     ret = reganode(pRExC_state,
6621                                    (U8)(FOLD ? (LOC ? REFFL : REFF) : REF),
6622                                    num);
6623                     *flagp |= HASWIDTH;
6624
6625                     /* override incorrect value set in reganode MJD */
6626                     Set_Node_Offset(ret, parse_start+1);
6627                     Set_Node_Cur_Length(ret); /* MJD */
6628                     RExC_parse--;
6629                     nextchar(pRExC_state);
6630                 }
6631             }
6632             break;
6633         case '\0':
6634             if (RExC_parse >= RExC_end)
6635                 FAIL("Trailing \\");
6636             /* FALL THROUGH */
6637         default:
6638             /* Do not generate "unrecognized" warnings here, we fall
6639                back into the quick-grab loop below */
6640             parse_start--;
6641             goto defchar;
6642         }
6643         break;
6644
6645     case '#':
6646         if (RExC_flags & RXf_PMf_EXTENDED) {
6647             while (RExC_parse < RExC_end && *RExC_parse != '\n')
6648                 RExC_parse++;
6649             if (RExC_parse < RExC_end)
6650                 goto tryagain;
6651         }
6652         /* FALL THROUGH */
6653
6654     default: {
6655             register STRLEN len;
6656             register UV ender;
6657             register char *p;
6658             char *s;
6659             STRLEN foldlen;
6660             U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
6661
6662             parse_start = RExC_parse - 1;
6663
6664             RExC_parse++;
6665
6666         defchar:
6667             ender = 0;
6668             ret = reg_node(pRExC_state,
6669                            (U8)(FOLD ? (LOC ? EXACTFL : EXACTF) : EXACT));
6670             s = STRING(ret);
6671             for (len = 0, p = RExC_parse - 1;
6672               len < 127 && p < RExC_end;
6673               len++)
6674             {
6675                 char * const oldp = p;
6676
6677                 if (RExC_flags & RXf_PMf_EXTENDED)
6678                     p = regwhite(p, RExC_end);
6679                 switch (*p) {
6680                 case '^':
6681                 case '$':
6682                 case '.':
6683                 case '[':
6684                 case '(':
6685                 case ')':
6686                 case '|':
6687                     goto loopdone;
6688                 case '\\':
6689                     /* Literal Escapes Switch
6690
6691                        This switch is meant to handle escape sequences that
6692                        resolve to a literal character.
6693
6694                        Every escape sequence that represents something
6695                        else, like an assertion or a char class, is handled
6696                        in the switch marked 'Special Escapes' above in this
6697                        routine, but also has an entry here as anything that
6698                        isn't explicitly mentioned here will be treated as
6699                        an unescaped equivalent literal.
6700                     */
6701
6702                     switch (*++p) {
6703                     /* These are all the special escapes. */
6704                     case 'A':             /* Start assertion */
6705                     case 'b': case 'B':   /* Word-boundary assertion*/
6706                     case 'C':             /* Single char !DANGEROUS! */
6707                     case 'd': case 'D':   /* digit class */
6708                     case 'g': case 'G':   /* generic-backref, pos assertion */
6709                     case 'k': case 'K':   /* named backref, keep marker */
6710                     case 'N':             /* named char sequence */
6711                     case 'p': case 'P':   /* unicode property */
6712                     case 's': case 'S':   /* space class */
6713                     case 'v': case 'V':   /* (*PRUNE) and (*SKIP) */
6714                     case 'w': case 'W':   /* word class */
6715                     case 'X':             /* eXtended Unicode "combining character sequence" */
6716                     case 'z': case 'Z':   /* End of line/string assertion */
6717                         --p;
6718                         goto loopdone;
6719
6720                     /* Anything after here is an escape that resolves to a
6721                        literal. (Except digits, which may or may not)
6722                      */
6723                     case 'n':
6724                         ender = '\n';
6725                         p++;
6726                         break;
6727                     case 'r':
6728                         ender = '\r';
6729                         p++;
6730                         break;
6731                     case 't':
6732                         ender = '\t';
6733                         p++;
6734                         break;
6735                     case 'f':
6736                         ender = '\f';
6737                         p++;
6738                         break;
6739                     case 'e':
6740                           ender = ASCII_TO_NATIVE('\033');
6741                         p++;
6742                         break;
6743                     case 'a':
6744                           ender = ASCII_TO_NATIVE('\007');
6745                         p++;
6746                         break;
6747                     case 'x':
6748                         if (*++p == '{') {
6749                             char* const e = strchr(p, '}');
6750         
6751                             if (!e) {
6752                                 RExC_parse = p + 1;
6753                                 vFAIL("Missing right brace on \\x{}");
6754                             }
6755                             else {
6756                                 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
6757                                     | PERL_SCAN_DISALLOW_PREFIX;
6758                                 STRLEN numlen = e - p - 1;
6759                                 ender = grok_hex(p + 1, &numlen, &flags, NULL);
6760                                 if (ender > 0xff)
6761                                     RExC_utf8 = 1;
6762                                 p = e + 1;
6763                             }
6764                         }
6765                         else {
6766                             I32 flags = PERL_SCAN_DISALLOW_PREFIX;
6767                             STRLEN numlen = 2;
6768                             ender = grok_hex(p, &numlen, &flags, NULL);
6769                             p += numlen;
6770                         }
6771                         if (PL_encoding && ender < 0x100)
6772                             goto recode_encoding;
6773                         break;
6774                     case 'c':
6775                         p++;
6776                         ender = UCHARAT(p++);
6777                         ender = toCTRL(ender);
6778                         break;
6779                     case '0': case '1': case '2': case '3':case '4':
6780                     case '5': case '6': case '7': case '8':case '9':
6781                         if (*p == '0' ||
6782                           (isDIGIT(p[1]) && atoi(p) >= RExC_npar) ) {
6783                             I32 flags = 0;
6784                             STRLEN numlen = 3;
6785                             ender = grok_oct(p, &numlen, &flags, NULL);
6786                             p += numlen;
6787                         }
6788                         else {
6789                             --p;
6790                             goto loopdone;
6791                         }
6792                         if (PL_encoding && ender < 0x100)
6793                             goto recode_encoding;
6794                         break;
6795                     recode_encoding:
6796                         {
6797                             SV* enc = PL_encoding;
6798                             ender = reg_recode((const char)(U8)ender, &enc);
6799                             if (!enc && SIZE_ONLY && ckWARN(WARN_REGEXP))
6800                                 vWARN(p, "Invalid escape in the specified encoding");
6801                             RExC_utf8 = 1;
6802                         }
6803                         break;
6804                     case '\0':
6805                         if (p >= RExC_end)
6806                             FAIL("Trailing \\");
6807                         /* FALL THROUGH */
6808                     default:
6809                         if (!SIZE_ONLY&& isALPHA(*p) && ckWARN(WARN_REGEXP))
6810                             vWARN2(p + 1, "Unrecognized escape \\%c passed through", UCHARAT(p));
6811                         goto normal_default;
6812                     }
6813                     break;
6814                 default:
6815                   normal_default:
6816                     if (UTF8_IS_START(*p) && UTF) {
6817                         STRLEN numlen;
6818                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
6819                                                &numlen, UTF8_ALLOW_DEFAULT);
6820                         p += numlen;
6821                     }
6822                     else
6823                         ender = *p++;
6824                     break;
6825                 }
6826                 if (RExC_flags & RXf_PMf_EXTENDED)
6827                     p = regwhite(p, RExC_end);
6828                 if (UTF && FOLD) {
6829                     /* Prime the casefolded buffer. */
6830                     ender = toFOLD_uni(ender, tmpbuf, &foldlen);
6831                 }
6832                 if (ISMULT2(p)) { /* Back off on ?+*. */
6833                     if (len)
6834                         p = oldp;
6835                     else if (UTF) {
6836                          if (FOLD) {
6837                               /* Emit all the Unicode characters. */
6838                               STRLEN numlen;
6839                               for (foldbuf = tmpbuf;
6840                                    foldlen;
6841                                    foldlen -= numlen) {
6842                                    ender = utf8_to_uvchr(foldbuf, &numlen);
6843                                    if (numlen > 0) {
6844                                         const STRLEN unilen = reguni(pRExC_state, ender, s);
6845                                         s       += unilen;
6846                                         len     += unilen;
6847                                         /* In EBCDIC the numlen
6848                                          * and unilen can differ. */
6849                                         foldbuf += numlen;
6850                                         if (numlen >= foldlen)
6851                                              break;
6852                                    }
6853                                    else
6854                                         break; /* "Can't happen." */
6855                               }
6856                          }
6857                          else {
6858                               const STRLEN unilen = reguni(pRExC_state, ender, s);
6859                               if (unilen > 0) {
6860                                    s   += unilen;
6861                                    len += unilen;
6862                               }
6863                          }
6864                     }
6865                     else {
6866                         len++;
6867                         REGC((char)ender, s++);
6868                     }
6869                     break;
6870                 }
6871                 if (UTF) {
6872                      if (FOLD) {
6873                           /* Emit all the Unicode characters. */
6874                           STRLEN numlen;
6875                           for (foldbuf = tmpbuf;
6876                                foldlen;
6877                                foldlen -= numlen) {
6878                                ender = utf8_to_uvchr(foldbuf, &numlen);
6879                                if (numlen > 0) {
6880                                     const STRLEN unilen = reguni(pRExC_state, ender, s);
6881                                     len     += unilen;
6882                                     s       += unilen;
6883                                     /* In EBCDIC the numlen
6884                                      * and unilen can differ. */
6885                                     foldbuf += numlen;
6886                                     if (numlen >= foldlen)
6887                                          break;
6888                                }
6889                                else
6890                                     break;
6891                           }
6892                      }
6893                      else {
6894                           const STRLEN unilen = reguni(pRExC_state, ender, s);
6895                           if (unilen > 0) {
6896                                s   += unilen;
6897                                len += unilen;
6898                           }
6899                      }
6900                      len--;
6901                 }
6902                 else
6903                     REGC((char)ender, s++);
6904             }
6905         loopdone:
6906             RExC_parse = p - 1;
6907             Set_Node_Cur_Length(ret); /* MJD */
6908             nextchar(pRExC_state);
6909             {
6910                 /* len is STRLEN which is unsigned, need to copy to signed */
6911                 IV iv = len;
6912                 if (iv < 0)
6913                     vFAIL("Internal disaster");
6914             }
6915             if (len > 0)
6916                 *flagp |= HASWIDTH;
6917             if (len == 1 && UNI_IS_INVARIANT(ender))
6918                 *flagp |= SIMPLE;
6919                 
6920             if (SIZE_ONLY)
6921                 RExC_size += STR_SZ(len);
6922             else {
6923                 STR_LEN(ret) = len;
6924                 RExC_emit += STR_SZ(len);
6925             }
6926         }
6927         break;
6928     }
6929
6930     return(ret);
6931 }
6932
6933 STATIC char *
6934 S_regwhite(char *p, const char *e)
6935 {
6936     while (p < e) {
6937         if (isSPACE(*p))
6938             ++p;
6939         else if (*p == '#') {
6940             do {
6941                 p++;
6942             } while (p < e && *p != '\n');
6943         }
6944         else
6945             break;
6946     }
6947     return p;
6948 }
6949
6950 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
6951    Character classes ([:foo:]) can also be negated ([:^foo:]).
6952    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
6953    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
6954    but trigger failures because they are currently unimplemented. */
6955
6956 #define POSIXCC_DONE(c)   ((c) == ':')
6957 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
6958 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
6959
6960 STATIC I32
6961 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
6962 {
6963     dVAR;
6964     I32 namedclass = OOB_NAMEDCLASS;
6965
6966     if (value == '[' && RExC_parse + 1 < RExC_end &&
6967         /* I smell either [: or [= or [. -- POSIX has been here, right? */
6968         POSIXCC(UCHARAT(RExC_parse))) {
6969         const char c = UCHARAT(RExC_parse);
6970         char* const s = RExC_parse++;
6971         
6972         while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
6973             RExC_parse++;
6974         if (RExC_parse == RExC_end)
6975             /* Grandfather lone [:, [=, [. */
6976             RExC_parse = s;
6977         else {
6978             const char* const t = RExC_parse++; /* skip over the c */
6979             assert(*t == c);
6980
6981             if (UCHARAT(RExC_parse) == ']') {
6982                 const char *posixcc = s + 1;
6983                 RExC_parse++; /* skip over the ending ] */
6984
6985                 if (*s == ':') {
6986                     const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
6987                     const I32 skip = t - posixcc;
6988
6989                     /* Initially switch on the length of the name.  */
6990                     switch (skip) {
6991                     case 4:
6992                         if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
6993                             namedclass = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
6994                         break;
6995                     case 5:
6996                         /* Names all of length 5.  */
6997                         /* alnum alpha ascii blank cntrl digit graph lower
6998                            print punct space upper  */
6999                         /* Offset 4 gives the best switch position.  */
7000                         switch (posixcc[4]) {
7001                         case 'a':
7002                             if (memEQ(posixcc, "alph", 4)) /* alpha */
7003                                 namedclass = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
7004                             break;
7005                         case 'e':
7006                             if (memEQ(posixcc, "spac", 4)) /* space */
7007                                 namedclass = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
7008                             break;
7009                         case 'h':
7010                             if (memEQ(posixcc, "grap", 4)) /* graph */
7011                                 namedclass = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
7012                             break;
7013                         case 'i':
7014                             if (memEQ(posixcc, "asci", 4)) /* ascii */
7015                                 namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII;
7016                             break;
7017                         case 'k':
7018                             if (memEQ(posixcc, "blan", 4)) /* blank */
7019                                 namedclass = complement ? ANYOF_NBLANK : ANYOF_BLANK;
7020                             break;
7021                         case 'l':
7022                             if (memEQ(posixcc, "cntr", 4)) /* cntrl */
7023                                 namedclass = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
7024                             break;
7025                         case 'm':
7026                             if (memEQ(posixcc, "alnu", 4)) /* alnum */
7027                                 namedclass = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
7028                             break;
7029                         case 'r':
7030                             if (memEQ(posixcc, "lowe", 4)) /* lower */
7031                                 namedclass = complement ? ANYOF_NLOWER : ANYOF_LOWER;
7032                             else if (memEQ(posixcc, "uppe", 4)) /* upper */
7033                                 namedclass = complement ? ANYOF_NUPPER : ANYOF_UPPER;
7034                             break;
7035                         case 't':
7036                             if (memEQ(posixcc, "digi", 4)) /* digit */
7037                                 namedclass = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
7038                             else if (memEQ(posixcc, "prin", 4)) /* print */
7039                                 namedclass = complement ? ANYOF_NPRINT : ANYOF_PRINT;
7040                             else if (memEQ(posixcc, "punc", 4)) /* punct */
7041                                 namedclass = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
7042                             break;
7043                         }
7044                         break;
7045                     case 6:
7046                         if (memEQ(posixcc, "xdigit", 6))
7047                             namedclass = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
7048                         break;
7049                     }
7050
7051                     if (namedclass == OOB_NAMEDCLASS)
7052                         Simple_vFAIL3("POSIX class [:%.*s:] unknown",
7053                                       t - s - 1, s + 1);
7054                     assert (posixcc[skip] == ':');
7055                     assert (posixcc[skip+1] == ']');
7056                 } else if (!SIZE_ONLY) {
7057                     /* [[=foo=]] and [[.foo.]] are still future. */
7058
7059                     /* adjust RExC_parse so the warning shows after
7060                        the class closes */
7061                     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
7062                         RExC_parse++;
7063                     Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
7064                 }
7065             } else {
7066                 /* Maternal grandfather:
7067                  * "[:" ending in ":" but not in ":]" */
7068                 RExC_parse = s;
7069             }
7070         }
7071     }
7072
7073     return namedclass;
7074 }
7075
7076 STATIC void
7077 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
7078 {
7079     dVAR;
7080     if (POSIXCC(UCHARAT(RExC_parse))) {
7081         const char *s = RExC_parse;
7082         const char  c = *s++;
7083
7084         while (isALNUM(*s))
7085             s++;
7086         if (*s && c == *s && s[1] == ']') {
7087             if (ckWARN(WARN_REGEXP))
7088                 vWARN3(s+2,
7089                         "POSIX syntax [%c %c] belongs inside character classes",
7090                         c, c);
7091
7092             /* [[=foo=]] and [[.foo.]] are still future. */
7093             if (POSIXCC_NOTYET(c)) {
7094                 /* adjust RExC_parse so the error shows after
7095                    the class closes */
7096                 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
7097                     NOOP;
7098                 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
7099             }
7100         }
7101     }
7102 }
7103
7104
7105 #define _C_C_T_(NAME,TEST,WORD)                         \
7106 ANYOF_##NAME:                                           \
7107     if (LOC)                                            \
7108         ANYOF_CLASS_SET(ret, ANYOF_##NAME);             \
7109     else {                                              \
7110         for (value = 0; value < 256; value++)           \
7111             if (TEST)                                   \
7112                 ANYOF_BITMAP_SET(ret, value);           \
7113     }                                                   \
7114     yesno = '+';                                        \
7115     what = WORD;                                        \
7116     break;                                              \
7117 case ANYOF_N##NAME:                                     \
7118     if (LOC)                                            \
7119         ANYOF_CLASS_SET(ret, ANYOF_N##NAME);            \
7120     else {                                              \
7121         for (value = 0; value < 256; value++)           \
7122             if (!TEST)                                  \
7123                 ANYOF_BITMAP_SET(ret, value);           \
7124     }                                                   \
7125     yesno = '!';                                        \
7126     what = WORD;                                        \
7127     break
7128
7129
7130 /*
7131    parse a class specification and produce either an ANYOF node that
7132    matches the pattern or if the pattern matches a single char only and
7133    that char is < 256 and we are case insensitive then we produce an 
7134    EXACT node instead.
7135 */
7136
7137 STATIC regnode *
7138 S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
7139 {
7140     dVAR;
7141     register UV value = 0;
7142     register UV nextvalue;
7143     register IV prevvalue = OOB_UNICODE;
7144     register IV range = 0;
7145     register regnode *ret;
7146     STRLEN numlen;
7147     IV namedclass;
7148     char *rangebegin = NULL;
7149     bool need_class = 0;
7150     SV *listsv = NULL;
7151     UV n;
7152     bool optimize_invert   = TRUE;
7153     AV* unicode_alternate  = NULL;
7154 #ifdef EBCDIC
7155     UV literal_endpoint = 0;
7156 #endif
7157     UV stored = 0;  /* number of chars stored in the class */
7158
7159     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
7160         case we need to change the emitted regop to an EXACT. */
7161     const char * orig_parse = RExC_parse;
7162     GET_RE_DEBUG_FLAGS_DECL;
7163 #ifndef DEBUGGING
7164     PERL_UNUSED_ARG(depth);
7165 #endif
7166
7167     DEBUG_PARSE("clas");
7168
7169     /* Assume we are going to generate an ANYOF node. */
7170     ret = reganode(pRExC_state, ANYOF, 0);
7171
7172     if (!SIZE_ONLY)
7173         ANYOF_FLAGS(ret) = 0;
7174
7175     if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
7176         RExC_naughty++;
7177         RExC_parse++;
7178         if (!SIZE_ONLY)
7179             ANYOF_FLAGS(ret) |= ANYOF_INVERT;
7180     }
7181
7182     if (SIZE_ONLY) {
7183         RExC_size += ANYOF_SKIP;
7184         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
7185     }
7186     else {
7187         RExC_emit += ANYOF_SKIP;
7188         if (FOLD)
7189             ANYOF_FLAGS(ret) |= ANYOF_FOLD;
7190         if (LOC)
7191             ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
7192         ANYOF_BITMAP_ZERO(ret);
7193         listsv = newSVpvs("# comment\n");
7194     }
7195
7196     nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
7197
7198     if (!SIZE_ONLY && POSIXCC(nextvalue))
7199         checkposixcc(pRExC_state);
7200
7201     /* allow 1st char to be ] (allowing it to be - is dealt with later) */
7202     if (UCHARAT(RExC_parse) == ']')
7203         goto charclassloop;
7204
7205 parseit:
7206     while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
7207
7208     charclassloop:
7209
7210         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
7211
7212         if (!range)
7213             rangebegin = RExC_parse;
7214         if (UTF) {
7215             value = utf8n_to_uvchr((U8*)RExC_parse,
7216                                    RExC_end - RExC_parse,
7217                                    &numlen, UTF8_ALLOW_DEFAULT);
7218             RExC_parse += numlen;
7219         }
7220         else
7221             value = UCHARAT(RExC_parse++);
7222
7223         nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
7224         if (value == '[' && POSIXCC(nextvalue))
7225             namedclass = regpposixcc(pRExC_state, value);
7226         else if (value == '\\') {
7227             if (UTF) {
7228                 value = utf8n_to_uvchr((U8*)RExC_parse,
7229                                    RExC_end - RExC_parse,
7230                                    &numlen, UTF8_ALLOW_DEFAULT);
7231                 RExC_parse += numlen;
7232             }
7233             else
7234                 value = UCHARAT(RExC_parse++);
7235             /* Some compilers cannot handle switching on 64-bit integer
7236              * values, therefore value cannot be an UV.  Yes, this will
7237              * be a problem later if we want switch on Unicode.
7238              * A similar issue a little bit later when switching on
7239              * namedclass. --jhi */
7240             switch ((I32)value) {
7241             case 'w':   namedclass = ANYOF_ALNUM;       break;
7242             case 'W':   namedclass = ANYOF_NALNUM;      break;
7243             case 's':   namedclass = ANYOF_SPACE;       break;
7244             case 'S':   namedclass = ANYOF_NSPACE;      break;
7245             case 'd':   namedclass = ANYOF_DIGIT;       break;
7246             case 'D':   namedclass = ANYOF_NDIGIT;      break;
7247             case 'N':  /* Handle \N{NAME} in class */
7248                 {
7249                     /* We only pay attention to the first char of 
7250                     multichar strings being returned. I kinda wonder
7251                     if this makes sense as it does change the behaviour
7252                     from earlier versions, OTOH that behaviour was broken
7253                     as well. */
7254                     UV v; /* value is register so we cant & it /grrr */
7255                     if (reg_namedseq(pRExC_state, &v)) {
7256                         goto parseit;
7257                     }
7258                     value= v; 
7259                 }
7260                 break;
7261             case 'p':
7262             case 'P':
7263                 {
7264                 char *e;
7265                 if (RExC_parse >= RExC_end)
7266                     vFAIL2("Empty \\%c{}", (U8)value);
7267                 if (*RExC_parse == '{') {
7268                     const U8 c = (U8)value;
7269                     e = strchr(RExC_parse++, '}');
7270                     if (!e)
7271                         vFAIL2("Missing right brace on \\%c{}", c);
7272                     while (isSPACE(UCHARAT(RExC_parse)))
7273                         RExC_parse++;
7274                     if (e == RExC_parse)
7275                         vFAIL2("Empty \\%c{}", c);
7276                     n = e - RExC_parse;
7277                     while (isSPACE(UCHARAT(RExC_parse + n - 1)))
7278                         n--;
7279                 }
7280                 else {
7281                     e = RExC_parse;
7282                     n = 1;
7283                 }
7284                 if (!SIZE_ONLY) {
7285                     if (UCHARAT(RExC_parse) == '^') {
7286                          RExC_parse++;
7287                          n--;
7288                          value = value == 'p' ? 'P' : 'p'; /* toggle */
7289                          while (isSPACE(UCHARAT(RExC_parse))) {
7290                               RExC_parse++;
7291                               n--;
7292                          }
7293                     }
7294                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%.*s\n",
7295                         (value=='p' ? '+' : '!'), (int)n, RExC_parse);
7296                 }
7297                 RExC_parse = e + 1;
7298                 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
7299                 namedclass = ANYOF_MAX;  /* no official name, but it's named */
7300                 }
7301                 break;
7302             case 'n':   value = '\n';                   break;
7303             case 'r':   value = '\r';                   break;
7304             case 't':   value = '\t';                   break;
7305             case 'f':   value = '\f';                   break;
7306             case 'b':   value = '\b';                   break;
7307             case 'e':   value = ASCII_TO_NATIVE('\033');break;
7308             case 'a':   value = ASCII_TO_NATIVE('\007');break;
7309             case 'x':
7310                 if (*RExC_parse == '{') {
7311                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
7312                         | PERL_SCAN_DISALLOW_PREFIX;
7313                     char * const e = strchr(RExC_parse++, '}');
7314                     if (!e)
7315                         vFAIL("Missing right brace on \\x{}");
7316
7317                     numlen = e - RExC_parse;
7318                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
7319                     RExC_parse = e + 1;
7320                 }
7321                 else {
7322                     I32 flags = PERL_SCAN_DISALLOW_PREFIX;
7323                     numlen = 2;
7324                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
7325                     RExC_parse += numlen;
7326                 }
7327                 if (PL_encoding && value < 0x100)
7328                     goto recode_encoding;
7329                 break;
7330             case 'c':
7331                 value = UCHARAT(RExC_parse++);
7332                 value = toCTRL(value);
7333                 break;
7334             case '0': case '1': case '2': case '3': case '4':
7335             case '5': case '6': case '7': case '8': case '9':
7336                 {
7337                     I32 flags = 0;
7338                     numlen = 3;
7339                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
7340                     RExC_parse += numlen;
7341                     if (PL_encoding && value < 0x100)
7342                         goto recode_encoding;
7343                     break;
7344                 }
7345             recode_encoding:
7346                 {
7347                     SV* enc = PL_encoding;
7348                     value = reg_recode((const char)(U8)value, &enc);
7349                     if (!enc && SIZE_ONLY && ckWARN(WARN_REGEXP))
7350                         vWARN(RExC_parse,
7351                               "Invalid escape in the specified encoding");
7352                     break;
7353                 }
7354             default:
7355                 if (!SIZE_ONLY && isALPHA(value) && ckWARN(WARN_REGEXP))
7356                     vWARN2(RExC_parse,
7357                            "Unrecognized escape \\%c in character class passed through",
7358                            (int)value);
7359                 break;
7360             }
7361         } /* end of \blah */
7362 #ifdef EBCDIC
7363         else
7364             literal_endpoint++;
7365 #endif
7366
7367         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
7368
7369             if (!SIZE_ONLY && !need_class)
7370                 ANYOF_CLASS_ZERO(ret);
7371
7372             need_class = 1;
7373
7374             /* a bad range like a-\d, a-[:digit:] ? */
7375             if (range) {
7376                 if (!SIZE_ONLY) {
7377                     if (ckWARN(WARN_REGEXP)) {
7378                         const int w =
7379                             RExC_parse >= rangebegin ?
7380                             RExC_parse - rangebegin : 0;
7381                         vWARN4(RExC_parse,
7382                                "False [] range \"%*.*s\"",
7383                                w, w, rangebegin);
7384                     }
7385                     if (prevvalue < 256) {
7386                         ANYOF_BITMAP_SET(ret, prevvalue);
7387                         ANYOF_BITMAP_SET(ret, '-');
7388                     }
7389                     else {
7390                         ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
7391                         Perl_sv_catpvf(aTHX_ listsv,
7392                                        "%04"UVxf"\n%04"UVxf"\n", (UV)prevvalue, (UV) '-');
7393                     }
7394                 }
7395
7396                 range = 0; /* this was not a true range */
7397             }
7398
7399
7400     
7401             if (!SIZE_ONLY) {
7402                 const char *what = NULL;
7403                 char yesno = 0;
7404
7405                 if (namedclass > OOB_NAMEDCLASS)
7406                     optimize_invert = FALSE;
7407                 /* Possible truncation here but in some 64-bit environments
7408                  * the compiler gets heartburn about switch on 64-bit values.
7409                  * A similar issue a little earlier when switching on value.
7410                  * --jhi */
7411                 switch ((I32)namedclass) {
7412                 case _C_C_T_(ALNUM, isALNUM(value), "Word");
7413                 case _C_C_T_(ALNUMC, isALNUMC(value), "Alnum");
7414                 case _C_C_T_(ALPHA, isALPHA(value), "Alpha");
7415                 case _C_C_T_(BLANK, isBLANK(value), "Blank");
7416                 case _C_C_T_(CNTRL, isCNTRL(value), "Cntrl");
7417                 case _C_C_T_(GRAPH, isGRAPH(value), "Graph");
7418                 case _C_C_T_(LOWER, isLOWER(value), "Lower");
7419                 case _C_C_T_(PRINT, isPRINT(value), "Print");
7420                 case _C_C_T_(PSXSPC, isPSXSPC(value), "Space");
7421                 case _C_C_T_(PUNCT, isPUNCT(value), "Punct");
7422                 case _C_C_T_(SPACE, isSPACE(value), "SpacePerl");
7423                 case _C_C_T_(UPPER, isUPPER(value), "Upper");
7424                 case _C_C_T_(XDIGIT, isXDIGIT(value), "XDigit");
7425                 case ANYOF_ASCII:
7426                     if (LOC)
7427                         ANYOF_CLASS_SET(ret, ANYOF_ASCII);
7428                     else {
7429 #ifndef EBCDIC
7430                         for (value = 0; value < 128; value++)
7431                             ANYOF_BITMAP_SET(ret, value);
7432 #else  /* EBCDIC */
7433                         for (value = 0; value < 256; value++) {
7434                             if (isASCII(value))
7435                                 ANYOF_BITMAP_SET(ret, value);
7436                         }
7437 #endif /* EBCDIC */
7438                     }
7439                     yesno = '+';
7440                     what = "ASCII";
7441                     break;
7442                 case ANYOF_NASCII:
7443                     if (LOC)
7444                         ANYOF_CLASS_SET(ret, ANYOF_NASCII);
7445                     else {
7446 #ifndef EBCDIC
7447                         for (value = 128; value < 256; value++)
7448                             ANYOF_BITMAP_SET(ret, value);
7449 #else  /* EBCDIC */
7450                         for (value = 0; value < 256; value++) {
7451                             if (!isASCII(value))
7452                                 ANYOF_BITMAP_SET(ret, value);
7453                         }
7454 #endif /* EBCDIC */
7455                     }
7456                     yesno = '!';
7457                     what = "ASCII";
7458                     break;              
7459                 case ANYOF_DIGIT:
7460                     if (LOC)
7461                         ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
7462                     else {
7463                         /* consecutive digits assumed */
7464                         for (value = '0'; value <= '9'; value++)
7465                             ANYOF_BITMAP_SET(ret, value);
7466                     }
7467                     yesno = '+';
7468                     what = "Digit";
7469                     break;
7470                 case ANYOF_NDIGIT:
7471                     if (LOC)
7472                         ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
7473                     else {
7474                         /* consecutive digits assumed */
7475                         for (value = 0; value < '0'; value++)
7476                             ANYOF_BITMAP_SET(ret, value);
7477                         for (value = '9' + 1; value < 256; value++)
7478                             ANYOF_BITMAP_SET(ret, value);
7479                     }
7480                     yesno = '!';
7481                     what = "Digit";
7482                     break;              
7483                 case ANYOF_MAX:
7484                     /* this is to handle \p and \P */
7485                     break;
7486                 default:
7487                     vFAIL("Invalid [::] class");
7488                     break;
7489                 }
7490                 if (what) {
7491                     /* Strings such as "+utf8::isWord\n" */
7492                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::Is%s\n", yesno, what);
7493                 }
7494                 if (LOC)
7495                     ANYOF_FLAGS(ret) |= ANYOF_CLASS;
7496                 continue;
7497             }
7498         } /* end of namedclass \blah */
7499
7500         if (range) {
7501             if (prevvalue > (IV)value) /* b-a */ {
7502                 const int w = RExC_parse - rangebegin;
7503                 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
7504                 range = 0; /* not a valid range */
7505             }
7506         }
7507         else {
7508             prevvalue = value; /* save the beginning of the range */
7509             if (*RExC_parse == '-' && RExC_parse+1 < RExC_end &&
7510                 RExC_parse[1] != ']') {
7511                 RExC_parse++;
7512
7513                 /* a bad range like \w-, [:word:]- ? */
7514                 if (namedclass > OOB_NAMEDCLASS) {
7515                     if (ckWARN(WARN_REGEXP)) {
7516                         const int w =
7517                             RExC_parse >= rangebegin ?
7518                             RExC_parse - rangebegin : 0;
7519                         vWARN4(RExC_parse,
7520                                "False [] range \"%*.*s\"",
7521                                w, w, rangebegin);
7522                     }
7523                     if (!SIZE_ONLY)
7524                         ANYOF_BITMAP_SET(ret, '-');
7525                 } else
7526                     range = 1;  /* yeah, it's a range! */
7527                 continue;       /* but do it the next time */
7528             }
7529         }
7530
7531         /* now is the next time */
7532         /*stored += (value - prevvalue + 1);*/
7533         if (!SIZE_ONLY) {
7534             if (prevvalue < 256) {
7535                 const IV ceilvalue = value < 256 ? value : 255;
7536                 IV i;
7537 #ifdef EBCDIC
7538                 /* In EBCDIC [\x89-\x91] should include
7539                  * the \x8e but [i-j] should not. */
7540                 if (literal_endpoint == 2 &&
7541                     ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
7542                      (isUPPER(prevvalue) && isUPPER(ceilvalue))))
7543                 {
7544                     if (isLOWER(prevvalue)) {
7545                         for (i = prevvalue; i <= ceilvalue; i++)
7546                             if (isLOWER(i))
7547                                 ANYOF_BITMAP_SET(ret, i);
7548                     } else {
7549                         for (i = prevvalue; i <= ceilvalue; i++)
7550                             if (isUPPER(i))
7551                                 ANYOF_BITMAP_SET(ret, i);
7552                     }
7553                 }
7554                 else
7555 #endif
7556                       for (i = prevvalue; i <= ceilvalue; i++) {
7557                         if (!ANYOF_BITMAP_TEST(ret,i)) {
7558                             stored++;  
7559                             ANYOF_BITMAP_SET(ret, i);
7560                         }
7561                       }
7562           }
7563           if (value > 255 || UTF) {
7564                 const UV prevnatvalue  = NATIVE_TO_UNI(prevvalue);
7565                 const UV natvalue      = NATIVE_TO_UNI(value);
7566                 stored+=2; /* can't optimize this class */
7567                 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
7568                 if (prevnatvalue < natvalue) { /* what about > ? */
7569                     Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
7570                                    prevnatvalue, natvalue);
7571                 }
7572                 else if (prevnatvalue == natvalue) {
7573                     Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", natvalue);
7574                     if (FOLD) {
7575                          U8 foldbuf[UTF8_MAXBYTES_CASE+1];
7576                          STRLEN foldlen;
7577                          const UV f = to_uni_fold(natvalue, foldbuf, &foldlen);
7578
7579 #ifdef EBCDIC /* RD t/uni/fold ff and 6b */
7580                          if (RExC_precomp[0] == ':' &&
7581                              RExC_precomp[1] == '[' &&
7582                              (f == 0xDF || f == 0x92)) {
7583                              f = NATIVE_TO_UNI(f);
7584                         }
7585 #endif
7586                          /* If folding and foldable and a single
7587                           * character, insert also the folded version
7588                           * to the charclass. */
7589                          if (f != value) {
7590 #ifdef EBCDIC /* RD tunifold ligatures s,t fb05, fb06 */
7591                              if ((RExC_precomp[0] == ':' &&
7592                                   RExC_precomp[1] == '[' &&
7593                                   (f == 0xA2 &&
7594                                    (value == 0xFB05 || value == 0xFB06))) ?
7595                                  foldlen == ((STRLEN)UNISKIP(f) - 1) :
7596                                  foldlen == (STRLEN)UNISKIP(f) )
7597 #else
7598                               if (foldlen == (STRLEN)UNISKIP(f))
7599 #endif
7600                                   Perl_sv_catpvf(aTHX_ listsv,
7601                                                  "%04"UVxf"\n", f);
7602                               else {
7603                                   /* Any multicharacter foldings
7604                                    * require the following transform:
7605                                    * [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst)
7606                                    * where E folds into "pq" and F folds
7607                                    * into "rst", all other characters
7608                                    * fold to single characters.  We save
7609                                    * away these multicharacter foldings,
7610                                    * to be later saved as part of the
7611                                    * additional "s" data. */
7612                                   SV *sv;
7613
7614                                   if (!unicode_alternate)
7615                                       unicode_alternate = newAV();
7616                                   sv = newSVpvn((char*)foldbuf, foldlen);
7617                                   SvUTF8_on(sv);
7618                                   av_push(unicode_alternate, sv);
7619                               }
7620                          }
7621
7622                          /* If folding and the value is one of the Greek
7623                           * sigmas insert a few more sigmas to make the
7624                           * folding rules of the sigmas to work right.
7625                           * Note that not all the possible combinations
7626                           * are handled here: some of them are handled
7627                           * by the standard folding rules, and some of
7628                           * them (literal or EXACTF cases) are handled
7629                           * during runtime in regexec.c:S_find_byclass(). */
7630                          if (value == UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) {
7631                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
7632                                              (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA);
7633                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
7634                                              (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
7635                          }
7636                          else if (value == UNICODE_GREEK_CAPITAL_LETTER_SIGMA)
7637                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
7638                                              (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
7639                     }
7640                 }
7641             }
7642 #ifdef EBCDIC
7643             literal_endpoint = 0;
7644 #endif
7645         }
7646
7647         range = 0; /* this range (if it was one) is done now */
7648     }
7649
7650     if (need_class) {
7651         ANYOF_FLAGS(ret) |= ANYOF_LARGE;
7652         if (SIZE_ONLY)
7653             RExC_size += ANYOF_CLASS_ADD_SKIP;
7654         else
7655             RExC_emit += ANYOF_CLASS_ADD_SKIP;
7656     }
7657
7658
7659     if (SIZE_ONLY)
7660         return ret;
7661     /****** !SIZE_ONLY AFTER HERE *********/
7662
7663     if( stored == 1 && value < 256
7664         && !( ANYOF_FLAGS(ret) & ( ANYOF_FLAGS_ALL ^ ANYOF_FOLD ) )
7665     ) {
7666         /* optimize single char class to an EXACT node
7667            but *only* when its not a UTF/high char  */
7668         const char * cur_parse= RExC_parse;
7669         RExC_emit = (regnode *)orig_emit;
7670         RExC_parse = (char *)orig_parse;
7671         ret = reg_node(pRExC_state,
7672                        (U8)((ANYOF_FLAGS(ret) & ANYOF_FOLD) ? EXACTF : EXACT));
7673         RExC_parse = (char *)cur_parse;
7674         *STRING(ret)= (char)value;
7675         STR_LEN(ret)= 1;
7676         RExC_emit += STR_SZ(1);
7677         return ret;
7678     }
7679     /* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */
7680     if ( /* If the only flag is folding (plus possibly inversion). */
7681         ((ANYOF_FLAGS(ret) & (ANYOF_FLAGS_ALL ^ ANYOF_INVERT)) == ANYOF_FOLD)
7682        ) {
7683         for (value = 0; value < 256; ++value) {
7684             if (ANYOF_BITMAP_TEST(ret, value)) {
7685                 UV fold = PL_fold[value];
7686
7687                 if (fold != value)
7688                     ANYOF_BITMAP_SET(ret, fold);
7689             }
7690         }
7691         ANYOF_FLAGS(ret) &= ~ANYOF_FOLD;
7692     }
7693
7694     /* optimize inverted simple patterns (e.g. [^a-z]) */
7695     if (optimize_invert &&
7696         /* If the only flag is inversion. */
7697         (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT) {
7698         for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
7699             ANYOF_BITMAP(ret)[value] ^= ANYOF_FLAGS_ALL;
7700         ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL;
7701     }
7702     {
7703         AV * const av = newAV();
7704         SV *rv;
7705         /* The 0th element stores the character class description
7706          * in its textual form: used later (regexec.c:Perl_regclass_swash())
7707          * to initialize the appropriate swash (which gets stored in
7708          * the 1st element), and also useful for dumping the regnode.
7709          * The 2nd element stores the multicharacter foldings,
7710          * used later (regexec.c:S_reginclass()). */
7711         av_store(av, 0, listsv);
7712         av_store(av, 1, NULL);
7713         av_store(av, 2, (SV*)unicode_alternate);
7714         rv = newRV_noinc((SV*)av);
7715         n = add_data(pRExC_state, 1, "s");
7716         RExC_rxi->data->data[n] = (void*)rv;
7717         ARG_SET(ret, n);
7718     }
7719     return ret;
7720 }
7721 #undef _C_C_T_
7722
7723
7724 STATIC char*
7725 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
7726 {
7727     char* const retval = RExC_parse++;
7728
7729     for (;;) {
7730         if (*RExC_parse == '(' && RExC_parse[1] == '?' &&
7731                 RExC_parse[2] == '#') {
7732             while (*RExC_parse != ')') {
7733                 if (RExC_parse == RExC_end)
7734                     FAIL("Sequence (?#... not terminated");
7735                 RExC_parse++;
7736             }
7737             RExC_parse++;
7738             continue;
7739         }
7740         if (RExC_flags & RXf_PMf_EXTENDED) {
7741             if (isSPACE(*RExC_parse)) {
7742                 RExC_parse++;
7743                 continue;
7744             }
7745             else if (*RExC_parse == '#') {
7746                 while (RExC_parse < RExC_end)
7747                     if (*RExC_parse++ == '\n') break;
7748                 continue;
7749             }
7750         }
7751         return retval;
7752     }
7753 }
7754
7755 /*
7756 - reg_node - emit a node
7757 */
7758 STATIC regnode *                        /* Location. */
7759 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
7760 {
7761     dVAR;
7762     register regnode *ptr;
7763     regnode * const ret = RExC_emit;
7764     GET_RE_DEBUG_FLAGS_DECL;
7765
7766     if (SIZE_ONLY) {
7767         SIZE_ALIGN(RExC_size);
7768         RExC_size += 1;
7769         return(ret);
7770     }
7771 #ifdef DEBUGGING
7772     if (OP(RExC_emit) == 255)
7773         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %s: %d ",
7774             reg_name[op], OP(RExC_emit));
7775 #endif  
7776     NODE_ALIGN_FILL(ret);
7777     ptr = ret;
7778     FILL_ADVANCE_NODE(ptr, op);
7779 #ifdef RE_TRACK_PATTERN_OFFSETS
7780     if (RExC_offsets) {         /* MJD */
7781         MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n", 
7782               "reg_node", __LINE__, 
7783               reg_name[op],
7784               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] 
7785                 ? "Overwriting end of array!\n" : "OK",
7786               (UV)(RExC_emit - RExC_emit_start),
7787               (UV)(RExC_parse - RExC_start),
7788               (UV)RExC_offsets[0])); 
7789         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
7790     }
7791 #endif
7792     RExC_emit = ptr;
7793     return(ret);
7794 }
7795
7796 /*
7797 - reganode - emit a node with an argument
7798 */
7799 STATIC regnode *                        /* Location. */
7800 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
7801 {
7802     dVAR;
7803     register regnode *ptr;
7804     regnode * const ret = RExC_emit;
7805     GET_RE_DEBUG_FLAGS_DECL;
7806
7807     if (SIZE_ONLY) {
7808         SIZE_ALIGN(RExC_size);
7809         RExC_size += 2;
7810         /* 
7811            We can't do this:
7812            
7813            assert(2==regarglen[op]+1); 
7814         
7815            Anything larger than this has to allocate the extra amount.
7816            If we changed this to be:
7817            
7818            RExC_size += (1 + regarglen[op]);
7819            
7820            then it wouldn't matter. Its not clear what side effect
7821            might come from that so its not done so far.
7822            -- dmq
7823         */
7824         return(ret);
7825     }
7826 #ifdef DEBUGGING
7827     if (OP(RExC_emit) == 255)
7828         Perl_croak(aTHX_ "panic: reganode overwriting end of allocated program space");
7829 #endif 
7830     NODE_ALIGN_FILL(ret);
7831     ptr = ret;
7832     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
7833 #ifdef RE_TRACK_PATTERN_OFFSETS
7834     if (RExC_offsets) {         /* MJD */
7835         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
7836               "reganode",
7837               __LINE__,
7838               reg_name[op],
7839               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? 
7840               "Overwriting end of array!\n" : "OK",
7841               (UV)(RExC_emit - RExC_emit_start),
7842               (UV)(RExC_parse - RExC_start),
7843               (UV)RExC_offsets[0])); 
7844         Set_Cur_Node_Offset;
7845     }
7846 #endif            
7847     RExC_emit = ptr;
7848     return(ret);
7849 }
7850
7851 /*
7852 - reguni - emit (if appropriate) a Unicode character
7853 */
7854 STATIC STRLEN
7855 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
7856 {
7857     dVAR;
7858     return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
7859 }
7860
7861 /*
7862 - reginsert - insert an operator in front of already-emitted operand
7863 *
7864 * Means relocating the operand.
7865 */
7866 STATIC void
7867 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
7868 {
7869     dVAR;
7870     register regnode *src;
7871     register regnode *dst;
7872     register regnode *place;
7873     const int offset = regarglen[(U8)op];
7874     const int size = NODE_STEP_REGNODE + offset;
7875     GET_RE_DEBUG_FLAGS_DECL;
7876 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
7877     DEBUG_PARSE_FMT("inst"," - %s",reg_name[op]);
7878     if (SIZE_ONLY) {
7879         RExC_size += size;
7880         return;
7881     }
7882
7883     src = RExC_emit;
7884     RExC_emit += size;
7885     dst = RExC_emit;
7886     if (RExC_open_parens) {
7887         int paren;
7888         DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);
7889         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
7890             if ( RExC_open_parens[paren] >= opnd ) {
7891                 DEBUG_PARSE_FMT("open"," - %d",size);
7892                 RExC_open_parens[paren] += size;
7893             } else {
7894                 DEBUG_PARSE_FMT("open"," - %s","ok");
7895             }
7896             if ( RExC_close_parens[paren] >= opnd ) {
7897                 DEBUG_PARSE_FMT("close"," - %d",size);
7898                 RExC_close_parens[paren] += size;
7899             } else {
7900                 DEBUG_PARSE_FMT("close"," - %s","ok");
7901             }
7902         }
7903     }
7904
7905     while (src > opnd) {
7906         StructCopy(--src, --dst, regnode);
7907 #ifdef RE_TRACK_PATTERN_OFFSETS
7908         if (RExC_offsets) {     /* MJD 20010112 */
7909             MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
7910                   "reg_insert",
7911                   __LINE__,
7912                   reg_name[op],
7913                   (UV)(dst - RExC_emit_start) > RExC_offsets[0] 
7914                     ? "Overwriting end of array!\n" : "OK",
7915                   (UV)(src - RExC_emit_start),
7916                   (UV)(dst - RExC_emit_start),
7917                   (UV)RExC_offsets[0])); 
7918             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
7919             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
7920         }
7921 #endif
7922     }
7923     
7924
7925     place = opnd;               /* Op node, where operand used to be. */
7926 #ifdef RE_TRACK_PATTERN_OFFSETS
7927     if (RExC_offsets) {         /* MJD */
7928         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
7929               "reginsert",
7930               __LINE__,
7931               reg_name[op],
7932               (UV)(place - RExC_emit_start) > RExC_offsets[0] 
7933               ? "Overwriting end of array!\n" : "OK",
7934               (UV)(place - RExC_emit_start),
7935               (UV)(RExC_parse - RExC_start),
7936               (UV)RExC_offsets[0]));
7937         Set_Node_Offset(place, RExC_parse);
7938         Set_Node_Length(place, 1);
7939     }
7940 #endif    
7941     src = NEXTOPER(place);
7942     FILL_ADVANCE_NODE(place, op);
7943     Zero(src, offset, regnode);
7944 }
7945
7946 /*
7947 - regtail - set the next-pointer at the end of a node chain of p to val.
7948 - SEE ALSO: regtail_study
7949 */
7950 /* TODO: All three parms should be const */
7951 STATIC void
7952 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
7953 {
7954     dVAR;
7955     register regnode *scan;
7956     GET_RE_DEBUG_FLAGS_DECL;
7957 #ifndef DEBUGGING
7958     PERL_UNUSED_ARG(depth);
7959 #endif
7960
7961     if (SIZE_ONLY)
7962         return;
7963
7964     /* Find last node. */
7965     scan = p;
7966     for (;;) {
7967         regnode * const temp = regnext(scan);
7968         DEBUG_PARSE_r({
7969             SV * const mysv=sv_newmortal();
7970             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
7971             regprop(RExC_rx, mysv, scan);
7972             PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
7973                 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
7974                     (temp == NULL ? "->" : ""),
7975                     (temp == NULL ? reg_name[OP(val)] : "")
7976             );
7977         });
7978         if (temp == NULL)
7979             break;
7980         scan = temp;
7981     }
7982
7983     if (reg_off_by_arg[OP(scan)]) {
7984         ARG_SET(scan, val - scan);
7985     }
7986     else {
7987         NEXT_OFF(scan) = val - scan;
7988     }
7989 }
7990
7991 #ifdef DEBUGGING
7992 /*
7993 - regtail_study - set the next-pointer at the end of a node chain of p to val.
7994 - Look for optimizable sequences at the same time.
7995 - currently only looks for EXACT chains.
7996
7997 This is expermental code. The idea is to use this routine to perform 
7998 in place optimizations on branches and groups as they are constructed,
7999 with the long term intention of removing optimization from study_chunk so
8000 that it is purely analytical.
8001
8002 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
8003 to control which is which.
8004
8005 */
8006 /* TODO: All four parms should be const */
8007
8008 STATIC U8
8009 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
8010 {
8011     dVAR;
8012     register regnode *scan;
8013     U8 exact = PSEUDO;
8014 #ifdef EXPERIMENTAL_INPLACESCAN
8015     I32 min = 0;
8016 #endif
8017
8018     GET_RE_DEBUG_FLAGS_DECL;
8019
8020
8021     if (SIZE_ONLY)
8022         return exact;
8023
8024     /* Find last node. */
8025
8026     scan = p;
8027     for (;;) {
8028         regnode * const temp = regnext(scan);
8029 #ifdef EXPERIMENTAL_INPLACESCAN
8030         if (PL_regkind[OP(scan)] == EXACT)
8031             if (join_exact(pRExC_state,scan,&min,1,val,depth+1))
8032                 return EXACT;
8033 #endif
8034         if ( exact ) {
8035             switch (OP(scan)) {
8036                 case EXACT:
8037                 case EXACTF:
8038                 case EXACTFL:
8039                         if( exact == PSEUDO )
8040                             exact= OP(scan);
8041                         else if ( exact != OP(scan) )
8042                             exact= 0;
8043                 case NOTHING:
8044                     break;
8045                 default:
8046                     exact= 0;
8047             }
8048         }
8049         DEBUG_PARSE_r({
8050             SV * const mysv=sv_newmortal();
8051             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
8052             regprop(RExC_rx, mysv, scan);
8053             PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
8054                 SvPV_nolen_const(mysv),
8055                 REG_NODE_NUM(scan),
8056                 reg_name[exact]);
8057         });
8058         if (temp == NULL)
8059             break;
8060         scan = temp;
8061     }
8062     DEBUG_PARSE_r({
8063         SV * const mysv_val=sv_newmortal();
8064         DEBUG_PARSE_MSG("");
8065         regprop(RExC_rx, mysv_val, val);
8066         PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
8067                       SvPV_nolen_const(mysv_val),
8068                       (IV)REG_NODE_NUM(val),
8069                       (IV)(val - scan)
8070         );
8071     });
8072     if (reg_off_by_arg[OP(scan)]) {
8073         ARG_SET(scan, val - scan);
8074     }
8075     else {
8076         NEXT_OFF(scan) = val - scan;
8077     }
8078
8079     return exact;
8080 }
8081 #endif
8082
8083 /*
8084  - regcurly - a little FSA that accepts {\d+,?\d*}
8085  */
8086 STATIC I32
8087 S_regcurly(register const char *s)
8088 {
8089     if (*s++ != '{')
8090         return FALSE;
8091     if (!isDIGIT(*s))
8092         return FALSE;
8093     while (isDIGIT(*s))
8094         s++;
8095     if (*s == ',')
8096         s++;
8097     while (isDIGIT(*s))
8098         s++;
8099     if (*s != '}')
8100         return FALSE;
8101     return TRUE;
8102 }
8103
8104
8105 /*
8106  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
8107  */
8108 void
8109 Perl_regdump(pTHX_ const regexp *r)
8110 {
8111 #ifdef DEBUGGING
8112     dVAR;
8113     SV * const sv = sv_newmortal();
8114     SV *dsv= sv_newmortal();
8115     RXi_GET_DECL(r,ri);
8116
8117     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
8118
8119     /* Header fields of interest. */
8120     if (r->anchored_substr) {
8121         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr), 
8122             RE_SV_DUMPLEN(r->anchored_substr), 30);
8123         PerlIO_printf(Perl_debug_log,
8124                       "anchored %s%s at %"IVdf" ",
8125                       s, RE_SV_TAIL(r->anchored_substr),
8126                       (IV)r->anchored_offset);
8127     } else if (r->anchored_utf8) {
8128         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8), 
8129             RE_SV_DUMPLEN(r->anchored_utf8), 30);
8130         PerlIO_printf(Perl_debug_log,
8131                       "anchored utf8 %s%s at %"IVdf" ",
8132                       s, RE_SV_TAIL(r->anchored_utf8),
8133                       (IV)r->anchored_offset);
8134     }                 
8135     if (r->float_substr) {
8136         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr), 
8137             RE_SV_DUMPLEN(r->float_substr), 30);
8138         PerlIO_printf(Perl_debug_log,
8139                       "floating %s%s at %"IVdf"..%"UVuf" ",
8140                       s, RE_SV_TAIL(r->float_substr),
8141                       (IV)r->float_min_offset, (UV)r->float_max_offset);
8142     } else if (r->float_utf8) {
8143         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8), 
8144             RE_SV_DUMPLEN(r->float_utf8), 30);
8145         PerlIO_printf(Perl_debug_log,
8146                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
8147                       s, RE_SV_TAIL(r->float_utf8),
8148                       (IV)r->float_min_offset, (UV)r->float_max_offset);
8149     }
8150     if (r->check_substr || r->check_utf8)
8151         PerlIO_printf(Perl_debug_log,
8152                       (const char *)
8153                       (r->check_substr == r->float_substr
8154                        && r->check_utf8 == r->float_utf8
8155                        ? "(checking floating" : "(checking anchored"));
8156     if (r->extflags & RXf_NOSCAN)
8157         PerlIO_printf(Perl_debug_log, " noscan");
8158     if (r->extflags & RXf_CHECK_ALL)
8159         PerlIO_printf(Perl_debug_log, " isall");
8160     if (r->check_substr || r->check_utf8)
8161         PerlIO_printf(Perl_debug_log, ") ");
8162
8163     if (ri->regstclass) {
8164         regprop(r, sv, ri->regstclass);
8165         PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
8166     }
8167     if (r->extflags & RXf_ANCH) {
8168         PerlIO_printf(Perl_debug_log, "anchored");
8169         if (r->extflags & RXf_ANCH_BOL)
8170             PerlIO_printf(Perl_debug_log, "(BOL)");
8171         if (r->extflags & RXf_ANCH_MBOL)
8172             PerlIO_printf(Perl_debug_log, "(MBOL)");
8173         if (r->extflags & RXf_ANCH_SBOL)
8174             PerlIO_printf(Perl_debug_log, "(SBOL)");
8175         if (r->extflags & RXf_ANCH_GPOS)
8176             PerlIO_printf(Perl_debug_log, "(GPOS)");
8177         PerlIO_putc(Perl_debug_log, ' ');
8178     }
8179     if (r->extflags & RXf_GPOS_SEEN)
8180         PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
8181     if (r->intflags & PREGf_SKIP)
8182         PerlIO_printf(Perl_debug_log, "plus ");
8183     if (r->intflags & PREGf_IMPLICIT)
8184         PerlIO_printf(Perl_debug_log, "implicit ");
8185     PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
8186     if (r->extflags & RXf_EVAL_SEEN)
8187         PerlIO_printf(Perl_debug_log, "with eval ");
8188     PerlIO_printf(Perl_debug_log, "\n");
8189 #else
8190     PERL_UNUSED_CONTEXT;
8191     PERL_UNUSED_ARG(r);
8192 #endif  /* DEBUGGING */
8193 }
8194
8195 /*
8196 - regprop - printable representation of opcode
8197 */
8198 void
8199 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
8200 {
8201 #ifdef DEBUGGING
8202     dVAR;
8203     register int k;
8204     RXi_GET_DECL(prog,progi);
8205     GET_RE_DEBUG_FLAGS_DECL;
8206     
8207
8208     sv_setpvn(sv, "", 0);
8209
8210     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
8211         /* It would be nice to FAIL() here, but this may be called from
8212            regexec.c, and it would be hard to supply pRExC_state. */
8213         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
8214     sv_catpv(sv, reg_name[OP(o)]); /* Take off const! */
8215
8216     k = PL_regkind[OP(o)];
8217
8218     if (k == EXACT) {
8219         SV * const dsv = sv_2mortal(newSVpvs(""));
8220         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT) 
8221          * is a crude hack but it may be the best for now since 
8222          * we have no flag "this EXACTish node was UTF-8" 
8223          * --jhi */
8224         const char * const s = 
8225             pv_pretty(dsv, STRING(o), STR_LEN(o), 60, 
8226                 PL_colors[0], PL_colors[1],
8227                 PERL_PV_ESCAPE_UNI_DETECT |
8228                 PERL_PV_PRETTY_ELIPSES    |
8229                 PERL_PV_PRETTY_LTGT    
8230             ); 
8231         Perl_sv_catpvf(aTHX_ sv, " %s", s );
8232     } else if (k == TRIE) {
8233         /* print the details of the trie in dumpuntil instead, as
8234          * progi->data isn't available here */
8235         const char op = OP(o);
8236         const U32 n = ARG(o);
8237         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
8238                (reg_ac_data *)progi->data->data[n] :
8239                NULL;
8240         const reg_trie_data * const trie
8241             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
8242         
8243         Perl_sv_catpvf(aTHX_ sv, "-%s",reg_name[o->flags]);
8244         DEBUG_TRIE_COMPILE_r(
8245             Perl_sv_catpvf(aTHX_ sv,
8246                 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
8247                 (UV)trie->startstate,
8248                 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
8249                 (UV)trie->wordcount,
8250                 (UV)trie->minlen,
8251                 (UV)trie->maxlen,
8252                 (UV)TRIE_CHARCOUNT(trie),
8253                 (UV)trie->uniquecharcount
8254             )
8255         );
8256         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
8257             int i;
8258             int rangestart = -1;
8259             U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
8260             Perl_sv_catpvf(aTHX_ sv, "[");
8261             for (i = 0; i <= 256; i++) {
8262                 if (i < 256 && BITMAP_TEST(bitmap,i)) {
8263                     if (rangestart == -1)
8264                         rangestart = i;
8265                 } else if (rangestart != -1) {
8266                     if (i <= rangestart + 3)
8267                         for (; rangestart < i; rangestart++)
8268                             put_byte(sv, rangestart);
8269                     else {
8270                         put_byte(sv, rangestart);
8271                         sv_catpvs(sv, "-");
8272                         put_byte(sv, i - 1);
8273                     }
8274                     rangestart = -1;
8275                 }
8276             }
8277             Perl_sv_catpvf(aTHX_ sv, "]");
8278         } 
8279          
8280     } else if (k == CURLY) {
8281         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
8282             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
8283         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
8284     }
8285     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
8286         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
8287     else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
8288         Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
8289         if ( prog->paren_names ) {
8290             if ( k != REF || OP(o) < NREF) {        
8291                 AV *list= (AV *)progi->data->data[progi->name_list_idx];
8292                 SV **name= av_fetch(list, ARG(o), 0 );
8293                 if (name)
8294                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
8295             }       
8296             else {
8297                 AV *list= (AV *)progi->data->data[ progi->name_list_idx ];
8298                 SV *sv_dat=(SV*)progi->data->data[ ARG( o ) ];
8299                 I32 *nums=(I32*)SvPVX(sv_dat);
8300                 SV **name= av_fetch(list, nums[0], 0 );
8301                 I32 n;
8302                 if (name) {
8303                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
8304                         Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
8305                                     (n ? "," : ""), (IV)nums[n]);
8306                     }
8307                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
8308                 }
8309             }
8310         }            
8311     } else if (k == GOSUB) 
8312         Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
8313     else if (k == VERB) {
8314         if (!o->flags) 
8315             Perl_sv_catpvf(aTHX_ sv, ":%"SVf, 
8316                 SVfARG((SV*)progi->data->data[ ARG( o ) ]));
8317     } else if (k == LOGICAL)
8318         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);     /* 2: embedded, otherwise 1 */
8319     else if (k == ANYOF) {
8320         int i, rangestart = -1;
8321         const U8 flags = ANYOF_FLAGS(o);
8322
8323         /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
8324         static const char * const anyofs[] = {
8325             "\\w",
8326             "\\W",
8327             "\\s",
8328             "\\S",
8329             "\\d",
8330             "\\D",
8331             "[:alnum:]",
8332             "[:^alnum:]",
8333             "[:alpha:]",
8334             "[:^alpha:]",
8335             "[:ascii:]",
8336             "[:^ascii:]",
8337             "[:ctrl:]",
8338             "[:^ctrl:]",
8339             "[:graph:]",
8340             "[:^graph:]",
8341             "[:lower:]",
8342             "[:^lower:]",
8343             "[:print:]",
8344             "[:^print:]",
8345             "[:punct:]",
8346             "[:^punct:]",
8347             "[:upper:]",
8348             "[:^upper:]",
8349             "[:xdigit:]",
8350             "[:^xdigit:]",
8351             "[:space:]",
8352             "[:^space:]",
8353             "[:blank:]",
8354             "[:^blank:]"
8355         };
8356
8357         if (flags & ANYOF_LOCALE)
8358             sv_catpvs(sv, "{loc}");
8359         if (flags & ANYOF_FOLD)
8360             sv_catpvs(sv, "{i}");
8361         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
8362         if (flags & ANYOF_INVERT)
8363             sv_catpvs(sv, "^");
8364         for (i = 0; i <= 256; i++) {
8365             if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
8366                 if (rangestart == -1)
8367                     rangestart = i;
8368             } else if (rangestart != -1) {
8369                 if (i <= rangestart + 3)
8370                     for (; rangestart < i; rangestart++)
8371                         put_byte(sv, rangestart);
8372                 else {
8373                     put_byte(sv, rangestart);
8374                     sv_catpvs(sv, "-");
8375                     put_byte(sv, i - 1);
8376                 }
8377                 rangestart = -1;
8378             }
8379         }
8380
8381         if (o->flags & ANYOF_CLASS)
8382             for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
8383                 if (ANYOF_CLASS_TEST(o,i))
8384                     sv_catpv(sv, anyofs[i]);
8385
8386         if (flags & ANYOF_UNICODE)
8387             sv_catpvs(sv, "{unicode}");
8388         else if (flags & ANYOF_UNICODE_ALL)
8389             sv_catpvs(sv, "{unicode_all}");
8390
8391         {
8392             SV *lv;
8393             SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
8394         
8395             if (lv) {
8396                 if (sw) {
8397                     U8 s[UTF8_MAXBYTES_CASE+1];
8398                 
8399                     for (i = 0; i <= 256; i++) { /* just the first 256 */
8400                         uvchr_to_utf8(s, i);
8401                         
8402                         if (i < 256 && swash_fetch(sw, s, TRUE)) {
8403                             if (rangestart == -1)
8404                                 rangestart = i;
8405                         } else if (rangestart != -1) {
8406                             if (i <= rangestart + 3)
8407                                 for (; rangestart < i; rangestart++) {
8408                                     const U8 * const e = uvchr_to_utf8(s,rangestart);
8409                                     U8 *p;
8410                                     for(p = s; p < e; p++)
8411                                         put_byte(sv, *p);
8412                                 }
8413                             else {
8414                                 const U8 *e = uvchr_to_utf8(s,rangestart);
8415                                 U8 *p;
8416                                 for (p = s; p < e; p++)
8417                                     put_byte(sv, *p);
8418                                 sv_catpvs(sv, "-");
8419                                 e = uvchr_to_utf8(s, i-1);
8420                                 for (p = s; p < e; p++)
8421                                     put_byte(sv, *p);
8422                                 }
8423                                 rangestart = -1;
8424                             }
8425                         }
8426                         
8427                     sv_catpvs(sv, "..."); /* et cetera */
8428                 }
8429
8430                 {
8431                     char *s = savesvpv(lv);
8432                     char * const origs = s;
8433                 
8434                     while (*s && *s != '\n')
8435                         s++;
8436                 
8437                     if (*s == '\n') {
8438                         const char * const t = ++s;
8439                         
8440                         while (*s) {
8441                             if (*s == '\n')
8442                                 *s = ' ';
8443                             s++;
8444                         }
8445                         if (s[-1] == ' ')
8446                             s[-1] = 0;
8447                         
8448                         sv_catpv(sv, t);
8449                     }
8450                 
8451                     Safefree(origs);
8452                 }
8453             }
8454         }
8455
8456         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
8457     }
8458     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
8459         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
8460 #else
8461     PERL_UNUSED_CONTEXT;
8462     PERL_UNUSED_ARG(sv);
8463     PERL_UNUSED_ARG(o);
8464     PERL_UNUSED_ARG(prog);
8465 #endif  /* DEBUGGING */
8466 }
8467
8468 SV *
8469 Perl_re_intuit_string(pTHX_ regexp *prog)
8470 {                               /* Assume that RE_INTUIT is set */
8471     dVAR;
8472     GET_RE_DEBUG_FLAGS_DECL;
8473     PERL_UNUSED_CONTEXT;
8474
8475     DEBUG_COMPILE_r(
8476         {
8477             const char * const s = SvPV_nolen_const(prog->check_substr
8478                       ? prog->check_substr : prog->check_utf8);
8479
8480             if (!PL_colorset) reginitcolors();
8481             PerlIO_printf(Perl_debug_log,
8482                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
8483                       PL_colors[4],
8484                       prog->check_substr ? "" : "utf8 ",
8485                       PL_colors[5],PL_colors[0],
8486                       s,
8487                       PL_colors[1],
8488                       (strlen(s) > 60 ? "..." : ""));
8489         } );
8490
8491     return prog->check_substr ? prog->check_substr : prog->check_utf8;
8492 }
8493
8494 /* 
8495    pregfree() 
8496    
8497    handles refcounting and freeing the perl core regexp structure. When 
8498    it is necessary to actually free the structure the first thing it 
8499    does is call the 'free' method of the regexp_engine associated to to 
8500    the regexp, allowing the handling of the void *pprivate; member 
8501    first. (This routine is not overridable by extensions, which is why 
8502    the extensions free is called first.)
8503    
8504    See regdupe and regdupe_internal if you change anything here. 
8505 */
8506 #ifndef PERL_IN_XSUB_RE
8507 void
8508 Perl_pregfree(pTHX_ struct regexp *r)
8509 {
8510     dVAR;
8511     GET_RE_DEBUG_FLAGS_DECL;
8512
8513     if (!r || (--r->refcnt > 0))
8514         return;
8515         
8516     CALLREGFREE_PVT(r); /* free the private data */
8517     
8518     /* gcov results gave these as non-null 100% of the time, so there's no
8519        optimisation in checking them before calling Safefree  */
8520     Safefree(r->precomp);
8521     RX_MATCH_COPY_FREE(r);
8522 #ifdef PERL_OLD_COPY_ON_WRITE
8523     if (r->saved_copy)
8524         SvREFCNT_dec(r->saved_copy);
8525 #endif
8526     if (r->substrs) {
8527         if (r->anchored_substr)
8528             SvREFCNT_dec(r->anchored_substr);
8529         if (r->anchored_utf8)
8530             SvREFCNT_dec(r->anchored_utf8);
8531         if (r->float_substr)
8532             SvREFCNT_dec(r->float_substr);
8533         if (r->float_utf8)
8534             SvREFCNT_dec(r->float_utf8);
8535         Safefree(r->substrs);
8536     }
8537     if (r->paren_names)
8538             SvREFCNT_dec(r->paren_names);
8539     
8540     Safefree(r->startp);
8541     Safefree(r->endp);
8542     Safefree(r);
8543 }
8544 #endif
8545
8546 /* regfree_internal() 
8547
8548    Free the private data in a regexp. This is overloadable by 
8549    extensions. Perl takes care of the regexp structure in pregfree(), 
8550    this covers the *pprivate pointer which technically perldoesnt 
8551    know about, however of course we have to handle the 
8552    regexp_internal structure when no extension is in use. 
8553    
8554    Note this is called before freeing anything in the regexp 
8555    structure. 
8556  */
8557  
8558 void
8559 Perl_regfree_internal(pTHX_ struct regexp *r)
8560 {
8561     dVAR;
8562     RXi_GET_DECL(r,ri);
8563     GET_RE_DEBUG_FLAGS_DECL;
8564     
8565     DEBUG_COMPILE_r({
8566         if (!PL_colorset)
8567             reginitcolors();
8568         {
8569             SV *dsv= sv_newmortal();
8570             RE_PV_QUOTED_DECL(s, (r->extflags & RXf_UTF8),
8571                 dsv, r->precomp, r->prelen, 60);
8572             PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n", 
8573                 PL_colors[4],PL_colors[5],s);
8574         }
8575     });
8576 #ifdef RE_TRACK_PATTERN_OFFSETS
8577     if (ri->u.offsets)
8578         Safefree(ri->u.offsets);             /* 20010421 MJD */
8579 #endif
8580     if (ri->data) {
8581         int n = ri->data->count;
8582         PAD* new_comppad = NULL;
8583         PAD* old_comppad;
8584         PADOFFSET refcnt;
8585
8586         while (--n >= 0) {
8587           /* If you add a ->what type here, update the comment in regcomp.h */
8588             switch (ri->data->what[n]) {
8589             case 's':
8590             case 'S':
8591             case 'u':
8592                 SvREFCNT_dec((SV*)ri->data->data[n]);
8593                 break;
8594             case 'f':
8595                 Safefree(ri->data->data[n]);
8596                 break;
8597             case 'p':
8598                 new_comppad = (AV*)ri->data->data[n];
8599                 break;
8600             case 'o':
8601                 if (new_comppad == NULL)
8602                     Perl_croak(aTHX_ "panic: pregfree comppad");
8603                 PAD_SAVE_LOCAL(old_comppad,
8604                     /* Watch out for global destruction's random ordering. */
8605                     (SvTYPE(new_comppad) == SVt_PVAV) ? new_comppad : NULL
8606                 );
8607                 OP_REFCNT_LOCK;
8608                 refcnt = OpREFCNT_dec((OP_4tree*)ri->data->data[n]);
8609                 OP_REFCNT_UNLOCK;
8610                 if (!refcnt)
8611                     op_free((OP_4tree*)ri->data->data[n]);
8612
8613                 PAD_RESTORE_LOCAL(old_comppad);
8614                 SvREFCNT_dec((SV*)new_comppad);
8615                 new_comppad = NULL;
8616                 break;
8617             case 'n':
8618                 break;
8619             case 'T':           
8620                 { /* Aho Corasick add-on structure for a trie node.
8621                      Used in stclass optimization only */
8622                     U32 refcount;
8623                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
8624                     OP_REFCNT_LOCK;
8625                     refcount = --aho->refcount;
8626                     OP_REFCNT_UNLOCK;
8627                     if ( !refcount ) {
8628                         PerlMemShared_free(aho->states);
8629                         PerlMemShared_free(aho->fail);
8630                          /* do this last!!!! */
8631                         PerlMemShared_free(ri->data->data[n]);
8632                         PerlMemShared_free(ri->regstclass);
8633                     }
8634                 }
8635                 break;
8636             case 't':
8637                 {
8638                     /* trie structure. */
8639                     U32 refcount;
8640                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
8641                     OP_REFCNT_LOCK;
8642                     refcount = --trie->refcount;
8643                     OP_REFCNT_UNLOCK;
8644                     if ( !refcount ) {
8645                         PerlMemShared_free(trie->charmap);
8646                         PerlMemShared_free(trie->states);
8647                         PerlMemShared_free(trie->trans);
8648                         if (trie->bitmap)
8649                             PerlMemShared_free(trie->bitmap);
8650                         if (trie->wordlen)
8651                             PerlMemShared_free(trie->wordlen);
8652                         if (trie->jump)
8653                             PerlMemShared_free(trie->jump);
8654                         if (trie->nextword)
8655                             PerlMemShared_free(trie->nextword);
8656                         /* do this last!!!! */
8657                         PerlMemShared_free(ri->data->data[n]);
8658                     }
8659                 }
8660                 break;
8661             default:
8662                 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
8663             }
8664         }
8665         Safefree(ri->data->what);
8666         Safefree(ri->data);
8667     }
8668     if (ri->swap) {
8669         Safefree(ri->swap->startp);
8670         Safefree(ri->swap->endp);
8671         Safefree(ri->swap);
8672     }
8673     Safefree(ri);
8674 }
8675
8676 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
8677 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8678 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8679 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
8680
8681 /* 
8682    regdupe - duplicate a regexp. 
8683    
8684    This routine is called by sv.c's re_dup and is expected to clone a 
8685    given regexp structure. It is a no-op when not under USE_ITHREADS. 
8686    (Originally this *was* re_dup() for change history see sv.c)
8687    
8688    After all of the core data stored in struct regexp is duplicated
8689    the regexp_engine.dupe method is used to copy any private data
8690    stored in the *pprivate pointer. This allows extensions to handle
8691    any duplication it needs to do.
8692
8693    See pregfree() and regfree_internal() if you change anything here. 
8694 */
8695 #if defined(USE_ITHREADS)
8696 #ifndef PERL_IN_XSUB_RE
8697 regexp *
8698 Perl_re_dup(pTHX_ const regexp *r, CLONE_PARAMS *param)
8699 {
8700     dVAR;
8701     regexp *ret;
8702     int i, npar;
8703     struct reg_substr_datum *s;
8704
8705     if (!r)
8706         return (REGEXP *)NULL;
8707
8708     if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
8709         return ret;
8710
8711     
8712     npar = r->nparens+1;
8713     Newxz(ret, 1, regexp);
8714     Newx(ret->startp, npar, I32);
8715     Copy(r->startp, ret->startp, npar, I32);
8716     Newx(ret->endp, npar, I32);
8717     Copy(r->endp, ret->endp, npar, I32);
8718
8719     if (r->substrs) {
8720         Newx(ret->substrs, 1, struct reg_substr_data);
8721         for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
8722             s->min_offset = r->substrs->data[i].min_offset;
8723             s->max_offset = r->substrs->data[i].max_offset;
8724             s->end_shift  = r->substrs->data[i].end_shift;
8725             s->substr     = sv_dup_inc(r->substrs->data[i].substr, param);
8726             s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
8727         }
8728     } else 
8729         ret->substrs = NULL;    
8730
8731     ret->precomp        = SAVEPVN(r->precomp, r->prelen);
8732     ret->refcnt         = r->refcnt;
8733     ret->minlen         = r->minlen;
8734     ret->minlenret      = r->minlenret;
8735     ret->prelen         = r->prelen;
8736     ret->nparens        = r->nparens;
8737     ret->lastparen      = r->lastparen;
8738     ret->lastcloseparen = r->lastcloseparen;
8739     ret->intflags       = r->intflags;
8740     ret->extflags       = r->extflags;
8741
8742     ret->sublen         = r->sublen;
8743
8744     ret->engine         = r->engine;
8745     
8746     ret->paren_names    = hv_dup_inc(r->paren_names, param);
8747
8748     if (RX_MATCH_COPIED(ret))
8749         ret->subbeg  = SAVEPVN(r->subbeg, r->sublen);
8750     else
8751         ret->subbeg = NULL;
8752 #ifdef PERL_OLD_COPY_ON_WRITE
8753     ret->saved_copy = NULL;
8754 #endif
8755     
8756     ret->pprivate = r->pprivate;
8757     if (ret->pprivate) 
8758         RXi_SET(ret,CALLREGDUPE_PVT(ret,param));
8759     
8760     ptr_table_store(PL_ptr_table, r, ret);
8761     return ret;
8762 }
8763 #endif /* PERL_IN_XSUB_RE */
8764
8765 /*
8766    regdupe_internal()
8767    
8768    This is the internal complement to regdupe() which is used to copy
8769    the structure pointed to by the *pprivate pointer in the regexp.
8770    This is the core version of the extension overridable cloning hook.
8771    The regexp structure being duplicated will be copied by perl prior
8772    to this and will be provided as the regexp *r argument, however 
8773    with the /old/ structures pprivate pointer value. Thus this routine
8774    may override any copying normally done by perl.
8775    
8776    It returns a pointer to the new regexp_internal structure.
8777 */
8778
8779 void *
8780 Perl_regdupe_internal(pTHX_ const regexp *r, CLONE_PARAMS *param)
8781 {
8782     dVAR;
8783     regexp_internal *reti;
8784     int len, npar;
8785     RXi_GET_DECL(r,ri);
8786     
8787     npar = r->nparens+1;
8788     len = ProgLen(ri);
8789     
8790     Newxc(reti, sizeof(regexp_internal) + (len+1)*sizeof(regnode), char, regexp_internal);
8791     Copy(ri->program, reti->program, len+1, regnode);
8792     
8793     if(ri->swap) {
8794         Newx(reti->swap, 1, regexp_paren_ofs);
8795         /* no need to copy these */
8796         Newx(reti->swap->startp, npar, I32);
8797         Newx(reti->swap->endp, npar, I32);
8798     } else {
8799         reti->swap = NULL;
8800     }
8801
8802
8803     reti->regstclass = NULL;
8804     if (ri->data) {
8805         struct reg_data *d;
8806         const int count = ri->data->count;
8807         int i;
8808
8809         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
8810                 char, struct reg_data);
8811         Newx(d->what, count, U8);
8812
8813         d->count = count;
8814         for (i = 0; i < count; i++) {
8815             d->what[i] = ri->data->what[i];
8816             switch (d->what[i]) {
8817                 /* legal options are one of: sSfpontTu
8818                    see also regcomp.h and pregfree() */
8819             case 's':
8820             case 'S':
8821             case 'p': /* actually an AV, but the dup function is identical.  */
8822             case 'u': /* actually an HV, but the dup function is identical.  */
8823                 d->data[i] = sv_dup_inc((SV *)ri->data->data[i], param);
8824                 break;
8825             case 'f':
8826                 /* This is cheating. */
8827                 Newx(d->data[i], 1, struct regnode_charclass_class);
8828                 StructCopy(ri->data->data[i], d->data[i],
8829                             struct regnode_charclass_class);
8830                 reti->regstclass = (regnode*)d->data[i];
8831                 break;
8832             case 'o':
8833                 /* Compiled op trees are readonly and in shared memory,
8834                    and can thus be shared without duplication. */
8835                 OP_REFCNT_LOCK;
8836                 d->data[i] = (void*)OpREFCNT_inc((OP*)ri->data->data[i]);
8837                 OP_REFCNT_UNLOCK;
8838                 break;
8839             case 'T':
8840                 /* Trie stclasses are readonly and can thus be shared
8841                  * without duplication. We free the stclass in pregfree
8842                  * when the corresponding reg_ac_data struct is freed.
8843                  */
8844                 reti->regstclass= ri->regstclass;
8845                 /* Fall through */
8846             case 't':
8847                 OP_REFCNT_LOCK;
8848                 ((reg_trie_data*)ri->data->data[i])->refcount++;
8849                 OP_REFCNT_UNLOCK;
8850                 /* Fall through */
8851             case 'n':
8852                 d->data[i] = ri->data->data[i];
8853                 break;
8854             default:
8855                 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
8856             }
8857         }
8858
8859         reti->data = d;
8860     }
8861     else
8862         reti->data = NULL;
8863
8864     reti->name_list_idx = ri->name_list_idx;
8865
8866 #ifdef RE_TRACK_PATTERN_OFFSETS
8867     if (ri->u.offsets) {
8868         Newx(reti->u.offsets, 2*len+1, U32);
8869         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
8870     }
8871 #else
8872     SetProgLen(reti,len);
8873 #endif
8874
8875     return (void*)reti;
8876 }
8877
8878 #endif    /* USE_ITHREADS */
8879
8880 /* 
8881    reg_stringify() 
8882    
8883    converts a regexp embedded in a MAGIC struct to its stringified form, 
8884    caching the converted form in the struct and returns the cached 
8885    string. 
8886
8887    If lp is nonnull then it is used to return the length of the 
8888    resulting string
8889    
8890    If flags is nonnull and the returned string contains UTF8 then 
8891    (*flags & 1) will be true.
8892    
8893    If haseval is nonnull then it is used to return whether the pattern 
8894    contains evals.
8895    
8896    Normally called via macro: 
8897    
8898         CALLREG_STRINGIFY(mg,&len,&utf8);
8899         
8900    And internally with
8901    
8902         CALLREG_AS_STR(mg,&lp,&flags,&haseval)        
8903     
8904    See sv_2pv_flags() in sv.c for an example of internal usage.
8905     
8906  */
8907 #ifndef PERL_IN_XSUB_RE
8908 char *
8909 Perl_reg_stringify(pTHX_ MAGIC *mg, STRLEN *lp, U32 *flags, I32 *haseval ) {
8910     dVAR;
8911     const regexp * const re = (regexp *)mg->mg_obj;
8912
8913     if (!mg->mg_ptr) {
8914         const char *fptr = STD_PAT_MODS;        /*"msix"*/
8915         char reflags[7];
8916         char ch;
8917         bool hask = ((re->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
8918         bool hasm = ((re->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD);
8919         U16 reganch = (U16)((re->extflags & RXf_PMf_STD_PMMOD) >> 12);
8920         bool need_newline = 0;
8921         int left = 0;
8922         int right = 4 + hask;
8923         if (hask) 
8924             reflags[left++] = KEEPCOPY_PAT_MOD; /*'k'*/
8925         while((ch = *fptr++)) {
8926             if(reganch & 1) {
8927                 reflags[left++] = ch;
8928             }
8929             else {
8930                 reflags[right--] = ch;
8931             }
8932             reganch >>= 1;
8933         }
8934         if(hasm) {
8935             reflags[left] = '-';
8936             left = 5 + hask;
8937         }
8938         /* printf("[%*.7s]\n",left,reflags); */
8939         mg->mg_len = re->prelen + 4 + left;
8940         /*
8941          * If /x was used, we have to worry about a regex ending with a
8942          * comment later being embedded within another regex. If so, we don't
8943          * want this regex's "commentization" to leak out to the right part of
8944          * the enclosing regex, we must cap it with a newline.
8945          *
8946          * So, if /x was used, we scan backwards from the end of the regex. If
8947          * we find a '#' before we find a newline, we need to add a newline
8948          * ourself. If we find a '\n' first (or if we don't find '#' or '\n'),
8949          * we don't need to add anything.  -jfriedl
8950          */
8951         if (PMf_EXTENDED & re->extflags) {
8952             const char *endptr = re->precomp + re->prelen;
8953             while (endptr >= re->precomp) {
8954                 const char c = *(endptr--);
8955                 if (c == '\n')
8956                     break; /* don't need another */
8957                 if (c == '#') {
8958                     /* we end while in a comment, so we need a newline */
8959                     mg->mg_len++; /* save space for it */
8960                     need_newline = 1; /* note to add it */
8961                     break;
8962                 }
8963             }
8964         }
8965
8966         Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
8967         mg->mg_ptr[0] = '(';
8968         mg->mg_ptr[1] = '?';
8969         Copy(reflags, mg->mg_ptr+2, left, char);
8970         *(mg->mg_ptr+left+2) = ':';
8971         Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
8972         if (need_newline)
8973             mg->mg_ptr[mg->mg_len - 2] = '\n';
8974         mg->mg_ptr[mg->mg_len - 1] = ')';
8975         mg->mg_ptr[mg->mg_len] = 0;
8976     }
8977     if (haseval) 
8978         *haseval = re->seen_evals;
8979     if (flags)    
8980         *flags = ((re->extflags & RXf_UTF8) ? 1 : 0);
8981     
8982     if (lp)
8983         *lp = mg->mg_len;
8984     return mg->mg_ptr;
8985 }
8986
8987 /*
8988  - regnext - dig the "next" pointer out of a node
8989  */
8990 regnode *
8991 Perl_regnext(pTHX_ register regnode *p)
8992 {
8993     dVAR;
8994     register I32 offset;
8995
8996     if (!p)
8997         return(NULL);
8998
8999     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
9000     if (offset == 0)
9001         return(NULL);
9002
9003     return(p+offset);
9004 }
9005 #endif
9006
9007 STATIC void     
9008 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
9009 {
9010     va_list args;
9011     STRLEN l1 = strlen(pat1);
9012     STRLEN l2 = strlen(pat2);
9013     char buf[512];
9014     SV *msv;
9015     const char *message;
9016
9017     if (l1 > 510)
9018         l1 = 510;
9019     if (l1 + l2 > 510)
9020         l2 = 510 - l1;
9021     Copy(pat1, buf, l1 , char);
9022     Copy(pat2, buf + l1, l2 , char);
9023     buf[l1 + l2] = '\n';
9024     buf[l1 + l2 + 1] = '\0';
9025 #ifdef I_STDARG
9026     /* ANSI variant takes additional second argument */
9027     va_start(args, pat2);
9028 #else
9029     va_start(args);
9030 #endif
9031     msv = vmess(buf, &args);
9032     va_end(args);
9033     message = SvPV_const(msv,l1);
9034     if (l1 > 512)
9035         l1 = 512;
9036     Copy(message, buf, l1 , char);
9037     buf[l1-1] = '\0';                   /* Overwrite \n */
9038     Perl_croak(aTHX_ "%s", buf);
9039 }
9040
9041 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
9042
9043 #ifndef PERL_IN_XSUB_RE
9044 void
9045 Perl_save_re_context(pTHX)
9046 {
9047     dVAR;
9048
9049     struct re_save_state *state;
9050
9051     SAVEVPTR(PL_curcop);
9052     SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
9053
9054     state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
9055     PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
9056     SSPUSHINT(SAVEt_RE_STATE);
9057
9058     Copy(&PL_reg_state, state, 1, struct re_save_state);
9059
9060     PL_reg_start_tmp = 0;
9061     PL_reg_start_tmpl = 0;
9062     PL_reg_oldsaved = NULL;
9063     PL_reg_oldsavedlen = 0;
9064     PL_reg_maxiter = 0;
9065     PL_reg_leftiter = 0;
9066     PL_reg_poscache = NULL;
9067     PL_reg_poscache_size = 0;
9068 #ifdef PERL_OLD_COPY_ON_WRITE
9069     PL_nrs = NULL;
9070 #endif
9071
9072     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
9073     if (PL_curpm) {
9074         const REGEXP * const rx = PM_GETRE(PL_curpm);
9075         if (rx) {
9076             U32 i;
9077             for (i = 1; i <= rx->nparens; i++) {
9078                 char digits[TYPE_CHARS(long)];
9079                 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
9080                 GV *const *const gvp
9081                     = (GV**)hv_fetch(PL_defstash, digits, len, 0);
9082
9083                 if (gvp) {
9084                     GV * const gv = *gvp;
9085                     if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
9086                         save_scalar(gv);
9087                 }
9088             }
9089         }
9090     }
9091 }
9092 #endif
9093
9094 static void
9095 clear_re(pTHX_ void *r)
9096 {
9097     dVAR;
9098     ReREFCNT_dec((regexp *)r);
9099 }
9100
9101 #ifdef DEBUGGING
9102
9103 STATIC void
9104 S_put_byte(pTHX_ SV *sv, int c)
9105 {
9106     if (isCNTRL(c) || c == 255 || !isPRINT(c))
9107         Perl_sv_catpvf(aTHX_ sv, "\\%o", c);
9108     else if (c == '-' || c == ']' || c == '\\' || c == '^')
9109         Perl_sv_catpvf(aTHX_ sv, "\\%c", c);
9110     else
9111         Perl_sv_catpvf(aTHX_ sv, "%c", c);
9112 }
9113
9114
9115 #define CLEAR_OPTSTART \
9116     if (optstart) STMT_START { \
9117             DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
9118             optstart=NULL; \
9119     } STMT_END
9120
9121 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
9122
9123 STATIC const regnode *
9124 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
9125             const regnode *last, const regnode *plast, 
9126             SV* sv, I32 indent, U32 depth)
9127 {
9128     dVAR;
9129     register U8 op = PSEUDO;    /* Arbitrary non-END op. */
9130     register const regnode *next;
9131     const regnode *optstart= NULL;
9132     
9133     RXi_GET_DECL(r,ri);
9134     GET_RE_DEBUG_FLAGS_DECL;
9135     
9136 #ifdef DEBUG_DUMPUNTIL
9137     PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
9138         last ? last-start : 0,plast ? plast-start : 0);
9139 #endif
9140             
9141     if (plast && plast < last) 
9142         last= plast;
9143
9144     while (PL_regkind[op] != END && (!last || node < last)) {
9145         /* While that wasn't END last time... */
9146         NODE_ALIGN(node);
9147         op = OP(node);
9148         if (op == CLOSE || op == WHILEM)
9149             indent--;
9150         next = regnext((regnode *)node);
9151
9152         /* Where, what. */
9153         if (OP(node) == OPTIMIZED) {
9154             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
9155                 optstart = node;
9156             else
9157                 goto after_print;
9158         } else
9159             CLEAR_OPTSTART;
9160         
9161         regprop(r, sv, node);
9162         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
9163                       (int)(2*indent + 1), "", SvPVX_const(sv));
9164         
9165         if (OP(node) != OPTIMIZED) {                  
9166             if (next == NULL)           /* Next ptr. */
9167                 PerlIO_printf(Perl_debug_log, " (0)");
9168             else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
9169                 PerlIO_printf(Perl_debug_log, " (FAIL)");
9170             else 
9171                 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
9172             (void)PerlIO_putc(Perl_debug_log, '\n'); 
9173         }
9174         
9175       after_print:
9176         if (PL_regkind[(U8)op] == BRANCHJ) {
9177             assert(next);
9178             {
9179                 register const regnode *nnode = (OP(next) == LONGJMP
9180                                              ? regnext((regnode *)next)
9181                                              : next);
9182                 if (last && nnode > last)
9183                     nnode = last;
9184                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
9185             }
9186         }
9187         else if (PL_regkind[(U8)op] == BRANCH) {
9188             assert(next);
9189             DUMPUNTIL(NEXTOPER(node), next);
9190         }
9191         else if ( PL_regkind[(U8)op]  == TRIE ) {
9192             const regnode *this_trie = node;
9193             const char op = OP(node);
9194             const U32 n = ARG(node);
9195             const reg_ac_data * const ac = op>=AHOCORASICK ?
9196                (reg_ac_data *)ri->data->data[n] :
9197                NULL;
9198             const reg_trie_data * const trie =
9199                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
9200 #ifdef DEBUGGING
9201             AV *const trie_words = (AV *) ri->data->data[n + TRIE_WORDS_OFFSET];
9202 #endif
9203             const regnode *nextbranch= NULL;
9204             I32 word_idx;
9205             sv_setpvn(sv, "", 0);
9206             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
9207                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
9208                 
9209                 PerlIO_printf(Perl_debug_log, "%*s%s ",
9210                    (int)(2*(indent+3)), "",
9211                     elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
9212                             PL_colors[0], PL_colors[1],
9213                             (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
9214                             PERL_PV_PRETTY_ELIPSES    |
9215                             PERL_PV_PRETTY_LTGT
9216                             )
9217                             : "???"
9218                 );
9219                 if (trie->jump) {
9220                     U16 dist= trie->jump[word_idx+1];
9221                     PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
9222                                   (UV)((dist ? this_trie + dist : next) - start));
9223                     if (dist) {
9224                         if (!nextbranch)
9225                             nextbranch= this_trie + trie->jump[0];    
9226                         DUMPUNTIL(this_trie + dist, nextbranch);
9227                     }
9228                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
9229                         nextbranch= regnext((regnode *)nextbranch);
9230                 } else {
9231                     PerlIO_printf(Perl_debug_log, "\n");
9232                 }
9233             }
9234             if (last && next > last)
9235                 node= last;
9236             else
9237                 node= next;
9238         }
9239         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
9240             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
9241                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
9242         }
9243         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
9244             assert(next);
9245             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
9246         }
9247         else if ( op == PLUS || op == STAR) {
9248             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
9249         }
9250         else if (op == ANYOF) {
9251             /* arglen 1 + class block */
9252             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_LARGE)
9253                     ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
9254             node = NEXTOPER(node);
9255         }
9256         else if (PL_regkind[(U8)op] == EXACT) {
9257             /* Literal string, where present. */
9258             node += NODE_SZ_STR(node) - 1;
9259             node = NEXTOPER(node);
9260         }
9261         else {
9262             node = NEXTOPER(node);
9263             node += regarglen[(U8)op];
9264         }
9265         if (op == CURLYX || op == OPEN)
9266             indent++;
9267     }
9268     CLEAR_OPTSTART;
9269 #ifdef DEBUG_DUMPUNTIL    
9270     PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
9271 #endif
9272     return node;
9273 }
9274
9275 #endif  /* DEBUGGING */
9276
9277 /*
9278  * Local variables:
9279  * c-indentation-style: bsd
9280  * c-basic-offset: 4
9281  * indent-tabs-mode: t
9282  * End:
9283  *
9284  * ex: set ts=8 sts=4 sw=4 noet:
9285  */