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