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