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