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