This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Disable positive lookaround optimisations
[perl5.git] / regcomp.c
1 /*    regcomp.c
2  */
3
4 /*
5  * "A fair jaw-cracker dwarf-language must be."  --Samwise Gamgee
6  */
7
8 /* This file contains functions for compiling a regular expression.  See
9  * also regexec.c which funnily enough, contains functions for executing
10  * a regular expression.
11  *
12  * This file is also copied at build time to ext/re/re_comp.c, where
13  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
14  * This causes the main functions to be compiled under new names and with
15  * debugging support added, which makes "use re 'debug'" work.
16  */
17
18 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
19  * confused with the original package (see point 3 below).  Thanks, Henry!
20  */
21
22 /* Additional note: this code is very heavily munged from Henry's version
23  * in places.  In some spots I've traded clarity for efficiency, so don't
24  * blame Henry for some of the lack of readability.
25  */
26
27 /* The names of the functions have been changed from regcomp and
28  * regexec to  pregcomp and pregexec in order to avoid conflicts
29  * with the POSIX routines of the same names.
30 */
31
32 #ifdef PERL_EXT_RE_BUILD
33 #include "re_top.h"
34 #endif
35
36 /*
37  * pregcomp and pregexec -- regsub and regerror are not used in perl
38  *
39  *      Copyright (c) 1986 by University of Toronto.
40  *      Written by Henry Spencer.  Not derived from licensed software.
41  *
42  *      Permission is granted to anyone to use this software for any
43  *      purpose on any computer system, and to redistribute it freely,
44  *      subject to the following restrictions:
45  *
46  *      1. The author is not responsible for the consequences of use of
47  *              this software, no matter how awful, even if they arise
48  *              from defects in it.
49  *
50  *      2. The origin of this software must not be misrepresented, either
51  *              by explicit claim or by omission.
52  *
53  *      3. Altered versions must be plainly marked as such, and must not
54  *              be misrepresented as being the original software.
55  *
56  *
57  ****    Alterations to Henry's code are...
58  ****
59  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
60  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, 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->lastparen) >= nums[i] &&
4673                         rx->endp[nums[i]] != -1) 
4674                     {
4675                         ret = reg_numbered_buff_get(nums[i],rx,NULL,0);
4676                         if (!retarray) 
4677                             return ret;
4678                     } else {
4679                         ret = newSVsv(&PL_sv_undef);
4680                     }
4681                     if (retarray) {
4682                         SvREFCNT_inc(ret); 
4683                         av_push(retarray, ret);
4684                     }
4685                 }
4686                 if (retarray)
4687                     return (SV*)retarray;
4688             }
4689         }
4690     }
4691     return NULL;
4692 }
4693
4694 SV*
4695 Perl_reg_numbered_buff_get(pTHX_ I32 paren, const REGEXP * const rx, SV* usesv, U32 flags)
4696 {
4697     char *s = NULL;
4698     I32 i = 0;
4699     I32 s1, t1;
4700     SV *sv = usesv ? usesv : newSVpvs("");
4701     PERL_UNUSED_ARG(flags);
4702         
4703     if (!rx->subbeg) {
4704         sv_setsv(sv,&PL_sv_undef);
4705         return sv;
4706     } 
4707     else               
4708     if (paren == -2 && rx->startp[0] != -1) {
4709         /* $` */
4710         i = rx->startp[0];
4711         s = rx->subbeg;
4712     }
4713     else 
4714     if (paren == -1 && rx->endp[0] != -1) {
4715         /* $' */
4716         s = rx->subbeg + rx->endp[0];
4717         i = rx->sublen - rx->endp[0];
4718     } 
4719     else
4720     if ( 0 <= paren && paren <= (I32)rx->nparens &&
4721         (s1 = rx->startp[paren]) != -1 &&
4722         (t1 = rx->endp[paren]) != -1)
4723     {
4724         /* $& $1 ... */
4725         i = t1 - s1;
4726         s = rx->subbeg + s1;
4727     } else {
4728         sv_setsv(sv,&PL_sv_undef);
4729         return sv;
4730     }          
4731     assert(rx->sublen >= (s - rx->subbeg) + i );
4732     if (i >= 0) {
4733         const int oldtainted = PL_tainted;
4734         TAINT_NOT;
4735         sv_setpvn(sv, s, i);
4736         PL_tainted = oldtainted;
4737         if ( (rx->extflags & RXf_CANY_SEEN)
4738             ? (RX_MATCH_UTF8(rx)
4739                         && (!i || is_utf8_string((U8*)s, i)))
4740             : (RX_MATCH_UTF8(rx)) )
4741         {
4742             SvUTF8_on(sv);
4743         }
4744         else
4745             SvUTF8_off(sv);
4746         if (PL_tainting) {
4747             if (RX_MATCH_TAINTED(rx)) {
4748                 if (SvTYPE(sv) >= SVt_PVMG) {
4749                     MAGIC* const mg = SvMAGIC(sv);
4750                     MAGIC* mgt;
4751                     PL_tainted = 1;
4752                     SvMAGIC_set(sv, mg->mg_moremagic);
4753                     SvTAINT(sv);
4754                     if ((mgt = SvMAGIC(sv))) {
4755                         mg->mg_moremagic = mgt;
4756                         SvMAGIC_set(sv, mg);
4757                     }
4758                 } else {
4759                     PL_tainted = 1;
4760                     SvTAINT(sv);
4761                 }
4762             } else 
4763                 SvTAINTED_off(sv);
4764         }
4765     } else {
4766         sv_setsv(sv,&PL_sv_undef);
4767     }
4768     return sv;
4769 }
4770 #endif
4771
4772 /* Scans the name of a named buffer from the pattern.
4773  * If flags is REG_RSN_RETURN_NULL returns null.
4774  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
4775  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
4776  * to the parsed name as looked up in the RExC_paren_names hash.
4777  * If there is an error throws a vFAIL().. type exception.
4778  */
4779
4780 #define REG_RSN_RETURN_NULL    0
4781 #define REG_RSN_RETURN_NAME    1
4782 #define REG_RSN_RETURN_DATA    2
4783
4784 STATIC SV*
4785 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags) {
4786     char *name_start = RExC_parse;
4787
4788     if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
4789          /* skip IDFIRST by using do...while */
4790         if (UTF)
4791             do {
4792                 RExC_parse += UTF8SKIP(RExC_parse);
4793             } while (isALNUM_utf8((U8*)RExC_parse));
4794         else
4795             do {
4796                 RExC_parse++;
4797             } while (isALNUM(*RExC_parse));
4798     }
4799
4800     if ( flags ) {
4801         SV* sv_name = sv_2mortal(Perl_newSVpvn(aTHX_ name_start,
4802             (int)(RExC_parse - name_start)));
4803         if (UTF)
4804             SvUTF8_on(sv_name);
4805         if ( flags == REG_RSN_RETURN_NAME)
4806             return sv_name;
4807         else if (flags==REG_RSN_RETURN_DATA) {
4808             HE *he_str = NULL;
4809             SV *sv_dat = NULL;
4810             if ( ! sv_name )      /* should not happen*/
4811                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
4812             if (RExC_paren_names)
4813                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
4814             if ( he_str )
4815                 sv_dat = HeVAL(he_str);
4816             if ( ! sv_dat )
4817                 vFAIL("Reference to nonexistent named group");
4818             return sv_dat;
4819         }
4820         else {
4821             Perl_croak(aTHX_ "panic: bad flag in reg_scan_name");
4822         }
4823         /* NOT REACHED */
4824     }
4825     return NULL;
4826 }
4827
4828 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
4829     int rem=(int)(RExC_end - RExC_parse);                       \
4830     int cut;                                                    \
4831     int num;                                                    \
4832     int iscut=0;                                                \
4833     if (rem>10) {                                               \
4834         rem=10;                                                 \
4835         iscut=1;                                                \
4836     }                                                           \
4837     cut=10-rem;                                                 \
4838     if (RExC_lastparse!=RExC_parse)                             \
4839         PerlIO_printf(Perl_debug_log," >%.*s%-*s",              \
4840             rem, RExC_parse,                                    \
4841             cut + 4,                                            \
4842             iscut ? "..." : "<"                                 \
4843         );                                                      \
4844     else                                                        \
4845         PerlIO_printf(Perl_debug_log,"%16s","");                \
4846                                                                 \
4847     if (SIZE_ONLY)                                              \
4848        num=RExC_size;                                           \
4849     else                                                        \
4850        num=REG_NODE_NUM(RExC_emit);                             \
4851     if (RExC_lastnum!=num)                                      \
4852        PerlIO_printf(Perl_debug_log,"|%4d",num);                \
4853     else                                                        \
4854        PerlIO_printf(Perl_debug_log,"|%4s","");                 \
4855     PerlIO_printf(Perl_debug_log,"|%*s%-4s",                    \
4856         (int)((depth*2)), "",                                   \
4857         (funcname)                                              \
4858     );                                                          \
4859     RExC_lastnum=num;                                           \
4860     RExC_lastparse=RExC_parse;                                  \
4861 })
4862
4863
4864
4865 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
4866     DEBUG_PARSE_MSG((funcname));                            \
4867     PerlIO_printf(Perl_debug_log,"%4s","\n");               \
4868 })
4869 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({           \
4870     DEBUG_PARSE_MSG((funcname));                            \
4871     PerlIO_printf(Perl_debug_log,fmt "\n",args);               \
4872 })
4873 /*
4874  - reg - regular expression, i.e. main body or parenthesized thing
4875  *
4876  * Caller must absorb opening parenthesis.
4877  *
4878  * Combining parenthesis handling with the base level of regular expression
4879  * is a trifle forced, but the need to tie the tails of the branches to what
4880  * follows makes it hard to avoid.
4881  */
4882 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
4883 #ifdef DEBUGGING
4884 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
4885 #else
4886 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
4887 #endif
4888
4889 /* this idea is borrowed from STR_WITH_LEN in handy.h */
4890 #define CHECK_WORD(s,v,l)  \
4891     (((sizeof(s)-1)==(l)) && (strnEQ(start_verb, (s ""), (sizeof(s)-1))))
4892
4893 STATIC regnode *
4894 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
4895     /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
4896 {
4897     dVAR;
4898     register regnode *ret;              /* Will be the head of the group. */
4899     register regnode *br;
4900     register regnode *lastbr;
4901     register regnode *ender = NULL;
4902     register I32 parno = 0;
4903     I32 flags;
4904     const I32 oregflags = RExC_flags;
4905     bool have_branch = 0;
4906     bool is_open = 0;
4907
4908     /* for (?g), (?gc), and (?o) warnings; warning
4909        about (?c) will warn about (?g) -- japhy    */
4910
4911 #define WASTED_O  0x01
4912 #define WASTED_G  0x02
4913 #define WASTED_C  0x04
4914 #define WASTED_GC (0x02|0x04)
4915     I32 wastedflags = 0x00;
4916
4917     char * parse_start = RExC_parse; /* MJD */
4918     char * const oregcomp_parse = RExC_parse;
4919
4920     GET_RE_DEBUG_FLAGS_DECL;
4921     DEBUG_PARSE("reg ");
4922
4923
4924     *flagp = 0;                         /* Tentatively. */
4925
4926
4927     /* Make an OPEN node, if parenthesized. */
4928     if (paren) {
4929         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
4930             char *start_verb = RExC_parse;
4931             STRLEN verb_len = 0;
4932             char *start_arg = NULL;
4933             unsigned char op = 0;
4934             int argok = 1;
4935             int internal_argval = 0; /* internal_argval is only useful if !argok */
4936             while ( *RExC_parse && *RExC_parse != ')' ) {
4937                 if ( *RExC_parse == ':' ) {
4938                     start_arg = RExC_parse + 1;
4939                     break;
4940                 }
4941                 RExC_parse++;
4942             }
4943             ++start_verb;
4944             verb_len = RExC_parse - start_verb;
4945             if ( start_arg ) {
4946                 RExC_parse++;
4947                 while ( *RExC_parse && *RExC_parse != ')' ) 
4948                     RExC_parse++;
4949                 if ( *RExC_parse != ')' ) 
4950                     vFAIL("Unterminated verb pattern argument");
4951                 if ( RExC_parse == start_arg )
4952                     start_arg = NULL;
4953             } else {
4954                 if ( *RExC_parse != ')' )
4955                     vFAIL("Unterminated verb pattern");
4956             }
4957             
4958             switch ( *start_verb ) {
4959             case 'A':  /* (*ACCEPT) */
4960                 if ( CHECK_WORD("ACCEPT",start_verb,verb_len) ) {
4961                     op = ACCEPT;
4962                     internal_argval = RExC_nestroot;
4963                 }
4964                 break;
4965             case 'C':  /* (*COMMIT) */
4966                 if ( CHECK_WORD("COMMIT",start_verb,verb_len) )
4967                     op = COMMIT;
4968                 break;
4969             case 'F':  /* (*FAIL) */
4970                 if ( verb_len==1 || CHECK_WORD("FAIL",start_verb,verb_len) ) {
4971                     op = OPFAIL;
4972                     argok = 0;
4973                 }
4974                 break;
4975             case ':':  /* (*:NAME) */
4976             case 'M':  /* (*MARK:NAME) */
4977                 if ( verb_len==0 || CHECK_WORD("MARK",start_verb,verb_len) ) {
4978                     op = MARKPOINT;
4979                     argok = -1;
4980                 }
4981                 break;
4982             case 'P':  /* (*PRUNE) */
4983                 if ( CHECK_WORD("PRUNE",start_verb,verb_len) )
4984                     op = PRUNE;
4985                 break;
4986             case 'S':   /* (*SKIP) */  
4987                 if ( CHECK_WORD("SKIP",start_verb,verb_len) ) 
4988                     op = SKIP;
4989                 break;
4990             case 'T':  /* (*THEN) */
4991                 /* [19:06] <TimToady> :: is then */
4992                 if ( CHECK_WORD("THEN",start_verb,verb_len) ) {
4993                     op = CUTGROUP;
4994                     RExC_seen |= REG_SEEN_CUTGROUP;
4995                 }
4996                 break;
4997             }
4998             if ( ! op ) {
4999                 RExC_parse++;
5000                 vFAIL3("Unknown verb pattern '%.*s'",
5001                     verb_len, start_verb);
5002             }
5003             if ( argok ) {
5004                 if ( start_arg && internal_argval ) {
5005                     vFAIL3("Verb pattern '%.*s' may not have an argument",
5006                         verb_len, start_verb); 
5007                 } else if ( argok < 0 && !start_arg ) {
5008                     vFAIL3("Verb pattern '%.*s' has a mandatory argument",
5009                         verb_len, start_verb);    
5010                 } else {
5011                     ret = reganode(pRExC_state, op, internal_argval);
5012                     if ( ! internal_argval && ! SIZE_ONLY ) {
5013                         if (start_arg) {
5014                             SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
5015                             ARG(ret) = add_data( pRExC_state, 1, "S" );
5016                             RExC_rxi->data->data[ARG(ret)]=(void*)sv;
5017                             ret->flags = 0;
5018                         } else {
5019                             ret->flags = 1; 
5020                         }
5021                     }               
5022                 }
5023                 if (!internal_argval)
5024                     RExC_seen |= REG_SEEN_VERBARG;
5025             } else if ( start_arg ) {
5026                 vFAIL3("Verb pattern '%.*s' may not have an argument",
5027                         verb_len, start_verb);    
5028             } else {
5029                 ret = reg_node(pRExC_state, op);
5030             }
5031             nextchar(pRExC_state);
5032             return ret;
5033         } else 
5034         if (*RExC_parse == '?') { /* (?...) */
5035             bool is_logical = 0;
5036             const char * const seqstart = RExC_parse;
5037
5038             RExC_parse++;
5039             paren = *RExC_parse++;
5040             ret = NULL;                 /* For look-ahead/behind. */
5041             switch (paren) {
5042
5043             case 'P':   /* (?P...) variants for those used to PCRE/Python */
5044                 paren = *RExC_parse++;
5045                 if ( paren == '<')         /* (?P<...>) named capture */
5046                     goto named_capture;
5047                 else if (paren == '>') {   /* (?P>name) named recursion */
5048                     goto named_recursion;
5049                 }
5050                 else if (paren == '=') {   /* (?P=...)  named backref */
5051                     /* this pretty much dupes the code for \k<NAME> in regatom(), if
5052                        you change this make sure you change that */
5053                     char* name_start = RExC_parse;
5054                     U32 num = 0;
5055                     SV *sv_dat = reg_scan_name(pRExC_state,
5056                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
5057                     if (RExC_parse == name_start || *RExC_parse != ')')
5058                         vFAIL2("Sequence %.3s... not terminated",parse_start);
5059
5060                     if (!SIZE_ONLY) {
5061                         num = add_data( pRExC_state, 1, "S" );
5062                         RExC_rxi->data->data[num]=(void*)sv_dat;
5063                         SvREFCNT_inc(sv_dat);
5064                     }
5065                     RExC_sawback = 1;
5066                     ret = reganode(pRExC_state,
5067                            (U8)(FOLD ? (LOC ? NREFFL : NREFF) : NREF),
5068                            num);
5069                     *flagp |= HASWIDTH;
5070
5071                     Set_Node_Offset(ret, parse_start+1);
5072                     Set_Node_Cur_Length(ret); /* MJD */
5073
5074                     nextchar(pRExC_state);
5075                     return ret;
5076                 }
5077                 goto unknown;
5078             case '<':           /* (?<...) */
5079                 if (*RExC_parse == '!')
5080                     paren = ',';
5081                 else if (*RExC_parse != '=') 
5082               named_capture:
5083                 {               /* (?<...>) */
5084                     char *name_start;
5085                     SV *svname;
5086                     paren= '>';
5087             case '\'':          /* (?'...') */
5088                     name_start= RExC_parse;
5089                     svname = reg_scan_name(pRExC_state,
5090                         SIZE_ONLY ?  /* reverse test from the others */
5091                         REG_RSN_RETURN_NAME : 
5092                         REG_RSN_RETURN_NULL);
5093                     if (RExC_parse == name_start)
5094                         goto unknown;
5095                     if (*RExC_parse != paren)
5096                         vFAIL2("Sequence (?%c... not terminated",
5097                             paren=='>' ? '<' : paren);
5098                     if (SIZE_ONLY) {
5099                         HE *he_str;
5100                         SV *sv_dat = NULL;
5101                         if (!svname) /* shouldnt happen */
5102                             Perl_croak(aTHX_
5103                                 "panic: reg_scan_name returned NULL");
5104                         if (!RExC_paren_names) {
5105                             RExC_paren_names= newHV();
5106                             sv_2mortal((SV*)RExC_paren_names);
5107 #ifdef DEBUGGING
5108                             RExC_paren_name_list= newAV();
5109                             sv_2mortal((SV*)RExC_paren_name_list);
5110 #endif
5111                         }
5112                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
5113                         if ( he_str )
5114                             sv_dat = HeVAL(he_str);
5115                         if ( ! sv_dat ) {
5116                             /* croak baby croak */
5117                             Perl_croak(aTHX_
5118                                 "panic: paren_name hash element allocation failed");
5119                         } else if ( SvPOK(sv_dat) ) {
5120                             IV count=SvIV(sv_dat);
5121                             I32 *pv=(I32*)SvGROW(sv_dat,SvCUR(sv_dat)+sizeof(I32)+1);
5122                             SvCUR_set(sv_dat,SvCUR(sv_dat)+sizeof(I32));
5123                             pv[count]=RExC_npar;
5124                             SvIVX(sv_dat)++;
5125                         } else {
5126                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
5127                             sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
5128                             SvIOK_on(sv_dat);
5129                             SvIVX(sv_dat)= 1;
5130                         }
5131 #ifdef DEBUGGING
5132                         if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
5133                             SvREFCNT_dec(svname);
5134 #endif
5135
5136                         /*sv_dump(sv_dat);*/
5137                     }
5138                     nextchar(pRExC_state);
5139                     paren = 1;
5140                     goto capturing_parens;
5141                 }
5142                 RExC_seen |= REG_SEEN_LOOKBEHIND;
5143                 RExC_parse++;
5144             case '=':           /* (?=...) */
5145             case '!':           /* (?!...) */
5146                 RExC_seen_zerolen++;
5147                 if (*RExC_parse == ')') {
5148                     ret=reg_node(pRExC_state, OPFAIL);
5149                     nextchar(pRExC_state);
5150                     return ret;
5151                 }
5152             case ':':           /* (?:...) */
5153             case '>':           /* (?>...) */
5154                 break;
5155             case '$':           /* (?$...) */
5156             case '@':           /* (?@...) */
5157                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
5158                 break;
5159             case '#':           /* (?#...) */
5160                 while (*RExC_parse && *RExC_parse != ')')
5161                     RExC_parse++;
5162                 if (*RExC_parse != ')')
5163                     FAIL("Sequence (?#... not terminated");
5164                 nextchar(pRExC_state);
5165                 *flagp = TRYAGAIN;
5166                 return NULL;
5167             case '0' :           /* (?0) */
5168             case 'R' :           /* (?R) */
5169                 if (*RExC_parse != ')')
5170                     FAIL("Sequence (?R) not terminated");
5171                 ret = reg_node(pRExC_state, GOSTART);
5172                 nextchar(pRExC_state);
5173                 return ret;
5174                 /*notreached*/
5175             { /* named and numeric backreferences */
5176                 I32 num;
5177             case '&':            /* (?&NAME) */
5178                 parse_start = RExC_parse - 1;
5179               named_recursion:
5180                 {
5181                     SV *sv_dat = reg_scan_name(pRExC_state,
5182                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
5183                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
5184                 }
5185                 goto gen_recurse_regop;
5186                 /* NOT REACHED */
5187             case '+':
5188                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
5189                     RExC_parse++;
5190                     vFAIL("Illegal pattern");
5191                 }
5192                 goto parse_recursion;
5193                 /* NOT REACHED*/
5194             case '-': /* (?-1) */
5195                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
5196                     RExC_parse--; /* rewind to let it be handled later */
5197                     goto parse_flags;
5198                 } 
5199                 /*FALLTHROUGH */
5200             case '1': case '2': case '3': case '4': /* (?1) */
5201             case '5': case '6': case '7': case '8': case '9':
5202                 RExC_parse--;
5203               parse_recursion:
5204                 num = atoi(RExC_parse);
5205                 parse_start = RExC_parse - 1; /* MJD */
5206                 if (*RExC_parse == '-')
5207                     RExC_parse++;
5208                 while (isDIGIT(*RExC_parse))
5209                         RExC_parse++;
5210                 if (*RExC_parse!=')') 
5211                     vFAIL("Expecting close bracket");
5212                         
5213               gen_recurse_regop:
5214                 if ( paren == '-' ) {
5215                     /*
5216                     Diagram of capture buffer numbering.
5217                     Top line is the normal capture buffer numbers
5218                     Botton line is the negative indexing as from
5219                     the X (the (?-2))
5220
5221                     +   1 2    3 4 5 X          6 7
5222                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
5223                     -   5 4    3 2 1 X          x x
5224
5225                     */
5226                     num = RExC_npar + num;
5227                     if (num < 1)  {
5228                         RExC_parse++;
5229                         vFAIL("Reference to nonexistent group");
5230                     }
5231                 } else if ( paren == '+' ) {
5232                     num = RExC_npar + num - 1;
5233                 }
5234
5235                 ret = reganode(pRExC_state, GOSUB, num);
5236                 if (!SIZE_ONLY) {
5237                     if (num > (I32)RExC_rx->nparens) {
5238                         RExC_parse++;
5239                         vFAIL("Reference to nonexistent group");
5240                     }
5241                     ARG2L_SET( ret, RExC_recurse_count++);
5242                     RExC_emit++;
5243                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
5244                         "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
5245                 } else {
5246                     RExC_size++;
5247                 }
5248                 RExC_seen |= REG_SEEN_RECURSE;
5249                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
5250                 Set_Node_Offset(ret, parse_start); /* MJD */
5251
5252                 nextchar(pRExC_state);
5253                 return ret;
5254             } /* named and numeric backreferences */
5255             /* NOT REACHED */
5256
5257             case 'p':           /* (?p...) */
5258                 if (SIZE_ONLY && ckWARN2(WARN_DEPRECATED, WARN_REGEXP))
5259                     vWARNdep(RExC_parse, "(?p{}) is deprecated - use (??{})");
5260                 /* FALL THROUGH*/
5261             case '?':           /* (??...) */
5262                 is_logical = 1;
5263                 if (*RExC_parse != '{')
5264                     goto unknown;
5265                 paren = *RExC_parse++;
5266                 /* FALL THROUGH */
5267             case '{':           /* (?{...}) */
5268             {
5269                 I32 count = 1;
5270                 U32 n = 0;
5271                 char c;
5272                 char *s = RExC_parse;
5273
5274                 RExC_seen_zerolen++;
5275                 RExC_seen |= REG_SEEN_EVAL;
5276                 while (count && (c = *RExC_parse)) {
5277                     if (c == '\\') {
5278                         if (RExC_parse[1])
5279                             RExC_parse++;
5280                     }
5281                     else if (c == '{')
5282                         count++;
5283                     else if (c == '}')
5284                         count--;
5285                     RExC_parse++;
5286                 }
5287                 if (*RExC_parse != ')') {
5288                     RExC_parse = s;             
5289                     vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
5290                 }
5291                 if (!SIZE_ONLY) {
5292                     PAD *pad;
5293                     OP_4tree *sop, *rop;
5294                     SV * const sv = newSVpvn(s, RExC_parse - 1 - s);
5295
5296                     ENTER;
5297                     Perl_save_re_context(aTHX);
5298                     rop = sv_compile_2op(sv, &sop, "re", &pad);
5299                     sop->op_private |= OPpREFCOUNTED;
5300                     /* re_dup will OpREFCNT_inc */
5301                     OpREFCNT_set(sop, 1);
5302                     LEAVE;
5303
5304                     n = add_data(pRExC_state, 3, "nop");
5305                     RExC_rxi->data->data[n] = (void*)rop;
5306                     RExC_rxi->data->data[n+1] = (void*)sop;
5307                     RExC_rxi->data->data[n+2] = (void*)pad;
5308                     SvREFCNT_dec(sv);
5309                 }
5310                 else {                                          /* First pass */
5311                     if (PL_reginterp_cnt < ++RExC_seen_evals
5312                         && IN_PERL_RUNTIME)
5313                         /* No compiled RE interpolated, has runtime
5314                            components ===> unsafe.  */
5315                         FAIL("Eval-group not allowed at runtime, use re 'eval'");
5316                     if (PL_tainting && PL_tainted)
5317                         FAIL("Eval-group in insecure regular expression");
5318 #if PERL_VERSION > 8
5319                     if (IN_PERL_COMPILETIME)
5320                         PL_cv_has_eval = 1;
5321 #endif
5322                 }
5323
5324                 nextchar(pRExC_state);
5325                 if (is_logical) {
5326                     ret = reg_node(pRExC_state, LOGICAL);
5327                     if (!SIZE_ONLY)
5328                         ret->flags = 2;
5329                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
5330                     /* deal with the length of this later - MJD */
5331                     return ret;
5332                 }
5333                 ret = reganode(pRExC_state, EVAL, n);
5334                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
5335                 Set_Node_Offset(ret, parse_start);
5336                 return ret;
5337             }
5338             case '(':           /* (?(?{...})...) and (?(?=...)...) */
5339             {
5340                 int is_define= 0;
5341                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
5342                     if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
5343                         || RExC_parse[1] == '<'
5344                         || RExC_parse[1] == '{') { /* Lookahead or eval. */
5345                         I32 flag;
5346                         
5347                         ret = reg_node(pRExC_state, LOGICAL);
5348                         if (!SIZE_ONLY)
5349                             ret->flags = 1;
5350                         REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
5351                         goto insert_if;
5352                     }
5353                 }
5354                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
5355                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
5356                 {
5357                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
5358                     char *name_start= RExC_parse++;
5359                     U32 num = 0;
5360                     SV *sv_dat=reg_scan_name(pRExC_state,
5361                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
5362                     if (RExC_parse == name_start || *RExC_parse != ch)
5363                         vFAIL2("Sequence (?(%c... not terminated",
5364                             (ch == '>' ? '<' : ch));
5365                     RExC_parse++;
5366                     if (!SIZE_ONLY) {
5367                         num = add_data( pRExC_state, 1, "S" );
5368                         RExC_rxi->data->data[num]=(void*)sv_dat;
5369                         SvREFCNT_inc(sv_dat);
5370                     }
5371                     ret = reganode(pRExC_state,NGROUPP,num);
5372                     goto insert_if_check_paren;
5373                 }
5374                 else if (RExC_parse[0] == 'D' &&
5375                          RExC_parse[1] == 'E' &&
5376                          RExC_parse[2] == 'F' &&
5377                          RExC_parse[3] == 'I' &&
5378                          RExC_parse[4] == 'N' &&
5379                          RExC_parse[5] == 'E')
5380                 {
5381                     ret = reganode(pRExC_state,DEFINEP,0);
5382                     RExC_parse +=6 ;
5383                     is_define = 1;
5384                     goto insert_if_check_paren;
5385                 }
5386                 else if (RExC_parse[0] == 'R') {
5387                     RExC_parse++;
5388                     parno = 0;
5389                     if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
5390                         parno = atoi(RExC_parse++);
5391                         while (isDIGIT(*RExC_parse))
5392                             RExC_parse++;
5393                     } else if (RExC_parse[0] == '&') {
5394                         SV *sv_dat;
5395                         RExC_parse++;
5396                         sv_dat = reg_scan_name(pRExC_state,
5397                             SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
5398                         parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
5399                     }
5400                     ret = reganode(pRExC_state,INSUBP,parno); 
5401                     goto insert_if_check_paren;
5402                 }
5403                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
5404                     /* (?(1)...) */
5405                     char c;
5406                     parno = atoi(RExC_parse++);
5407
5408                     while (isDIGIT(*RExC_parse))
5409                         RExC_parse++;
5410                     ret = reganode(pRExC_state, GROUPP, parno);
5411
5412                  insert_if_check_paren:
5413                     if ((c = *nextchar(pRExC_state)) != ')')
5414                         vFAIL("Switch condition not recognized");
5415                   insert_if:
5416                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
5417                     br = regbranch(pRExC_state, &flags, 1,depth+1);
5418                     if (br == NULL)
5419                         br = reganode(pRExC_state, LONGJMP, 0);
5420                     else
5421                         REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
5422                     c = *nextchar(pRExC_state);
5423                     if (flags&HASWIDTH)
5424                         *flagp |= HASWIDTH;
5425                     if (c == '|') {
5426                         if (is_define) 
5427                             vFAIL("(?(DEFINE)....) does not allow branches");
5428                         lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
5429                         regbranch(pRExC_state, &flags, 1,depth+1);
5430                         REGTAIL(pRExC_state, ret, lastbr);
5431                         if (flags&HASWIDTH)
5432                             *flagp |= HASWIDTH;
5433                         c = *nextchar(pRExC_state);
5434                     }
5435                     else
5436                         lastbr = NULL;
5437                     if (c != ')')
5438                         vFAIL("Switch (?(condition)... contains too many branches");
5439                     ender = reg_node(pRExC_state, TAIL);
5440                     REGTAIL(pRExC_state, br, ender);
5441                     if (lastbr) {
5442                         REGTAIL(pRExC_state, lastbr, ender);
5443                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
5444                     }
5445                     else
5446                         REGTAIL(pRExC_state, ret, ender);
5447                     return ret;
5448                 }
5449                 else {
5450                     vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
5451                 }
5452             }
5453             case 0:
5454                 RExC_parse--; /* for vFAIL to print correctly */
5455                 vFAIL("Sequence (? incomplete");
5456                 break;
5457             default:
5458                 --RExC_parse;
5459                 parse_flags:      /* (?i) */  
5460             {
5461                 U32 posflags = 0, negflags = 0;
5462                 U32 *flagsp = &posflags;
5463
5464                 while (*RExC_parse) {
5465                     /* && strchr("iogcmsx", *RExC_parse) */
5466                     /* (?g), (?gc) and (?o) are useless here
5467                        and must be globally applied -- japhy */
5468                     switch (*RExC_parse) {
5469                     CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
5470                     case 'o':
5471                     case 'g':
5472                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
5473                             const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
5474                             if (! (wastedflags & wflagbit) ) {
5475                                 wastedflags |= wflagbit;
5476                                 vWARN5(
5477                                     RExC_parse + 1,
5478                                     "Useless (%s%c) - %suse /%c modifier",
5479                                     flagsp == &negflags ? "?-" : "?",
5480                                     *RExC_parse,
5481                                     flagsp == &negflags ? "don't " : "",
5482                                     *RExC_parse
5483                                 );
5484                             }
5485                         }
5486                         break;
5487                         
5488                     case 'c':
5489                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
5490                             if (! (wastedflags & WASTED_C) ) {
5491                                 wastedflags |= WASTED_GC;
5492                                 vWARN3(
5493                                     RExC_parse + 1,
5494                                     "Useless (%sc) - %suse /gc modifier",
5495                                     flagsp == &negflags ? "?-" : "?",
5496                                     flagsp == &negflags ? "don't " : ""
5497                                 );
5498                             }
5499                         }
5500                         break;
5501                     case 'k':
5502                         if (flagsp == &negflags) {
5503                             if (SIZE_ONLY && ckWARN(WARN_REGEXP))
5504                                 vWARN(RExC_parse + 1,"Useless use of (?-k)");
5505                         } else {
5506                             *flagsp |= RXf_PMf_KEEPCOPY;
5507                         }
5508                         break;
5509                     case '-':
5510                         if (flagsp == &negflags)
5511                             goto unknown;
5512                         flagsp = &negflags;
5513                         wastedflags = 0;  /* reset so (?g-c) warns twice */
5514                         break;
5515                     case ':':
5516                         paren = ':';
5517                         /*FALLTHROUGH*/
5518                     case ')':
5519                         RExC_flags |= posflags;
5520                         RExC_flags &= ~negflags;
5521                         nextchar(pRExC_state);
5522                         if (paren != ':') {
5523                             *flagp = TRYAGAIN;
5524                             return NULL;
5525                         } else {
5526                             ret = NULL;
5527                             goto parse_rest;
5528                         }
5529                         /*NOTREACHED*/
5530                     default:
5531                     unknown:
5532                         RExC_parse++;
5533                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
5534                         /*NOTREACHED*/
5535                     }                           
5536                     ++RExC_parse;
5537                 }
5538             }} /* one for the default block, one for the switch */
5539         }
5540         else {                  /* (...) */
5541           capturing_parens:
5542             parno = RExC_npar;
5543             RExC_npar++;
5544             
5545             ret = reganode(pRExC_state, OPEN, parno);
5546             if (!SIZE_ONLY ){
5547                 if (!RExC_nestroot) 
5548                     RExC_nestroot = parno;
5549                 if (RExC_seen & REG_SEEN_RECURSE) {
5550                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
5551                         "Setting open paren #%"IVdf" to %d\n", 
5552                         (IV)parno, REG_NODE_NUM(ret)));
5553                     RExC_open_parens[parno-1]= ret;
5554                 }
5555             }
5556             Set_Node_Length(ret, 1); /* MJD */
5557             Set_Node_Offset(ret, RExC_parse); /* MJD */
5558             is_open = 1;
5559         }
5560     }
5561     else                        /* ! paren */
5562         ret = NULL;
5563    
5564    parse_rest:
5565     /* Pick up the branches, linking them together. */
5566     parse_start = RExC_parse;   /* MJD */
5567     br = regbranch(pRExC_state, &flags, 1,depth+1);
5568     /*     branch_len = (paren != 0); */
5569
5570     if (br == NULL)
5571         return(NULL);
5572     if (*RExC_parse == '|') {
5573         if (!SIZE_ONLY && RExC_extralen) {
5574             reginsert(pRExC_state, BRANCHJ, br, depth+1);
5575         }
5576         else {                  /* MJD */
5577             reginsert(pRExC_state, BRANCH, br, depth+1);
5578             Set_Node_Length(br, paren != 0);
5579             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
5580         }
5581         have_branch = 1;
5582         if (SIZE_ONLY)
5583             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
5584     }
5585     else if (paren == ':') {
5586         *flagp |= flags&SIMPLE;
5587     }
5588     if (is_open) {                              /* Starts with OPEN. */
5589         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
5590     }
5591     else if (paren != '?')              /* Not Conditional */
5592         ret = br;
5593     *flagp |= flags & (SPSTART | HASWIDTH);
5594     lastbr = br;
5595     while (*RExC_parse == '|') {
5596         if (!SIZE_ONLY && RExC_extralen) {
5597             ender = reganode(pRExC_state, LONGJMP,0);
5598             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
5599         }
5600         if (SIZE_ONLY)
5601             RExC_extralen += 2;         /* Account for LONGJMP. */
5602         nextchar(pRExC_state);
5603         br = regbranch(pRExC_state, &flags, 0, depth+1);
5604
5605         if (br == NULL)
5606             return(NULL);
5607         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
5608         lastbr = br;
5609         if (flags&HASWIDTH)
5610             *flagp |= HASWIDTH;
5611         *flagp |= flags&SPSTART;
5612     }
5613
5614     if (have_branch || paren != ':') {
5615         /* Make a closing node, and hook it on the end. */
5616         switch (paren) {
5617         case ':':
5618             ender = reg_node(pRExC_state, TAIL);
5619             break;
5620         case 1:
5621             ender = reganode(pRExC_state, CLOSE, parno);
5622             if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
5623                 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
5624                         "Setting close paren #%"IVdf" to %d\n", 
5625                         (IV)parno, REG_NODE_NUM(ender)));
5626                 RExC_close_parens[parno-1]= ender;
5627                 if (RExC_nestroot == parno) 
5628                     RExC_nestroot = 0;
5629             }       
5630             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
5631             Set_Node_Length(ender,1); /* MJD */
5632             break;
5633         case '<':
5634         case ',':
5635         case '=':
5636         case '!':
5637             *flagp &= ~HASWIDTH;
5638             /* FALL THROUGH */
5639         case '>':
5640             ender = reg_node(pRExC_state, SUCCEED);
5641             break;
5642         case 0:
5643             ender = reg_node(pRExC_state, END);
5644             if (!SIZE_ONLY) {
5645                 assert(!RExC_opend); /* there can only be one! */
5646                 RExC_opend = ender;
5647             }
5648             break;
5649         }
5650         REGTAIL(pRExC_state, lastbr, ender);
5651
5652         if (have_branch && !SIZE_ONLY) {
5653             if (depth==1)
5654                 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
5655
5656             /* Hook the tails of the branches to the closing node. */
5657             for (br = ret; br; br = regnext(br)) {
5658                 const U8 op = PL_regkind[OP(br)];
5659                 if (op == BRANCH) {
5660                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
5661                 }
5662                 else if (op == BRANCHJ) {
5663                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
5664                 }
5665             }
5666         }
5667     }
5668
5669     {
5670         const char *p;
5671         static const char parens[] = "=!<,>";
5672
5673         if (paren && (p = strchr(parens, paren))) {
5674             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
5675             int flag = (p - parens) > 1;
5676
5677             if (paren == '>')
5678                 node = SUSPEND, flag = 0;
5679             reginsert(pRExC_state, node,ret, depth+1);
5680             Set_Node_Cur_Length(ret);
5681             Set_Node_Offset(ret, parse_start + 1);
5682             ret->flags = flag;
5683             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
5684         }
5685     }
5686
5687     /* Check for proper termination. */
5688     if (paren) {
5689         RExC_flags = oregflags;
5690         if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
5691             RExC_parse = oregcomp_parse;
5692             vFAIL("Unmatched (");
5693         }
5694     }
5695     else if (!paren && RExC_parse < RExC_end) {
5696         if (*RExC_parse == ')') {
5697             RExC_parse++;
5698             vFAIL("Unmatched )");
5699         }
5700         else
5701             FAIL("Junk on end of regexp");      /* "Can't happen". */
5702         /* NOTREACHED */
5703     }
5704
5705     return(ret);
5706 }
5707
5708 /*
5709  - regbranch - one alternative of an | operator
5710  *
5711  * Implements the concatenation operator.
5712  */
5713 STATIC regnode *
5714 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
5715 {
5716     dVAR;
5717     register regnode *ret;
5718     register regnode *chain = NULL;
5719     register regnode *latest;
5720     I32 flags = 0, c = 0;
5721     GET_RE_DEBUG_FLAGS_DECL;
5722     DEBUG_PARSE("brnc");
5723     if (first)
5724         ret = NULL;
5725     else {
5726         if (!SIZE_ONLY && RExC_extralen)
5727             ret = reganode(pRExC_state, BRANCHJ,0);
5728         else {
5729             ret = reg_node(pRExC_state, BRANCH);
5730             Set_Node_Length(ret, 1);
5731         }
5732     }
5733         
5734     if (!first && SIZE_ONLY)
5735         RExC_extralen += 1;                     /* BRANCHJ */
5736
5737     *flagp = WORST;                     /* Tentatively. */
5738
5739     RExC_parse--;
5740     nextchar(pRExC_state);
5741     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
5742         flags &= ~TRYAGAIN;
5743         latest = regpiece(pRExC_state, &flags,depth+1);
5744         if (latest == NULL) {
5745             if (flags & TRYAGAIN)
5746                 continue;
5747             return(NULL);
5748         }
5749         else if (ret == NULL)
5750             ret = latest;
5751         *flagp |= flags&HASWIDTH;
5752         if (chain == NULL)      /* First piece. */
5753             *flagp |= flags&SPSTART;
5754         else {
5755             RExC_naughty++;
5756             REGTAIL(pRExC_state, chain, latest);
5757         }
5758         chain = latest;
5759         c++;
5760     }
5761     if (chain == NULL) {        /* Loop ran zero times. */
5762         chain = reg_node(pRExC_state, NOTHING);
5763         if (ret == NULL)
5764             ret = chain;
5765     }
5766     if (c == 1) {
5767         *flagp |= flags&SIMPLE;
5768     }
5769
5770     return ret;
5771 }
5772
5773 /*
5774  - regpiece - something followed by possible [*+?]
5775  *
5776  * Note that the branching code sequences used for ? and the general cases
5777  * of * and + are somewhat optimized:  they use the same NOTHING node as
5778  * both the endmarker for their branch list and the body of the last branch.
5779  * It might seem that this node could be dispensed with entirely, but the
5780  * endmarker role is not redundant.
5781  */
5782 STATIC regnode *
5783 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
5784 {
5785     dVAR;
5786     register regnode *ret;
5787     register char op;
5788     register char *next;
5789     I32 flags;
5790     const char * const origparse = RExC_parse;
5791     I32 min;
5792     I32 max = REG_INFTY;
5793     char *parse_start;
5794     const char *maxpos = NULL;
5795     GET_RE_DEBUG_FLAGS_DECL;
5796     DEBUG_PARSE("piec");
5797
5798     ret = regatom(pRExC_state, &flags,depth+1);
5799     if (ret == NULL) {
5800         if (flags & TRYAGAIN)
5801             *flagp |= TRYAGAIN;
5802         return(NULL);
5803     }
5804
5805     op = *RExC_parse;
5806
5807     if (op == '{' && regcurly(RExC_parse)) {
5808         maxpos = NULL;
5809         parse_start = RExC_parse; /* MJD */
5810         next = RExC_parse + 1;
5811         while (isDIGIT(*next) || *next == ',') {
5812             if (*next == ',') {
5813                 if (maxpos)
5814                     break;
5815                 else
5816                     maxpos = next;
5817             }
5818             next++;
5819         }
5820         if (*next == '}') {             /* got one */
5821             if (!maxpos)
5822                 maxpos = next;
5823             RExC_parse++;
5824             min = atoi(RExC_parse);
5825             if (*maxpos == ',')
5826                 maxpos++;
5827             else
5828                 maxpos = RExC_parse;
5829             max = atoi(maxpos);
5830             if (!max && *maxpos != '0')
5831                 max = REG_INFTY;                /* meaning "infinity" */
5832             else if (max >= REG_INFTY)
5833                 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
5834             RExC_parse = next;
5835             nextchar(pRExC_state);
5836
5837         do_curly:
5838             if ((flags&SIMPLE)) {
5839                 RExC_naughty += 2 + RExC_naughty / 2;
5840                 reginsert(pRExC_state, CURLY, ret, depth+1);
5841                 Set_Node_Offset(ret, parse_start+1); /* MJD */
5842                 Set_Node_Cur_Length(ret);
5843             }
5844             else {
5845                 regnode * const w = reg_node(pRExC_state, WHILEM);
5846
5847                 w->flags = 0;
5848                 REGTAIL(pRExC_state, ret, w);
5849                 if (!SIZE_ONLY && RExC_extralen) {
5850                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
5851                     reginsert(pRExC_state, NOTHING,ret, depth+1);
5852                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
5853                 }
5854                 reginsert(pRExC_state, CURLYX,ret, depth+1);
5855                                 /* MJD hk */
5856                 Set_Node_Offset(ret, parse_start+1);
5857                 Set_Node_Length(ret,
5858                                 op == '{' ? (RExC_parse - parse_start) : 1);
5859
5860                 if (!SIZE_ONLY && RExC_extralen)
5861                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
5862                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
5863                 if (SIZE_ONLY)
5864                     RExC_whilem_seen++, RExC_extralen += 3;
5865                 RExC_naughty += 4 + RExC_naughty;       /* compound interest */
5866             }
5867             ret->flags = 0;
5868
5869             if (min > 0)
5870                 *flagp = WORST;
5871             if (max > 0)
5872                 *flagp |= HASWIDTH;
5873             if (max && max < min)
5874                 vFAIL("Can't do {n,m} with n > m");
5875             if (!SIZE_ONLY) {
5876                 ARG1_SET(ret, (U16)min);
5877                 ARG2_SET(ret, (U16)max);
5878             }
5879
5880             goto nest_check;
5881         }
5882     }
5883
5884     if (!ISMULT1(op)) {
5885         *flagp = flags;
5886         return(ret);
5887     }
5888
5889 #if 0                           /* Now runtime fix should be reliable. */
5890
5891     /* if this is reinstated, don't forget to put this back into perldiag:
5892
5893             =item Regexp *+ operand could be empty at {#} in regex m/%s/
5894
5895            (F) The part of the regexp subject to either the * or + quantifier
5896            could match an empty string. The {#} shows in the regular
5897            expression about where the problem was discovered.
5898
5899     */
5900
5901     if (!(flags&HASWIDTH) && op != '?')
5902       vFAIL("Regexp *+ operand could be empty");
5903 #endif
5904
5905     parse_start = RExC_parse;
5906     nextchar(pRExC_state);
5907
5908     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
5909
5910     if (op == '*' && (flags&SIMPLE)) {
5911         reginsert(pRExC_state, STAR, ret, depth+1);
5912         ret->flags = 0;
5913         RExC_naughty += 4;
5914     }
5915     else if (op == '*') {
5916         min = 0;
5917         goto do_curly;
5918     }
5919     else if (op == '+' && (flags&SIMPLE)) {
5920         reginsert(pRExC_state, PLUS, ret, depth+1);
5921         ret->flags = 0;
5922         RExC_naughty += 3;
5923     }
5924     else if (op == '+') {
5925         min = 1;
5926         goto do_curly;
5927     }
5928     else if (op == '?') {
5929         min = 0; max = 1;
5930         goto do_curly;
5931     }
5932   nest_check:
5933     if (!SIZE_ONLY && !(flags&HASWIDTH) && max > REG_INFTY/3 && ckWARN(WARN_REGEXP)) {
5934         vWARN3(RExC_parse,
5935                "%.*s matches null string many times",
5936                (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
5937                origparse);
5938     }
5939
5940     if (RExC_parse < RExC_end && *RExC_parse == '?') {
5941         nextchar(pRExC_state);
5942         reginsert(pRExC_state, MINMOD, ret, depth+1);
5943         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
5944     }
5945 #ifndef REG_ALLOW_MINMOD_SUSPEND
5946     else
5947 #endif
5948     if (RExC_parse < RExC_end && *RExC_parse == '+') {
5949         regnode *ender;
5950         nextchar(pRExC_state);
5951         ender = reg_node(pRExC_state, SUCCEED);
5952         REGTAIL(pRExC_state, ret, ender);
5953         reginsert(pRExC_state, SUSPEND, ret, depth+1);
5954         ret->flags = 0;
5955         ender = reg_node(pRExC_state, TAIL);
5956         REGTAIL(pRExC_state, ret, ender);
5957         /*ret= ender;*/
5958     }
5959
5960     if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
5961         RExC_parse++;
5962         vFAIL("Nested quantifiers");
5963     }
5964
5965     return(ret);
5966 }
5967
5968
5969 /* reg_namedseq(pRExC_state,UVp)
5970    
5971    This is expected to be called by a parser routine that has 
5972    recognized'\N' and needs to handle the rest. RExC_parse is 
5973    expected to point at the first char following the N at the time
5974    of the call.
5975    
5976    If valuep is non-null then it is assumed that we are parsing inside 
5977    of a charclass definition and the first codepoint in the resolved
5978    string is returned via *valuep and the routine will return NULL. 
5979    In this mode if a multichar string is returned from the charnames 
5980    handler a warning will be issued, and only the first char in the 
5981    sequence will be examined. If the string returned is zero length
5982    then the value of *valuep is undefined and NON-NULL will 
5983    be returned to indicate failure. (This will NOT be a valid pointer 
5984    to a regnode.)
5985    
5986    If value is null then it is assumed that we are parsing normal text
5987    and inserts a new EXACT node into the program containing the resolved
5988    string and returns a pointer to the new node. If the string is 
5989    zerolength a NOTHING node is emitted.
5990    
5991    On success RExC_parse is set to the char following the endbrace.
5992    Parsing failures will generate a fatal errorvia vFAIL(...)
5993    
5994    NOTE: We cache all results from the charnames handler locally in 
5995    the RExC_charnames hash (created on first use) to prevent a charnames 
5996    handler from playing silly-buggers and returning a short string and 
5997    then a long string for a given pattern. Since the regexp program 
5998    size is calculated during an initial parse this would result
5999    in a buffer overrun so we cache to prevent the charname result from
6000    changing during the course of the parse.
6001    
6002  */
6003 STATIC regnode *
6004 S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep) 
6005 {
6006     char * name;        /* start of the content of the name */
6007     char * endbrace;    /* endbrace following the name */
6008     SV *sv_str = NULL;  
6009     SV *sv_name = NULL;
6010     STRLEN len; /* this has various purposes throughout the code */
6011     bool cached = 0; /* if this is true then we shouldn't refcount dev sv_str */
6012     regnode *ret = NULL;
6013     
6014     if (*RExC_parse != '{') {
6015         vFAIL("Missing braces on \\N{}");
6016     }
6017     name = RExC_parse+1;
6018     endbrace = strchr(RExC_parse, '}');
6019     if ( ! endbrace ) {
6020         RExC_parse++;
6021         vFAIL("Missing right brace on \\N{}");
6022     } 
6023     RExC_parse = endbrace + 1;  
6024     
6025     
6026     /* RExC_parse points at the beginning brace, 
6027        endbrace points at the last */
6028     if ( name[0]=='U' && name[1]=='+' ) {
6029         /* its a "unicode hex" notation {U+89AB} */
6030         I32 fl = PERL_SCAN_ALLOW_UNDERSCORES
6031             | PERL_SCAN_DISALLOW_PREFIX
6032             | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
6033         UV cp;
6034         len = (STRLEN)(endbrace - name - 2);
6035         cp = grok_hex(name + 2, &len, &fl, NULL);
6036         if ( len != (STRLEN)(endbrace - name - 2) ) {
6037             cp = 0xFFFD;
6038         }    
6039         if (cp > 0xff)
6040             RExC_utf8 = 1;
6041         if ( valuep ) {
6042             *valuep = cp;
6043             return NULL;
6044         }
6045         sv_str= Perl_newSVpvf_nocontext("%c",(int)cp);
6046     } else {
6047         /* fetch the charnames handler for this scope */
6048         HV * const table = GvHV(PL_hintgv);
6049         SV **cvp= table ? 
6050             hv_fetchs(table, "charnames", FALSE) :
6051             NULL;
6052         SV *cv= cvp ? *cvp : NULL;
6053         HE *he_str;
6054         int count;
6055         /* create an SV with the name as argument */
6056         sv_name = newSVpvn(name, endbrace - name);
6057         
6058         if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
6059             vFAIL2("Constant(\\N{%s}) unknown: "
6060                   "(possibly a missing \"use charnames ...\")",
6061                   SvPVX(sv_name));
6062         }
6063         if (!cvp || !SvOK(*cvp)) { /* when $^H{charnames} = undef; */
6064             vFAIL2("Constant(\\N{%s}): "
6065                   "$^H{charnames} is not defined",SvPVX(sv_name));
6066         }
6067         
6068         
6069         
6070         if (!RExC_charnames) {
6071             /* make sure our cache is allocated */
6072             RExC_charnames = newHV();
6073             sv_2mortal((SV*)RExC_charnames);
6074         } 
6075             /* see if we have looked this one up before */
6076         he_str = hv_fetch_ent( RExC_charnames, sv_name, 0, 0 );
6077         if ( he_str ) {
6078             sv_str = HeVAL(he_str);
6079             cached = 1;
6080         } else {
6081             dSP ;
6082
6083             ENTER ;
6084             SAVETMPS ;
6085             PUSHMARK(SP) ;
6086             
6087             XPUSHs(sv_name);
6088             
6089             PUTBACK ;
6090             
6091             count= call_sv(cv, G_SCALAR);
6092             
6093             if (count == 1) { /* XXXX is this right? dmq */
6094                 sv_str = POPs;
6095                 SvREFCNT_inc_simple_void(sv_str);
6096             } 
6097             
6098             SPAGAIN ;
6099             PUTBACK ;
6100             FREETMPS ;
6101             LEAVE ;
6102             
6103             if ( !sv_str || !SvOK(sv_str) ) {
6104                 vFAIL2("Constant(\\N{%s}): Call to &{$^H{charnames}} "
6105                       "did not return a defined value",SvPVX(sv_name));
6106             }
6107             if (hv_store_ent( RExC_charnames, sv_name, sv_str, 0))
6108                 cached = 1;
6109         }
6110     }
6111     if (valuep) {
6112         char *p = SvPV(sv_str, len);
6113         if (len) {
6114             STRLEN numlen = 1;
6115             if ( SvUTF8(sv_str) ) {
6116                 *valuep = utf8_to_uvchr((U8*)p, &numlen);
6117                 if (*valuep > 0x7F)
6118                     RExC_utf8 = 1; 
6119                 /* XXXX
6120                   We have to turn on utf8 for high bit chars otherwise
6121                   we get failures with
6122                   
6123                    "ss" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i
6124                    "SS" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i
6125                 
6126                   This is different from what \x{} would do with the same
6127                   codepoint, where the condition is > 0xFF.
6128                   - dmq
6129                 */
6130                 
6131                 
6132             } else {
6133                 *valuep = (UV)*p;
6134                 /* warn if we havent used the whole string? */
6135             }
6136             if (numlen<len && SIZE_ONLY && ckWARN(WARN_REGEXP)) {
6137                 vWARN2(RExC_parse,
6138                     "Ignoring excess chars from \\N{%s} in character class",
6139                     SvPVX(sv_name)
6140                 );
6141             }        
6142         } else if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
6143             vWARN2(RExC_parse,
6144                     "Ignoring zero length \\N{%s} in character class",
6145                     SvPVX(sv_name)
6146                 );
6147         }
6148         if (sv_name)    
6149             SvREFCNT_dec(sv_name);    
6150         if (!cached)
6151             SvREFCNT_dec(sv_str);    
6152         return len ? NULL : (regnode *)&len;
6153     } else if(SvCUR(sv_str)) {     
6154         
6155         char *s; 
6156         char *p, *pend;        
6157         STRLEN charlen = 1;
6158         char * parse_start = name-3; /* needed for the offsets */
6159         GET_RE_DEBUG_FLAGS_DECL;     /* needed for the offsets */
6160         
6161         ret = reg_node(pRExC_state,
6162             (U8)(FOLD ? (LOC ? EXACTFL : EXACTF) : EXACT));
6163         s= STRING(ret);
6164         
6165         if ( RExC_utf8 && !SvUTF8(sv_str) ) {
6166             sv_utf8_upgrade(sv_str);
6167         } else if ( !RExC_utf8 && SvUTF8(sv_str) ) {
6168             RExC_utf8= 1;
6169         }
6170         
6171         p = SvPV(sv_str, len);
6172         pend = p + len;
6173         /* len is the length written, charlen is the size the char read */
6174         for ( len = 0; p < pend; p += charlen ) {
6175             if (UTF) {
6176                 UV uvc = utf8_to_uvchr((U8*)p, &charlen);
6177                 if (FOLD) {
6178                     STRLEN foldlen,numlen;
6179                     U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
6180                     uvc = toFOLD_uni(uvc, tmpbuf, &foldlen);
6181                     /* Emit all the Unicode characters. */
6182                     
6183                     for (foldbuf = tmpbuf;
6184                         foldlen;
6185                         foldlen -= numlen) 
6186                     {
6187                         uvc = utf8_to_uvchr(foldbuf, &numlen);
6188                         if (numlen > 0) {
6189                             const STRLEN unilen = reguni(pRExC_state, uvc, s);
6190                             s       += unilen;
6191                             len     += unilen;
6192                             /* In EBCDIC the numlen
6193                             * and unilen can differ. */
6194                             foldbuf += numlen;
6195                             if (numlen >= foldlen)
6196                                 break;
6197                         }
6198                         else
6199                             break; /* "Can't happen." */
6200                     }                          
6201                 } else {
6202                     const STRLEN unilen = reguni(pRExC_state, uvc, s);
6203                     if (unilen > 0) {
6204                        s   += unilen;
6205                        len += unilen;
6206                     }
6207                 }
6208             } else {
6209                 len++;
6210                 REGC(*p, s++);
6211             }
6212         }
6213         if (SIZE_ONLY) {
6214             RExC_size += STR_SZ(len);
6215         } else {
6216             STR_LEN(ret) = len;
6217             RExC_emit += STR_SZ(len);
6218         }
6219         Set_Node_Cur_Length(ret); /* MJD */
6220         RExC_parse--; 
6221         nextchar(pRExC_state);
6222     } else {
6223         ret = reg_node(pRExC_state,NOTHING);
6224     }
6225     if (!cached) {
6226         SvREFCNT_dec(sv_str);
6227     }
6228     if (sv_name) {
6229         SvREFCNT_dec(sv_name); 
6230     }
6231     return ret;
6232
6233 }
6234
6235
6236 /*
6237  * reg_recode
6238  *
6239  * It returns the code point in utf8 for the value in *encp.
6240  *    value: a code value in the source encoding
6241  *    encp:  a pointer to an Encode object
6242  *
6243  * If the result from Encode is not a single character,
6244  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
6245  */
6246 STATIC UV
6247 S_reg_recode(pTHX_ const char value, SV **encp)
6248 {
6249     STRLEN numlen = 1;
6250     SV * const sv = sv_2mortal(newSVpvn(&value, numlen));
6251     const char * const s = encp && *encp ? sv_recode_to_utf8(sv, *encp)
6252                                          : SvPVX(sv);
6253     const STRLEN newlen = SvCUR(sv);
6254     UV uv = UNICODE_REPLACEMENT;
6255
6256     if (newlen)
6257         uv = SvUTF8(sv)
6258              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
6259              : *(U8*)s;
6260
6261     if (!newlen || numlen != newlen) {
6262         uv = UNICODE_REPLACEMENT;
6263         if (encp)
6264             *encp = NULL;
6265     }
6266     return uv;
6267 }
6268
6269
6270 /*
6271  - regatom - the lowest level
6272
6273    Try to identify anything special at the start of the pattern. If there
6274    is, then handle it as required. This may involve generating a single regop,
6275    such as for an assertion; or it may involve recursing, such as to
6276    handle a () structure.
6277
6278    If the string doesn't start with something special then we gobble up
6279    as much literal text as we can.
6280
6281    Once we have been able to handle whatever type of thing started the
6282    sequence, we return.
6283
6284    Note: we have to be careful with escapes, as they can be both literal
6285    and special, and in the case of \10 and friends can either, depending
6286    on context. Specifically there are two seperate switches for handling
6287    escape sequences, with the one for handling literal escapes requiring
6288    a dummy entry for all of the special escapes that are actually handled
6289    by the other.
6290 */
6291
6292 STATIC regnode *
6293 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
6294 {
6295     dVAR;
6296     register regnode *ret = NULL;
6297     I32 flags;
6298     char *parse_start = RExC_parse;
6299     GET_RE_DEBUG_FLAGS_DECL;
6300     DEBUG_PARSE("atom");
6301     *flagp = WORST;             /* Tentatively. */
6302
6303
6304 tryagain:
6305     switch (*RExC_parse) {
6306     case '^':
6307         RExC_seen_zerolen++;
6308         nextchar(pRExC_state);
6309         if (RExC_flags & RXf_PMf_MULTILINE)
6310             ret = reg_node(pRExC_state, MBOL);
6311         else if (RExC_flags & RXf_PMf_SINGLELINE)
6312             ret = reg_node(pRExC_state, SBOL);
6313         else
6314             ret = reg_node(pRExC_state, BOL);
6315         Set_Node_Length(ret, 1); /* MJD */
6316         break;
6317     case '$':
6318         nextchar(pRExC_state);
6319         if (*RExC_parse)
6320             RExC_seen_zerolen++;
6321         if (RExC_flags & RXf_PMf_MULTILINE)
6322             ret = reg_node(pRExC_state, MEOL);
6323         else if (RExC_flags & RXf_PMf_SINGLELINE)
6324             ret = reg_node(pRExC_state, SEOL);
6325         else
6326             ret = reg_node(pRExC_state, EOL);
6327         Set_Node_Length(ret, 1); /* MJD */
6328         break;
6329     case '.':
6330         nextchar(pRExC_state);
6331         if (RExC_flags & RXf_PMf_SINGLELINE)
6332             ret = reg_node(pRExC_state, SANY);
6333         else
6334             ret = reg_node(pRExC_state, REG_ANY);
6335         *flagp |= HASWIDTH|SIMPLE;
6336         RExC_naughty++;
6337         Set_Node_Length(ret, 1); /* MJD */
6338         break;
6339     case '[':
6340     {
6341         char * const oregcomp_parse = ++RExC_parse;
6342         ret = regclass(pRExC_state,depth+1);
6343         if (*RExC_parse != ']') {
6344             RExC_parse = oregcomp_parse;
6345             vFAIL("Unmatched [");
6346         }
6347         nextchar(pRExC_state);
6348         *flagp |= HASWIDTH|SIMPLE;
6349         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
6350         break;
6351     }
6352     case '(':
6353         nextchar(pRExC_state);
6354         ret = reg(pRExC_state, 1, &flags,depth+1);
6355         if (ret == NULL) {
6356                 if (flags & TRYAGAIN) {
6357                     if (RExC_parse == RExC_end) {
6358                          /* Make parent create an empty node if needed. */
6359                         *flagp |= TRYAGAIN;
6360                         return(NULL);
6361                     }
6362                     goto tryagain;
6363                 }
6364                 return(NULL);
6365         }
6366         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE);
6367         break;
6368     case '|':
6369     case ')':
6370         if (flags & TRYAGAIN) {
6371             *flagp |= TRYAGAIN;
6372             return NULL;
6373         }
6374         vFAIL("Internal urp");
6375                                 /* Supposed to be caught earlier. */
6376         break;
6377     case '{':
6378         if (!regcurly(RExC_parse)) {
6379             RExC_parse++;
6380             goto defchar;
6381         }
6382         /* FALL THROUGH */
6383     case '?':
6384     case '+':
6385     case '*':
6386         RExC_parse++;
6387         vFAIL("Quantifier follows nothing");
6388         break;
6389     case '\\':
6390         /* Special Escapes
6391
6392            This switch handles escape sequences that resolve to some kind
6393            of special regop and not to literal text. Escape sequnces that
6394            resolve to literal text are handled below in the switch marked
6395            "Literal Escapes".
6396
6397            Every entry in this switch *must* have a corresponding entry
6398            in the literal escape switch. However, the opposite is not
6399            required, as the default for this switch is to jump to the
6400            literal text handling code.
6401         */
6402         switch (*++RExC_parse) {
6403         /* Special Escapes */
6404         case 'A':
6405             RExC_seen_zerolen++;
6406             ret = reg_node(pRExC_state, SBOL);
6407             *flagp |= SIMPLE;
6408             goto finish_meta_pat;
6409         case 'G':
6410             ret = reg_node(pRExC_state, GPOS);
6411             RExC_seen |= REG_SEEN_GPOS;
6412             *flagp |= SIMPLE;
6413             goto finish_meta_pat;
6414         case 'K':
6415             RExC_seen_zerolen++;
6416             ret = reg_node(pRExC_state, KEEPS);
6417             *flagp |= SIMPLE;
6418             goto finish_meta_pat;
6419         case 'Z':
6420             ret = reg_node(pRExC_state, SEOL);
6421             *flagp |= SIMPLE;
6422             RExC_seen_zerolen++;                /* Do not optimize RE away */
6423             goto finish_meta_pat;
6424         case 'z':
6425             ret = reg_node(pRExC_state, EOS);
6426             *flagp |= SIMPLE;
6427             RExC_seen_zerolen++;                /* Do not optimize RE away */
6428             goto finish_meta_pat;
6429         case 'C':
6430             ret = reg_node(pRExC_state, CANY);
6431             RExC_seen |= REG_SEEN_CANY;
6432             *flagp |= HASWIDTH|SIMPLE;
6433             goto finish_meta_pat;
6434         case 'X':
6435             ret = reg_node(pRExC_state, CLUMP);
6436             *flagp |= HASWIDTH;
6437             goto finish_meta_pat;
6438         case 'w':
6439             ret = reg_node(pRExC_state, (U8)(LOC ? ALNUML     : ALNUM));
6440             *flagp |= HASWIDTH|SIMPLE;
6441             goto finish_meta_pat;
6442         case 'W':
6443             ret = reg_node(pRExC_state, (U8)(LOC ? NALNUML    : NALNUM));
6444             *flagp |= HASWIDTH|SIMPLE;
6445             goto finish_meta_pat;
6446         case 'b':
6447             RExC_seen_zerolen++;
6448             RExC_seen |= REG_SEEN_LOOKBEHIND;
6449             ret = reg_node(pRExC_state, (U8)(LOC ? BOUNDL     : BOUND));
6450             *flagp |= SIMPLE;
6451             goto finish_meta_pat;
6452         case 'B':
6453             RExC_seen_zerolen++;
6454             RExC_seen |= REG_SEEN_LOOKBEHIND;
6455             ret = reg_node(pRExC_state, (U8)(LOC ? NBOUNDL    : NBOUND));
6456             *flagp |= SIMPLE;
6457             goto finish_meta_pat;
6458         case 's':
6459             ret = reg_node(pRExC_state, (U8)(LOC ? SPACEL     : SPACE));
6460             *flagp |= HASWIDTH|SIMPLE;
6461             goto finish_meta_pat;
6462         case 'S':
6463             ret = reg_node(pRExC_state, (U8)(LOC ? NSPACEL    : NSPACE));
6464             *flagp |= HASWIDTH|SIMPLE;
6465             goto finish_meta_pat;
6466         case 'd':
6467             ret = reg_node(pRExC_state, DIGIT);
6468             *flagp |= HASWIDTH|SIMPLE;
6469             goto finish_meta_pat;
6470         case 'D':
6471             ret = reg_node(pRExC_state, NDIGIT);
6472             *flagp |= HASWIDTH|SIMPLE;
6473             goto finish_meta_pat;
6474         case 'v':
6475             ret = reganode(pRExC_state, PRUNE, 0);
6476             ret->flags = 1;
6477             *flagp |= SIMPLE;
6478             goto finish_meta_pat;
6479         case 'V':
6480             ret = reganode(pRExC_state, SKIP, 0);
6481             ret->flags = 1;
6482             *flagp |= SIMPLE;
6483          finish_meta_pat:           
6484             nextchar(pRExC_state);
6485             Set_Node_Length(ret, 2); /* MJD */
6486             break;          
6487         case 'p':
6488         case 'P':
6489             {   
6490                 char* const oldregxend = RExC_end;
6491                 char* parse_start = RExC_parse - 2;
6492
6493                 if (RExC_parse[1] == '{') {
6494                   /* a lovely hack--pretend we saw [\pX] instead */
6495                     RExC_end = strchr(RExC_parse, '}');
6496                     if (!RExC_end) {
6497                         const U8 c = (U8)*RExC_parse;
6498                         RExC_parse += 2;
6499                         RExC_end = oldregxend;
6500                         vFAIL2("Missing right brace on \\%c{}", c);
6501                     }
6502                     RExC_end++;
6503                 }
6504                 else {
6505                     RExC_end = RExC_parse + 2;
6506                     if (RExC_end > oldregxend)
6507                         RExC_end = oldregxend;
6508                 }
6509                 RExC_parse--;
6510
6511                 ret = regclass(pRExC_state,depth+1);
6512
6513                 RExC_end = oldregxend;
6514                 RExC_parse--;
6515
6516                 Set_Node_Offset(ret, parse_start + 2);
6517                 Set_Node_Cur_Length(ret);
6518                 nextchar(pRExC_state);
6519                 *flagp |= HASWIDTH|SIMPLE;
6520             }
6521             break;
6522         case 'N': 
6523             /* Handle \N{NAME} here and not below because it can be 
6524             multicharacter. join_exact() will join them up later on. 
6525             Also this makes sure that things like /\N{BLAH}+/ and 
6526             \N{BLAH} being multi char Just Happen. dmq*/
6527             ++RExC_parse;
6528             ret= reg_namedseq(pRExC_state, NULL); 
6529             break;
6530         case 'k':    /* Handle \k<NAME> and \k'NAME' */
6531         parse_named_seq:
6532         {   
6533             char ch= RExC_parse[1];         
6534             if (ch != '<' && ch != '\'' && ch != '{') {
6535                 RExC_parse++;
6536                 vFAIL2("Sequence %.2s... not terminated",parse_start);
6537             } else {
6538                 /* this pretty much dupes the code for (?P=...) in reg(), if
6539                    you change this make sure you change that */
6540                 char* name_start = (RExC_parse += 2);
6541                 U32 num = 0;
6542                 SV *sv_dat = reg_scan_name(pRExC_state,
6543                     SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6544                 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
6545                 if (RExC_parse == name_start || *RExC_parse != ch)
6546                     vFAIL2("Sequence %.3s... not terminated",parse_start);
6547
6548                 if (!SIZE_ONLY) {
6549                     num = add_data( pRExC_state, 1, "S" );
6550                     RExC_rxi->data->data[num]=(void*)sv_dat;
6551                     SvREFCNT_inc(sv_dat);
6552                 }
6553
6554                 RExC_sawback = 1;
6555                 ret = reganode(pRExC_state,
6556                            (U8)(FOLD ? (LOC ? NREFFL : NREFF) : NREF),
6557                            num);
6558                 *flagp |= HASWIDTH;
6559
6560                 /* override incorrect value set in reganode MJD */
6561                 Set_Node_Offset(ret, parse_start+1);
6562                 Set_Node_Cur_Length(ret); /* MJD */
6563                 nextchar(pRExC_state);
6564
6565             }
6566             break;
6567         }
6568         case 'g': 
6569         case '1': case '2': case '3': case '4':
6570         case '5': case '6': case '7': case '8': case '9':
6571             {
6572                 I32 num;
6573                 bool isg = *RExC_parse == 'g';
6574                 bool isrel = 0; 
6575                 bool hasbrace = 0;
6576                 if (isg) {
6577                     RExC_parse++;
6578                     if (*RExC_parse == '{') {
6579                         RExC_parse++;
6580                         hasbrace = 1;
6581                     }
6582                     if (*RExC_parse == '-') {
6583                         RExC_parse++;
6584                         isrel = 1;
6585                     }
6586                     if (hasbrace && !isDIGIT(*RExC_parse)) {
6587                         if (isrel) RExC_parse--;
6588                         RExC_parse -= 2;                            
6589                         goto parse_named_seq;
6590                 }   }
6591                 num = atoi(RExC_parse);
6592                 if (isrel) {
6593                     num = RExC_npar - num;
6594                     if (num < 1)
6595                         vFAIL("Reference to nonexistent or unclosed group");
6596                 }
6597                 if (!isg && num > 9 && num >= RExC_npar)
6598                     goto defchar;
6599                 else {
6600                     char * const parse_start = RExC_parse - 1; /* MJD */
6601                     while (isDIGIT(*RExC_parse))
6602                         RExC_parse++;
6603                     if (parse_start == RExC_parse - 1) 
6604                         vFAIL("Unterminated \\g... pattern");
6605                     if (hasbrace) {
6606                         if (*RExC_parse != '}') 
6607                             vFAIL("Unterminated \\g{...} pattern");
6608                         RExC_parse++;
6609                     }    
6610                     if (!SIZE_ONLY) {
6611                         if (num > (I32)RExC_rx->nparens)
6612                             vFAIL("Reference to nonexistent group");
6613                     }
6614                     RExC_sawback = 1;
6615                     ret = reganode(pRExC_state,
6616                                    (U8)(FOLD ? (LOC ? REFFL : REFF) : REF),
6617                                    num);
6618                     *flagp |= HASWIDTH;
6619
6620                     /* override incorrect value set in reganode MJD */
6621                     Set_Node_Offset(ret, parse_start+1);
6622                     Set_Node_Cur_Length(ret); /* MJD */
6623                     RExC_parse--;
6624                     nextchar(pRExC_state);
6625                 }
6626             }
6627             break;
6628         case '\0':
6629             if (RExC_parse >= RExC_end)
6630                 FAIL("Trailing \\");
6631             /* FALL THROUGH */
6632         default:
6633             /* Do not generate "unrecognized" warnings here, we fall
6634                back into the quick-grab loop below */
6635             parse_start--;
6636             goto defchar;
6637         }
6638         break;
6639
6640     case '#':
6641         if (RExC_flags & RXf_PMf_EXTENDED) {
6642             while (RExC_parse < RExC_end && *RExC_parse != '\n')
6643                 RExC_parse++;
6644             if (RExC_parse < RExC_end)
6645                 goto tryagain;
6646         }
6647         /* FALL THROUGH */
6648
6649     default: {
6650             register STRLEN len;
6651             register UV ender;
6652             register char *p;
6653             char *s;
6654             STRLEN foldlen;
6655             U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
6656
6657             parse_start = RExC_parse - 1;
6658
6659             RExC_parse++;
6660
6661         defchar:
6662             ender = 0;
6663             ret = reg_node(pRExC_state,
6664                            (U8)(FOLD ? (LOC ? EXACTFL : EXACTF) : EXACT));
6665             s = STRING(ret);
6666             for (len = 0, p = RExC_parse - 1;
6667               len < 127 && p < RExC_end;
6668               len++)
6669             {
6670                 char * const oldp = p;
6671
6672                 if (RExC_flags & RXf_PMf_EXTENDED)
6673                     p = regwhite(p, RExC_end);
6674                 switch (*p) {
6675                 case '^':
6676                 case '$':
6677                 case '.':
6678                 case '[':
6679                 case '(':
6680                 case ')':
6681                 case '|':
6682                     goto loopdone;
6683                 case '\\':
6684                     /* Literal Escapes Switch
6685
6686                        This switch is meant to handle escape sequences that
6687                        resolve to a literal character.
6688
6689                        Every escape sequence that represents something
6690                        else, like an assertion or a char class, is handled
6691                        in the switch marked 'Special Escapes' above in this
6692                        routine, but also has an entry here as anything that
6693                        isn't explicitly mentioned here will be treated as
6694                        an unescaped equivalent literal.
6695                     */
6696
6697                     switch (*++p) {
6698                     /* These are all the special escapes. */
6699                     case 'A':             /* Start assertion */
6700                     case 'b': case 'B':   /* Word-boundary assertion*/
6701                     case 'C':             /* Single char !DANGEROUS! */
6702                     case 'd': case 'D':   /* digit class */
6703                     case 'g': case 'G':   /* generic-backref, pos assertion */
6704                     case 'k': case 'K':   /* named backref, keep marker */
6705                     case 'N':             /* named char sequence */
6706                     case 'p': case 'P':   /* unicode property */
6707                     case 's': case 'S':   /* space class */
6708                     case 'v': case 'V':   /* (*PRUNE) and (*SKIP) */
6709                     case 'w': case 'W':   /* word class */
6710                     case 'X':             /* eXtended Unicode "combining character sequence" */
6711                     case 'z': case 'Z':   /* End of line/string assertion */
6712                         --p;
6713                         goto loopdone;
6714
6715                     /* Anything after here is an escape that resolves to a
6716                        literal. (Except digits, which may or may not)
6717                      */
6718                     case 'n':
6719                         ender = '\n';
6720                         p++;
6721                         break;
6722                     case 'r':
6723                         ender = '\r';
6724                         p++;
6725                         break;
6726                     case 't':
6727                         ender = '\t';
6728                         p++;
6729                         break;
6730                     case 'f':
6731                         ender = '\f';
6732                         p++;
6733                         break;
6734                     case 'e':
6735                           ender = ASCII_TO_NATIVE('\033');
6736                         p++;
6737                         break;
6738                     case 'a':
6739                           ender = ASCII_TO_NATIVE('\007');
6740                         p++;
6741                         break;
6742                     case 'x':
6743                         if (*++p == '{') {
6744                             char* const e = strchr(p, '}');
6745         
6746                             if (!e) {
6747                                 RExC_parse = p + 1;
6748                                 vFAIL("Missing right brace on \\x{}");
6749                             }
6750                             else {
6751                                 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
6752                                     | PERL_SCAN_DISALLOW_PREFIX;
6753                                 STRLEN numlen = e - p - 1;
6754                                 ender = grok_hex(p + 1, &numlen, &flags, NULL);
6755                                 if (ender > 0xff)
6756                                     RExC_utf8 = 1;
6757                                 p = e + 1;
6758                             }
6759                         }
6760                         else {
6761                             I32 flags = PERL_SCAN_DISALLOW_PREFIX;
6762                             STRLEN numlen = 2;
6763                             ender = grok_hex(p, &numlen, &flags, NULL);
6764                             p += numlen;
6765                         }
6766                         if (PL_encoding && ender < 0x100)
6767                             goto recode_encoding;
6768                         break;
6769                     case 'c':
6770                         p++;
6771                         ender = UCHARAT(p++);
6772                         ender = toCTRL(ender);
6773                         break;
6774                     case '0': case '1': case '2': case '3':case '4':
6775                     case '5': case '6': case '7': case '8':case '9':
6776                         if (*p == '0' ||
6777                           (isDIGIT(p[1]) && atoi(p) >= RExC_npar) ) {
6778                             I32 flags = 0;
6779                             STRLEN numlen = 3;
6780                             ender = grok_oct(p, &numlen, &flags, NULL);
6781                             p += numlen;
6782                         }
6783                         else {
6784                             --p;
6785                             goto loopdone;
6786                         }
6787                         if (PL_encoding && ender < 0x100)
6788                             goto recode_encoding;
6789                         break;
6790                     recode_encoding:
6791                         {
6792                             SV* enc = PL_encoding;
6793                             ender = reg_recode((const char)(U8)ender, &enc);
6794                             if (!enc && SIZE_ONLY && ckWARN(WARN_REGEXP))
6795                                 vWARN(p, "Invalid escape in the specified encoding");
6796                             RExC_utf8 = 1;
6797                         }
6798                         break;
6799                     case '\0':
6800                         if (p >= RExC_end)
6801                             FAIL("Trailing \\");
6802                         /* FALL THROUGH */
6803                     default:
6804                         if (!SIZE_ONLY&& isALPHA(*p) && ckWARN(WARN_REGEXP))
6805                             vWARN2(p + 1, "Unrecognized escape \\%c passed through", UCHARAT(p));
6806                         goto normal_default;
6807                     }
6808                     break;
6809                 default:
6810                   normal_default:
6811                     if (UTF8_IS_START(*p) && UTF) {
6812                         STRLEN numlen;
6813                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
6814                                                &numlen, UTF8_ALLOW_DEFAULT);
6815                         p += numlen;
6816                     }
6817                     else
6818                         ender = *p++;
6819                     break;
6820                 }
6821                 if (RExC_flags & RXf_PMf_EXTENDED)
6822                     p = regwhite(p, RExC_end);
6823                 if (UTF && FOLD) {
6824                     /* Prime the casefolded buffer. */
6825                     ender = toFOLD_uni(ender, tmpbuf, &foldlen);
6826                 }
6827                 if (ISMULT2(p)) { /* Back off on ?+*. */
6828                     if (len)
6829                         p = oldp;
6830                     else if (UTF) {
6831                          if (FOLD) {
6832                               /* Emit all the Unicode characters. */
6833                               STRLEN numlen;
6834                               for (foldbuf = tmpbuf;
6835                                    foldlen;
6836                                    foldlen -= numlen) {
6837                                    ender = utf8_to_uvchr(foldbuf, &numlen);
6838                                    if (numlen > 0) {
6839                                         const STRLEN unilen = reguni(pRExC_state, ender, s);
6840                                         s       += unilen;
6841                                         len     += unilen;
6842                                         /* In EBCDIC the numlen
6843                                          * and unilen can differ. */
6844                                         foldbuf += numlen;
6845                                         if (numlen >= foldlen)
6846                                              break;
6847                                    }
6848                                    else
6849                                         break; /* "Can't happen." */
6850                               }
6851                          }
6852                          else {
6853                               const STRLEN unilen = reguni(pRExC_state, ender, s);
6854                               if (unilen > 0) {
6855                                    s   += unilen;
6856                                    len += unilen;
6857                               }
6858                          }
6859                     }
6860                     else {
6861                         len++;
6862                         REGC((char)ender, s++);
6863                     }
6864                     break;
6865                 }
6866                 if (UTF) {
6867                      if (FOLD) {
6868                           /* Emit all the Unicode characters. */
6869                           STRLEN numlen;
6870                           for (foldbuf = tmpbuf;
6871                                foldlen;
6872                                foldlen -= numlen) {
6873                                ender = utf8_to_uvchr(foldbuf, &numlen);
6874                                if (numlen > 0) {
6875                                     const STRLEN unilen = reguni(pRExC_state, ender, s);
6876                                     len     += unilen;
6877                                     s       += unilen;
6878                                     /* In EBCDIC the numlen
6879                                      * and unilen can differ. */
6880                                     foldbuf += numlen;
6881                                     if (numlen >= foldlen)
6882                                          break;
6883                                }
6884                                else
6885                                     break;
6886                           }
6887                      }
6888                      else {
6889                           const STRLEN unilen = reguni(pRExC_state, ender, s);
6890                           if (unilen > 0) {
6891                                s   += unilen;
6892                                len += unilen;
6893                           }
6894                      }
6895                      len--;
6896                 }
6897                 else
6898                     REGC((char)ender, s++);
6899             }
6900         loopdone:
6901             RExC_parse = p - 1;
6902             Set_Node_Cur_Length(ret); /* MJD */
6903             nextchar(pRExC_state);
6904             {
6905                 /* len is STRLEN which is unsigned, need to copy to signed */
6906                 IV iv = len;
6907                 if (iv < 0)
6908                     vFAIL("Internal disaster");
6909             }
6910             if (len > 0)
6911                 *flagp |= HASWIDTH;
6912             if (len == 1 && UNI_IS_INVARIANT(ender))
6913                 *flagp |= SIMPLE;
6914                 
6915             if (SIZE_ONLY)
6916                 RExC_size += STR_SZ(len);
6917             else {
6918                 STR_LEN(ret) = len;
6919                 RExC_emit += STR_SZ(len);
6920             }
6921         }
6922         break;
6923     }
6924
6925     return(ret);
6926 }
6927
6928 STATIC char *
6929 S_regwhite(char *p, const char *e)
6930 {
6931     while (p < e) {
6932         if (isSPACE(*p))
6933             ++p;
6934         else if (*p == '#') {
6935             do {
6936                 p++;
6937             } while (p < e && *p != '\n');
6938         }
6939         else
6940             break;
6941     }
6942     return p;
6943 }
6944
6945 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
6946    Character classes ([:foo:]) can also be negated ([:^foo:]).
6947    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
6948    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
6949    but trigger failures because they are currently unimplemented. */
6950
6951 #define POSIXCC_DONE(c)   ((c) == ':')
6952 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
6953 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
6954
6955 STATIC I32
6956 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
6957 {
6958     dVAR;
6959     I32 namedclass = OOB_NAMEDCLASS;
6960
6961     if (value == '[' && RExC_parse + 1 < RExC_end &&
6962         /* I smell either [: or [= or [. -- POSIX has been here, right? */
6963         POSIXCC(UCHARAT(RExC_parse))) {
6964         const char c = UCHARAT(RExC_parse);
6965         char* const s = RExC_parse++;
6966         
6967         while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
6968             RExC_parse++;
6969         if (RExC_parse == RExC_end)
6970             /* Grandfather lone [:, [=, [. */
6971             RExC_parse = s;
6972         else {
6973             const char* const t = RExC_parse++; /* skip over the c */
6974             assert(*t == c);
6975
6976             if (UCHARAT(RExC_parse) == ']') {
6977                 const char *posixcc = s + 1;
6978                 RExC_parse++; /* skip over the ending ] */
6979
6980                 if (*s == ':') {
6981                     const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
6982                     const I32 skip = t - posixcc;
6983
6984                     /* Initially switch on the length of the name.  */
6985                     switch (skip) {
6986                     case 4:
6987                         if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
6988                             namedclass = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
6989                         break;
6990                     case 5:
6991                         /* Names all of length 5.  */
6992                         /* alnum alpha ascii blank cntrl digit graph lower
6993                            print punct space upper  */
6994                         /* Offset 4 gives the best switch position.  */
6995                         switch (posixcc[4]) {
6996                         case 'a':
6997                             if (memEQ(posixcc, "alph", 4)) /* alpha */
6998                                 namedclass = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
6999                             break;
7000                         case 'e':
7001                             if (memEQ(posixcc, "spac", 4)) /* space */
7002                                 namedclass = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
7003                             break;
7004                         case 'h':
7005                             if (memEQ(posixcc, "grap", 4)) /* graph */
7006                                 namedclass = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
7007                             break;
7008                         case 'i':
7009                             if (memEQ(posixcc, "asci", 4)) /* ascii */
7010                                 namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII;
7011                             break;
7012                         case 'k':
7013                             if (memEQ(posixcc, "blan", 4)) /* blank */
7014                                 namedclass = complement ? ANYOF_NBLANK : ANYOF_BLANK;
7015                             break;
7016                         case 'l':
7017                             if (memEQ(posixcc, "cntr", 4)) /* cntrl */
7018                                 namedclass = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
7019                             break;
7020                         case 'm':
7021                             if (memEQ(posixcc, "alnu", 4)) /* alnum */
7022                                 namedclass = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
7023                             break;
7024                         case 'r':
7025                             if (memEQ(posixcc, "lowe", 4)) /* lower */
7026                                 namedclass = complement ? ANYOF_NLOWER : ANYOF_LOWER;
7027                             else if (memEQ(posixcc, "uppe", 4)) /* upper */
7028                                 namedclass = complement ? ANYOF_NUPPER : ANYOF_UPPER;
7029                             break;
7030                         case 't':
7031                             if (memEQ(posixcc, "digi", 4)) /* digit */
7032                                 namedclass = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
7033                             else if (memEQ(posixcc, "prin", 4)) /* print */
7034                                 namedclass = complement ? ANYOF_NPRINT : ANYOF_PRINT;
7035                             else if (memEQ(posixcc, "punc", 4)) /* punct */
7036                                 namedclass = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
7037                             break;
7038                         }
7039                         break;
7040                     case 6:
7041                         if (memEQ(posixcc, "xdigit", 6))
7042                             namedclass = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
7043                         break;
7044                     }
7045
7046                     if (namedclass == OOB_NAMEDCLASS)
7047                         Simple_vFAIL3("POSIX class [:%.*s:] unknown",
7048                                       t - s - 1, s + 1);
7049                     assert (posixcc[skip] == ':');
7050                     assert (posixcc[skip+1] == ']');
7051                 } else if (!SIZE_ONLY) {
7052                     /* [[=foo=]] and [[.foo.]] are still future. */
7053
7054                     /* adjust RExC_parse so the warning shows after
7055                        the class closes */
7056                     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
7057                         RExC_parse++;
7058                     Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
7059                 }
7060             } else {
7061                 /* Maternal grandfather:
7062                  * "[:" ending in ":" but not in ":]" */
7063                 RExC_parse = s;
7064             }
7065         }
7066     }
7067
7068     return namedclass;
7069 }
7070
7071 STATIC void
7072 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
7073 {
7074     dVAR;
7075     if (POSIXCC(UCHARAT(RExC_parse))) {
7076         const char *s = RExC_parse;
7077         const char  c = *s++;
7078
7079         while (isALNUM(*s))
7080             s++;
7081         if (*s && c == *s && s[1] == ']') {
7082             if (ckWARN(WARN_REGEXP))
7083                 vWARN3(s+2,
7084                         "POSIX syntax [%c %c] belongs inside character classes",
7085                         c, c);
7086
7087             /* [[=foo=]] and [[.foo.]] are still future. */
7088             if (POSIXCC_NOTYET(c)) {
7089                 /* adjust RExC_parse so the error shows after
7090                    the class closes */
7091                 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
7092                     NOOP;
7093                 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
7094             }
7095         }
7096     }
7097 }
7098
7099
7100 #define _C_C_T_(NAME,TEST,WORD)                         \
7101 ANYOF_##NAME:                                           \
7102     if (LOC)                                            \
7103         ANYOF_CLASS_SET(ret, ANYOF_##NAME);             \
7104     else {                                              \
7105         for (value = 0; value < 256; value++)           \
7106             if (TEST)                                   \
7107                 ANYOF_BITMAP_SET(ret, value);           \
7108     }                                                   \
7109     yesno = '+';                                        \
7110     what = WORD;                                        \
7111     break;                                              \
7112 case ANYOF_N##NAME:                                     \
7113     if (LOC)                                            \
7114         ANYOF_CLASS_SET(ret, ANYOF_N##NAME);            \
7115     else {                                              \
7116         for (value = 0; value < 256; value++)           \
7117             if (!TEST)                                  \
7118                 ANYOF_BITMAP_SET(ret, value);           \
7119     }                                                   \
7120     yesno = '!';                                        \
7121     what = WORD;                                        \
7122     break
7123
7124
7125 /*
7126    parse a class specification and produce either an ANYOF node that
7127    matches the pattern or if the pattern matches a single char only and
7128    that char is < 256 and we are case insensitive then we produce an 
7129    EXACT node instead.
7130 */
7131
7132 STATIC regnode *
7133 S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
7134 {
7135     dVAR;
7136     register UV value = 0;
7137     register UV nextvalue;
7138     register IV prevvalue = OOB_UNICODE;
7139     register IV range = 0;
7140     register regnode *ret;
7141     STRLEN numlen;
7142     IV namedclass;
7143     char *rangebegin = NULL;
7144     bool need_class = 0;
7145     SV *listsv = NULL;
7146     UV n;
7147     bool optimize_invert   = TRUE;
7148     AV* unicode_alternate  = NULL;
7149 #ifdef EBCDIC
7150     UV literal_endpoint = 0;
7151 #endif
7152     UV stored = 0;  /* number of chars stored in the class */
7153
7154     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
7155         case we need to change the emitted regop to an EXACT. */
7156     const char * orig_parse = RExC_parse;
7157     GET_RE_DEBUG_FLAGS_DECL;
7158 #ifndef DEBUGGING
7159     PERL_UNUSED_ARG(depth);
7160 #endif
7161
7162     DEBUG_PARSE("clas");
7163
7164     /* Assume we are going to generate an ANYOF node. */
7165     ret = reganode(pRExC_state, ANYOF, 0);
7166
7167     if (!SIZE_ONLY)
7168         ANYOF_FLAGS(ret) = 0;
7169
7170     if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
7171         RExC_naughty++;
7172         RExC_parse++;
7173         if (!SIZE_ONLY)
7174             ANYOF_FLAGS(ret) |= ANYOF_INVERT;
7175     }
7176
7177     if (SIZE_ONLY) {
7178         RExC_size += ANYOF_SKIP;
7179         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
7180     }
7181     else {
7182         RExC_emit += ANYOF_SKIP;
7183         if (FOLD)
7184             ANYOF_FLAGS(ret) |= ANYOF_FOLD;
7185         if (LOC)
7186             ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
7187         ANYOF_BITMAP_ZERO(ret);
7188         listsv = newSVpvs("# comment\n");
7189     }
7190
7191     nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
7192
7193     if (!SIZE_ONLY && POSIXCC(nextvalue))
7194         checkposixcc(pRExC_state);
7195
7196     /* allow 1st char to be ] (allowing it to be - is dealt with later) */
7197     if (UCHARAT(RExC_parse) == ']')
7198         goto charclassloop;
7199
7200 parseit:
7201     while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
7202
7203     charclassloop:
7204
7205         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
7206
7207         if (!range)
7208             rangebegin = RExC_parse;
7209         if (UTF) {
7210             value = utf8n_to_uvchr((U8*)RExC_parse,
7211                                    RExC_end - RExC_parse,
7212                                    &numlen, UTF8_ALLOW_DEFAULT);
7213             RExC_parse += numlen;
7214         }
7215         else
7216             value = UCHARAT(RExC_parse++);
7217
7218         nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
7219         if (value == '[' && POSIXCC(nextvalue))
7220             namedclass = regpposixcc(pRExC_state, value);
7221         else if (value == '\\') {
7222             if (UTF) {
7223                 value = utf8n_to_uvchr((U8*)RExC_parse,
7224                                    RExC_end - RExC_parse,
7225                                    &numlen, UTF8_ALLOW_DEFAULT);
7226                 RExC_parse += numlen;
7227             }
7228             else
7229                 value = UCHARAT(RExC_parse++);
7230             /* Some compilers cannot handle switching on 64-bit integer
7231              * values, therefore value cannot be an UV.  Yes, this will
7232              * be a problem later if we want switch on Unicode.
7233              * A similar issue a little bit later when switching on
7234              * namedclass. --jhi */
7235             switch ((I32)value) {
7236             case 'w':   namedclass = ANYOF_ALNUM;       break;
7237             case 'W':   namedclass = ANYOF_NALNUM;      break;
7238             case 's':   namedclass = ANYOF_SPACE;       break;
7239             case 'S':   namedclass = ANYOF_NSPACE;      break;
7240             case 'd':   namedclass = ANYOF_DIGIT;       break;
7241             case 'D':   namedclass = ANYOF_NDIGIT;      break;
7242             case 'N':  /* Handle \N{NAME} in class */
7243                 {
7244                     /* We only pay attention to the first char of 
7245                     multichar strings being returned. I kinda wonder
7246                     if this makes sense as it does change the behaviour
7247                     from earlier versions, OTOH that behaviour was broken
7248                     as well. */
7249                     UV v; /* value is register so we cant & it /grrr */
7250                     if (reg_namedseq(pRExC_state, &v)) {
7251                         goto parseit;
7252                     }
7253                     value= v; 
7254                 }
7255                 break;
7256             case 'p':
7257             case 'P':
7258                 {
7259                 char *e;
7260                 if (RExC_parse >= RExC_end)
7261                     vFAIL2("Empty \\%c{}", (U8)value);
7262                 if (*RExC_parse == '{') {
7263                     const U8 c = (U8)value;
7264                     e = strchr(RExC_parse++, '}');
7265                     if (!e)
7266                         vFAIL2("Missing right brace on \\%c{}", c);
7267                     while (isSPACE(UCHARAT(RExC_parse)))
7268                         RExC_parse++;
7269                     if (e == RExC_parse)
7270                         vFAIL2("Empty \\%c{}", c);
7271                     n = e - RExC_parse;
7272                     while (isSPACE(UCHARAT(RExC_parse + n - 1)))
7273                         n--;
7274                 }
7275                 else {
7276                     e = RExC_parse;
7277                     n = 1;
7278                 }
7279                 if (!SIZE_ONLY) {
7280                     if (UCHARAT(RExC_parse) == '^') {
7281                          RExC_parse++;
7282                          n--;
7283                          value = value == 'p' ? 'P' : 'p'; /* toggle */
7284                          while (isSPACE(UCHARAT(RExC_parse))) {
7285                               RExC_parse++;
7286                               n--;
7287                          }
7288                     }
7289                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%.*s\n",
7290                         (value=='p' ? '+' : '!'), (int)n, RExC_parse);
7291                 }
7292                 RExC_parse = e + 1;
7293                 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
7294                 namedclass = ANYOF_MAX;  /* no official name, but it's named */
7295                 }
7296                 break;
7297             case 'n':   value = '\n';                   break;
7298             case 'r':   value = '\r';                   break;
7299             case 't':   value = '\t';                   break;
7300             case 'f':   value = '\f';                   break;
7301             case 'b':   value = '\b';                   break;
7302             case 'e':   value = ASCII_TO_NATIVE('\033');break;
7303             case 'a':   value = ASCII_TO_NATIVE('\007');break;
7304             case 'x':
7305                 if (*RExC_parse == '{') {
7306                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
7307                         | PERL_SCAN_DISALLOW_PREFIX;
7308                     char * const e = strchr(RExC_parse++, '}');
7309                     if (!e)
7310                         vFAIL("Missing right brace on \\x{}");
7311
7312                     numlen = e - RExC_parse;
7313                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
7314                     RExC_parse = e + 1;
7315                 }
7316                 else {
7317                     I32 flags = PERL_SCAN_DISALLOW_PREFIX;
7318                     numlen = 2;
7319                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
7320                     RExC_parse += numlen;
7321                 }
7322                 if (PL_encoding && value < 0x100)
7323                     goto recode_encoding;
7324                 break;
7325             case 'c':
7326                 value = UCHARAT(RExC_parse++);
7327                 value = toCTRL(value);
7328                 break;
7329             case '0': case '1': case '2': case '3': case '4':
7330             case '5': case '6': case '7': case '8': case '9':
7331                 {
7332                     I32 flags = 0;
7333                     numlen = 3;
7334                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
7335                     RExC_parse += numlen;
7336                     if (PL_encoding && value < 0x100)
7337                         goto recode_encoding;
7338                     break;
7339                 }
7340             recode_encoding:
7341                 {
7342                     SV* enc = PL_encoding;
7343                     value = reg_recode((const char)(U8)value, &enc);
7344                     if (!enc && SIZE_ONLY && ckWARN(WARN_REGEXP))
7345                         vWARN(RExC_parse,
7346                               "Invalid escape in the specified encoding");
7347                     break;
7348                 }
7349             default:
7350                 if (!SIZE_ONLY && isALPHA(value) && ckWARN(WARN_REGEXP))
7351                     vWARN2(RExC_parse,
7352                            "Unrecognized escape \\%c in character class passed through",
7353                            (int)value);
7354                 break;
7355             }
7356         } /* end of \blah */
7357 #ifdef EBCDIC
7358         else
7359             literal_endpoint++;
7360 #endif
7361
7362         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
7363
7364             if (!SIZE_ONLY && !need_class)
7365                 ANYOF_CLASS_ZERO(ret);
7366
7367             need_class = 1;
7368
7369             /* a bad range like a-\d, a-[:digit:] ? */
7370             if (range) {
7371                 if (!SIZE_ONLY) {
7372                     if (ckWARN(WARN_REGEXP)) {
7373                         const int w =
7374                             RExC_parse >= rangebegin ?
7375                             RExC_parse - rangebegin : 0;
7376                         vWARN4(RExC_parse,
7377                                "False [] range \"%*.*s\"",
7378                                w, w, rangebegin);
7379                     }
7380                     if (prevvalue < 256) {
7381                         ANYOF_BITMAP_SET(ret, prevvalue);
7382                         ANYOF_BITMAP_SET(ret, '-');
7383                     }
7384                     else {
7385                         ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
7386                         Perl_sv_catpvf(aTHX_ listsv,
7387                                        "%04"UVxf"\n%04"UVxf"\n", (UV)prevvalue, (UV) '-');
7388                     }
7389                 }
7390
7391                 range = 0; /* this was not a true range */
7392             }
7393
7394
7395     
7396             if (!SIZE_ONLY) {
7397                 const char *what = NULL;
7398                 char yesno = 0;
7399
7400                 if (namedclass > OOB_NAMEDCLASS)
7401                     optimize_invert = FALSE;
7402                 /* Possible truncation here but in some 64-bit environments
7403                  * the compiler gets heartburn about switch on 64-bit values.
7404                  * A similar issue a little earlier when switching on value.
7405                  * --jhi */
7406                 switch ((I32)namedclass) {
7407                 case _C_C_T_(ALNUM, isALNUM(value), "Word");
7408                 case _C_C_T_(ALNUMC, isALNUMC(value), "Alnum");
7409                 case _C_C_T_(ALPHA, isALPHA(value), "Alpha");
7410                 case _C_C_T_(BLANK, isBLANK(value), "Blank");
7411                 case _C_C_T_(CNTRL, isCNTRL(value), "Cntrl");
7412                 case _C_C_T_(GRAPH, isGRAPH(value), "Graph");
7413                 case _C_C_T_(LOWER, isLOWER(value), "Lower");
7414                 case _C_C_T_(PRINT, isPRINT(value), "Print");
7415                 case _C_C_T_(PSXSPC, isPSXSPC(value), "Space");
7416                 case _C_C_T_(PUNCT, isPUNCT(value), "Punct");
7417                 case _C_C_T_(SPACE, isSPACE(value), "SpacePerl");
7418                 case _C_C_T_(UPPER, isUPPER(value), "Upper");
7419                 case _C_C_T_(XDIGIT, isXDIGIT(value), "XDigit");
7420                 case ANYOF_ASCII:
7421                     if (LOC)
7422                         ANYOF_CLASS_SET(ret, ANYOF_ASCII);
7423                     else {
7424 #ifndef EBCDIC
7425                         for (value = 0; value < 128; value++)
7426                             ANYOF_BITMAP_SET(ret, value);
7427 #else  /* EBCDIC */
7428                         for (value = 0; value < 256; value++) {
7429                             if (isASCII(value))
7430                                 ANYOF_BITMAP_SET(ret, value);
7431                         }
7432 #endif /* EBCDIC */
7433                     }
7434                     yesno = '+';
7435                     what = "ASCII";
7436                     break;
7437                 case ANYOF_NASCII:
7438                     if (LOC)
7439                         ANYOF_CLASS_SET(ret, ANYOF_NASCII);
7440                     else {
7441 #ifndef EBCDIC
7442                         for (value = 128; value < 256; value++)
7443                             ANYOF_BITMAP_SET(ret, value);
7444 #else  /* EBCDIC */
7445                         for (value = 0; value < 256; value++) {
7446                             if (!isASCII(value))
7447                                 ANYOF_BITMAP_SET(ret, value);
7448                         }
7449 #endif /* EBCDIC */
7450                     }
7451                     yesno = '!';
7452                     what = "ASCII";
7453                     break;              
7454                 case ANYOF_DIGIT:
7455                     if (LOC)
7456                         ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
7457                     else {
7458                         /* consecutive digits assumed */
7459                         for (value = '0'; value <= '9'; value++)
7460                             ANYOF_BITMAP_SET(ret, value);
7461                     }
7462                     yesno = '+';
7463                     what = "Digit";
7464                     break;
7465                 case ANYOF_NDIGIT:
7466                     if (LOC)
7467                         ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
7468                     else {
7469                         /* consecutive digits assumed */
7470                         for (value = 0; value < '0'; value++)
7471                             ANYOF_BITMAP_SET(ret, value);
7472                         for (value = '9' + 1; value < 256; value++)
7473                             ANYOF_BITMAP_SET(ret, value);
7474                     }
7475                     yesno = '!';
7476                     what = "Digit";
7477                     break;              
7478                 case ANYOF_MAX:
7479                     /* this is to handle \p and \P */
7480                     break;
7481                 default:
7482                     vFAIL("Invalid [::] class");
7483                     break;
7484                 }
7485                 if (what) {
7486                     /* Strings such as "+utf8::isWord\n" */
7487                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::Is%s\n", yesno, what);
7488                 }
7489                 if (LOC)
7490                     ANYOF_FLAGS(ret) |= ANYOF_CLASS;
7491                 continue;
7492             }
7493         } /* end of namedclass \blah */
7494
7495         if (range) {
7496             if (prevvalue > (IV)value) /* b-a */ {
7497                 const int w = RExC_parse - rangebegin;
7498                 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
7499                 range = 0; /* not a valid range */
7500             }
7501         }
7502         else {
7503             prevvalue = value; /* save the beginning of the range */
7504             if (*RExC_parse == '-' && RExC_parse+1 < RExC_end &&
7505                 RExC_parse[1] != ']') {
7506                 RExC_parse++;
7507
7508                 /* a bad range like \w-, [:word:]- ? */
7509                 if (namedclass > OOB_NAMEDCLASS) {
7510                     if (ckWARN(WARN_REGEXP)) {
7511                         const int w =
7512                             RExC_parse >= rangebegin ?
7513                             RExC_parse - rangebegin : 0;
7514                         vWARN4(RExC_parse,
7515                                "False [] range \"%*.*s\"",
7516                                w, w, rangebegin);
7517                     }
7518                     if (!SIZE_ONLY)
7519                         ANYOF_BITMAP_SET(ret, '-');
7520                 } else
7521                     range = 1;  /* yeah, it's a range! */
7522                 continue;       /* but do it the next time */
7523             }
7524         }
7525
7526         /* now is the next time */
7527         /*stored += (value - prevvalue + 1);*/
7528         if (!SIZE_ONLY) {
7529             if (prevvalue < 256) {
7530                 const IV ceilvalue = value < 256 ? value : 255;
7531                 IV i;
7532 #ifdef EBCDIC
7533                 /* In EBCDIC [\x89-\x91] should include
7534                  * the \x8e but [i-j] should not. */
7535                 if (literal_endpoint == 2 &&
7536                     ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
7537                      (isUPPER(prevvalue) && isUPPER(ceilvalue))))
7538                 {
7539                     if (isLOWER(prevvalue)) {
7540                         for (i = prevvalue; i <= ceilvalue; i++)
7541                             if (isLOWER(i))
7542                                 ANYOF_BITMAP_SET(ret, i);
7543                     } else {
7544                         for (i = prevvalue; i <= ceilvalue; i++)
7545                             if (isUPPER(i))
7546                                 ANYOF_BITMAP_SET(ret, i);
7547                     }
7548                 }
7549                 else
7550 #endif
7551                       for (i = prevvalue; i <= ceilvalue; i++) {
7552                         if (!ANYOF_BITMAP_TEST(ret,i)) {
7553                             stored++;  
7554                             ANYOF_BITMAP_SET(ret, i);
7555                         }
7556                       }
7557           }
7558           if (value > 255 || UTF) {
7559                 const UV prevnatvalue  = NATIVE_TO_UNI(prevvalue);
7560                 const UV natvalue      = NATIVE_TO_UNI(value);
7561                 stored+=2; /* can't optimize this class */
7562                 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
7563                 if (prevnatvalue < natvalue) { /* what about > ? */
7564                     Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
7565                                    prevnatvalue, natvalue);
7566                 }
7567                 else if (prevnatvalue == natvalue) {
7568                     Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", natvalue);
7569                     if (FOLD) {
7570                          U8 foldbuf[UTF8_MAXBYTES_CASE+1];
7571                          STRLEN foldlen;
7572                          const UV f = to_uni_fold(natvalue, foldbuf, &foldlen);
7573
7574 #ifdef EBCDIC /* RD t/uni/fold ff and 6b */
7575                          if (RExC_precomp[0] == ':' &&
7576                              RExC_precomp[1] == '[' &&
7577                              (f == 0xDF || f == 0x92)) {
7578                              f = NATIVE_TO_UNI(f);
7579                         }
7580 #endif
7581                          /* If folding and foldable and a single
7582                           * character, insert also the folded version
7583                           * to the charclass. */
7584                          if (f != value) {
7585 #ifdef EBCDIC /* RD tunifold ligatures s,t fb05, fb06 */
7586                              if ((RExC_precomp[0] == ':' &&
7587                                   RExC_precomp[1] == '[' &&
7588                                   (f == 0xA2 &&
7589                                    (value == 0xFB05 || value == 0xFB06))) ?
7590                                  foldlen == ((STRLEN)UNISKIP(f) - 1) :
7591                                  foldlen == (STRLEN)UNISKIP(f) )
7592 #else
7593                               if (foldlen == (STRLEN)UNISKIP(f))
7594 #endif
7595                                   Perl_sv_catpvf(aTHX_ listsv,
7596                                                  "%04"UVxf"\n", f);
7597                               else {
7598                                   /* Any multicharacter foldings
7599                                    * require the following transform:
7600                                    * [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst)
7601                                    * where E folds into "pq" and F folds
7602                                    * into "rst", all other characters
7603                                    * fold to single characters.  We save
7604                                    * away these multicharacter foldings,
7605                                    * to be later saved as part of the
7606                                    * additional "s" data. */
7607                                   SV *sv;
7608
7609                                   if (!unicode_alternate)
7610                                       unicode_alternate = newAV();
7611                                   sv = newSVpvn((char*)foldbuf, foldlen);
7612                                   SvUTF8_on(sv);
7613                                   av_push(unicode_alternate, sv);
7614                               }
7615                          }
7616
7617                          /* If folding and the value is one of the Greek
7618                           * sigmas insert a few more sigmas to make the
7619                           * folding rules of the sigmas to work right.
7620                           * Note that not all the possible combinations
7621                           * are handled here: some of them are handled
7622                           * by the standard folding rules, and some of
7623                           * them (literal or EXACTF cases) are handled
7624                           * during runtime in regexec.c:S_find_byclass(). */
7625                          if (value == UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) {
7626                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
7627                                              (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA);
7628                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
7629                                              (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
7630                          }
7631                          else if (value == UNICODE_GREEK_CAPITAL_LETTER_SIGMA)
7632                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
7633                                              (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
7634                     }
7635                 }
7636             }
7637 #ifdef EBCDIC
7638             literal_endpoint = 0;
7639 #endif
7640         }
7641
7642         range = 0; /* this range (if it was one) is done now */
7643     }
7644
7645     if (need_class) {
7646         ANYOF_FLAGS(ret) |= ANYOF_LARGE;
7647         if (SIZE_ONLY)
7648             RExC_size += ANYOF_CLASS_ADD_SKIP;
7649         else
7650             RExC_emit += ANYOF_CLASS_ADD_SKIP;
7651     }
7652
7653
7654     if (SIZE_ONLY)
7655         return ret;
7656     /****** !SIZE_ONLY AFTER HERE *********/
7657
7658     if( stored == 1 && value < 256
7659         && !( ANYOF_FLAGS(ret) & ( ANYOF_FLAGS_ALL ^ ANYOF_FOLD ) )
7660     ) {
7661         /* optimize single char class to an EXACT node
7662            but *only* when its not a UTF/high char  */
7663         const char * cur_parse= RExC_parse;
7664         RExC_emit = (regnode *)orig_emit;
7665         RExC_parse = (char *)orig_parse;
7666         ret = reg_node(pRExC_state,
7667                        (U8)((ANYOF_FLAGS(ret) & ANYOF_FOLD) ? EXACTF : EXACT));
7668         RExC_parse = (char *)cur_parse;
7669         *STRING(ret)= (char)value;
7670         STR_LEN(ret)= 1;
7671         RExC_emit += STR_SZ(1);
7672         return ret;
7673     }
7674     /* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */
7675     if ( /* If the only flag is folding (plus possibly inversion). */
7676         ((ANYOF_FLAGS(ret) & (ANYOF_FLAGS_ALL ^ ANYOF_INVERT)) == ANYOF_FOLD)
7677        ) {
7678         for (value = 0; value < 256; ++value) {
7679             if (ANYOF_BITMAP_TEST(ret, value)) {
7680                 UV fold = PL_fold[value];
7681
7682                 if (fold != value)
7683                     ANYOF_BITMAP_SET(ret, fold);
7684             }
7685         }
7686         ANYOF_FLAGS(ret) &= ~ANYOF_FOLD;
7687     }
7688
7689     /* optimize inverted simple patterns (e.g. [^a-z]) */
7690     if (optimize_invert &&
7691         /* If the only flag is inversion. */
7692         (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT) {
7693         for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
7694             ANYOF_BITMAP(ret)[value] ^= ANYOF_FLAGS_ALL;
7695         ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL;
7696     }
7697     {
7698         AV * const av = newAV();
7699         SV *rv;
7700         /* The 0th element stores the character class description
7701          * in its textual form: used later (regexec.c:Perl_regclass_swash())
7702          * to initialize the appropriate swash (which gets stored in
7703          * the 1st element), and also useful for dumping the regnode.
7704          * The 2nd element stores the multicharacter foldings,
7705          * used later (regexec.c:S_reginclass()). */
7706         av_store(av, 0, listsv);
7707         av_store(av, 1, NULL);
7708         av_store(av, 2, (SV*)unicode_alternate);
7709         rv = newRV_noinc((SV*)av);
7710         n = add_data(pRExC_state, 1, "s");
7711         RExC_rxi->data->data[n] = (void*)rv;
7712         ARG_SET(ret, n);
7713     }
7714     return ret;
7715 }
7716 #undef _C_C_T_
7717
7718
7719 STATIC char*
7720 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
7721 {
7722     char* const retval = RExC_parse++;
7723
7724     for (;;) {
7725         if (*RExC_parse == '(' && RExC_parse[1] == '?' &&
7726                 RExC_parse[2] == '#') {
7727             while (*RExC_parse != ')') {
7728                 if (RExC_parse == RExC_end)
7729                     FAIL("Sequence (?#... not terminated");
7730                 RExC_parse++;
7731             }
7732             RExC_parse++;
7733             continue;
7734         }
7735         if (RExC_flags & RXf_PMf_EXTENDED) {
7736             if (isSPACE(*RExC_parse)) {
7737                 RExC_parse++;
7738                 continue;
7739             }
7740             else if (*RExC_parse == '#') {
7741                 while (RExC_parse < RExC_end)
7742                     if (*RExC_parse++ == '\n') break;
7743                 continue;
7744             }
7745         }
7746         return retval;
7747     }
7748 }
7749
7750 /*
7751 - reg_node - emit a node
7752 */
7753 STATIC regnode *                        /* Location. */
7754 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
7755 {
7756     dVAR;
7757     register regnode *ptr;
7758     regnode * const ret = RExC_emit;
7759     GET_RE_DEBUG_FLAGS_DECL;
7760
7761     if (SIZE_ONLY) {
7762         SIZE_ALIGN(RExC_size);
7763         RExC_size += 1;
7764         return(ret);
7765     }
7766 #ifdef DEBUGGING
7767     if (OP(RExC_emit) == 255)
7768         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %s: %d ",
7769             reg_name[op], OP(RExC_emit));
7770 #endif  
7771     NODE_ALIGN_FILL(ret);
7772     ptr = ret;
7773     FILL_ADVANCE_NODE(ptr, op);
7774 #ifdef RE_TRACK_PATTERN_OFFSETS
7775     if (RExC_offsets) {         /* MJD */
7776         MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n", 
7777               "reg_node", __LINE__, 
7778               reg_name[op],
7779               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] 
7780                 ? "Overwriting end of array!\n" : "OK",
7781               (UV)(RExC_emit - RExC_emit_start),
7782               (UV)(RExC_parse - RExC_start),
7783               (UV)RExC_offsets[0])); 
7784         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
7785     }
7786 #endif
7787     RExC_emit = ptr;
7788     return(ret);
7789 }
7790
7791 /*
7792 - reganode - emit a node with an argument
7793 */
7794 STATIC regnode *                        /* Location. */
7795 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
7796 {
7797     dVAR;
7798     register regnode *ptr;
7799     regnode * const ret = RExC_emit;
7800     GET_RE_DEBUG_FLAGS_DECL;
7801
7802     if (SIZE_ONLY) {
7803         SIZE_ALIGN(RExC_size);
7804         RExC_size += 2;
7805         /* 
7806            We can't do this:
7807            
7808            assert(2==regarglen[op]+1); 
7809         
7810            Anything larger than this has to allocate the extra amount.
7811            If we changed this to be:
7812            
7813            RExC_size += (1 + regarglen[op]);
7814            
7815            then it wouldn't matter. Its not clear what side effect
7816            might come from that so its not done so far.
7817            -- dmq
7818         */
7819         return(ret);
7820     }
7821 #ifdef DEBUGGING
7822     if (OP(RExC_emit) == 255)
7823         Perl_croak(aTHX_ "panic: reganode overwriting end of allocated program space");
7824 #endif 
7825     NODE_ALIGN_FILL(ret);
7826     ptr = ret;
7827     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
7828 #ifdef RE_TRACK_PATTERN_OFFSETS
7829     if (RExC_offsets) {         /* MJD */
7830         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
7831               "reganode",
7832               __LINE__,
7833               reg_name[op],
7834               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? 
7835               "Overwriting end of array!\n" : "OK",
7836               (UV)(RExC_emit - RExC_emit_start),
7837               (UV)(RExC_parse - RExC_start),
7838               (UV)RExC_offsets[0])); 
7839         Set_Cur_Node_Offset;
7840     }
7841 #endif            
7842     RExC_emit = ptr;
7843     return(ret);
7844 }
7845
7846 /*
7847 - reguni - emit (if appropriate) a Unicode character
7848 */
7849 STATIC STRLEN
7850 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
7851 {
7852     dVAR;
7853     return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
7854 }
7855
7856 /*
7857 - reginsert - insert an operator in front of already-emitted operand
7858 *
7859 * Means relocating the operand.
7860 */
7861 STATIC void
7862 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
7863 {
7864     dVAR;
7865     register regnode *src;
7866     register regnode *dst;
7867     register regnode *place;
7868     const int offset = regarglen[(U8)op];
7869     const int size = NODE_STEP_REGNODE + offset;
7870     GET_RE_DEBUG_FLAGS_DECL;
7871 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
7872     DEBUG_PARSE_FMT("inst"," - %s",reg_name[op]);
7873     if (SIZE_ONLY) {
7874         RExC_size += size;
7875         return;
7876     }
7877
7878     src = RExC_emit;
7879     RExC_emit += size;
7880     dst = RExC_emit;
7881     if (RExC_open_parens) {
7882         int paren;
7883         DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);
7884         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
7885             if ( RExC_open_parens[paren] >= opnd ) {
7886                 DEBUG_PARSE_FMT("open"," - %d",size);
7887                 RExC_open_parens[paren] += size;
7888             } else {
7889                 DEBUG_PARSE_FMT("open"," - %s","ok");
7890             }
7891             if ( RExC_close_parens[paren] >= opnd ) {
7892                 DEBUG_PARSE_FMT("close"," - %d",size);
7893                 RExC_close_parens[paren] += size;
7894             } else {
7895                 DEBUG_PARSE_FMT("close"," - %s","ok");
7896             }
7897         }
7898     }
7899
7900     while (src > opnd) {
7901         StructCopy(--src, --dst, regnode);
7902 #ifdef RE_TRACK_PATTERN_OFFSETS
7903         if (RExC_offsets) {     /* MJD 20010112 */
7904             MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
7905                   "reg_insert",
7906                   __LINE__,
7907                   reg_name[op],
7908                   (UV)(dst - RExC_emit_start) > RExC_offsets[0] 
7909                     ? "Overwriting end of array!\n" : "OK",
7910                   (UV)(src - RExC_emit_start),
7911                   (UV)(dst - RExC_emit_start),
7912                   (UV)RExC_offsets[0])); 
7913             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
7914             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
7915         }
7916 #endif
7917     }
7918     
7919
7920     place = opnd;               /* Op node, where operand used to be. */
7921 #ifdef RE_TRACK_PATTERN_OFFSETS
7922     if (RExC_offsets) {         /* MJD */
7923         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
7924               "reginsert",
7925               __LINE__,
7926               reg_name[op],
7927               (UV)(place - RExC_emit_start) > RExC_offsets[0] 
7928               ? "Overwriting end of array!\n" : "OK",
7929               (UV)(place - RExC_emit_start),
7930               (UV)(RExC_parse - RExC_start),
7931               (UV)RExC_offsets[0]));
7932         Set_Node_Offset(place, RExC_parse);
7933         Set_Node_Length(place, 1);
7934     }
7935 #endif    
7936     src = NEXTOPER(place);
7937     FILL_ADVANCE_NODE(place, op);
7938     Zero(src, offset, regnode);
7939 }
7940
7941 /*
7942 - regtail - set the next-pointer at the end of a node chain of p to val.
7943 - SEE ALSO: regtail_study
7944 */
7945 /* TODO: All three parms should be const */
7946 STATIC void
7947 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
7948 {
7949     dVAR;
7950     register regnode *scan;
7951     GET_RE_DEBUG_FLAGS_DECL;
7952 #ifndef DEBUGGING
7953     PERL_UNUSED_ARG(depth);
7954 #endif
7955
7956     if (SIZE_ONLY)
7957         return;
7958
7959     /* Find last node. */
7960     scan = p;
7961     for (;;) {
7962         regnode * const temp = regnext(scan);
7963         DEBUG_PARSE_r({
7964             SV * const mysv=sv_newmortal();
7965             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
7966             regprop(RExC_rx, mysv, scan);
7967             PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
7968                 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
7969                     (temp == NULL ? "->" : ""),
7970                     (temp == NULL ? reg_name[OP(val)] : "")
7971             );
7972         });
7973         if (temp == NULL)
7974             break;
7975         scan = temp;
7976     }
7977
7978     if (reg_off_by_arg[OP(scan)]) {
7979         ARG_SET(scan, val - scan);
7980     }
7981     else {
7982         NEXT_OFF(scan) = val - scan;
7983     }
7984 }
7985
7986 #ifdef DEBUGGING
7987 /*
7988 - regtail_study - set the next-pointer at the end of a node chain of p to val.
7989 - Look for optimizable sequences at the same time.
7990 - currently only looks for EXACT chains.
7991
7992 This is expermental code. The idea is to use this routine to perform 
7993 in place optimizations on branches and groups as they are constructed,
7994 with the long term intention of removing optimization from study_chunk so
7995 that it is purely analytical.
7996
7997 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
7998 to control which is which.
7999
8000 */
8001 /* TODO: All four parms should be const */
8002
8003 STATIC U8
8004 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
8005 {
8006     dVAR;
8007     register regnode *scan;
8008     U8 exact = PSEUDO;
8009 #ifdef EXPERIMENTAL_INPLACESCAN
8010     I32 min = 0;
8011 #endif
8012
8013     GET_RE_DEBUG_FLAGS_DECL;
8014
8015
8016     if (SIZE_ONLY)
8017         return exact;
8018
8019     /* Find last node. */
8020
8021     scan = p;
8022     for (;;) {
8023         regnode * const temp = regnext(scan);
8024 #ifdef EXPERIMENTAL_INPLACESCAN
8025         if (PL_regkind[OP(scan)] == EXACT)
8026             if (join_exact(pRExC_state,scan,&min,1,val,depth+1))
8027                 return EXACT;
8028 #endif
8029         if ( exact ) {
8030             switch (OP(scan)) {
8031                 case EXACT:
8032                 case EXACTF:
8033                 case EXACTFL:
8034                         if( exact == PSEUDO )
8035                             exact= OP(scan);
8036                         else if ( exact != OP(scan) )
8037                             exact= 0;
8038                 case NOTHING:
8039                     break;
8040                 default:
8041                     exact= 0;
8042             }
8043         }
8044         DEBUG_PARSE_r({
8045             SV * const mysv=sv_newmortal();
8046             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
8047             regprop(RExC_rx, mysv, scan);
8048             PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
8049                 SvPV_nolen_const(mysv),
8050                 REG_NODE_NUM(scan),
8051                 reg_name[exact]);
8052         });
8053         if (temp == NULL)
8054             break;
8055         scan = temp;
8056     }
8057     DEBUG_PARSE_r({
8058         SV * const mysv_val=sv_newmortal();
8059         DEBUG_PARSE_MSG("");
8060         regprop(RExC_rx, mysv_val, val);
8061         PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
8062                       SvPV_nolen_const(mysv_val),
8063                       (IV)REG_NODE_NUM(val),
8064                       (IV)(val - scan)
8065         );
8066     });
8067     if (reg_off_by_arg[OP(scan)]) {
8068         ARG_SET(scan, val - scan);
8069     }
8070     else {
8071         NEXT_OFF(scan) = val - scan;
8072     }
8073
8074     return exact;
8075 }
8076 #endif
8077
8078 /*
8079  - regcurly - a little FSA that accepts {\d+,?\d*}
8080  */
8081 STATIC I32
8082 S_regcurly(register const char *s)
8083 {
8084     if (*s++ != '{')
8085         return FALSE;
8086     if (!isDIGIT(*s))
8087         return FALSE;
8088     while (isDIGIT(*s))
8089         s++;
8090     if (*s == ',')
8091         s++;
8092     while (isDIGIT(*s))
8093         s++;
8094     if (*s != '}')
8095         return FALSE;
8096     return TRUE;
8097 }
8098
8099
8100 /*
8101  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
8102  */
8103 void
8104 Perl_regdump(pTHX_ const regexp *r)
8105 {
8106 #ifdef DEBUGGING
8107     dVAR;
8108     SV * const sv = sv_newmortal();
8109     SV *dsv= sv_newmortal();
8110     RXi_GET_DECL(r,ri);
8111
8112     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
8113
8114     /* Header fields of interest. */
8115     if (r->anchored_substr) {
8116         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr), 
8117             RE_SV_DUMPLEN(r->anchored_substr), 30);
8118         PerlIO_printf(Perl_debug_log,
8119                       "anchored %s%s at %"IVdf" ",
8120                       s, RE_SV_TAIL(r->anchored_substr),
8121                       (IV)r->anchored_offset);
8122     } else if (r->anchored_utf8) {
8123         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8), 
8124             RE_SV_DUMPLEN(r->anchored_utf8), 30);
8125         PerlIO_printf(Perl_debug_log,
8126                       "anchored utf8 %s%s at %"IVdf" ",
8127                       s, RE_SV_TAIL(r->anchored_utf8),
8128                       (IV)r->anchored_offset);
8129     }                 
8130     if (r->float_substr) {
8131         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr), 
8132             RE_SV_DUMPLEN(r->float_substr), 30);
8133         PerlIO_printf(Perl_debug_log,
8134                       "floating %s%s at %"IVdf"..%"UVuf" ",
8135                       s, RE_SV_TAIL(r->float_substr),
8136                       (IV)r->float_min_offset, (UV)r->float_max_offset);
8137     } else if (r->float_utf8) {
8138         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8), 
8139             RE_SV_DUMPLEN(r->float_utf8), 30);
8140         PerlIO_printf(Perl_debug_log,
8141                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
8142                       s, RE_SV_TAIL(r->float_utf8),
8143                       (IV)r->float_min_offset, (UV)r->float_max_offset);
8144     }
8145     if (r->check_substr || r->check_utf8)
8146         PerlIO_printf(Perl_debug_log,
8147                       (const char *)
8148                       (r->check_substr == r->float_substr
8149                        && r->check_utf8 == r->float_utf8
8150                        ? "(checking floating" : "(checking anchored"));
8151     if (r->extflags & RXf_NOSCAN)
8152         PerlIO_printf(Perl_debug_log, " noscan");
8153     if (r->extflags & RXf_CHECK_ALL)
8154         PerlIO_printf(Perl_debug_log, " isall");
8155     if (r->check_substr || r->check_utf8)
8156         PerlIO_printf(Perl_debug_log, ") ");
8157
8158     if (ri->regstclass) {
8159         regprop(r, sv, ri->regstclass);
8160         PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
8161     }
8162     if (r->extflags & RXf_ANCH) {
8163         PerlIO_printf(Perl_debug_log, "anchored");
8164         if (r->extflags & RXf_ANCH_BOL)
8165             PerlIO_printf(Perl_debug_log, "(BOL)");
8166         if (r->extflags & RXf_ANCH_MBOL)
8167             PerlIO_printf(Perl_debug_log, "(MBOL)");
8168         if (r->extflags & RXf_ANCH_SBOL)
8169             PerlIO_printf(Perl_debug_log, "(SBOL)");
8170         if (r->extflags & RXf_ANCH_GPOS)
8171             PerlIO_printf(Perl_debug_log, "(GPOS)");
8172         PerlIO_putc(Perl_debug_log, ' ');
8173     }
8174     if (r->extflags & RXf_GPOS_SEEN)
8175         PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
8176     if (r->intflags & PREGf_SKIP)
8177         PerlIO_printf(Perl_debug_log, "plus ");
8178     if (r->intflags & PREGf_IMPLICIT)
8179         PerlIO_printf(Perl_debug_log, "implicit ");
8180     PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
8181     if (r->extflags & RXf_EVAL_SEEN)
8182         PerlIO_printf(Perl_debug_log, "with eval ");
8183     PerlIO_printf(Perl_debug_log, "\n");
8184 #else
8185     PERL_UNUSED_CONTEXT;
8186     PERL_UNUSED_ARG(r);
8187 #endif  /* DEBUGGING */
8188 }
8189
8190 /*
8191 - regprop - printable representation of opcode
8192 */
8193 void
8194 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
8195 {
8196 #ifdef DEBUGGING
8197     dVAR;
8198     register int k;
8199     RXi_GET_DECL(prog,progi);
8200     GET_RE_DEBUG_FLAGS_DECL;
8201     
8202
8203     sv_setpvn(sv, "", 0);
8204
8205     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
8206         /* It would be nice to FAIL() here, but this may be called from
8207            regexec.c, and it would be hard to supply pRExC_state. */
8208         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
8209     sv_catpv(sv, reg_name[OP(o)]); /* Take off const! */
8210
8211     k = PL_regkind[OP(o)];
8212
8213     if (k == EXACT) {
8214         SV * const dsv = sv_2mortal(newSVpvs(""));
8215         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT) 
8216          * is a crude hack but it may be the best for now since 
8217          * we have no flag "this EXACTish node was UTF-8" 
8218          * --jhi */
8219         const char * const s = 
8220             pv_pretty(dsv, STRING(o), STR_LEN(o), 60, 
8221                 PL_colors[0], PL_colors[1],
8222                 PERL_PV_ESCAPE_UNI_DETECT |
8223                 PERL_PV_PRETTY_ELIPSES    |
8224                 PERL_PV_PRETTY_LTGT    
8225             ); 
8226         Perl_sv_catpvf(aTHX_ sv, " %s", s );
8227     } else if (k == TRIE) {
8228         /* print the details of the trie in dumpuntil instead, as
8229          * progi->data isn't available here */
8230         const char op = OP(o);
8231         const U32 n = ARG(o);
8232         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
8233                (reg_ac_data *)progi->data->data[n] :
8234                NULL;
8235         const reg_trie_data * const trie
8236             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
8237         
8238         Perl_sv_catpvf(aTHX_ sv, "-%s",reg_name[o->flags]);
8239         DEBUG_TRIE_COMPILE_r(
8240             Perl_sv_catpvf(aTHX_ sv,
8241                 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
8242                 (UV)trie->startstate,
8243                 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
8244                 (UV)trie->wordcount,
8245                 (UV)trie->minlen,
8246                 (UV)trie->maxlen,
8247                 (UV)TRIE_CHARCOUNT(trie),
8248                 (UV)trie->uniquecharcount
8249             )
8250         );
8251         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
8252             int i;
8253             int rangestart = -1;
8254             U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
8255             Perl_sv_catpvf(aTHX_ sv, "[");
8256             for (i = 0; i <= 256; i++) {
8257                 if (i < 256 && BITMAP_TEST(bitmap,i)) {
8258                     if (rangestart == -1)
8259                         rangestart = i;
8260                 } else if (rangestart != -1) {
8261                     if (i <= rangestart + 3)
8262                         for (; rangestart < i; rangestart++)
8263                             put_byte(sv, rangestart);
8264                     else {
8265                         put_byte(sv, rangestart);
8266                         sv_catpvs(sv, "-");
8267                         put_byte(sv, i - 1);
8268                     }
8269                     rangestart = -1;
8270                 }
8271             }
8272             Perl_sv_catpvf(aTHX_ sv, "]");
8273         } 
8274          
8275     } else if (k == CURLY) {
8276         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
8277             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
8278         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
8279     }
8280     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
8281         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
8282     else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
8283         Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
8284         if ( prog->paren_names ) {
8285             if ( k != REF || OP(o) < NREF) {        
8286                 AV *list= (AV *)progi->data->data[progi->name_list_idx];
8287                 SV **name= av_fetch(list, ARG(o), 0 );
8288                 if (name)
8289                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
8290             }       
8291             else {
8292                 AV *list= (AV *)progi->data->data[ progi->name_list_idx ];
8293                 SV *sv_dat=(SV*)progi->data->data[ ARG( o ) ];
8294                 I32 *nums=(I32*)SvPVX(sv_dat);
8295                 SV **name= av_fetch(list, nums[0], 0 );
8296                 I32 n;
8297                 if (name) {
8298                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
8299                         Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
8300                                     (n ? "," : ""), (IV)nums[n]);
8301                     }
8302                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
8303                 }
8304             }
8305         }            
8306     } else if (k == GOSUB) 
8307         Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
8308     else if (k == VERB) {
8309         if (!o->flags) 
8310             Perl_sv_catpvf(aTHX_ sv, ":%"SVf, 
8311                 SVfARG((SV*)progi->data->data[ ARG( o ) ]));
8312     } else if (k == LOGICAL)
8313         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);     /* 2: embedded, otherwise 1 */
8314     else if (k == ANYOF) {
8315         int i, rangestart = -1;
8316         const U8 flags = ANYOF_FLAGS(o);
8317
8318         /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
8319         static const char * const anyofs[] = {
8320             "\\w",
8321             "\\W",
8322             "\\s",
8323             "\\S",
8324             "\\d",
8325             "\\D",
8326             "[:alnum:]",
8327             "[:^alnum:]",
8328             "[:alpha:]",
8329             "[:^alpha:]",
8330             "[:ascii:]",
8331             "[:^ascii:]",
8332             "[:ctrl:]",
8333             "[:^ctrl:]",
8334             "[:graph:]",
8335             "[:^graph:]",
8336             "[:lower:]",
8337             "[:^lower:]",
8338             "[:print:]",
8339             "[:^print:]",
8340             "[:punct:]",
8341             "[:^punct:]",
8342             "[:upper:]",
8343             "[:^upper:]",
8344             "[:xdigit:]",
8345             "[:^xdigit:]",
8346             "[:space:]",
8347             "[:^space:]",
8348             "[:blank:]",
8349             "[:^blank:]"
8350         };
8351
8352         if (flags & ANYOF_LOCALE)
8353             sv_catpvs(sv, "{loc}");
8354         if (flags & ANYOF_FOLD)
8355             sv_catpvs(sv, "{i}");
8356         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
8357         if (flags & ANYOF_INVERT)
8358             sv_catpvs(sv, "^");
8359         for (i = 0; i <= 256; i++) {
8360             if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
8361                 if (rangestart == -1)
8362                     rangestart = i;
8363             } else if (rangestart != -1) {
8364                 if (i <= rangestart + 3)
8365                     for (; rangestart < i; rangestart++)
8366                         put_byte(sv, rangestart);
8367                 else {
8368                     put_byte(sv, rangestart);
8369                     sv_catpvs(sv, "-");
8370                     put_byte(sv, i - 1);
8371                 }
8372                 rangestart = -1;
8373             }
8374         }
8375
8376         if (o->flags & ANYOF_CLASS)
8377             for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
8378                 if (ANYOF_CLASS_TEST(o,i))
8379                     sv_catpv(sv, anyofs[i]);
8380
8381         if (flags & ANYOF_UNICODE)
8382             sv_catpvs(sv, "{unicode}");
8383         else if (flags & ANYOF_UNICODE_ALL)
8384             sv_catpvs(sv, "{unicode_all}");
8385
8386         {
8387             SV *lv;
8388             SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
8389         
8390             if (lv) {
8391                 if (sw) {
8392                     U8 s[UTF8_MAXBYTES_CASE+1];
8393                 
8394                     for (i = 0; i <= 256; i++) { /* just the first 256 */
8395                         uvchr_to_utf8(s, i);
8396                         
8397                         if (i < 256 && swash_fetch(sw, s, TRUE)) {
8398                             if (rangestart == -1)
8399                                 rangestart = i;
8400                         } else if (rangestart != -1) {
8401                             if (i <= rangestart + 3)
8402                                 for (; rangestart < i; rangestart++) {
8403                                     const U8 * const e = uvchr_to_utf8(s,rangestart);
8404                                     U8 *p;
8405                                     for(p = s; p < e; p++)
8406                                         put_byte(sv, *p);
8407                                 }
8408                             else {
8409                                 const U8 *e = uvchr_to_utf8(s,rangestart);
8410                                 U8 *p;
8411                                 for (p = s; p < e; p++)
8412                                     put_byte(sv, *p);
8413                                 sv_catpvs(sv, "-");
8414                                 e = uvchr_to_utf8(s, i-1);
8415                                 for (p = s; p < e; p++)
8416                                     put_byte(sv, *p);
8417                                 }
8418                                 rangestart = -1;
8419                             }
8420                         }
8421                         
8422                     sv_catpvs(sv, "..."); /* et cetera */
8423                 }
8424
8425                 {
8426                     char *s = savesvpv(lv);
8427                     char * const origs = s;
8428                 
8429                     while (*s && *s != '\n')
8430                         s++;
8431                 
8432                     if (*s == '\n') {
8433                         const char * const t = ++s;
8434                         
8435                         while (*s) {
8436                             if (*s == '\n')
8437                                 *s = ' ';
8438                             s++;
8439                         }
8440                         if (s[-1] == ' ')
8441                             s[-1] = 0;
8442                         
8443                         sv_catpv(sv, t);
8444                     }
8445                 
8446                     Safefree(origs);
8447                 }
8448             }
8449         }
8450
8451         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
8452     }
8453     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
8454         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
8455 #else
8456     PERL_UNUSED_CONTEXT;
8457     PERL_UNUSED_ARG(sv);
8458     PERL_UNUSED_ARG(o);
8459     PERL_UNUSED_ARG(prog);
8460 #endif  /* DEBUGGING */
8461 }
8462
8463 SV *
8464 Perl_re_intuit_string(pTHX_ regexp *prog)
8465 {                               /* Assume that RE_INTUIT is set */
8466     dVAR;
8467     GET_RE_DEBUG_FLAGS_DECL;
8468     PERL_UNUSED_CONTEXT;
8469
8470     DEBUG_COMPILE_r(
8471         {
8472             const char * const s = SvPV_nolen_const(prog->check_substr
8473                       ? prog->check_substr : prog->check_utf8);
8474
8475             if (!PL_colorset) reginitcolors();
8476             PerlIO_printf(Perl_debug_log,
8477                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
8478                       PL_colors[4],
8479                       prog->check_substr ? "" : "utf8 ",
8480                       PL_colors[5],PL_colors[0],
8481                       s,
8482                       PL_colors[1],
8483                       (strlen(s) > 60 ? "..." : ""));
8484         } );
8485
8486     return prog->check_substr ? prog->check_substr : prog->check_utf8;
8487 }
8488
8489 /* 
8490    pregfree() 
8491    
8492    handles refcounting and freeing the perl core regexp structure. When 
8493    it is necessary to actually free the structure the first thing it 
8494    does is call the 'free' method of the regexp_engine associated to to 
8495    the regexp, allowing the handling of the void *pprivate; member 
8496    first. (This routine is not overridable by extensions, which is why 
8497    the extensions free is called first.)
8498    
8499    See regdupe and regdupe_internal if you change anything here. 
8500 */
8501 #ifndef PERL_IN_XSUB_RE
8502 void
8503 Perl_pregfree(pTHX_ struct regexp *r)
8504 {
8505     dVAR;
8506     GET_RE_DEBUG_FLAGS_DECL;
8507
8508     if (!r || (--r->refcnt > 0))
8509         return;
8510         
8511     CALLREGFREE_PVT(r); /* free the private data */
8512     
8513     /* gcov results gave these as non-null 100% of the time, so there's no
8514        optimisation in checking them before calling Safefree  */
8515     Safefree(r->precomp);
8516     RX_MATCH_COPY_FREE(r);
8517 #ifdef PERL_OLD_COPY_ON_WRITE
8518     if (r->saved_copy)
8519         SvREFCNT_dec(r->saved_copy);
8520 #endif
8521     if (r->substrs) {
8522         if (r->anchored_substr)
8523             SvREFCNT_dec(r->anchored_substr);
8524         if (r->anchored_utf8)
8525             SvREFCNT_dec(r->anchored_utf8);
8526         if (r->float_substr)
8527             SvREFCNT_dec(r->float_substr);
8528         if (r->float_utf8)
8529             SvREFCNT_dec(r->float_utf8);
8530         Safefree(r->substrs);
8531     }
8532     if (r->paren_names)
8533             SvREFCNT_dec(r->paren_names);
8534     
8535     Safefree(r->startp);
8536     Safefree(r->endp);
8537     Safefree(r);
8538 }
8539 #endif
8540
8541 /* regfree_internal() 
8542
8543    Free the private data in a regexp. This is overloadable by 
8544    extensions. Perl takes care of the regexp structure in pregfree(), 
8545    this covers the *pprivate pointer which technically perldoesnt 
8546    know about, however of course we have to handle the 
8547    regexp_internal structure when no extension is in use. 
8548    
8549    Note this is called before freeing anything in the regexp 
8550    structure. 
8551  */
8552  
8553 void
8554 Perl_regfree_internal(pTHX_ struct regexp *r)
8555 {
8556     dVAR;
8557     RXi_GET_DECL(r,ri);
8558     GET_RE_DEBUG_FLAGS_DECL;
8559     
8560     DEBUG_COMPILE_r({
8561         if (!PL_colorset)
8562             reginitcolors();
8563         {
8564             SV *dsv= sv_newmortal();
8565             RE_PV_QUOTED_DECL(s, (r->extflags & RXf_UTF8),
8566                 dsv, r->precomp, r->prelen, 60);
8567             PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n", 
8568                 PL_colors[4],PL_colors[5],s);
8569         }
8570     });
8571 #ifdef RE_TRACK_PATTERN_OFFSETS
8572     if (ri->u.offsets)
8573         Safefree(ri->u.offsets);             /* 20010421 MJD */
8574 #endif
8575     if (ri->data) {
8576         int n = ri->data->count;
8577         PAD* new_comppad = NULL;
8578         PAD* old_comppad;
8579         PADOFFSET refcnt;
8580
8581         while (--n >= 0) {
8582           /* If you add a ->what type here, update the comment in regcomp.h */
8583             switch (ri->data->what[n]) {
8584             case 's':
8585             case 'S':
8586             case 'u':
8587                 SvREFCNT_dec((SV*)ri->data->data[n]);
8588                 break;
8589             case 'f':
8590                 Safefree(ri->data->data[n]);
8591                 break;
8592             case 'p':
8593                 new_comppad = (AV*)ri->data->data[n];
8594                 break;
8595             case 'o':
8596                 if (new_comppad == NULL)
8597                     Perl_croak(aTHX_ "panic: pregfree comppad");
8598                 PAD_SAVE_LOCAL(old_comppad,
8599                     /* Watch out for global destruction's random ordering. */
8600                     (SvTYPE(new_comppad) == SVt_PVAV) ? new_comppad : NULL
8601                 );
8602                 OP_REFCNT_LOCK;
8603                 refcnt = OpREFCNT_dec((OP_4tree*)ri->data->data[n]);
8604                 OP_REFCNT_UNLOCK;
8605                 if (!refcnt)
8606                     op_free((OP_4tree*)ri->data->data[n]);
8607
8608                 PAD_RESTORE_LOCAL(old_comppad);
8609                 SvREFCNT_dec((SV*)new_comppad);
8610                 new_comppad = NULL;
8611                 break;
8612             case 'n':
8613                 break;
8614             case 'T':           
8615                 { /* Aho Corasick add-on structure for a trie node.
8616                      Used in stclass optimization only */
8617                     U32 refcount;
8618                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
8619                     OP_REFCNT_LOCK;
8620                     refcount = --aho->refcount;
8621                     OP_REFCNT_UNLOCK;
8622                     if ( !refcount ) {
8623                         PerlMemShared_free(aho->states);
8624                         PerlMemShared_free(aho->fail);
8625                          /* do this last!!!! */
8626                         PerlMemShared_free(ri->data->data[n]);
8627                         PerlMemShared_free(ri->regstclass);
8628                     }
8629                 }
8630                 break;
8631             case 't':
8632                 {
8633                     /* trie structure. */
8634                     U32 refcount;
8635                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
8636                     OP_REFCNT_LOCK;
8637                     refcount = --trie->refcount;
8638                     OP_REFCNT_UNLOCK;
8639                     if ( !refcount ) {
8640                         PerlMemShared_free(trie->charmap);
8641                         PerlMemShared_free(trie->states);
8642                         PerlMemShared_free(trie->trans);
8643                         if (trie->bitmap)
8644                             PerlMemShared_free(trie->bitmap);
8645                         if (trie->wordlen)
8646                             PerlMemShared_free(trie->wordlen);
8647                         if (trie->jump)
8648                             PerlMemShared_free(trie->jump);
8649                         if (trie->nextword)
8650                             PerlMemShared_free(trie->nextword);
8651                         /* do this last!!!! */
8652                         PerlMemShared_free(ri->data->data[n]);
8653                     }
8654                 }
8655                 break;
8656             default:
8657                 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
8658             }
8659         }
8660         Safefree(ri->data->what);
8661         Safefree(ri->data);
8662     }
8663     if (ri->swap) {
8664         Safefree(ri->swap->startp);
8665         Safefree(ri->swap->endp);
8666         Safefree(ri->swap);
8667     }
8668     Safefree(ri);
8669 }
8670
8671 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
8672 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8673 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8674 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
8675
8676 /* 
8677    regdupe - duplicate a regexp. 
8678    
8679    This routine is called by sv.c's re_dup and is expected to clone a 
8680    given regexp structure. It is a no-op when not under USE_ITHREADS. 
8681    (Originally this *was* re_dup() for change history see sv.c)
8682    
8683    After all of the core data stored in struct regexp is duplicated
8684    the regexp_engine.dupe method is used to copy any private data
8685    stored in the *pprivate pointer. This allows extensions to handle
8686    any duplication it needs to do.
8687
8688    See pregfree() and regfree_internal() if you change anything here. 
8689 */
8690 #if defined(USE_ITHREADS)
8691 #ifndef PERL_IN_XSUB_RE
8692 regexp *
8693 Perl_re_dup(pTHX_ const regexp *r, CLONE_PARAMS *param)
8694 {
8695     dVAR;
8696     regexp *ret;
8697     int i, npar;
8698     struct reg_substr_datum *s;
8699
8700     if (!r)
8701         return (REGEXP *)NULL;
8702
8703     if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
8704         return ret;
8705
8706     
8707     npar = r->nparens+1;
8708     Newxz(ret, 1, regexp);
8709     Newx(ret->startp, npar, I32);
8710     Copy(r->startp, ret->startp, npar, I32);
8711     Newx(ret->endp, npar, I32);
8712     Copy(r->endp, ret->endp, npar, I32);
8713
8714     if (r->substrs) {
8715         Newx(ret->substrs, 1, struct reg_substr_data);
8716         for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
8717             s->min_offset = r->substrs->data[i].min_offset;
8718             s->max_offset = r->substrs->data[i].max_offset;
8719             s->end_shift  = r->substrs->data[i].end_shift;
8720             s->substr     = sv_dup_inc(r->substrs->data[i].substr, param);
8721             s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
8722         }
8723     } else 
8724         ret->substrs = NULL;    
8725
8726     ret->precomp        = SAVEPVN(r->precomp, r->prelen);
8727     ret->refcnt         = r->refcnt;
8728     ret->minlen         = r->minlen;
8729     ret->minlenret      = r->minlenret;
8730     ret->prelen         = r->prelen;
8731     ret->nparens        = r->nparens;
8732     ret->lastparen      = r->lastparen;
8733     ret->lastcloseparen = r->lastcloseparen;
8734     ret->intflags       = r->intflags;
8735     ret->extflags       = r->extflags;
8736
8737     ret->sublen         = r->sublen;
8738
8739     ret->engine         = r->engine;
8740     
8741     ret->paren_names    = hv_dup_inc(r->paren_names, param);
8742
8743     if (RX_MATCH_COPIED(ret))
8744         ret->subbeg  = SAVEPVN(r->subbeg, r->sublen);
8745     else
8746         ret->subbeg = NULL;
8747 #ifdef PERL_OLD_COPY_ON_WRITE
8748     ret->saved_copy = NULL;
8749 #endif
8750     
8751     ret->pprivate = r->pprivate;
8752     if (ret->pprivate) 
8753         RXi_SET(ret,CALLREGDUPE_PVT(ret,param));
8754     
8755     ptr_table_store(PL_ptr_table, r, ret);
8756     return ret;
8757 }
8758 #endif /* PERL_IN_XSUB_RE */
8759
8760 /*
8761    regdupe_internal()
8762    
8763    This is the internal complement to regdupe() which is used to copy
8764    the structure pointed to by the *pprivate pointer in the regexp.
8765    This is the core version of the extension overridable cloning hook.
8766    The regexp structure being duplicated will be copied by perl prior
8767    to this and will be provided as the regexp *r argument, however 
8768    with the /old/ structures pprivate pointer value. Thus this routine
8769    may override any copying normally done by perl.
8770    
8771    It returns a pointer to the new regexp_internal structure.
8772 */
8773
8774 void *
8775 Perl_regdupe_internal(pTHX_ const regexp *r, CLONE_PARAMS *param)
8776 {
8777     dVAR;
8778     regexp_internal *reti;
8779     int len, npar;
8780     RXi_GET_DECL(r,ri);
8781     
8782     npar = r->nparens+1;
8783     len = ProgLen(ri);
8784     
8785     Newxc(reti, sizeof(regexp_internal) + (len+1)*sizeof(regnode), char, regexp_internal);
8786     Copy(ri->program, reti->program, len+1, regnode);
8787     
8788     if(ri->swap) {
8789         Newx(reti->swap, 1, regexp_paren_ofs);
8790         /* no need to copy these */
8791         Newx(reti->swap->startp, npar, I32);
8792         Newx(reti->swap->endp, npar, I32);
8793     } else {
8794         reti->swap = NULL;
8795     }
8796
8797
8798     reti->regstclass = NULL;
8799     if (ri->data) {
8800         struct reg_data *d;
8801         const int count = ri->data->count;
8802         int i;
8803
8804         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
8805                 char, struct reg_data);
8806         Newx(d->what, count, U8);
8807
8808         d->count = count;
8809         for (i = 0; i < count; i++) {
8810             d->what[i] = ri->data->what[i];
8811             switch (d->what[i]) {
8812                 /* legal options are one of: sSfpontTu
8813                    see also regcomp.h and pregfree() */
8814             case 's':
8815             case 'S':
8816             case 'p': /* actually an AV, but the dup function is identical.  */
8817             case 'u': /* actually an HV, but the dup function is identical.  */
8818                 d->data[i] = sv_dup_inc((SV *)ri->data->data[i], param);
8819                 break;
8820             case 'f':
8821                 /* This is cheating. */
8822                 Newx(d->data[i], 1, struct regnode_charclass_class);
8823                 StructCopy(ri->data->data[i], d->data[i],
8824                             struct regnode_charclass_class);
8825                 reti->regstclass = (regnode*)d->data[i];
8826                 break;
8827             case 'o':
8828                 /* Compiled op trees are readonly and in shared memory,
8829                    and can thus be shared without duplication. */
8830                 OP_REFCNT_LOCK;
8831                 d->data[i] = (void*)OpREFCNT_inc((OP*)ri->data->data[i]);
8832                 OP_REFCNT_UNLOCK;
8833                 break;
8834             case 'T':
8835                 /* Trie stclasses are readonly and can thus be shared
8836                  * without duplication. We free the stclass in pregfree
8837                  * when the corresponding reg_ac_data struct is freed.
8838                  */
8839                 reti->regstclass= ri->regstclass;
8840                 /* Fall through */
8841             case 't':
8842                 OP_REFCNT_LOCK;
8843                 ((reg_trie_data*)ri->data->data[i])->refcount++;
8844                 OP_REFCNT_UNLOCK;
8845                 /* Fall through */
8846             case 'n':
8847                 d->data[i] = ri->data->data[i];
8848                 break;
8849             default:
8850                 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
8851             }
8852         }
8853
8854         reti->data = d;
8855     }
8856     else
8857         reti->data = NULL;
8858
8859     reti->name_list_idx = ri->name_list_idx;
8860
8861 #ifdef RE_TRACK_PATTERN_OFFSETS
8862     if (ri->u.offsets) {
8863         Newx(reti->u.offsets, 2*len+1, U32);
8864         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
8865     }
8866 #else
8867     SetProgLen(reti,len);
8868 #endif
8869
8870     return (void*)reti;
8871 }
8872
8873 #endif    /* USE_ITHREADS */
8874
8875 /* 
8876    reg_stringify() 
8877    
8878    converts a regexp embedded in a MAGIC struct to its stringified form, 
8879    caching the converted form in the struct and returns the cached 
8880    string. 
8881
8882    If lp is nonnull then it is used to return the length of the 
8883    resulting string
8884    
8885    If flags is nonnull and the returned string contains UTF8 then 
8886    (*flags & 1) will be true.
8887    
8888    If haseval is nonnull then it is used to return whether the pattern 
8889    contains evals.
8890    
8891    Normally called via macro: 
8892    
8893         CALLREG_STRINGIFY(mg,&len,&utf8);
8894         
8895    And internally with
8896    
8897         CALLREG_AS_STR(mg,&lp,&flags,&haseval)        
8898     
8899    See sv_2pv_flags() in sv.c for an example of internal usage.
8900     
8901  */
8902 #ifndef PERL_IN_XSUB_RE
8903 char *
8904 Perl_reg_stringify(pTHX_ MAGIC *mg, STRLEN *lp, U32 *flags, I32 *haseval ) {
8905     dVAR;
8906     const regexp * const re = (regexp *)mg->mg_obj;
8907
8908     if (!mg->mg_ptr) {
8909         const char *fptr = STD_PAT_MODS;        /*"msix"*/
8910         char reflags[7];
8911         char ch;
8912         bool hask = ((re->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
8913         bool hasm = ((re->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD);
8914         U16 reganch = (U16)((re->extflags & RXf_PMf_STD_PMMOD) >> 12);
8915         bool need_newline = 0;
8916         int left = 0;
8917         int right = 4 + hask;
8918         if (hask) 
8919             reflags[left++] = KEEPCOPY_PAT_MOD; /*'k'*/
8920         while((ch = *fptr++)) {
8921             if(reganch & 1) {
8922                 reflags[left++] = ch;
8923             }
8924             else {
8925                 reflags[right--] = ch;
8926             }
8927             reganch >>= 1;
8928         }
8929         if(hasm) {
8930             reflags[left] = '-';
8931             left = 5 + hask;
8932         }
8933         /* printf("[%*.7s]\n",left,reflags); */
8934         mg->mg_len = re->prelen + 4 + left;
8935         /*
8936          * If /x was used, we have to worry about a regex ending with a
8937          * comment later being embedded within another regex. If so, we don't
8938          * want this regex's "commentization" to leak out to the right part of
8939          * the enclosing regex, we must cap it with a newline.
8940          *
8941          * So, if /x was used, we scan backwards from the end of the regex. If
8942          * we find a '#' before we find a newline, we need to add a newline
8943          * ourself. If we find a '\n' first (or if we don't find '#' or '\n'),
8944          * we don't need to add anything.  -jfriedl
8945          */
8946         if (PMf_EXTENDED & re->extflags) {
8947             const char *endptr = re->precomp + re->prelen;
8948             while (endptr >= re->precomp) {
8949                 const char c = *(endptr--);
8950                 if (c == '\n')
8951                     break; /* don't need another */
8952                 if (c == '#') {
8953                     /* we end while in a comment, so we need a newline */
8954                     mg->mg_len++; /* save space for it */
8955                     need_newline = 1; /* note to add it */
8956                     break;
8957                 }
8958             }
8959         }
8960
8961         Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
8962         mg->mg_ptr[0] = '(';
8963         mg->mg_ptr[1] = '?';
8964         Copy(reflags, mg->mg_ptr+2, left, char);
8965         *(mg->mg_ptr+left+2) = ':';
8966         Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
8967         if (need_newline)
8968             mg->mg_ptr[mg->mg_len - 2] = '\n';
8969         mg->mg_ptr[mg->mg_len - 1] = ')';
8970         mg->mg_ptr[mg->mg_len] = 0;
8971     }
8972     if (haseval) 
8973         *haseval = re->seen_evals;
8974     if (flags)    
8975         *flags = ((re->extflags & RXf_UTF8) ? 1 : 0);
8976     
8977     if (lp)
8978         *lp = mg->mg_len;
8979     return mg->mg_ptr;
8980 }
8981
8982 /*
8983  - regnext - dig the "next" pointer out of a node
8984  */
8985 regnode *
8986 Perl_regnext(pTHX_ register regnode *p)
8987 {
8988     dVAR;
8989     register I32 offset;
8990
8991     if (!p)
8992         return(NULL);
8993
8994     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
8995     if (offset == 0)
8996         return(NULL);
8997
8998     return(p+offset);
8999 }
9000 #endif
9001
9002 STATIC void     
9003 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
9004 {
9005     va_list args;
9006     STRLEN l1 = strlen(pat1);
9007     STRLEN l2 = strlen(pat2);
9008     char buf[512];
9009     SV *msv;
9010     const char *message;
9011
9012     if (l1 > 510)
9013         l1 = 510;
9014     if (l1 + l2 > 510)
9015         l2 = 510 - l1;
9016     Copy(pat1, buf, l1 , char);
9017     Copy(pat2, buf + l1, l2 , char);
9018     buf[l1 + l2] = '\n';
9019     buf[l1 + l2 + 1] = '\0';
9020 #ifdef I_STDARG
9021     /* ANSI variant takes additional second argument */
9022     va_start(args, pat2);
9023 #else
9024     va_start(args);
9025 #endif
9026     msv = vmess(buf, &args);
9027     va_end(args);
9028     message = SvPV_const(msv,l1);
9029     if (l1 > 512)
9030         l1 = 512;
9031     Copy(message, buf, l1 , char);
9032     buf[l1-1] = '\0';                   /* Overwrite \n */
9033     Perl_croak(aTHX_ "%s", buf);
9034 }
9035
9036 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
9037
9038 #ifndef PERL_IN_XSUB_RE
9039 void
9040 Perl_save_re_context(pTHX)
9041 {
9042     dVAR;
9043
9044     struct re_save_state *state;
9045
9046     SAVEVPTR(PL_curcop);
9047     SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
9048
9049     state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
9050     PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
9051     SSPUSHINT(SAVEt_RE_STATE);
9052
9053     Copy(&PL_reg_state, state, 1, struct re_save_state);
9054
9055     PL_reg_start_tmp = 0;
9056     PL_reg_start_tmpl = 0;
9057     PL_reg_oldsaved = NULL;
9058     PL_reg_oldsavedlen = 0;
9059     PL_reg_maxiter = 0;
9060     PL_reg_leftiter = 0;
9061     PL_reg_poscache = NULL;
9062     PL_reg_poscache_size = 0;
9063 #ifdef PERL_OLD_COPY_ON_WRITE
9064     PL_nrs = NULL;
9065 #endif
9066
9067     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
9068     if (PL_curpm) {
9069         const REGEXP * const rx = PM_GETRE(PL_curpm);
9070         if (rx) {
9071             U32 i;
9072             for (i = 1; i <= rx->nparens; i++) {
9073                 char digits[TYPE_CHARS(long)];
9074                 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
9075                 GV *const *const gvp
9076                     = (GV**)hv_fetch(PL_defstash, digits, len, 0);
9077
9078                 if (gvp) {
9079                     GV * const gv = *gvp;
9080                     if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
9081                         save_scalar(gv);
9082                 }
9083             }
9084         }
9085     }
9086 }
9087 #endif
9088
9089 static void
9090 clear_re(pTHX_ void *r)
9091 {
9092     dVAR;
9093     ReREFCNT_dec((regexp *)r);
9094 }
9095
9096 #ifdef DEBUGGING
9097
9098 STATIC void
9099 S_put_byte(pTHX_ SV *sv, int c)
9100 {
9101     if (isCNTRL(c) || c == 255 || !isPRINT(c))
9102         Perl_sv_catpvf(aTHX_ sv, "\\%o", c);
9103     else if (c == '-' || c == ']' || c == '\\' || c == '^')
9104         Perl_sv_catpvf(aTHX_ sv, "\\%c", c);
9105     else
9106         Perl_sv_catpvf(aTHX_ sv, "%c", c);
9107 }
9108
9109
9110 #define CLEAR_OPTSTART \
9111     if (optstart) STMT_START { \
9112             DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
9113             optstart=NULL; \
9114     } STMT_END
9115
9116 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
9117
9118 STATIC const regnode *
9119 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
9120             const regnode *last, const regnode *plast, 
9121             SV* sv, I32 indent, U32 depth)
9122 {
9123     dVAR;
9124     register U8 op = PSEUDO;    /* Arbitrary non-END op. */
9125     register const regnode *next;
9126     const regnode *optstart= NULL;
9127     
9128     RXi_GET_DECL(r,ri);
9129     GET_RE_DEBUG_FLAGS_DECL;
9130     
9131 #ifdef DEBUG_DUMPUNTIL
9132     PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
9133         last ? last-start : 0,plast ? plast-start : 0);
9134 #endif
9135             
9136     if (plast && plast < last) 
9137         last= plast;
9138
9139     while (PL_regkind[op] != END && (!last || node < last)) {
9140         /* While that wasn't END last time... */
9141         NODE_ALIGN(node);
9142         op = OP(node);
9143         if (op == CLOSE || op == WHILEM)
9144             indent--;
9145         next = regnext((regnode *)node);
9146
9147         /* Where, what. */
9148         if (OP(node) == OPTIMIZED) {
9149             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
9150                 optstart = node;
9151             else
9152                 goto after_print;
9153         } else
9154             CLEAR_OPTSTART;
9155         
9156         regprop(r, sv, node);
9157         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
9158                       (int)(2*indent + 1), "", SvPVX_const(sv));
9159         
9160         if (OP(node) != OPTIMIZED) {                  
9161             if (next == NULL)           /* Next ptr. */
9162                 PerlIO_printf(Perl_debug_log, " (0)");
9163             else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
9164                 PerlIO_printf(Perl_debug_log, " (FAIL)");
9165             else 
9166                 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
9167             (void)PerlIO_putc(Perl_debug_log, '\n'); 
9168         }
9169         
9170       after_print:
9171         if (PL_regkind[(U8)op] == BRANCHJ) {
9172             assert(next);
9173             {
9174                 register const regnode *nnode = (OP(next) == LONGJMP
9175                                              ? regnext((regnode *)next)
9176                                              : next);
9177                 if (last && nnode > last)
9178                     nnode = last;
9179                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
9180             }
9181         }
9182         else if (PL_regkind[(U8)op] == BRANCH) {
9183             assert(next);
9184             DUMPUNTIL(NEXTOPER(node), next);
9185         }
9186         else if ( PL_regkind[(U8)op]  == TRIE ) {
9187             const regnode *this_trie = node;
9188             const char op = OP(node);
9189             const U32 n = ARG(node);
9190             const reg_ac_data * const ac = op>=AHOCORASICK ?
9191                (reg_ac_data *)ri->data->data[n] :
9192                NULL;
9193             const reg_trie_data * const trie =
9194                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
9195 #ifdef DEBUGGING
9196             AV *const trie_words = (AV *) ri->data->data[n + TRIE_WORDS_OFFSET];
9197 #endif
9198             const regnode *nextbranch= NULL;
9199             I32 word_idx;
9200             sv_setpvn(sv, "", 0);
9201             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
9202                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
9203                 
9204                 PerlIO_printf(Perl_debug_log, "%*s%s ",
9205                    (int)(2*(indent+3)), "",
9206                     elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
9207                             PL_colors[0], PL_colors[1],
9208                             (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
9209                             PERL_PV_PRETTY_ELIPSES    |
9210                             PERL_PV_PRETTY_LTGT
9211                             )
9212                             : "???"
9213                 );
9214                 if (trie->jump) {
9215                     U16 dist= trie->jump[word_idx+1];
9216                     PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
9217                                   (UV)((dist ? this_trie + dist : next) - start));
9218                     if (dist) {
9219                         if (!nextbranch)
9220                             nextbranch= this_trie + trie->jump[0];    
9221                         DUMPUNTIL(this_trie + dist, nextbranch);
9222                     }
9223                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
9224                         nextbranch= regnext((regnode *)nextbranch);
9225                 } else {
9226                     PerlIO_printf(Perl_debug_log, "\n");
9227                 }
9228             }
9229             if (last && next > last)
9230                 node= last;
9231             else
9232                 node= next;
9233         }
9234         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
9235             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
9236                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
9237         }
9238         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
9239             assert(next);
9240             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
9241         }
9242         else if ( op == PLUS || op == STAR) {
9243             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
9244         }
9245         else if (op == ANYOF) {
9246             /* arglen 1 + class block */
9247             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_LARGE)
9248                     ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
9249             node = NEXTOPER(node);
9250         }
9251         else if (PL_regkind[(U8)op] == EXACT) {
9252             /* Literal string, where present. */
9253             node += NODE_SZ_STR(node) - 1;
9254             node = NEXTOPER(node);
9255         }
9256         else {
9257             node = NEXTOPER(node);
9258             node += regarglen[(U8)op];
9259         }
9260         if (op == CURLYX || op == OPEN)
9261             indent++;
9262     }
9263     CLEAR_OPTSTART;
9264 #ifdef DEBUG_DUMPUNTIL    
9265     PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
9266 #endif
9267     return node;
9268 }
9269
9270 #endif  /* DEBUGGING */
9271
9272 /*
9273  * Local variables:
9274  * c-indentation-style: bsd
9275  * c-basic-offset: 4
9276  * indent-tabs-mode: t
9277  * End:
9278  *
9279  * ex: set ts=8 sts=4 sw=4 noet:
9280  */