]> git.vpit.fr Git - perl/modules/re-engine-Hooks.git/blob - src/5015000/regcomp.c
Fix infinite recursion with perl 5.17.[12]
[perl/modules/re-engine-Hooks.git] / src / 5015000 / regcomp.c
1 /*    regcomp.c
2  */
3
4 /*
5  * 'A fair jaw-cracker dwarf-language must be.'            --Samwise Gamgee
6  *
7  *     [p.285 of _The Lord of the Rings_, II/iii: "The Ring Goes South"]
8  */
9
10 /* This file contains functions for compiling a regular expression.  See
11  * also regexec.c which funnily enough, contains functions for executing
12  * a regular expression.
13  *
14  * This file is also copied at build time to ext/re/re_comp.c, where
15  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
16  * This causes the main functions to be compiled under new names and with
17  * debugging support added, which makes "use re 'debug'" work.
18  */
19
20 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
21  * confused with the original package (see point 3 below).  Thanks, Henry!
22  */
23
24 /* Additional note: this code is very heavily munged from Henry's version
25  * in places.  In some spots I've traded clarity for efficiency, so don't
26  * blame Henry for some of the lack of readability.
27  */
28
29 /* The names of the functions have been changed from regcomp and
30  * regexec to pregcomp and pregexec in order to avoid conflicts
31  * with the POSIX routines of the same names.
32 */
33
34 #ifdef PERL_EXT_RE_BUILD
35 #include "re_top.h"
36 #endif
37
38 /*
39  * pregcomp and pregexec -- regsub and regerror are not used in perl
40  *
41  *      Copyright (c) 1986 by University of Toronto.
42  *      Written by Henry Spencer.  Not derived from licensed software.
43  *
44  *      Permission is granted to anyone to use this software for any
45  *      purpose on any computer system, and to redistribute it freely,
46  *      subject to the following restrictions:
47  *
48  *      1. The author is not responsible for the consequences of use of
49  *              this software, no matter how awful, even if they arise
50  *              from defects in it.
51  *
52  *      2. The origin of this software must not be misrepresented, either
53  *              by explicit claim or by omission.
54  *
55  *      3. Altered versions must be plainly marked as such, and must not
56  *              be misrepresented as being the original software.
57  *
58  *
59  ****    Alterations to Henry's code are...
60  ****
61  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
62  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
63  ****    by Larry Wall and others
64  ****
65  ****    You may distribute under the terms of either the GNU General Public
66  ****    License or the Artistic License, as specified in the README file.
67
68  *
69  * Beware that some of this code is subtly aware of the way operator
70  * precedence is structured in regular expressions.  Serious changes in
71  * regular-expression syntax might require a total rethink.
72  */
73 #include "EXTERN.h"
74 #define PERL_IN_REGCOMP_C
75 #include "perl.h"
76
77 #ifndef PERL_IN_XSUB_RE
78 #include "re_defs.h"
79 #endif
80
81 #define REG_COMP_C
82 #ifdef PERL_IN_XSUB_RE
83 #  include "re_comp.h"
84 #else
85 #  include "regcomp.h"
86 #endif
87
88 #include "dquote_static.c"
89
90 #ifdef op
91 #undef op
92 #endif /* op */
93
94 #ifdef MSDOS
95 #  if defined(BUGGY_MSC6)
96  /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
97 #    pragma optimize("a",off)
98  /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
99 #    pragma optimize("w",on )
100 #  endif /* BUGGY_MSC6 */
101 #endif /* MSDOS */
102
103 #ifndef STATIC
104 #define STATIC  static
105 #endif
106
107 typedef struct RExC_state_t {
108     U32         flags;                  /* are we folding, multilining? */
109     char        *precomp;               /* uncompiled string. */
110     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
111     regexp      *rx;                    /* perl core regexp structure */
112     regexp_internal     *rxi;           /* internal data for regexp object pprivate field */        
113     char        *start;                 /* Start of input for compile */
114     char        *end;                   /* End of input for compile */
115     char        *parse;                 /* Input-scan pointer. */
116     I32         whilem_seen;            /* number of WHILEM in this expr */
117     regnode     *emit_start;            /* Start of emitted-code area */
118     regnode     *emit_bound;            /* First regnode outside of the allocated space */
119     regnode     *emit;                  /* Code-emit pointer; &regdummy = don't = compiling */
120     I32         naughty;                /* How bad is this pattern? */
121     I32         sawback;                /* Did we see \1, ...? */
122     U32         seen;
123     I32         size;                   /* Code size. */
124     I32         npar;                   /* Capture buffer count, (OPEN). */
125     I32         cpar;                   /* Capture buffer count, (CLOSE). */
126     I32         nestroot;               /* root parens we are in - used by accept */
127     I32         extralen;
128     I32         seen_zerolen;
129     I32         seen_evals;
130     regnode     **open_parens;          /* pointers to open parens */
131     regnode     **close_parens;         /* pointers to close parens */
132     regnode     *opend;                 /* END node in program */
133     I32         utf8;           /* whether the pattern is utf8 or not */
134     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
135                                 /* XXX use this for future optimisation of case
136                                  * where pattern must be upgraded to utf8. */
137     I32         uni_semantics;  /* If a d charset modifier should use unicode
138                                    rules, even if the pattern is not in
139                                    utf8 */
140     HV          *paren_names;           /* Paren names */
141     
142     regnode     **recurse;              /* Recurse regops */
143     I32         recurse_count;          /* Number of recurse regops */
144     I32         in_lookbehind;
145     I32         contains_locale;
146     I32         override_recoding;
147 #if ADD_TO_REGEXEC
148     char        *starttry;              /* -Dr: where regtry was called. */
149 #define RExC_starttry   (pRExC_state->starttry)
150 #endif
151 #ifdef DEBUGGING
152     const char  *lastparse;
153     I32         lastnum;
154     AV          *paren_name_list;       /* idx -> name */
155 #define RExC_lastparse  (pRExC_state->lastparse)
156 #define RExC_lastnum    (pRExC_state->lastnum)
157 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
158 #endif
159 } RExC_state_t;
160
161 #define RExC_flags      (pRExC_state->flags)
162 #define RExC_precomp    (pRExC_state->precomp)
163 #define RExC_rx_sv      (pRExC_state->rx_sv)
164 #define RExC_rx         (pRExC_state->rx)
165 #define RExC_rxi        (pRExC_state->rxi)
166 #define RExC_start      (pRExC_state->start)
167 #define RExC_end        (pRExC_state->end)
168 #define RExC_parse      (pRExC_state->parse)
169 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
170 #ifdef RE_TRACK_PATTERN_OFFSETS
171 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the others */
172 #endif
173 #define RExC_emit       (pRExC_state->emit)
174 #define RExC_emit_start (pRExC_state->emit_start)
175 #define RExC_emit_bound (pRExC_state->emit_bound)
176 #define RExC_naughty    (pRExC_state->naughty)
177 #define RExC_sawback    (pRExC_state->sawback)
178 #define RExC_seen       (pRExC_state->seen)
179 #define RExC_size       (pRExC_state->size)
180 #define RExC_npar       (pRExC_state->npar)
181 #define RExC_nestroot   (pRExC_state->nestroot)
182 #define RExC_extralen   (pRExC_state->extralen)
183 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
184 #define RExC_seen_evals (pRExC_state->seen_evals)
185 #define RExC_utf8       (pRExC_state->utf8)
186 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
187 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
188 #define RExC_open_parens        (pRExC_state->open_parens)
189 #define RExC_close_parens       (pRExC_state->close_parens)
190 #define RExC_opend      (pRExC_state->opend)
191 #define RExC_paren_names        (pRExC_state->paren_names)
192 #define RExC_recurse    (pRExC_state->recurse)
193 #define RExC_recurse_count      (pRExC_state->recurse_count)
194 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
195 #define RExC_contains_locale    (pRExC_state->contains_locale)
196 #define RExC_override_recoding  (pRExC_state->override_recoding)
197
198
199 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
200 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
201         ((*s) == '{' && regcurly(s)))
202
203 #ifdef SPSTART
204 #undef SPSTART          /* dratted cpp namespace... */
205 #endif
206 /*
207  * Flags to be passed up and down.
208  */
209 #define WORST           0       /* Worst case. */
210 #define HASWIDTH        0x01    /* Known to match non-null strings. */
211
212 /* Simple enough to be STAR/PLUS operand, in an EXACT node must be a single
213  * character, and if utf8, must be invariant.  Note that this is not the same thing as REGNODE_SIMPLE */
214 #define SIMPLE          0x02
215 #define SPSTART         0x04    /* Starts with * or +. */
216 #define TRYAGAIN        0x08    /* Weeded out a declaration. */
217 #define POSTPONED       0x10    /* (?1),(?&name), (??{...}) or similar */
218
219 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
220
221 /* whether trie related optimizations are enabled */
222 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
223 #define TRIE_STUDY_OPT
224 #define FULL_TRIE_STUDY
225 #define TRIE_STCLASS
226 #endif
227
228
229
230 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
231 #define PBITVAL(paren) (1 << ((paren) & 7))
232 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
233 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
234 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
235
236 /* If not already in utf8, do a longjmp back to the beginning */
237 #define UTF8_LONGJMP 42 /* Choose a value not likely to ever conflict */
238 #define REQUIRE_UTF8    STMT_START {                                       \
239                                      if (! UTF) JMPENV_JUMP(UTF8_LONGJMP); \
240                         } STMT_END
241
242 /* About scan_data_t.
243
244   During optimisation we recurse through the regexp program performing
245   various inplace (keyhole style) optimisations. In addition study_chunk
246   and scan_commit populate this data structure with information about
247   what strings MUST appear in the pattern. We look for the longest 
248   string that must appear at a fixed location, and we look for the
249   longest string that may appear at a floating location. So for instance
250   in the pattern:
251   
252     /FOO[xX]A.*B[xX]BAR/
253     
254   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
255   strings (because they follow a .* construct). study_chunk will identify
256   both FOO and BAR as being the longest fixed and floating strings respectively.
257   
258   The strings can be composites, for instance
259   
260      /(f)(o)(o)/
261      
262   will result in a composite fixed substring 'foo'.
263   
264   For each string some basic information is maintained:
265   
266   - offset or min_offset
267     This is the position the string must appear at, or not before.
268     It also implicitly (when combined with minlenp) tells us how many
269     characters must match before the string we are searching for.
270     Likewise when combined with minlenp and the length of the string it
271     tells us how many characters must appear after the string we have 
272     found.
273   
274   - max_offset
275     Only used for floating strings. This is the rightmost point that
276     the string can appear at. If set to I32 max it indicates that the
277     string can occur infinitely far to the right.
278   
279   - minlenp
280     A pointer to the minimum length of the pattern that the string 
281     was found inside. This is important as in the case of positive 
282     lookahead or positive lookbehind we can have multiple patterns 
283     involved. Consider
284     
285     /(?=FOO).*F/
286     
287     The minimum length of the pattern overall is 3, the minimum length
288     of the lookahead part is 3, but the minimum length of the part that
289     will actually match is 1. So 'FOO's minimum length is 3, but the 
290     minimum length for the F is 1. This is important as the minimum length
291     is used to determine offsets in front of and behind the string being 
292     looked for.  Since strings can be composites this is the length of the
293     pattern at the time it was committed with a scan_commit. Note that
294     the length is calculated by study_chunk, so that the minimum lengths
295     are not known until the full pattern has been compiled, thus the 
296     pointer to the value.
297   
298   - lookbehind
299   
300     In the case of lookbehind the string being searched for can be
301     offset past the start point of the final matching string. 
302     If this value was just blithely removed from the min_offset it would
303     invalidate some of the calculations for how many chars must match
304     before or after (as they are derived from min_offset and minlen and
305     the length of the string being searched for). 
306     When the final pattern is compiled and the data is moved from the
307     scan_data_t structure into the regexp structure the information
308     about lookbehind is factored in, with the information that would 
309     have been lost precalculated in the end_shift field for the 
310     associated string.
311
312   The fields pos_min and pos_delta are used to store the minimum offset
313   and the delta to the maximum offset at the current point in the pattern.    
314
315 */
316
317 typedef struct scan_data_t {
318     /*I32 len_min;      unused */
319     /*I32 len_delta;    unused */
320     I32 pos_min;
321     I32 pos_delta;
322     SV *last_found;
323     I32 last_end;           /* min value, <0 unless valid. */
324     I32 last_start_min;
325     I32 last_start_max;
326     SV **longest;           /* Either &l_fixed, or &l_float. */
327     SV *longest_fixed;      /* longest fixed string found in pattern */
328     I32 offset_fixed;       /* offset where it starts */
329     I32 *minlen_fixed;      /* pointer to the minlen relevant to the string */
330     I32 lookbehind_fixed;   /* is the position of the string modfied by LB */
331     SV *longest_float;      /* longest floating string found in pattern */
332     I32 offset_float_min;   /* earliest point in string it can appear */
333     I32 offset_float_max;   /* latest point in string it can appear */
334     I32 *minlen_float;      /* pointer to the minlen relevant to the string */
335     I32 lookbehind_float;   /* is the position of the string modified by LB */
336     I32 flags;
337     I32 whilem_c;
338     I32 *last_closep;
339     struct regnode_charclass_class *start_class;
340 } scan_data_t;
341
342 /*
343  * Forward declarations for pregcomp()'s friends.
344  */
345
346 static const scan_data_t zero_scan_data =
347   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
348
349 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
350 #define SF_BEFORE_SEOL          0x0001
351 #define SF_BEFORE_MEOL          0x0002
352 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
353 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
354
355 #ifdef NO_UNARY_PLUS
356 #  define SF_FIX_SHIFT_EOL      (0+2)
357 #  define SF_FL_SHIFT_EOL               (0+4)
358 #else
359 #  define SF_FIX_SHIFT_EOL      (+2)
360 #  define SF_FL_SHIFT_EOL               (+4)
361 #endif
362
363 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
364 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
365
366 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
367 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
368 #define SF_IS_INF               0x0040
369 #define SF_HAS_PAR              0x0080
370 #define SF_IN_PAR               0x0100
371 #define SF_HAS_EVAL             0x0200
372 #define SCF_DO_SUBSTR           0x0400
373 #define SCF_DO_STCLASS_AND      0x0800
374 #define SCF_DO_STCLASS_OR       0x1000
375 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
376 #define SCF_WHILEM_VISITED_POS  0x2000
377
378 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
379 #define SCF_SEEN_ACCEPT         0x8000 
380
381 #define UTF cBOOL(RExC_utf8)
382 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
383 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
384 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_DEPENDS_CHARSET)
385 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags) >= REGEX_UNICODE_CHARSET)
386 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_RESTRICTED_CHARSET)
387 #define MORE_ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
388 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags) >= REGEX_ASCII_RESTRICTED_CHARSET)
389
390 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
391
392 #define OOB_UNICODE             12345678
393 #define OOB_NAMEDCLASS          -1
394
395 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
396 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
397
398
399 /* length of regex to show in messages that don't mark a position within */
400 #define RegexLengthToShowInErrorMessages 127
401
402 /*
403  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
404  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
405  * op/pragma/warn/regcomp.
406  */
407 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
408 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
409
410 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
411
412 /*
413  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
414  * arg. Show regex, up to a maximum length. If it's too long, chop and add
415  * "...".
416  */
417 #define _FAIL(code) STMT_START {                                        \
418     const char *ellipses = "";                                          \
419     IV len = RExC_end - RExC_precomp;                                   \
420                                                                         \
421     if (!SIZE_ONLY)                                                     \
422         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);                   \
423     if (len > RegexLengthToShowInErrorMessages) {                       \
424         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
425         len = RegexLengthToShowInErrorMessages - 10;                    \
426         ellipses = "...";                                               \
427     }                                                                   \
428     code;                                                               \
429 } STMT_END
430
431 #define FAIL(msg) _FAIL(                            \
432     Perl_croak(aTHX_ "%s in regex m/%.*s%s/",       \
433             msg, (int)len, RExC_precomp, ellipses))
434
435 #define FAIL2(msg,arg) _FAIL(                       \
436     Perl_croak(aTHX_ msg " in regex m/%.*s%s/",     \
437             arg, (int)len, RExC_precomp, ellipses))
438
439 /*
440  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
441  */
442 #define Simple_vFAIL(m) STMT_START {                                    \
443     const IV offset = RExC_parse - RExC_precomp;                        \
444     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
445             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
446 } STMT_END
447
448 /*
449  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
450  */
451 #define vFAIL(m) STMT_START {                           \
452     if (!SIZE_ONLY)                                     \
453         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);   \
454     Simple_vFAIL(m);                                    \
455 } STMT_END
456
457 /*
458  * Like Simple_vFAIL(), but accepts two arguments.
459  */
460 #define Simple_vFAIL2(m,a1) STMT_START {                        \
461     const IV offset = RExC_parse - RExC_precomp;                        \
462     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1,                   \
463             (int)offset, RExC_precomp, RExC_precomp + offset);  \
464 } STMT_END
465
466 /*
467  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
468  */
469 #define vFAIL2(m,a1) STMT_START {                       \
470     if (!SIZE_ONLY)                                     \
471         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);   \
472     Simple_vFAIL2(m, a1);                               \
473 } STMT_END
474
475
476 /*
477  * Like Simple_vFAIL(), but accepts three arguments.
478  */
479 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
480     const IV offset = RExC_parse - RExC_precomp;                \
481     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2,               \
482             (int)offset, RExC_precomp, RExC_precomp + offset);  \
483 } STMT_END
484
485 /*
486  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
487  */
488 #define vFAIL3(m,a1,a2) STMT_START {                    \
489     if (!SIZE_ONLY)                                     \
490         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);   \
491     Simple_vFAIL3(m, a1, a2);                           \
492 } STMT_END
493
494 /*
495  * Like Simple_vFAIL(), but accepts four arguments.
496  */
497 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
498     const IV offset = RExC_parse - RExC_precomp;                \
499     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3,           \
500             (int)offset, RExC_precomp, RExC_precomp + offset);  \
501 } STMT_END
502
503 #define ckWARNreg(loc,m) STMT_START {                                   \
504     const IV offset = loc - RExC_precomp;                               \
505     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
506             (int)offset, RExC_precomp, RExC_precomp + offset);          \
507 } STMT_END
508
509 #define ckWARNregdep(loc,m) STMT_START {                                \
510     const IV offset = loc - RExC_precomp;                               \
511     Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),     \
512             m REPORT_LOCATION,                                          \
513             (int)offset, RExC_precomp, RExC_precomp + offset);          \
514 } STMT_END
515
516 #define ckWARN2regdep(loc,m, a1) STMT_START {                           \
517     const IV offset = loc - RExC_precomp;                               \
518     Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),     \
519             m REPORT_LOCATION,                                          \
520             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
521 } STMT_END
522
523 #define ckWARN2reg(loc, m, a1) STMT_START {                             \
524     const IV offset = loc - RExC_precomp;                               \
525     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
526             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
527 } STMT_END
528
529 #define vWARN3(loc, m, a1, a2) STMT_START {                             \
530     const IV offset = loc - RExC_precomp;                               \
531     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
532             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
533 } STMT_END
534
535 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                         \
536     const IV offset = loc - RExC_precomp;                               \
537     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
538             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
539 } STMT_END
540
541 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
542     const IV offset = loc - RExC_precomp;                               \
543     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
544             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
545 } STMT_END
546
547 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
548     const IV offset = loc - RExC_precomp;                               \
549     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
550             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
551 } STMT_END
552
553 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
554     const IV offset = loc - RExC_precomp;                               \
555     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
556             a1, a2, a3, a4, (int)offset, RExC_precomp, RExC_precomp + offset); \
557 } STMT_END
558
559
560 /* Allow for side effects in s */
561 #define REGC(c,s) STMT_START {                  \
562     if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
563 } STMT_END
564
565 /* Macros for recording node offsets.   20001227 mjd@plover.com 
566  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
567  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
568  * Element 0 holds the number n.
569  * Position is 1 indexed.
570  */
571 #ifndef RE_TRACK_PATTERN_OFFSETS
572 #define Set_Node_Offset_To_R(node,byte)
573 #define Set_Node_Offset(node,byte)
574 #define Set_Cur_Node_Offset
575 #define Set_Node_Length_To_R(node,len)
576 #define Set_Node_Length(node,len)
577 #define Set_Node_Cur_Length(node)
578 #define Node_Offset(n) 
579 #define Node_Length(n) 
580 #define Set_Node_Offset_Length(node,offset,len)
581 #define ProgLen(ri) ri->u.proglen
582 #define SetProgLen(ri,x) ri->u.proglen = x
583 #else
584 #define ProgLen(ri) ri->u.offsets[0]
585 #define SetProgLen(ri,x) ri->u.offsets[0] = x
586 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
587     if (! SIZE_ONLY) {                                                  \
588         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
589                     __LINE__, (int)(node), (int)(byte)));               \
590         if((node) < 0) {                                                \
591             Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \
592         } else {                                                        \
593             RExC_offsets[2*(node)-1] = (byte);                          \
594         }                                                               \
595     }                                                                   \
596 } STMT_END
597
598 #define Set_Node_Offset(node,byte) \
599     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
600 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
601
602 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
603     if (! SIZE_ONLY) {                                                  \
604         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
605                 __LINE__, (int)(node), (int)(len)));                    \
606         if((node) < 0) {                                                \
607             Perl_croak(aTHX_ "value of node is %d in Length macro", (int)(node)); \
608         } else {                                                        \
609             RExC_offsets[2*(node)] = (len);                             \
610         }                                                               \
611     }                                                                   \
612 } STMT_END
613
614 #define Set_Node_Length(node,len) \
615     Set_Node_Length_To_R((node)-RExC_emit_start, len)
616 #define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
617 #define Set_Node_Cur_Length(node) \
618     Set_Node_Length(node, RExC_parse - parse_start)
619
620 /* Get offsets and lengths */
621 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
622 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
623
624 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
625     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
626     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
627 } STMT_END
628 #endif
629
630 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
631 #define EXPERIMENTAL_INPLACESCAN
632 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
633
634 #define DEBUG_STUDYDATA(str,data,depth)                              \
635 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
636     PerlIO_printf(Perl_debug_log,                                    \
637         "%*s" str "Pos:%"IVdf"/%"IVdf                                \
638         " Flags: 0x%"UVXf" Whilem_c: %"IVdf" Lcp: %"IVdf" %s",       \
639         (int)(depth)*2, "",                                          \
640         (IV)((data)->pos_min),                                       \
641         (IV)((data)->pos_delta),                                     \
642         (UV)((data)->flags),                                         \
643         (IV)((data)->whilem_c),                                      \
644         (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
645         is_inf ? "INF " : ""                                         \
646     );                                                               \
647     if ((data)->last_found)                                          \
648         PerlIO_printf(Perl_debug_log,                                \
649             "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
650             " %sFloat: '%s' @ %"IVdf"/%"IVdf"",                      \
651             SvPVX_const((data)->last_found),                         \
652             (IV)((data)->last_end),                                  \
653             (IV)((data)->last_start_min),                            \
654             (IV)((data)->last_start_max),                            \
655             ((data)->longest &&                                      \
656              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
657             SvPVX_const((data)->longest_fixed),                      \
658             (IV)((data)->offset_fixed),                              \
659             ((data)->longest &&                                      \
660              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
661             SvPVX_const((data)->longest_float),                      \
662             (IV)((data)->offset_float_min),                          \
663             (IV)((data)->offset_float_max)                           \
664         );                                                           \
665     PerlIO_printf(Perl_debug_log,"\n");                              \
666 });
667
668 static void clear_re(pTHX_ void *r);
669
670 /* Mark that we cannot extend a found fixed substring at this point.
671    Update the longest found anchored substring and the longest found
672    floating substrings if needed. */
673
674 STATIC void
675 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp, int is_inf)
676 {
677     const STRLEN l = CHR_SVLEN(data->last_found);
678     const STRLEN old_l = CHR_SVLEN(*data->longest);
679     GET_RE_DEBUG_FLAGS_DECL;
680
681     PERL_ARGS_ASSERT_SCAN_COMMIT;
682
683     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
684         SvSetMagicSV(*data->longest, data->last_found);
685         if (*data->longest == data->longest_fixed) {
686             data->offset_fixed = l ? data->last_start_min : data->pos_min;
687             if (data->flags & SF_BEFORE_EOL)
688                 data->flags
689                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
690             else
691                 data->flags &= ~SF_FIX_BEFORE_EOL;
692             data->minlen_fixed=minlenp; 
693             data->lookbehind_fixed=0;
694         }
695         else { /* *data->longest == data->longest_float */
696             data->offset_float_min = l ? data->last_start_min : data->pos_min;
697             data->offset_float_max = (l
698                                       ? data->last_start_max
699                                       : data->pos_min + data->pos_delta);
700             if (is_inf || (U32)data->offset_float_max > (U32)I32_MAX)
701                 data->offset_float_max = I32_MAX;
702             if (data->flags & SF_BEFORE_EOL)
703                 data->flags
704                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
705             else
706                 data->flags &= ~SF_FL_BEFORE_EOL;
707             data->minlen_float=minlenp;
708             data->lookbehind_float=0;
709         }
710     }
711     SvCUR_set(data->last_found, 0);
712     {
713         SV * const sv = data->last_found;
714         if (SvUTF8(sv) && SvMAGICAL(sv)) {
715             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
716             if (mg)
717                 mg->mg_len = 0;
718         }
719     }
720     data->last_end = -1;
721     data->flags &= ~SF_BEFORE_EOL;
722     DEBUG_STUDYDATA("commit: ",data,0);
723 }
724
725 /* Can match anything (initialization) */
726 STATIC void
727 S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
728 {
729     PERL_ARGS_ASSERT_CL_ANYTHING;
730
731     ANYOF_BITMAP_SETALL(cl);
732     cl->flags = ANYOF_CLASS|ANYOF_EOS|ANYOF_UNICODE_ALL
733                 |ANYOF_LOC_NONBITMAP_FOLD|ANYOF_NON_UTF8_LATIN1_ALL;
734
735     /* If any portion of the regex is to operate under locale rules,
736      * initialization includes it.  The reason this isn't done for all regexes
737      * is that the optimizer was written under the assumption that locale was
738      * all-or-nothing.  Given the complexity and lack of documentation in the
739      * optimizer, and that there are inadequate test cases for locale, so many
740      * parts of it may not work properly, it is safest to avoid locale unless
741      * necessary. */
742     if (RExC_contains_locale) {
743         ANYOF_CLASS_SETALL(cl);     /* /l uses class */
744         cl->flags |= ANYOF_LOCALE;
745     }
746     else {
747         ANYOF_CLASS_ZERO(cl);       /* Only /l uses class now */
748     }
749 }
750
751 /* Can match anything (initialization) */
752 STATIC int
753 S_cl_is_anything(const struct regnode_charclass_class *cl)
754 {
755     int value;
756
757     PERL_ARGS_ASSERT_CL_IS_ANYTHING;
758
759     for (value = 0; value <= ANYOF_MAX; value += 2)
760         if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
761             return 1;
762     if (!(cl->flags & ANYOF_UNICODE_ALL))
763         return 0;
764     if (!ANYOF_BITMAP_TESTALLSET((const void*)cl))
765         return 0;
766     return 1;
767 }
768
769 /* Can match anything (initialization) */
770 STATIC void
771 S_cl_init(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
772 {
773     PERL_ARGS_ASSERT_CL_INIT;
774
775     Zero(cl, 1, struct regnode_charclass_class);
776     cl->type = ANYOF;
777     cl_anything(pRExC_state, cl);
778     ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
779 }
780
781 /* These two functions currently do the exact same thing */
782 #define cl_init_zero            S_cl_init
783
784 /* 'AND' a given class with another one.  Can create false positives.  'cl'
785  * should not be inverted.  'and_with->flags & ANYOF_CLASS' should be 0 if
786  * 'and_with' is a regnode_charclass instead of a regnode_charclass_class. */
787 STATIC void
788 S_cl_and(struct regnode_charclass_class *cl,
789         const struct regnode_charclass_class *and_with)
790 {
791     PERL_ARGS_ASSERT_CL_AND;
792
793     assert(and_with->type == ANYOF);
794
795     /* I (khw) am not sure all these restrictions are necessary XXX */
796     if (!(ANYOF_CLASS_TEST_ANY_SET(and_with))
797         && !(ANYOF_CLASS_TEST_ANY_SET(cl))
798         && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
799         && !(and_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
800         && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) {
801         int i;
802
803         if (and_with->flags & ANYOF_INVERT)
804             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
805                 cl->bitmap[i] &= ~and_with->bitmap[i];
806         else
807             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
808                 cl->bitmap[i] &= and_with->bitmap[i];
809     } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
810
811     if (and_with->flags & ANYOF_INVERT) {
812
813         /* Here, the and'ed node is inverted.  Get the AND of the flags that
814          * aren't affected by the inversion.  Those that are affected are
815          * handled individually below */
816         U8 affected_flags = cl->flags & ~INVERSION_UNAFFECTED_FLAGS;
817         cl->flags &= (and_with->flags & INVERSION_UNAFFECTED_FLAGS);
818         cl->flags |= affected_flags;
819
820         /* We currently don't know how to deal with things that aren't in the
821          * bitmap, but we know that the intersection is no greater than what
822          * is already in cl, so let there be false positives that get sorted
823          * out after the synthetic start class succeeds, and the node is
824          * matched for real. */
825
826         /* The inversion of these two flags indicate that the resulting
827          * intersection doesn't have them */
828         if (and_with->flags & ANYOF_UNICODE_ALL) {
829             cl->flags &= ~ANYOF_UNICODE_ALL;
830         }
831         if (and_with->flags & ANYOF_NON_UTF8_LATIN1_ALL) {
832             cl->flags &= ~ANYOF_NON_UTF8_LATIN1_ALL;
833         }
834     }
835     else {   /* and'd node is not inverted */
836         U8 outside_bitmap_but_not_utf8; /* Temp variable */
837
838         if (! ANYOF_NONBITMAP(and_with)) {
839
840             /* Here 'and_with' doesn't match anything outside the bitmap
841              * (except possibly ANYOF_UNICODE_ALL), which means the
842              * intersection can't either, except for ANYOF_UNICODE_ALL, in
843              * which case we don't know what the intersection is, but it's no
844              * greater than what cl already has, so can just leave it alone,
845              * with possible false positives */
846             if (! (and_with->flags & ANYOF_UNICODE_ALL)) {
847                 ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
848                 cl->flags &= ~ANYOF_NONBITMAP_NON_UTF8;
849             }
850         }
851         else if (! ANYOF_NONBITMAP(cl)) {
852
853             /* Here, 'and_with' does match something outside the bitmap, and cl
854              * doesn't have a list of things to match outside the bitmap.  If
855              * cl can match all code points above 255, the intersection will
856              * be those above-255 code points that 'and_with' matches.  If cl
857              * can't match all Unicode code points, it means that it can't
858              * match anything outside the bitmap (since the 'if' that got us
859              * into this block tested for that), so we leave the bitmap empty.
860              */
861             if (cl->flags & ANYOF_UNICODE_ALL) {
862                 ARG_SET(cl, ARG(and_with));
863
864                 /* and_with's ARG may match things that don't require UTF8.
865                  * And now cl's will too, in spite of this being an 'and'.  See
866                  * the comments below about the kludge */
867                 cl->flags |= and_with->flags & ANYOF_NONBITMAP_NON_UTF8;
868             }
869         }
870         else {
871             /* Here, both 'and_with' and cl match something outside the
872              * bitmap.  Currently we do not do the intersection, so just match
873              * whatever cl had at the beginning.  */
874         }
875
876
877         /* Take the intersection of the two sets of flags.  However, the
878          * ANYOF_NONBITMAP_NON_UTF8 flag is treated as an 'or'.  This is a
879          * kludge around the fact that this flag is not treated like the others
880          * which are initialized in cl_anything().  The way the optimizer works
881          * is that the synthetic start class (SSC) is initialized to match
882          * anything, and then the first time a real node is encountered, its
883          * values are AND'd with the SSC's with the result being the values of
884          * the real node.  However, there are paths through the optimizer where
885          * the AND never gets called, so those initialized bits are set
886          * inappropriately, which is not usually a big deal, as they just cause
887          * false positives in the SSC, which will just mean a probably
888          * imperceptible slow down in execution.  However this bit has a
889          * higher false positive consequence in that it can cause utf8.pm,
890          * utf8_heavy.pl ... to be loaded when not necessary, which is a much
891          * bigger slowdown and also causes significant extra memory to be used.
892          * In order to prevent this, the code now takes a different tack.  The
893          * bit isn't set unless some part of the regular expression needs it,
894          * but once set it won't get cleared.  This means that these extra
895          * modules won't get loaded unless there was some path through the
896          * pattern that would have required them anyway, and  so any false
897          * positives that occur by not ANDing them out when they could be
898          * aren't as severe as they would be if we treated this bit like all
899          * the others */
900         outside_bitmap_but_not_utf8 = (cl->flags | and_with->flags)
901                                       & ANYOF_NONBITMAP_NON_UTF8;
902         cl->flags &= and_with->flags;
903         cl->flags |= outside_bitmap_but_not_utf8;
904     }
905 }
906
907 /* 'OR' a given class with another one.  Can create false positives.  'cl'
908  * should not be inverted.  'or_with->flags & ANYOF_CLASS' should be 0 if
909  * 'or_with' is a regnode_charclass instead of a regnode_charclass_class. */
910 STATIC void
911 S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
912 {
913     PERL_ARGS_ASSERT_CL_OR;
914
915     if (or_with->flags & ANYOF_INVERT) {
916
917         /* Here, the or'd node is to be inverted.  This means we take the
918          * complement of everything not in the bitmap, but currently we don't
919          * know what that is, so give up and match anything */
920         if (ANYOF_NONBITMAP(or_with)) {
921             cl_anything(pRExC_state, cl);
922         }
923         /* We do not use
924          * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
925          *   <= (B1 | !B2) | (CL1 | !CL2)
926          * which is wasteful if CL2 is small, but we ignore CL2:
927          *   (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
928          * XXXX Can we handle case-fold?  Unclear:
929          *   (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
930          *   (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
931          */
932         else if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
933              && !(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
934              && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD) ) {
935             int i;
936
937             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
938                 cl->bitmap[i] |= ~or_with->bitmap[i];
939         } /* XXXX: logic is complicated otherwise */
940         else {
941             cl_anything(pRExC_state, cl);
942         }
943
944         /* And, we can just take the union of the flags that aren't affected
945          * by the inversion */
946         cl->flags |= or_with->flags & INVERSION_UNAFFECTED_FLAGS;
947
948         /* For the remaining flags:
949             ANYOF_UNICODE_ALL and inverted means to not match anything above
950                     255, which means that the union with cl should just be
951                     what cl has in it, so can ignore this flag
952             ANYOF_NON_UTF8_LATIN1_ALL and inverted means if not utf8 and ord
953                     is 127-255 to match them, but then invert that, so the
954                     union with cl should just be what cl has in it, so can
955                     ignore this flag
956          */
957     } else {    /* 'or_with' is not inverted */
958         /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
959         if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
960              && (!(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
961                  || (cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) ) {
962             int i;
963
964             /* OR char bitmap and class bitmap separately */
965             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
966                 cl->bitmap[i] |= or_with->bitmap[i];
967             if (ANYOF_CLASS_TEST_ANY_SET(or_with)) {
968                 for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++)
969                     cl->classflags[i] |= or_with->classflags[i];
970                 cl->flags |= ANYOF_CLASS;
971             }
972         }
973         else { /* XXXX: logic is complicated, leave it along for a moment. */
974             cl_anything(pRExC_state, cl);
975         }
976
977         if (ANYOF_NONBITMAP(or_with)) {
978
979             /* Use the added node's outside-the-bit-map match if there isn't a
980              * conflict.  If there is a conflict (both nodes match something
981              * outside the bitmap, but what they match outside is not the same
982              * pointer, and hence not easily compared until XXX we extend
983              * inversion lists this far), give up and allow the start class to
984              * match everything outside the bitmap.  If that stuff is all above
985              * 255, can just set UNICODE_ALL, otherwise caould be anything. */
986             if (! ANYOF_NONBITMAP(cl)) {
987                 ARG_SET(cl, ARG(or_with));
988             }
989             else if (ARG(cl) != ARG(or_with)) {
990
991                 if ((or_with->flags & ANYOF_NONBITMAP_NON_UTF8)) {
992                     cl_anything(pRExC_state, cl);
993                 }
994                 else {
995                     cl->flags |= ANYOF_UNICODE_ALL;
996                 }
997             }
998         }
999
1000         /* Take the union */
1001         cl->flags |= or_with->flags;
1002     }
1003 }
1004
1005 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1006 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
1007 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1008 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list ? (TRIE_LIST_CUR( idx ) - 1) : 0 )
1009
1010
1011 #ifdef DEBUGGING
1012 /*
1013    dump_trie(trie,widecharmap,revcharmap)
1014    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1015    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1016
1017    These routines dump out a trie in a somewhat readable format.
1018    The _interim_ variants are used for debugging the interim
1019    tables that are used to generate the final compressed
1020    representation which is what dump_trie expects.
1021
1022    Part of the reason for their existence is to provide a form
1023    of documentation as to how the different representations function.
1024
1025 */
1026
1027 /*
1028   Dumps the final compressed table form of the trie to Perl_debug_log.
1029   Used for debugging make_trie().
1030 */
1031
1032 STATIC void
1033 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1034             AV *revcharmap, U32 depth)
1035 {
1036     U32 state;
1037     SV *sv=sv_newmortal();
1038     int colwidth= widecharmap ? 6 : 4;
1039     U16 word;
1040     GET_RE_DEBUG_FLAGS_DECL;
1041
1042     PERL_ARGS_ASSERT_DUMP_TRIE;
1043
1044     PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
1045         (int)depth * 2 + 2,"",
1046         "Match","Base","Ofs" );
1047
1048     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1049         SV ** const tmp = av_fetch( revcharmap, state, 0);
1050         if ( tmp ) {
1051             PerlIO_printf( Perl_debug_log, "%*s", 
1052                 colwidth,
1053                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1054                             PL_colors[0], PL_colors[1],
1055                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1056                             PERL_PV_ESCAPE_FIRSTCHAR 
1057                 ) 
1058             );
1059         }
1060     }
1061     PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
1062         (int)depth * 2 + 2,"");
1063
1064     for( state = 0 ; state < trie->uniquecharcount ; state++ )
1065         PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
1066     PerlIO_printf( Perl_debug_log, "\n");
1067
1068     for( state = 1 ; state < trie->statecount ; state++ ) {
1069         const U32 base = trie->states[ state ].trans.base;
1070
1071         PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state);
1072
1073         if ( trie->states[ state ].wordnum ) {
1074             PerlIO_printf( Perl_debug_log, " W%4X", trie->states[ state ].wordnum );
1075         } else {
1076             PerlIO_printf( Perl_debug_log, "%6s", "" );
1077         }
1078
1079         PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
1080
1081         if ( base ) {
1082             U32 ofs = 0;
1083
1084             while( ( base + ofs  < trie->uniquecharcount ) ||
1085                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
1086                      && trie->trans[ base + ofs - trie->uniquecharcount ].check != state))
1087                     ofs++;
1088
1089             PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
1090
1091             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
1092                 if ( ( base + ofs >= trie->uniquecharcount ) &&
1093                      ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
1094                      trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
1095                 {
1096                    PerlIO_printf( Perl_debug_log, "%*"UVXf,
1097                     colwidth,
1098                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
1099                 } else {
1100                     PerlIO_printf( Perl_debug_log, "%*s",colwidth,"   ." );
1101                 }
1102             }
1103
1104             PerlIO_printf( Perl_debug_log, "]");
1105
1106         }
1107         PerlIO_printf( Perl_debug_log, "\n" );
1108     }
1109     PerlIO_printf(Perl_debug_log, "%*sword_info N:(prev,len)=", (int)depth*2, "");
1110     for (word=1; word <= trie->wordcount; word++) {
1111         PerlIO_printf(Perl_debug_log, " %d:(%d,%d)",
1112             (int)word, (int)(trie->wordinfo[word].prev),
1113             (int)(trie->wordinfo[word].len));
1114     }
1115     PerlIO_printf(Perl_debug_log, "\n" );
1116 }    
1117 /*
1118   Dumps a fully constructed but uncompressed trie in list form.
1119   List tries normally only are used for construction when the number of 
1120   possible chars (trie->uniquecharcount) is very high.
1121   Used for debugging make_trie().
1122 */
1123 STATIC void
1124 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
1125                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
1126                          U32 depth)
1127 {
1128     U32 state;
1129     SV *sv=sv_newmortal();
1130     int colwidth= widecharmap ? 6 : 4;
1131     GET_RE_DEBUG_FLAGS_DECL;
1132
1133     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
1134
1135     /* print out the table precompression.  */
1136     PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
1137         (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
1138         "------:-----+-----------------\n" );
1139     
1140     for( state=1 ; state < next_alloc ; state ++ ) {
1141         U16 charid;
1142     
1143         PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
1144             (int)depth * 2 + 2,"", (UV)state  );
1145         if ( ! trie->states[ state ].wordnum ) {
1146             PerlIO_printf( Perl_debug_log, "%5s| ","");
1147         } else {
1148             PerlIO_printf( Perl_debug_log, "W%4x| ",
1149                 trie->states[ state ].wordnum
1150             );
1151         }
1152         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
1153             SV ** const tmp = av_fetch( revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
1154             if ( tmp ) {
1155                 PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
1156                     colwidth,
1157                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1158                             PL_colors[0], PL_colors[1],
1159                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1160                             PERL_PV_ESCAPE_FIRSTCHAR 
1161                     ) ,
1162                     TRIE_LIST_ITEM(state,charid).forid,
1163                     (UV)TRIE_LIST_ITEM(state,charid).newstate
1164                 );
1165                 if (!(charid % 10)) 
1166                     PerlIO_printf(Perl_debug_log, "\n%*s| ",
1167                         (int)((depth * 2) + 14), "");
1168             }
1169         }
1170         PerlIO_printf( Perl_debug_log, "\n");
1171     }
1172 }    
1173
1174 /*
1175   Dumps a fully constructed but uncompressed trie in table form.
1176   This is the normal DFA style state transition table, with a few 
1177   twists to facilitate compression later. 
1178   Used for debugging make_trie().
1179 */
1180 STATIC void
1181 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
1182                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
1183                           U32 depth)
1184 {
1185     U32 state;
1186     U16 charid;
1187     SV *sv=sv_newmortal();
1188     int colwidth= widecharmap ? 6 : 4;
1189     GET_RE_DEBUG_FLAGS_DECL;
1190
1191     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
1192     
1193     /*
1194        print out the table precompression so that we can do a visual check
1195        that they are identical.
1196      */
1197     
1198     PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
1199
1200     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1201         SV ** const tmp = av_fetch( revcharmap, charid, 0);
1202         if ( tmp ) {
1203             PerlIO_printf( Perl_debug_log, "%*s", 
1204                 colwidth,
1205                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1206                             PL_colors[0], PL_colors[1],
1207                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1208                             PERL_PV_ESCAPE_FIRSTCHAR 
1209                 ) 
1210             );
1211         }
1212     }
1213
1214     PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
1215
1216     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
1217         PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
1218     }
1219
1220     PerlIO_printf( Perl_debug_log, "\n" );
1221
1222     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
1223
1224         PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ", 
1225             (int)depth * 2 + 2,"",
1226             (UV)TRIE_NODENUM( state ) );
1227
1228         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1229             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
1230             if (v)
1231                 PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
1232             else
1233                 PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
1234         }
1235         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1236             PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check );
1237         } else {
1238             PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n", (UV)trie->trans[ state ].check,
1239             trie->states[ TRIE_NODENUM( state ) ].wordnum );
1240         }
1241     }
1242 }
1243
1244 #endif
1245
1246
1247 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
1248   startbranch: the first branch in the whole branch sequence
1249   first      : start branch of sequence of branch-exact nodes.
1250                May be the same as startbranch
1251   last       : Thing following the last branch.
1252                May be the same as tail.
1253   tail       : item following the branch sequence
1254   count      : words in the sequence
1255   flags      : currently the OP() type we will be building one of /EXACT(|F|Fl)/
1256   depth      : indent depth
1257
1258 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
1259
1260 A trie is an N'ary tree where the branches are determined by digital
1261 decomposition of the key. IE, at the root node you look up the 1st character and
1262 follow that branch repeat until you find the end of the branches. Nodes can be
1263 marked as "accepting" meaning they represent a complete word. Eg:
1264
1265   /he|she|his|hers/
1266
1267 would convert into the following structure. Numbers represent states, letters
1268 following numbers represent valid transitions on the letter from that state, if
1269 the number is in square brackets it represents an accepting state, otherwise it
1270 will be in parenthesis.
1271
1272       +-h->+-e->[3]-+-r->(8)-+-s->[9]
1273       |    |
1274       |   (2)
1275       |    |
1276      (1)   +-i->(6)-+-s->[7]
1277       |
1278       +-s->(3)-+-h->(4)-+-e->[5]
1279
1280       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
1281
1282 This shows that when matching against the string 'hers' we will begin at state 1
1283 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
1284 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
1285 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
1286 single traverse. We store a mapping from accepting to state to which word was
1287 matched, and then when we have multiple possibilities we try to complete the
1288 rest of the regex in the order in which they occured in the alternation.
1289
1290 The only prior NFA like behaviour that would be changed by the TRIE support is
1291 the silent ignoring of duplicate alternations which are of the form:
1292
1293  / (DUPE|DUPE) X? (?{ ... }) Y /x
1294
1295 Thus EVAL blocks following a trie may be called a different number of times with
1296 and without the optimisation. With the optimisations dupes will be silently
1297 ignored. This inconsistent behaviour of EVAL type nodes is well established as
1298 the following demonstrates:
1299
1300  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
1301
1302 which prints out 'word' three times, but
1303
1304  'words'=~/(word|word|word)(?{ print $1 })S/
1305
1306 which doesnt print it out at all. This is due to other optimisations kicking in.
1307
1308 Example of what happens on a structural level:
1309
1310 The regexp /(ac|ad|ab)+/ will produce the following debug output:
1311
1312    1: CURLYM[1] {1,32767}(18)
1313    5:   BRANCH(8)
1314    6:     EXACT <ac>(16)
1315    8:   BRANCH(11)
1316    9:     EXACT <ad>(16)
1317   11:   BRANCH(14)
1318   12:     EXACT <ab>(16)
1319   16:   SUCCEED(0)
1320   17:   NOTHING(18)
1321   18: END(0)
1322
1323 This would be optimizable with startbranch=5, first=5, last=16, tail=16
1324 and should turn into:
1325
1326    1: CURLYM[1] {1,32767}(18)
1327    5:   TRIE(16)
1328         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
1329           <ac>
1330           <ad>
1331           <ab>
1332   16:   SUCCEED(0)
1333   17:   NOTHING(18)
1334   18: END(0)
1335
1336 Cases where tail != last would be like /(?foo|bar)baz/:
1337
1338    1: BRANCH(4)
1339    2:   EXACT <foo>(8)
1340    4: BRANCH(7)
1341    5:   EXACT <bar>(8)
1342    7: TAIL(8)
1343    8: EXACT <baz>(10)
1344   10: END(0)
1345
1346 which would be optimizable with startbranch=1, first=1, last=7, tail=8
1347 and would end up looking like:
1348
1349     1: TRIE(8)
1350       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
1351         <foo>
1352         <bar>
1353    7: TAIL(8)
1354    8: EXACT <baz>(10)
1355   10: END(0)
1356
1357     d = uvuni_to_utf8_flags(d, uv, 0);
1358
1359 is the recommended Unicode-aware way of saying
1360
1361     *(d++) = uv;
1362 */
1363
1364 #define TRIE_STORE_REVCHAR                                                 \
1365     STMT_START {                                                           \
1366         if (UTF) {                                                         \
1367             SV *zlopp = newSV(2);                                          \
1368             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
1369             unsigned const char *const kapow = uvuni_to_utf8(flrbbbbb, uvc & 0xFF); \
1370             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
1371             SvPOK_on(zlopp);                                               \
1372             SvUTF8_on(zlopp);                                              \
1373             av_push(revcharmap, zlopp);                                    \
1374         } else {                                                           \
1375             char ooooff = (char)uvc;                                               \
1376             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
1377         }                                                                  \
1378         } STMT_END
1379
1380 #define TRIE_READ_CHAR STMT_START {                                           \
1381     wordlen++;                                                                \
1382     if ( UTF ) {                                                              \
1383         if ( folder ) {                                                       \
1384             if ( foldlen > 0 ) {                                              \
1385                uvc = utf8n_to_uvuni( scan, UTF8_MAXLEN, &len, uniflags );     \
1386                foldlen -= len;                                                \
1387                scan += len;                                                   \
1388                len = 0;                                                       \
1389             } else {                                                          \
1390                 uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
1391                 uvc = to_uni_fold( uvc, foldbuf, &foldlen );                  \
1392                 foldlen -= UNISKIP( uvc );                                    \
1393                 scan = foldbuf + UNISKIP( uvc );                              \
1394             }                                                                 \
1395         } else {                                                              \
1396             uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
1397         }                                                                     \
1398     } else {                                                                  \
1399         uvc = (U32)*uc;                                                       \
1400         len = 1;                                                              \
1401     }                                                                         \
1402 } STMT_END
1403
1404
1405
1406 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
1407     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
1408         U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
1409         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
1410     }                                                           \
1411     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
1412     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
1413     TRIE_LIST_CUR( state )++;                                   \
1414 } STMT_END
1415
1416 #define TRIE_LIST_NEW(state) STMT_START {                       \
1417     Newxz( trie->states[ state ].trans.list,               \
1418         4, reg_trie_trans_le );                                 \
1419      TRIE_LIST_CUR( state ) = 1;                                \
1420      TRIE_LIST_LEN( state ) = 4;                                \
1421 } STMT_END
1422
1423 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
1424     U16 dupe= trie->states[ state ].wordnum;                    \
1425     regnode * const noper_next = regnext( noper );              \
1426                                                                 \
1427     DEBUG_r({                                                   \
1428         /* store the word for dumping */                        \
1429         SV* tmp;                                                \
1430         if (OP(noper) != NOTHING)                               \
1431             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
1432         else                                                    \
1433             tmp = newSVpvn_utf8( "", 0, UTF );                  \
1434         av_push( trie_words, tmp );                             \
1435     });                                                         \
1436                                                                 \
1437     curword++;                                                  \
1438     trie->wordinfo[curword].prev   = 0;                         \
1439     trie->wordinfo[curword].len    = wordlen;                   \
1440     trie->wordinfo[curword].accept = state;                     \
1441                                                                 \
1442     if ( noper_next < tail ) {                                  \
1443         if (!trie->jump)                                        \
1444             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, sizeof(U16) ); \
1445         trie->jump[curword] = (U16)(noper_next - convert);      \
1446         if (!jumper)                                            \
1447             jumper = noper_next;                                \
1448         if (!nextbranch)                                        \
1449             nextbranch= regnext(cur);                           \
1450     }                                                           \
1451                                                                 \
1452     if ( dupe ) {                                               \
1453         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
1454         /* chain, so that when the bits of chain are later    */\
1455         /* linked together, the dups appear in the chain      */\
1456         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
1457         trie->wordinfo[dupe].prev = curword;                    \
1458     } else {                                                    \
1459         /* we haven't inserted this word yet.                */ \
1460         trie->states[ state ].wordnum = curword;                \
1461     }                                                           \
1462 } STMT_END
1463
1464
1465 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
1466      ( ( base + charid >=  ucharcount                                   \
1467          && base + charid < ubound                                      \
1468          && state == trie->trans[ base - ucharcount + charid ].check    \
1469          && trie->trans[ base - ucharcount + charid ].next )            \
1470            ? trie->trans[ base - ucharcount + charid ].next             \
1471            : ( state==1 ? special : 0 )                                 \
1472       )
1473
1474 #define MADE_TRIE       1
1475 #define MADE_JUMP_TRIE  2
1476 #define MADE_EXACT_TRIE 4
1477
1478 STATIC I32
1479 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth)
1480 {
1481     dVAR;
1482     /* first pass, loop through and scan words */
1483     reg_trie_data *trie;
1484     HV *widecharmap = NULL;
1485     AV *revcharmap = newAV();
1486     regnode *cur;
1487     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1488     STRLEN len = 0;
1489     UV uvc = 0;
1490     U16 curword = 0;
1491     U32 next_alloc = 0;
1492     regnode *jumper = NULL;
1493     regnode *nextbranch = NULL;
1494     regnode *convert = NULL;
1495     U32 *prev_states; /* temp array mapping each state to previous one */
1496     /* we just use folder as a flag in utf8 */
1497     const U8 * folder = NULL;
1498
1499 #ifdef DEBUGGING
1500     const U32 data_slot = add_data( pRExC_state, 4, "tuuu" );
1501     AV *trie_words = NULL;
1502     /* along with revcharmap, this only used during construction but both are
1503      * useful during debugging so we store them in the struct when debugging.
1504      */
1505 #else
1506     const U32 data_slot = add_data( pRExC_state, 2, "tu" );
1507     STRLEN trie_charcount=0;
1508 #endif
1509     SV *re_trie_maxbuff;
1510     GET_RE_DEBUG_FLAGS_DECL;
1511
1512     PERL_ARGS_ASSERT_MAKE_TRIE;
1513 #ifndef DEBUGGING
1514     PERL_UNUSED_ARG(depth);
1515 #endif
1516
1517     switch (flags) {
1518         case EXACTFA:
1519         case EXACTFU: folder = PL_fold_latin1; break;
1520         case EXACTF:  folder = PL_fold; break;
1521         case EXACTFL: folder = PL_fold_locale; break;
1522     }
1523
1524     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
1525     trie->refcount = 1;
1526     trie->startstate = 1;
1527     trie->wordcount = word_count;
1528     RExC_rxi->data->data[ data_slot ] = (void*)trie;
1529     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
1530     if (!(UTF && folder))
1531         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
1532     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
1533                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
1534
1535     DEBUG_r({
1536         trie_words = newAV();
1537     });
1538
1539     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
1540     if (!SvIOK(re_trie_maxbuff)) {
1541         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
1542     }
1543     DEBUG_OPTIMISE_r({
1544                 PerlIO_printf( Perl_debug_log,
1545                   "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
1546                   (int)depth * 2 + 2, "", 
1547                   REG_NODE_NUM(startbranch),REG_NODE_NUM(first), 
1548                   REG_NODE_NUM(last), REG_NODE_NUM(tail),
1549                   (int)depth);
1550     });
1551    
1552    /* Find the node we are going to overwrite */
1553     if ( first == startbranch && OP( last ) != BRANCH ) {
1554         /* whole branch chain */
1555         convert = first;
1556     } else {
1557         /* branch sub-chain */
1558         convert = NEXTOPER( first );
1559     }
1560         
1561     /*  -- First loop and Setup --
1562
1563        We first traverse the branches and scan each word to determine if it
1564        contains widechars, and how many unique chars there are, this is
1565        important as we have to build a table with at least as many columns as we
1566        have unique chars.
1567
1568        We use an array of integers to represent the character codes 0..255
1569        (trie->charmap) and we use a an HV* to store Unicode characters. We use the
1570        native representation of the character value as the key and IV's for the
1571        coded index.
1572
1573        *TODO* If we keep track of how many times each character is used we can
1574        remap the columns so that the table compression later on is more
1575        efficient in terms of memory by ensuring the most common value is in the
1576        middle and the least common are on the outside.  IMO this would be better
1577        than a most to least common mapping as theres a decent chance the most
1578        common letter will share a node with the least common, meaning the node
1579        will not be compressible. With a middle is most common approach the worst
1580        case is when we have the least common nodes twice.
1581
1582      */
1583
1584     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1585         regnode * const noper = NEXTOPER( cur );
1586         const U8 *uc = (U8*)STRING( noper );
1587         const U8 * const e  = uc + STR_LEN( noper );
1588         STRLEN foldlen = 0;
1589         U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1590         const U8 *scan = (U8*)NULL;
1591         U32 wordlen      = 0;         /* required init */
1592         STRLEN chars = 0;
1593         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the bitmap?*/
1594
1595         if (OP(noper) == NOTHING) {
1596             trie->minlen= 0;
1597             continue;
1598         }
1599         if ( set_bit ) /* bitmap only alloced when !(UTF&&Folding) */
1600             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
1601                                           regardless of encoding */
1602
1603         for ( ; uc < e ; uc += len ) {
1604             TRIE_CHARCOUNT(trie)++;
1605             TRIE_READ_CHAR;
1606             chars++;
1607             if ( uvc < 256 ) {
1608                 if ( !trie->charmap[ uvc ] ) {
1609                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
1610                     if ( folder )
1611                         trie->charmap[ folder[ uvc ] ] = trie->charmap[ uvc ];
1612                     TRIE_STORE_REVCHAR;
1613                 }
1614                 if ( set_bit ) {
1615                     /* store the codepoint in the bitmap, and its folded
1616                      * equivalent. */
1617                     TRIE_BITMAP_SET(trie,uvc);
1618
1619                     /* store the folded codepoint */
1620                     if ( folder ) TRIE_BITMAP_SET(trie,folder[ uvc ]);
1621
1622                     if ( !UTF ) {
1623                         /* store first byte of utf8 representation of
1624                            variant codepoints */
1625                         if (! UNI_IS_INVARIANT(uvc)) {
1626                             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));
1627                         }
1628                     }
1629                     set_bit = 0; /* We've done our bit :-) */
1630                 }
1631             } else {
1632                 SV** svpp;
1633                 if ( !widecharmap )
1634                     widecharmap = newHV();
1635
1636                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
1637
1638                 if ( !svpp )
1639                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
1640
1641                 if ( !SvTRUE( *svpp ) ) {
1642                     sv_setiv( *svpp, ++trie->uniquecharcount );
1643                     TRIE_STORE_REVCHAR;
1644                 }
1645             }
1646         }
1647         if( cur == first ) {
1648             trie->minlen=chars;
1649             trie->maxlen=chars;
1650         } else if (chars < trie->minlen) {
1651             trie->minlen=chars;
1652         } else if (chars > trie->maxlen) {
1653             trie->maxlen=chars;
1654         }
1655
1656     } /* end first pass */
1657     DEBUG_TRIE_COMPILE_r(
1658         PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
1659                 (int)depth * 2 + 2,"",
1660                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
1661                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
1662                 (int)trie->minlen, (int)trie->maxlen )
1663     );
1664
1665     /*
1666         We now know what we are dealing with in terms of unique chars and
1667         string sizes so we can calculate how much memory a naive
1668         representation using a flat table  will take. If it's over a reasonable
1669         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
1670         conservative but potentially much slower representation using an array
1671         of lists.
1672
1673         At the end we convert both representations into the same compressed
1674         form that will be used in regexec.c for matching with. The latter
1675         is a form that cannot be used to construct with but has memory
1676         properties similar to the list form and access properties similar
1677         to the table form making it both suitable for fast searches and
1678         small enough that its feasable to store for the duration of a program.
1679
1680         See the comment in the code where the compressed table is produced
1681         inplace from the flat tabe representation for an explanation of how
1682         the compression works.
1683
1684     */
1685
1686
1687     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
1688     prev_states[1] = 0;
1689
1690     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1) > SvIV(re_trie_maxbuff) ) {
1691         /*
1692             Second Pass -- Array Of Lists Representation
1693
1694             Each state will be represented by a list of charid:state records
1695             (reg_trie_trans_le) the first such element holds the CUR and LEN
1696             points of the allocated array. (See defines above).
1697
1698             We build the initial structure using the lists, and then convert
1699             it into the compressed table form which allows faster lookups
1700             (but cant be modified once converted).
1701         */
1702
1703         STRLEN transcount = 1;
1704
1705         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
1706             "%*sCompiling trie using list compiler\n",
1707             (int)depth * 2 + 2, ""));
1708         
1709         trie->states = (reg_trie_state *)
1710             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1711                                   sizeof(reg_trie_state) );
1712         TRIE_LIST_NEW(1);
1713         next_alloc = 2;
1714
1715         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1716
1717             regnode * const noper = NEXTOPER( cur );
1718             U8 *uc           = (U8*)STRING( noper );
1719             const U8 * const e = uc + STR_LEN( noper );
1720             U32 state        = 1;         /* required init */
1721             U16 charid       = 0;         /* sanity init */
1722             U8 *scan         = (U8*)NULL; /* sanity init */
1723             STRLEN foldlen   = 0;         /* required init */
1724             U32 wordlen      = 0;         /* required init */
1725             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1726
1727             if (OP(noper) != NOTHING) {
1728                 for ( ; uc < e ; uc += len ) {
1729
1730                     TRIE_READ_CHAR;
1731
1732                     if ( uvc < 256 ) {
1733                         charid = trie->charmap[ uvc ];
1734                     } else {
1735                         SV** const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1736                         if ( !svpp ) {
1737                             charid = 0;
1738                         } else {
1739                             charid=(U16)SvIV( *svpp );
1740                         }
1741                     }
1742                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
1743                     if ( charid ) {
1744
1745                         U16 check;
1746                         U32 newstate = 0;
1747
1748                         charid--;
1749                         if ( !trie->states[ state ].trans.list ) {
1750                             TRIE_LIST_NEW( state );
1751                         }
1752                         for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) {
1753                             if ( TRIE_LIST_ITEM( state, check ).forid == charid ) {
1754                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
1755                                 break;
1756                             }
1757                         }
1758                         if ( ! newstate ) {
1759                             newstate = next_alloc++;
1760                             prev_states[newstate] = state;
1761                             TRIE_LIST_PUSH( state, charid, newstate );
1762                             transcount++;
1763                         }
1764                         state = newstate;
1765                     } else {
1766                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1767                     }
1768                 }
1769             }
1770             TRIE_HANDLE_WORD(state);
1771
1772         } /* end second pass */
1773
1774         /* next alloc is the NEXT state to be allocated */
1775         trie->statecount = next_alloc; 
1776         trie->states = (reg_trie_state *)
1777             PerlMemShared_realloc( trie->states,
1778                                    next_alloc
1779                                    * sizeof(reg_trie_state) );
1780
1781         /* and now dump it out before we compress it */
1782         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
1783                                                          revcharmap, next_alloc,
1784                                                          depth+1)
1785         );
1786
1787         trie->trans = (reg_trie_trans *)
1788             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
1789         {
1790             U32 state;
1791             U32 tp = 0;
1792             U32 zp = 0;
1793
1794
1795             for( state=1 ; state < next_alloc ; state ++ ) {
1796                 U32 base=0;
1797
1798                 /*
1799                 DEBUG_TRIE_COMPILE_MORE_r(
1800                     PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
1801                 );
1802                 */
1803
1804                 if (trie->states[state].trans.list) {
1805                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
1806                     U16 maxid=minid;
1807                     U16 idx;
1808
1809                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1810                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
1811                         if ( forid < minid ) {
1812                             minid=forid;
1813                         } else if ( forid > maxid ) {
1814                             maxid=forid;
1815                         }
1816                     }
1817                     if ( transcount < tp + maxid - minid + 1) {
1818                         transcount *= 2;
1819                         trie->trans = (reg_trie_trans *)
1820                             PerlMemShared_realloc( trie->trans,
1821                                                      transcount
1822                                                      * sizeof(reg_trie_trans) );
1823                         Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans );
1824                     }
1825                     base = trie->uniquecharcount + tp - minid;
1826                     if ( maxid == minid ) {
1827                         U32 set = 0;
1828                         for ( ; zp < tp ; zp++ ) {
1829                             if ( ! trie->trans[ zp ].next ) {
1830                                 base = trie->uniquecharcount + zp - minid;
1831                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1832                                 trie->trans[ zp ].check = state;
1833                                 set = 1;
1834                                 break;
1835                             }
1836                         }
1837                         if ( !set ) {
1838                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1839                             trie->trans[ tp ].check = state;
1840                             tp++;
1841                             zp = tp;
1842                         }
1843                     } else {
1844                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1845                             const U32 tid = base -  trie->uniquecharcount + TRIE_LIST_ITEM( state, idx ).forid;
1846                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state, idx ).newstate;
1847                             trie->trans[ tid ].check = state;
1848                         }
1849                         tp += ( maxid - minid + 1 );
1850                     }
1851                     Safefree(trie->states[ state ].trans.list);
1852                 }
1853                 /*
1854                 DEBUG_TRIE_COMPILE_MORE_r(
1855                     PerlIO_printf( Perl_debug_log, " base: %d\n",base);
1856                 );
1857                 */
1858                 trie->states[ state ].trans.base=base;
1859             }
1860             trie->lasttrans = tp + 1;
1861         }
1862     } else {
1863         /*
1864            Second Pass -- Flat Table Representation.
1865
1866            we dont use the 0 slot of either trans[] or states[] so we add 1 to each.
1867            We know that we will need Charcount+1 trans at most to store the data
1868            (one row per char at worst case) So we preallocate both structures
1869            assuming worst case.
1870
1871            We then construct the trie using only the .next slots of the entry
1872            structs.
1873
1874            We use the .check field of the first entry of the node temporarily to
1875            make compression both faster and easier by keeping track of how many non
1876            zero fields are in the node.
1877
1878            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
1879            transition.
1880
1881            There are two terms at use here: state as a TRIE_NODEIDX() which is a
1882            number representing the first entry of the node, and state as a
1883            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1) and
1884            TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3) if there
1885            are 2 entrys per node. eg:
1886
1887              A B       A B
1888           1. 2 4    1. 3 7
1889           2. 0 3    3. 0 5
1890           3. 0 0    5. 0 0
1891           4. 0 0    7. 0 0
1892
1893            The table is internally in the right hand, idx form. However as we also
1894            have to deal with the states array which is indexed by nodenum we have to
1895            use TRIE_NODENUM() to convert.
1896
1897         */
1898         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
1899             "%*sCompiling trie using table compiler\n",
1900             (int)depth * 2 + 2, ""));
1901
1902         trie->trans = (reg_trie_trans *)
1903             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
1904                                   * trie->uniquecharcount + 1,
1905                                   sizeof(reg_trie_trans) );
1906         trie->states = (reg_trie_state *)
1907             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1908                                   sizeof(reg_trie_state) );
1909         next_alloc = trie->uniquecharcount + 1;
1910
1911
1912         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1913
1914             regnode * const noper   = NEXTOPER( cur );
1915             const U8 *uc     = (U8*)STRING( noper );
1916             const U8 * const e = uc + STR_LEN( noper );
1917
1918             U32 state        = 1;         /* required init */
1919
1920             U16 charid       = 0;         /* sanity init */
1921             U32 accept_state = 0;         /* sanity init */
1922             U8 *scan         = (U8*)NULL; /* sanity init */
1923
1924             STRLEN foldlen   = 0;         /* required init */
1925             U32 wordlen      = 0;         /* required init */
1926             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1927
1928             if ( OP(noper) != NOTHING ) {
1929                 for ( ; uc < e ; uc += len ) {
1930
1931                     TRIE_READ_CHAR;
1932
1933                     if ( uvc < 256 ) {
1934                         charid = trie->charmap[ uvc ];
1935                     } else {
1936                         SV* const * const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1937                         charid = svpp ? (U16)SvIV(*svpp) : 0;
1938                     }
1939                     if ( charid ) {
1940                         charid--;
1941                         if ( !trie->trans[ state + charid ].next ) {
1942                             trie->trans[ state + charid ].next = next_alloc;
1943                             trie->trans[ state ].check++;
1944                             prev_states[TRIE_NODENUM(next_alloc)]
1945                                     = TRIE_NODENUM(state);
1946                             next_alloc += trie->uniquecharcount;
1947                         }
1948                         state = trie->trans[ state + charid ].next;
1949                     } else {
1950                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1951                     }
1952                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
1953                 }
1954             }
1955             accept_state = TRIE_NODENUM( state );
1956             TRIE_HANDLE_WORD(accept_state);
1957
1958         } /* end second pass */
1959
1960         /* and now dump it out before we compress it */
1961         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
1962                                                           revcharmap,
1963                                                           next_alloc, depth+1));
1964
1965         {
1966         /*
1967            * Inplace compress the table.*
1968
1969            For sparse data sets the table constructed by the trie algorithm will
1970            be mostly 0/FAIL transitions or to put it another way mostly empty.
1971            (Note that leaf nodes will not contain any transitions.)
1972
1973            This algorithm compresses the tables by eliminating most such
1974            transitions, at the cost of a modest bit of extra work during lookup:
1975
1976            - Each states[] entry contains a .base field which indicates the
1977            index in the state[] array wheres its transition data is stored.
1978
1979            - If .base is 0 there are no valid transitions from that node.
1980
1981            - If .base is nonzero then charid is added to it to find an entry in
1982            the trans array.
1983
1984            -If trans[states[state].base+charid].check!=state then the
1985            transition is taken to be a 0/Fail transition. Thus if there are fail
1986            transitions at the front of the node then the .base offset will point
1987            somewhere inside the previous nodes data (or maybe even into a node
1988            even earlier), but the .check field determines if the transition is
1989            valid.
1990
1991            XXX - wrong maybe?
1992            The following process inplace converts the table to the compressed
1993            table: We first do not compress the root node 1,and mark all its
1994            .check pointers as 1 and set its .base pointer as 1 as well. This
1995            allows us to do a DFA construction from the compressed table later,
1996            and ensures that any .base pointers we calculate later are greater
1997            than 0.
1998
1999            - We set 'pos' to indicate the first entry of the second node.
2000
2001            - We then iterate over the columns of the node, finding the first and
2002            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
2003            and set the .check pointers accordingly, and advance pos
2004            appropriately and repreat for the next node. Note that when we copy
2005            the next pointers we have to convert them from the original
2006            NODEIDX form to NODENUM form as the former is not valid post
2007            compression.
2008
2009            - If a node has no transitions used we mark its base as 0 and do not
2010            advance the pos pointer.
2011
2012            - If a node only has one transition we use a second pointer into the
2013            structure to fill in allocated fail transitions from other states.
2014            This pointer is independent of the main pointer and scans forward
2015            looking for null transitions that are allocated to a state. When it
2016            finds one it writes the single transition into the "hole".  If the
2017            pointer doesnt find one the single transition is appended as normal.
2018
2019            - Once compressed we can Renew/realloc the structures to release the
2020            excess space.
2021
2022            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
2023            specifically Fig 3.47 and the associated pseudocode.
2024
2025            demq
2026         */
2027         const U32 laststate = TRIE_NODENUM( next_alloc );
2028         U32 state, charid;
2029         U32 pos = 0, zp=0;
2030         trie->statecount = laststate;
2031
2032         for ( state = 1 ; state < laststate ; state++ ) {
2033             U8 flag = 0;
2034             const U32 stateidx = TRIE_NODEIDX( state );
2035             const U32 o_used = trie->trans[ stateidx ].check;
2036             U32 used = trie->trans[ stateidx ].check;
2037             trie->trans[ stateidx ].check = 0;
2038
2039             for ( charid = 0 ; used && charid < trie->uniquecharcount ; charid++ ) {
2040                 if ( flag || trie->trans[ stateidx + charid ].next ) {
2041                     if ( trie->trans[ stateidx + charid ].next ) {
2042                         if (o_used == 1) {
2043                             for ( ; zp < pos ; zp++ ) {
2044                                 if ( ! trie->trans[ zp ].next ) {
2045                                     break;
2046                                 }
2047                             }
2048                             trie->states[ state ].trans.base = zp + trie->uniquecharcount - charid ;
2049                             trie->trans[ zp ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2050                             trie->trans[ zp ].check = state;
2051                             if ( ++zp > pos ) pos = zp;
2052                             break;
2053                         }
2054                         used--;
2055                     }
2056                     if ( !flag ) {
2057                         flag = 1;
2058                         trie->states[ state ].trans.base = pos + trie->uniquecharcount - charid ;
2059                     }
2060                     trie->trans[ pos ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2061                     trie->trans[ pos ].check = state;
2062                     pos++;
2063                 }
2064             }
2065         }
2066         trie->lasttrans = pos + 1;
2067         trie->states = (reg_trie_state *)
2068             PerlMemShared_realloc( trie->states, laststate
2069                                    * sizeof(reg_trie_state) );
2070         DEBUG_TRIE_COMPILE_MORE_r(
2071                 PerlIO_printf( Perl_debug_log,
2072                     "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
2073                     (int)depth * 2 + 2,"",
2074                     (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1 ),
2075                     (IV)next_alloc,
2076                     (IV)pos,
2077                     ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
2078             );
2079
2080         } /* end table compress */
2081     }
2082     DEBUG_TRIE_COMPILE_MORE_r(
2083             PerlIO_printf(Perl_debug_log, "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
2084                 (int)depth * 2 + 2, "",
2085                 (UV)trie->statecount,
2086                 (UV)trie->lasttrans)
2087     );
2088     /* resize the trans array to remove unused space */
2089     trie->trans = (reg_trie_trans *)
2090         PerlMemShared_realloc( trie->trans, trie->lasttrans
2091                                * sizeof(reg_trie_trans) );
2092
2093     {   /* Modify the program and insert the new TRIE node */ 
2094         U8 nodetype =(U8)(flags & 0xFF);
2095         char *str=NULL;
2096         
2097 #ifdef DEBUGGING
2098         regnode *optimize = NULL;
2099 #ifdef RE_TRACK_PATTERN_OFFSETS
2100
2101         U32 mjd_offset = 0;
2102         U32 mjd_nodelen = 0;
2103 #endif /* RE_TRACK_PATTERN_OFFSETS */
2104 #endif /* DEBUGGING */
2105         /*
2106            This means we convert either the first branch or the first Exact,
2107            depending on whether the thing following (in 'last') is a branch
2108            or not and whther first is the startbranch (ie is it a sub part of
2109            the alternation or is it the whole thing.)
2110            Assuming its a sub part we convert the EXACT otherwise we convert
2111            the whole branch sequence, including the first.
2112          */
2113         /* Find the node we are going to overwrite */
2114         if ( first != startbranch || OP( last ) == BRANCH ) {
2115             /* branch sub-chain */
2116             NEXT_OFF( first ) = (U16)(last - first);
2117 #ifdef RE_TRACK_PATTERN_OFFSETS
2118             DEBUG_r({
2119                 mjd_offset= Node_Offset((convert));
2120                 mjd_nodelen= Node_Length((convert));
2121             });
2122 #endif
2123             /* whole branch chain */
2124         }
2125 #ifdef RE_TRACK_PATTERN_OFFSETS
2126         else {
2127             DEBUG_r({
2128                 const  regnode *nop = NEXTOPER( convert );
2129                 mjd_offset= Node_Offset((nop));
2130                 mjd_nodelen= Node_Length((nop));
2131             });
2132         }
2133         DEBUG_OPTIMISE_r(
2134             PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
2135                 (int)depth * 2 + 2, "",
2136                 (UV)mjd_offset, (UV)mjd_nodelen)
2137         );
2138 #endif
2139         /* But first we check to see if there is a common prefix we can 
2140            split out as an EXACT and put in front of the TRIE node.  */
2141         trie->startstate= 1;
2142         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
2143             U32 state;
2144             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
2145                 U32 ofs = 0;
2146                 I32 idx = -1;
2147                 U32 count = 0;
2148                 const U32 base = trie->states[ state ].trans.base;
2149
2150                 if ( trie->states[state].wordnum )
2151                         count = 1;
2152
2153                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2154                     if ( ( base + ofs >= trie->uniquecharcount ) &&
2155                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
2156                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
2157                     {
2158                         if ( ++count > 1 ) {
2159                             SV **tmp = av_fetch( revcharmap, ofs, 0);
2160                             const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
2161                             if ( state == 1 ) break;
2162                             if ( count == 2 ) {
2163                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
2164                                 DEBUG_OPTIMISE_r(
2165                                     PerlIO_printf(Perl_debug_log,
2166                                         "%*sNew Start State=%"UVuf" Class: [",
2167                                         (int)depth * 2 + 2, "",
2168                                         (UV)state));
2169                                 if (idx >= 0) {
2170                                     SV ** const tmp = av_fetch( revcharmap, idx, 0);
2171                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
2172
2173                                     TRIE_BITMAP_SET(trie,*ch);
2174                                     if ( folder )
2175                                         TRIE_BITMAP_SET(trie, folder[ *ch ]);
2176                                     DEBUG_OPTIMISE_r(
2177                                         PerlIO_printf(Perl_debug_log, "%s", (char*)ch)
2178                                     );
2179                                 }
2180                             }
2181                             TRIE_BITMAP_SET(trie,*ch);
2182                             if ( folder )
2183                                 TRIE_BITMAP_SET(trie,folder[ *ch ]);
2184                             DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
2185                         }
2186                         idx = ofs;
2187                     }
2188                 }
2189                 if ( count == 1 ) {
2190                     SV **tmp = av_fetch( revcharmap, idx, 0);
2191                     STRLEN len;
2192                     char *ch = SvPV( *tmp, len );
2193                     DEBUG_OPTIMISE_r({
2194                         SV *sv=sv_newmortal();
2195                         PerlIO_printf( Perl_debug_log,
2196                             "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
2197                             (int)depth * 2 + 2, "",
2198                             (UV)state, (UV)idx, 
2199                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6, 
2200                                 PL_colors[0], PL_colors[1],
2201                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2202                                 PERL_PV_ESCAPE_FIRSTCHAR 
2203                             )
2204                         );
2205                     });
2206                     if ( state==1 ) {
2207                         OP( convert ) = nodetype;
2208                         str=STRING(convert);
2209                         STR_LEN(convert)=0;
2210                     }
2211                     STR_LEN(convert) += len;
2212                     while (len--)
2213                         *str++ = *ch++;
2214                 } else {
2215 #ifdef DEBUGGING            
2216                     if (state>1)
2217                         DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
2218 #endif
2219                     break;
2220                 }
2221             }
2222             trie->prefixlen = (state-1);
2223             if (str) {
2224                 regnode *n = convert+NODE_SZ_STR(convert);
2225                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
2226                 trie->startstate = state;
2227                 trie->minlen -= (state - 1);
2228                 trie->maxlen -= (state - 1);
2229 #ifdef DEBUGGING
2230                /* At least the UNICOS C compiler choked on this
2231                 * being argument to DEBUG_r(), so let's just have
2232                 * it right here. */
2233                if (
2234 #ifdef PERL_EXT_RE_BUILD
2235                    1
2236 #else
2237                    DEBUG_r_TEST
2238 #endif
2239                    ) {
2240                    regnode *fix = convert;
2241                    U32 word = trie->wordcount;
2242                    mjd_nodelen++;
2243                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
2244                    while( ++fix < n ) {
2245                        Set_Node_Offset_Length(fix, 0, 0);
2246                    }
2247                    while (word--) {
2248                        SV ** const tmp = av_fetch( trie_words, word, 0 );
2249                        if (tmp) {
2250                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
2251                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
2252                            else
2253                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
2254                        }
2255                    }
2256                }
2257 #endif
2258                 if (trie->maxlen) {
2259                     convert = n;
2260                 } else {
2261                     NEXT_OFF(convert) = (U16)(tail - convert);
2262                     DEBUG_r(optimize= n);
2263                 }
2264             }
2265         }
2266         if (!jumper) 
2267             jumper = last; 
2268         if ( trie->maxlen ) {
2269             NEXT_OFF( convert ) = (U16)(tail - convert);
2270             ARG_SET( convert, data_slot );
2271             /* Store the offset to the first unabsorbed branch in 
2272                jump[0], which is otherwise unused by the jump logic. 
2273                We use this when dumping a trie and during optimisation. */
2274             if (trie->jump) 
2275                 trie->jump[0] = (U16)(nextbranch - convert);
2276             
2277             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
2278              *   and there is a bitmap
2279              *   and the first "jump target" node we found leaves enough room
2280              * then convert the TRIE node into a TRIEC node, with the bitmap
2281              * embedded inline in the opcode - this is hypothetically faster.
2282              */
2283             if ( !trie->states[trie->startstate].wordnum
2284                  && trie->bitmap
2285                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
2286             {
2287                 OP( convert ) = TRIEC;
2288                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
2289                 PerlMemShared_free(trie->bitmap);
2290                 trie->bitmap= NULL;
2291             } else 
2292                 OP( convert ) = TRIE;
2293
2294             /* store the type in the flags */
2295             convert->flags = nodetype;
2296             DEBUG_r({
2297             optimize = convert 
2298                       + NODE_STEP_REGNODE 
2299                       + regarglen[ OP( convert ) ];
2300             });
2301             /* XXX We really should free up the resource in trie now, 
2302                    as we won't use them - (which resources?) dmq */
2303         }
2304         /* needed for dumping*/
2305         DEBUG_r(if (optimize) {
2306             regnode *opt = convert;
2307
2308             while ( ++opt < optimize) {
2309                 Set_Node_Offset_Length(opt,0,0);
2310             }
2311             /* 
2312                 Try to clean up some of the debris left after the 
2313                 optimisation.
2314              */
2315             while( optimize < jumper ) {
2316                 mjd_nodelen += Node_Length((optimize));
2317                 OP( optimize ) = OPTIMIZED;
2318                 Set_Node_Offset_Length(optimize,0,0);
2319                 optimize++;
2320             }
2321             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
2322         });
2323     } /* end node insert */
2324     REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, convert);
2325
2326     /*  Finish populating the prev field of the wordinfo array.  Walk back
2327      *  from each accept state until we find another accept state, and if
2328      *  so, point the first word's .prev field at the second word. If the
2329      *  second already has a .prev field set, stop now. This will be the
2330      *  case either if we've already processed that word's accept state,
2331      *  or that state had multiple words, and the overspill words were
2332      *  already linked up earlier.
2333      */
2334     {
2335         U16 word;
2336         U32 state;
2337         U16 prev;
2338
2339         for (word=1; word <= trie->wordcount; word++) {
2340             prev = 0;
2341             if (trie->wordinfo[word].prev)
2342                 continue;
2343             state = trie->wordinfo[word].accept;
2344             while (state) {
2345                 state = prev_states[state];
2346                 if (!state)
2347                     break;
2348                 prev = trie->states[state].wordnum;
2349                 if (prev)
2350                     break;
2351             }
2352             trie->wordinfo[word].prev = prev;
2353         }
2354         Safefree(prev_states);
2355     }
2356
2357
2358     /* and now dump out the compressed format */
2359     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
2360
2361     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
2362 #ifdef DEBUGGING
2363     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
2364     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
2365 #else
2366     SvREFCNT_dec(revcharmap);
2367 #endif
2368     return trie->jump 
2369            ? MADE_JUMP_TRIE 
2370            : trie->startstate>1 
2371              ? MADE_EXACT_TRIE 
2372              : MADE_TRIE;
2373 }
2374
2375 STATIC void
2376 S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source,  regnode *stclass, U32 depth)
2377 {
2378 /* The Trie is constructed and compressed now so we can build a fail array if it's needed
2379
2380    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
2381    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
2382    ISBN 0-201-10088-6
2383
2384    We find the fail state for each state in the trie, this state is the longest proper
2385    suffix of the current state's 'word' that is also a proper prefix of another word in our
2386    trie. State 1 represents the word '' and is thus the default fail state. This allows
2387    the DFA not to have to restart after its tried and failed a word at a given point, it
2388    simply continues as though it had been matching the other word in the first place.
2389    Consider
2390       'abcdgu'=~/abcdefg|cdgu/
2391    When we get to 'd' we are still matching the first word, we would encounter 'g' which would
2392    fail, which would bring us to the state representing 'd' in the second word where we would
2393    try 'g' and succeed, proceeding to match 'cdgu'.
2394  */
2395  /* add a fail transition */
2396     const U32 trie_offset = ARG(source);
2397     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
2398     U32 *q;
2399     const U32 ucharcount = trie->uniquecharcount;
2400     const U32 numstates = trie->statecount;
2401     const U32 ubound = trie->lasttrans + ucharcount;
2402     U32 q_read = 0;
2403     U32 q_write = 0;
2404     U32 charid;
2405     U32 base = trie->states[ 1 ].trans.base;
2406     U32 *fail;
2407     reg_ac_data *aho;
2408     const U32 data_slot = add_data( pRExC_state, 1, "T" );
2409     GET_RE_DEBUG_FLAGS_DECL;
2410
2411     PERL_ARGS_ASSERT_MAKE_TRIE_FAILTABLE;
2412 #ifndef DEBUGGING
2413     PERL_UNUSED_ARG(depth);
2414 #endif
2415
2416
2417     ARG_SET( stclass, data_slot );
2418     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
2419     RExC_rxi->data->data[ data_slot ] = (void*)aho;
2420     aho->trie=trie_offset;
2421     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
2422     Copy( trie->states, aho->states, numstates, reg_trie_state );
2423     Newxz( q, numstates, U32);
2424     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
2425     aho->refcount = 1;
2426     fail = aho->fail;
2427     /* initialize fail[0..1] to be 1 so that we always have
2428        a valid final fail state */
2429     fail[ 0 ] = fail[ 1 ] = 1;
2430
2431     for ( charid = 0; charid < ucharcount ; charid++ ) {
2432         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
2433         if ( newstate ) {
2434             q[ q_write ] = newstate;
2435             /* set to point at the root */
2436             fail[ q[ q_write++ ] ]=1;
2437         }
2438     }
2439     while ( q_read < q_write) {
2440         const U32 cur = q[ q_read++ % numstates ];
2441         base = trie->states[ cur ].trans.base;
2442
2443         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
2444             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
2445             if (ch_state) {
2446                 U32 fail_state = cur;
2447                 U32 fail_base;
2448                 do {
2449                     fail_state = fail[ fail_state ];
2450                     fail_base = aho->states[ fail_state ].trans.base;
2451                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
2452
2453                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
2454                 fail[ ch_state ] = fail_state;
2455                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
2456                 {
2457                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
2458                 }
2459                 q[ q_write++ % numstates] = ch_state;
2460             }
2461         }
2462     }
2463     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
2464        when we fail in state 1, this allows us to use the
2465        charclass scan to find a valid start char. This is based on the principle
2466        that theres a good chance the string being searched contains lots of stuff
2467        that cant be a start char.
2468      */
2469     fail[ 0 ] = fail[ 1 ] = 0;
2470     DEBUG_TRIE_COMPILE_r({
2471         PerlIO_printf(Perl_debug_log,
2472                       "%*sStclass Failtable (%"UVuf" states): 0", 
2473                       (int)(depth * 2), "", (UV)numstates
2474         );
2475         for( q_read=1; q_read<numstates; q_read++ ) {
2476             PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
2477         }
2478         PerlIO_printf(Perl_debug_log, "\n");
2479     });
2480     Safefree(q);
2481     /*RExC_seen |= REG_SEEN_TRIEDFA;*/
2482 }
2483
2484
2485 /*
2486  * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2487  * These need to be revisited when a newer toolchain becomes available.
2488  */
2489 #if defined(__sparc64__) && defined(__GNUC__)
2490 #   if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2491 #       undef  SPARC64_GCC_WORKAROUND
2492 #       define SPARC64_GCC_WORKAROUND 1
2493 #   endif
2494 #endif
2495
2496 #define DEBUG_PEEP(str,scan,depth) \
2497     DEBUG_OPTIMISE_r({if (scan){ \
2498        SV * const mysv=sv_newmortal(); \
2499        regnode *Next = regnext(scan); \
2500        regprop(RExC_rx, mysv, scan); \
2501        PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
2502        (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
2503        Next ? (REG_NODE_NUM(Next)) : 0 ); \
2504    }});
2505
2506
2507
2508
2509
2510 #define JOIN_EXACT(scan,min,flags) \
2511     if (PL_regkind[OP(scan)] == EXACT) \
2512         join_exact(pRExC_state,(scan),(min),(flags),NULL,depth+1)
2513
2514 STATIC U32
2515 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, I32 *min, U32 flags,regnode *val, U32 depth) {
2516     /* Merge several consecutive EXACTish nodes into one. */
2517     regnode *n = regnext(scan);
2518     U32 stringok = 1;
2519     regnode *next = scan + NODE_SZ_STR(scan);
2520     U32 merged = 0;
2521     U32 stopnow = 0;
2522 #ifdef DEBUGGING
2523     regnode *stop = scan;
2524     GET_RE_DEBUG_FLAGS_DECL;
2525 #else
2526     PERL_UNUSED_ARG(depth);
2527 #endif
2528
2529     PERL_ARGS_ASSERT_JOIN_EXACT;
2530 #ifndef EXPERIMENTAL_INPLACESCAN
2531     PERL_UNUSED_ARG(flags);
2532     PERL_UNUSED_ARG(val);
2533 #endif
2534     DEBUG_PEEP("join",scan,depth);
2535     
2536     /* Skip NOTHING, merge EXACT*. */
2537     while (n &&
2538            ( PL_regkind[OP(n)] == NOTHING ||
2539              (stringok && (OP(n) == OP(scan))))
2540            && NEXT_OFF(n)
2541            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
2542         
2543         if (OP(n) == TAIL || n > next)
2544             stringok = 0;
2545         if (PL_regkind[OP(n)] == NOTHING) {
2546             DEBUG_PEEP("skip:",n,depth);
2547             NEXT_OFF(scan) += NEXT_OFF(n);
2548             next = n + NODE_STEP_REGNODE;
2549 #ifdef DEBUGGING
2550             if (stringok)
2551                 stop = n;
2552 #endif
2553             n = regnext(n);
2554         }
2555         else if (stringok) {
2556             const unsigned int oldl = STR_LEN(scan);
2557             regnode * const nnext = regnext(n);
2558             
2559             DEBUG_PEEP("merg",n,depth);
2560             
2561             merged++;
2562             if (oldl + STR_LEN(n) > U8_MAX)
2563                 break;
2564             NEXT_OFF(scan) += NEXT_OFF(n);
2565             STR_LEN(scan) += STR_LEN(n);
2566             next = n + NODE_SZ_STR(n);
2567             /* Now we can overwrite *n : */
2568             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
2569 #ifdef DEBUGGING
2570             stop = next - 1;
2571 #endif
2572             n = nnext;
2573             if (stopnow) break;
2574         }
2575
2576 #ifdef EXPERIMENTAL_INPLACESCAN
2577         if (flags && !NEXT_OFF(n)) {
2578             DEBUG_PEEP("atch", val, depth);
2579             if (reg_off_by_arg[OP(n)]) {
2580                 ARG_SET(n, val - n);
2581             }
2582             else {
2583                 NEXT_OFF(n) = val - n;
2584             }
2585             stopnow = 1;
2586         }
2587 #endif
2588     }
2589 #define GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS   0x0390
2590 #define IOTA_D_T        GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS
2591 #define GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS     0x03B0
2592 #define UPSILON_D_T     GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS
2593
2594     if (UTF
2595         && ( OP(scan) == EXACTF || OP(scan) == EXACTFU || OP(scan) == EXACTFA)
2596         && ( STR_LEN(scan) >= 6 ) )
2597     {
2598     /*
2599     Two problematic code points in Unicode casefolding of EXACT nodes:
2600     
2601     U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
2602     U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
2603     
2604     which casefold to
2605     
2606     Unicode                      UTF-8
2607     
2608     U+03B9 U+0308 U+0301         0xCE 0xB9 0xCC 0x88 0xCC 0x81
2609     U+03C5 U+0308 U+0301         0xCF 0x85 0xCC 0x88 0xCC 0x81
2610     
2611     This means that in case-insensitive matching (or "loose matching",
2612     as Unicode calls it), an EXACTF of length six (the UTF-8 encoded byte
2613     length of the above casefolded versions) can match a target string
2614     of length two (the byte length of UTF-8 encoded U+0390 or U+03B0).
2615     This would rather mess up the minimum length computation.
2616     
2617     What we'll do is to look for the tail four bytes, and then peek
2618     at the preceding two bytes to see whether we need to decrease
2619     the minimum length by four (six minus two).
2620     
2621     Thanks to the design of UTF-8, there cannot be false matches:
2622     A sequence of valid UTF-8 bytes cannot be a subsequence of
2623     another valid sequence of UTF-8 bytes.
2624     
2625     */
2626          char * const s0 = STRING(scan), *s, *t;
2627          char * const s1 = s0 + STR_LEN(scan) - 1;
2628          char * const s2 = s1 - 4;
2629 #ifdef EBCDIC /* RD tunifold greek 0390 and 03B0 */
2630          const char t0[] = "\xaf\x49\xaf\x42";
2631 #else
2632          const char t0[] = "\xcc\x88\xcc\x81";
2633 #endif
2634          const char * const t1 = t0 + 3;
2635     
2636          for (s = s0 + 2;
2637               s < s2 && (t = ninstr(s, s1, t0, t1));
2638               s = t + 4) {
2639 #ifdef EBCDIC
2640               if (((U8)t[-1] == 0x68 && (U8)t[-2] == 0xB4) ||
2641                   ((U8)t[-1] == 0x46 && (U8)t[-2] == 0xB5))
2642 #else
2643               if (((U8)t[-1] == 0xB9 && (U8)t[-2] == 0xCE) ||
2644                   ((U8)t[-1] == 0x85 && (U8)t[-2] == 0xCF))
2645 #endif
2646                    *min -= 4;
2647          }
2648     }
2649     
2650 #ifdef DEBUGGING
2651     /* Allow dumping */
2652     n = scan + NODE_SZ_STR(scan);
2653     while (n <= stop) {
2654         if (PL_regkind[OP(n)] != NOTHING || OP(n) == NOTHING) {
2655             OP(n) = OPTIMIZED;
2656             NEXT_OFF(n) = 0;
2657         }
2658         n++;
2659     }
2660 #endif
2661     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
2662     return stopnow;
2663 }
2664
2665 /* REx optimizer.  Converts nodes into quicker variants "in place".
2666    Finds fixed substrings.  */
2667
2668 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
2669    to the position after last scanned or to NULL. */
2670
2671 #define INIT_AND_WITHP \
2672     assert(!and_withp); \
2673     Newx(and_withp,1,struct regnode_charclass_class); \
2674     SAVEFREEPV(and_withp)
2675
2676 /* this is a chain of data about sub patterns we are processing that
2677    need to be handled separately/specially in study_chunk. Its so
2678    we can simulate recursion without losing state.  */
2679 struct scan_frame;
2680 typedef struct scan_frame {
2681     regnode *last;  /* last node to process in this frame */
2682     regnode *next;  /* next node to process when last is reached */
2683     struct scan_frame *prev; /*previous frame*/
2684     I32 stop; /* what stopparen do we use */
2685 } scan_frame;
2686
2687
2688 #define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf)
2689
2690 #define CASE_SYNST_FNC(nAmE)                                       \
2691 case nAmE:                                                         \
2692     if (flags & SCF_DO_STCLASS_AND) {                              \
2693             for (value = 0; value < 256; value++)                  \
2694                 if (!is_ ## nAmE ## _cp(value))                       \
2695                     ANYOF_BITMAP_CLEAR(data->start_class, value);  \
2696     }                                                              \
2697     else {                                                         \
2698             for (value = 0; value < 256; value++)                  \
2699                 if (is_ ## nAmE ## _cp(value))                        \
2700                     ANYOF_BITMAP_SET(data->start_class, value);    \
2701     }                                                              \
2702     break;                                                         \
2703 case N ## nAmE:                                                    \
2704     if (flags & SCF_DO_STCLASS_AND) {                              \
2705             for (value = 0; value < 256; value++)                   \
2706                 if (is_ ## nAmE ## _cp(value))                         \
2707                     ANYOF_BITMAP_CLEAR(data->start_class, value);   \
2708     }                                                               \
2709     else {                                                          \
2710             for (value = 0; value < 256; value++)                   \
2711                 if (!is_ ## nAmE ## _cp(value))                        \
2712                     ANYOF_BITMAP_SET(data->start_class, value);     \
2713     }                                                               \
2714     break
2715
2716
2717
2718 STATIC I32
2719 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
2720                         I32 *minlenp, I32 *deltap,
2721                         regnode *last,
2722                         scan_data_t *data,
2723                         I32 stopparen,
2724                         U8* recursed,
2725                         struct regnode_charclass_class *and_withp,
2726                         U32 flags, U32 depth)
2727                         /* scanp: Start here (read-write). */
2728                         /* deltap: Write maxlen-minlen here. */
2729                         /* last: Stop before this one. */
2730                         /* data: string data about the pattern */
2731                         /* stopparen: treat close N as END */
2732                         /* recursed: which subroutines have we recursed into */
2733                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
2734 {
2735     dVAR;
2736     I32 min = 0, pars = 0, code;
2737     regnode *scan = *scanp, *next;
2738     I32 delta = 0;
2739     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
2740     int is_inf_internal = 0;            /* The studied chunk is infinite */
2741     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
2742     scan_data_t data_fake;
2743     SV *re_trie_maxbuff = NULL;
2744     regnode *first_non_open = scan;
2745     I32 stopmin = I32_MAX;
2746     scan_frame *frame = NULL;
2747     GET_RE_DEBUG_FLAGS_DECL;
2748
2749     PERL_ARGS_ASSERT_STUDY_CHUNK;
2750
2751 #ifdef DEBUGGING
2752     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
2753 #endif
2754
2755     if ( depth == 0 ) {
2756         while (first_non_open && OP(first_non_open) == OPEN)
2757             first_non_open=regnext(first_non_open);
2758     }
2759
2760
2761   fake_study_recurse:
2762     while ( scan && OP(scan) != END && scan < last ){
2763         /* Peephole optimizer: */
2764         DEBUG_STUDYDATA("Peep:", data,depth);
2765         DEBUG_PEEP("Peep",scan,depth);
2766         JOIN_EXACT(scan,&min,0);
2767
2768         /* Follow the next-chain of the current node and optimize
2769            away all the NOTHINGs from it.  */
2770         if (OP(scan) != CURLYX) {
2771             const int max = (reg_off_by_arg[OP(scan)]
2772                        ? I32_MAX
2773                        /* I32 may be smaller than U16 on CRAYs! */
2774                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
2775             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
2776             int noff;
2777             regnode *n = scan;
2778         
2779             /* Skip NOTHING and LONGJMP. */
2780             while ((n = regnext(n))
2781                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
2782                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
2783                    && off + noff < max)
2784                 off += noff;
2785             if (reg_off_by_arg[OP(scan)])
2786                 ARG(scan) = off;
2787             else
2788                 NEXT_OFF(scan) = off;
2789         }
2790
2791
2792
2793         /* The principal pseudo-switch.  Cannot be a switch, since we
2794            look into several different things.  */
2795         if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
2796                    || OP(scan) == IFTHEN) {
2797             next = regnext(scan);
2798             code = OP(scan);
2799             /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
2800         
2801             if (OP(next) == code || code == IFTHEN) {
2802                 /* NOTE - There is similar code to this block below for handling
2803                    TRIE nodes on a re-study.  If you change stuff here check there
2804                    too. */
2805                 I32 max1 = 0, min1 = I32_MAX, num = 0;
2806                 struct regnode_charclass_class accum;
2807                 regnode * const startbranch=scan;
2808                 
2809                 if (flags & SCF_DO_SUBSTR)
2810                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
2811                 if (flags & SCF_DO_STCLASS)
2812                     cl_init_zero(pRExC_state, &accum);
2813
2814                 while (OP(scan) == code) {
2815                     I32 deltanext, minnext, f = 0, fake;
2816                     struct regnode_charclass_class this_class;
2817
2818                     num++;
2819                     data_fake.flags = 0;
2820                     if (data) {
2821                         data_fake.whilem_c = data->whilem_c;
2822                         data_fake.last_closep = data->last_closep;
2823                     }
2824                     else
2825                         data_fake.last_closep = &fake;
2826
2827                     data_fake.pos_delta = delta;
2828                     next = regnext(scan);
2829                     scan = NEXTOPER(scan);
2830                     if (code != BRANCH)
2831                         scan = NEXTOPER(scan);
2832                     if (flags & SCF_DO_STCLASS) {
2833                         cl_init(pRExC_state, &this_class);
2834                         data_fake.start_class = &this_class;
2835                         f = SCF_DO_STCLASS_AND;
2836                     }
2837                     if (flags & SCF_WHILEM_VISITED_POS)
2838                         f |= SCF_WHILEM_VISITED_POS;
2839
2840                     /* we suppose the run is continuous, last=next...*/
2841                     minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
2842                                           next, &data_fake,
2843                                           stopparen, recursed, NULL, f,depth+1);
2844                     if (min1 > minnext)
2845                         min1 = minnext;
2846                     if (max1 < minnext + deltanext)
2847                         max1 = minnext + deltanext;
2848                     if (deltanext == I32_MAX)
2849                         is_inf = is_inf_internal = 1;
2850                     scan = next;
2851                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
2852                         pars++;
2853                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
2854                         if ( stopmin > minnext) 
2855                             stopmin = min + min1;
2856                         flags &= ~SCF_DO_SUBSTR;
2857                         if (data)
2858                             data->flags |= SCF_SEEN_ACCEPT;
2859                     }
2860                     if (data) {
2861                         if (data_fake.flags & SF_HAS_EVAL)
2862                             data->flags |= SF_HAS_EVAL;
2863                         data->whilem_c = data_fake.whilem_c;
2864                     }
2865                     if (flags & SCF_DO_STCLASS)
2866                         cl_or(pRExC_state, &accum, &this_class);
2867                 }
2868                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
2869                     min1 = 0;
2870                 if (flags & SCF_DO_SUBSTR) {
2871                     data->pos_min += min1;
2872                     data->pos_delta += max1 - min1;
2873                     if (max1 != min1 || is_inf)
2874                         data->longest = &(data->longest_float);
2875                 }
2876                 min += min1;
2877                 delta += max1 - min1;
2878                 if (flags & SCF_DO_STCLASS_OR) {
2879                     cl_or(pRExC_state, data->start_class, &accum);
2880                     if (min1) {
2881                         cl_and(data->start_class, and_withp);
2882                         flags &= ~SCF_DO_STCLASS;
2883                     }
2884                 }
2885                 else if (flags & SCF_DO_STCLASS_AND) {
2886                     if (min1) {
2887                         cl_and(data->start_class, &accum);
2888                         flags &= ~SCF_DO_STCLASS;
2889                     }
2890                     else {
2891                         /* Switch to OR mode: cache the old value of
2892                          * data->start_class */
2893                         INIT_AND_WITHP;
2894                         StructCopy(data->start_class, and_withp,
2895                                    struct regnode_charclass_class);
2896                         flags &= ~SCF_DO_STCLASS_AND;
2897                         StructCopy(&accum, data->start_class,
2898                                    struct regnode_charclass_class);
2899                         flags |= SCF_DO_STCLASS_OR;
2900                         data->start_class->flags |= ANYOF_EOS;
2901                     }
2902                 }
2903
2904                 if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) == BRANCH ) {
2905                 /* demq.
2906
2907                    Assuming this was/is a branch we are dealing with: 'scan' now
2908                    points at the item that follows the branch sequence, whatever
2909                    it is. We now start at the beginning of the sequence and look
2910                    for subsequences of
2911
2912                    BRANCH->EXACT=>x1
2913                    BRANCH->EXACT=>x2
2914                    tail
2915
2916                    which would be constructed from a pattern like /A|LIST|OF|WORDS/
2917
2918                    If we can find such a subsequence we need to turn the first
2919                    element into a trie and then add the subsequent branch exact
2920                    strings to the trie.
2921
2922                    We have two cases
2923
2924                      1. patterns where the whole set of branches can be converted. 
2925
2926                      2. patterns where only a subset can be converted.
2927
2928                    In case 1 we can replace the whole set with a single regop
2929                    for the trie. In case 2 we need to keep the start and end
2930                    branches so
2931
2932                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
2933                      becomes BRANCH TRIE; BRANCH X;
2934
2935                   There is an additional case, that being where there is a 
2936                   common prefix, which gets split out into an EXACT like node
2937                   preceding the TRIE node.
2938
2939                   If x(1..n)==tail then we can do a simple trie, if not we make
2940                   a "jump" trie, such that when we match the appropriate word
2941                   we "jump" to the appropriate tail node. Essentially we turn
2942                   a nested if into a case structure of sorts.
2943
2944                 */
2945                 
2946                     int made=0;
2947                     if (!re_trie_maxbuff) {
2948                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2949                         if (!SvIOK(re_trie_maxbuff))
2950                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2951                     }
2952                     if ( SvIV(re_trie_maxbuff)>=0  ) {
2953                         regnode *cur;
2954                         regnode *first = (regnode *)NULL;
2955                         regnode *last = (regnode *)NULL;
2956                         regnode *tail = scan;
2957                         U8 optype = 0;
2958                         U32 count=0;
2959
2960 #ifdef DEBUGGING
2961                         SV * const mysv = sv_newmortal();       /* for dumping */
2962 #endif
2963                         /* var tail is used because there may be a TAIL
2964                            regop in the way. Ie, the exacts will point to the
2965                            thing following the TAIL, but the last branch will
2966                            point at the TAIL. So we advance tail. If we
2967                            have nested (?:) we may have to move through several
2968                            tails.
2969                          */
2970
2971                         while ( OP( tail ) == TAIL ) {
2972                             /* this is the TAIL generated by (?:) */
2973                             tail = regnext( tail );
2974                         }
2975
2976                         
2977                         DEBUG_OPTIMISE_r({
2978                             regprop(RExC_rx, mysv, tail );
2979                             PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
2980                                 (int)depth * 2 + 2, "", 
2981                                 "Looking for TRIE'able sequences. Tail node is: ", 
2982                                 SvPV_nolen_const( mysv )
2983                             );
2984                         });
2985                         
2986                         /*
2987
2988                            step through the branches, cur represents each
2989                            branch, noper is the first thing to be matched
2990                            as part of that branch and noper_next is the
2991                            regnext() of that node. if noper is an EXACT
2992                            and noper_next is the same as scan (our current
2993                            position in the regex) then the EXACT branch is
2994                            a possible optimization target. Once we have
2995                            two or more consecutive such branches we can
2996                            create a trie of the EXACT's contents and stich
2997                            it in place. If the sequence represents all of
2998                            the branches we eliminate the whole thing and
2999                            replace it with a single TRIE. If it is a
3000                            subsequence then we need to stitch it in. This
3001                            means the first branch has to remain, and needs
3002                            to be repointed at the item on the branch chain
3003                            following the last branch optimized. This could
3004                            be either a BRANCH, in which case the
3005                            subsequence is internal, or it could be the
3006                            item following the branch sequence in which
3007                            case the subsequence is at the end.
3008
3009                         */
3010
3011                         /* dont use tail as the end marker for this traverse */
3012                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
3013                             regnode * const noper = NEXTOPER( cur );
3014 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
3015                             regnode * const noper_next = regnext( noper );
3016 #endif
3017
3018                             DEBUG_OPTIMISE_r({
3019                                 regprop(RExC_rx, mysv, cur);
3020                                 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
3021                                    (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
3022
3023                                 regprop(RExC_rx, mysv, noper);
3024                                 PerlIO_printf( Perl_debug_log, " -> %s",
3025                                     SvPV_nolen_const(mysv));
3026
3027                                 if ( noper_next ) {
3028                                   regprop(RExC_rx, mysv, noper_next );
3029                                   PerlIO_printf( Perl_debug_log,"\t=> %s\t",
3030                                     SvPV_nolen_const(mysv));
3031                                 }
3032                                 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d)\n",
3033                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur) );
3034                             });
3035                             if ( (((first && optype!=NOTHING) ? OP( noper ) == optype
3036                                          : PL_regkind[ OP( noper ) ] == EXACT )
3037                                   || OP(noper) == NOTHING )
3038 #ifdef NOJUMPTRIE
3039                                   && noper_next == tail
3040 #endif
3041                                   && count < U16_MAX)
3042                             {
3043                                 count++;
3044                                 if ( !first || optype == NOTHING ) {
3045                                     if (!first) first = cur;
3046                                     optype = OP( noper );
3047                                 } else {
3048                                     last = cur;
3049                                 }
3050                             } else {
3051 /* 
3052     Currently the trie logic handles case insensitive matching properly only
3053     when the pattern is UTF-8 and the node is EXACTFU (thus forcing unicode
3054     semantics).
3055
3056     If/when this is fixed the following define can be swapped
3057     in below to fully enable trie logic.
3058
3059 #define TRIE_TYPE_IS_SAFE 1
3060
3061 */
3062 #define TRIE_TYPE_IS_SAFE ((UTF && optype == EXACTFU) || optype==EXACT)
3063
3064                                 if ( last && TRIE_TYPE_IS_SAFE ) {
3065                                     make_trie( pRExC_state, 
3066                                             startbranch, first, cur, tail, count, 
3067                                             optype, depth+1 );
3068                                 }
3069                                 if ( PL_regkind[ OP( noper ) ] == EXACT
3070 #ifdef NOJUMPTRIE
3071                                      && noper_next == tail
3072 #endif
3073                                 ){
3074                                     count = 1;
3075                                     first = cur;
3076                                     optype = OP( noper );
3077                                 } else {
3078                                     count = 0;
3079                                     first = NULL;
3080                                     optype = 0;
3081                                 }
3082                                 last = NULL;
3083                             }
3084                         }
3085                         DEBUG_OPTIMISE_r({
3086                             regprop(RExC_rx, mysv, cur);
3087                             PerlIO_printf( Perl_debug_log,
3088                               "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
3089                               "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3090
3091                         });
3092                         
3093                         if ( last && TRIE_TYPE_IS_SAFE ) {
3094                             made= make_trie( pRExC_state, startbranch, first, scan, tail, count, optype, depth+1 );
3095 #ifdef TRIE_STUDY_OPT   
3096                             if ( ((made == MADE_EXACT_TRIE && 
3097                                  startbranch == first) 
3098                                  || ( first_non_open == first )) && 
3099                                  depth==0 ) {
3100                                 flags |= SCF_TRIE_RESTUDY;
3101                                 if ( startbranch == first 
3102                                      && scan == tail ) 
3103                                 {
3104                                     RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
3105                                 }
3106                             }
3107 #endif
3108                         }
3109                     }
3110                     
3111                 } /* do trie */
3112                 
3113             }
3114             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
3115                 scan = NEXTOPER(NEXTOPER(scan));
3116             } else                      /* single branch is optimized. */
3117                 scan = NEXTOPER(scan);
3118             continue;
3119         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
3120             scan_frame *newframe = NULL;
3121             I32 paren;
3122             regnode *start;
3123             regnode *end;
3124
3125             if (OP(scan) != SUSPEND) {
3126             /* set the pointer */
3127                 if (OP(scan) == GOSUB) {
3128                     paren = ARG(scan);
3129                     RExC_recurse[ARG2L(scan)] = scan;
3130                     start = RExC_open_parens[paren-1];
3131                     end   = RExC_close_parens[paren-1];
3132                 } else {
3133                     paren = 0;
3134                     start = RExC_rxi->program + 1;
3135                     end   = RExC_opend;
3136                 }
3137                 if (!recursed) {
3138                     Newxz(recursed, (((RExC_npar)>>3) +1), U8);
3139                     SAVEFREEPV(recursed);
3140                 }
3141                 if (!PAREN_TEST(recursed,paren+1)) {
3142                     PAREN_SET(recursed,paren+1);
3143                     Newx(newframe,1,scan_frame);
3144                 } else {
3145                     if (flags & SCF_DO_SUBSTR) {
3146                         SCAN_COMMIT(pRExC_state,data,minlenp);
3147                         data->longest = &(data->longest_float);
3148                     }
3149                     is_inf = is_inf_internal = 1;
3150                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3151                         cl_anything(pRExC_state, data->start_class);
3152                     flags &= ~SCF_DO_STCLASS;
3153                 }
3154             } else {
3155                 Newx(newframe,1,scan_frame);
3156                 paren = stopparen;
3157                 start = scan+2;
3158                 end = regnext(scan);
3159             }
3160             if (newframe) {
3161                 assert(start);
3162                 assert(end);
3163                 SAVEFREEPV(newframe);
3164                 newframe->next = regnext(scan);
3165                 newframe->last = last;
3166                 newframe->stop = stopparen;
3167                 newframe->prev = frame;
3168
3169                 frame = newframe;
3170                 scan =  start;
3171                 stopparen = paren;
3172                 last = end;
3173
3174                 continue;
3175             }
3176         }
3177         else if (OP(scan) == EXACT) {
3178             I32 l = STR_LEN(scan);
3179             UV uc;
3180             if (UTF) {
3181                 const U8 * const s = (U8*)STRING(scan);
3182                 l = utf8_length(s, s + l);
3183                 uc = utf8_to_uvchr(s, NULL);
3184             } else {
3185                 uc = *((U8*)STRING(scan));
3186             }
3187             min += l;
3188             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
3189                 /* The code below prefers earlier match for fixed
3190                    offset, later match for variable offset.  */
3191                 if (data->last_end == -1) { /* Update the start info. */
3192                     data->last_start_min = data->pos_min;
3193                     data->last_start_max = is_inf
3194                         ? I32_MAX : data->pos_min + data->pos_delta;
3195                 }
3196                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
3197                 if (UTF)
3198                     SvUTF8_on(data->last_found);
3199                 {
3200                     SV * const sv = data->last_found;
3201                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3202                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
3203                     if (mg && mg->mg_len >= 0)
3204                         mg->mg_len += utf8_length((U8*)STRING(scan),
3205                                                   (U8*)STRING(scan)+STR_LEN(scan));
3206                 }
3207                 data->last_end = data->pos_min + l;
3208                 data->pos_min += l; /* As in the first entry. */
3209                 data->flags &= ~SF_BEFORE_EOL;
3210             }
3211             if (flags & SCF_DO_STCLASS_AND) {
3212                 /* Check whether it is compatible with what we know already! */
3213                 int compat = 1;
3214
3215
3216                 /* If compatible, we or it in below.  It is compatible if is
3217                  * in the bitmp and either 1) its bit or its fold is set, or 2)
3218                  * it's for a locale.  Even if there isn't unicode semantics
3219                  * here, at runtime there may be because of matching against a
3220                  * utf8 string, so accept a possible false positive for
3221                  * latin1-range folds */
3222                 if (uc >= 0x100 ||
3223                     (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3224                     && !ANYOF_BITMAP_TEST(data->start_class, uc)
3225                     && (!(data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD)
3226                         || !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3227                     )
3228                 {
3229                     compat = 0;
3230                 }
3231                 ANYOF_CLASS_ZERO(data->start_class);
3232                 ANYOF_BITMAP_ZERO(data->start_class);
3233                 if (compat)
3234                     ANYOF_BITMAP_SET(data->start_class, uc);
3235                 else if (uc >= 0x100) {
3236                     int i;
3237
3238                     /* Some Unicode code points fold to the Latin1 range; as
3239                      * XXX temporary code, instead of figuring out if this is
3240                      * one, just assume it is and set all the start class bits
3241                      * that could be some such above 255 code point's fold
3242                      * which will generate fals positives.  As the code
3243                      * elsewhere that does compute the fold settles down, it
3244                      * can be extracted out and re-used here */
3245                     for (i = 0; i < 256; i++){
3246                         if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3247                             ANYOF_BITMAP_SET(data->start_class, i);
3248                         }
3249                     }
3250                 }
3251                 data->start_class->flags &= ~ANYOF_EOS;
3252                 if (uc < 0x100)
3253                   data->start_class->flags &= ~ANYOF_UNICODE_ALL;
3254             }
3255             else if (flags & SCF_DO_STCLASS_OR) {
3256                 /* false positive possible if the class is case-folded */
3257                 if (uc < 0x100)
3258                     ANYOF_BITMAP_SET(data->start_class, uc);
3259                 else
3260                     data->start_class->flags |= ANYOF_UNICODE_ALL;
3261                 data->start_class->flags &= ~ANYOF_EOS;
3262                 cl_and(data->start_class, and_withp);
3263             }
3264             flags &= ~SCF_DO_STCLASS;
3265         }
3266         else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
3267             I32 l = STR_LEN(scan);
3268             UV uc = *((U8*)STRING(scan));
3269
3270             /* Search for fixed substrings supports EXACT only. */
3271             if (flags & SCF_DO_SUBSTR) {
3272                 assert(data);
3273                 SCAN_COMMIT(pRExC_state, data, minlenp);
3274             }
3275             if (UTF) {
3276                 const U8 * const s = (U8 *)STRING(scan);
3277                 l = utf8_length(s, s + l);
3278                 uc = utf8_to_uvchr(s, NULL);
3279             }
3280             min += l;
3281             if (flags & SCF_DO_SUBSTR)
3282                 data->pos_min += l;
3283             if (flags & SCF_DO_STCLASS_AND) {
3284                 /* Check whether it is compatible with what we know already! */
3285                 int compat = 1;
3286                 if (uc >= 0x100 ||
3287                  (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3288                   && !ANYOF_BITMAP_TEST(data->start_class, uc)
3289                   && !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3290                 {
3291                     compat = 0;
3292                 }
3293                 ANYOF_CLASS_ZERO(data->start_class);
3294                 ANYOF_BITMAP_ZERO(data->start_class);
3295                 if (compat) {
3296                     ANYOF_BITMAP_SET(data->start_class, uc);
3297                     data->start_class->flags &= ~ANYOF_EOS;
3298                     data->start_class->flags |= ANYOF_LOC_NONBITMAP_FOLD;
3299                     if (OP(scan) == EXACTFL) {
3300                         /* XXX This set is probably no longer necessary, and
3301                          * probably wrong as LOCALE now is on in the initial
3302                          * state */
3303                         data->start_class->flags |= ANYOF_LOCALE;
3304                     }
3305                     else {
3306
3307                         /* Also set the other member of the fold pair.  In case
3308                          * that unicode semantics is called for at runtime, use
3309                          * the full latin1 fold.  (Can't do this for locale,
3310                          * because not known until runtime */
3311                         ANYOF_BITMAP_SET(data->start_class, PL_fold_latin1[uc]);
3312                     }
3313                 }
3314                 else if (uc >= 0x100) {
3315                     int i;
3316                     for (i = 0; i < 256; i++){
3317                         if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3318                             ANYOF_BITMAP_SET(data->start_class, i);
3319                         }
3320                     }
3321                 }
3322             }
3323             else if (flags & SCF_DO_STCLASS_OR) {
3324                 if (data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD) {
3325                     /* false positive possible if the class is case-folded.
3326                        Assume that the locale settings are the same... */
3327                     if (uc < 0x100) {
3328                         ANYOF_BITMAP_SET(data->start_class, uc);
3329                         if (OP(scan) != EXACTFL) {
3330
3331                             /* And set the other member of the fold pair, but
3332                              * can't do that in locale because not known until
3333                              * run-time */
3334                             ANYOF_BITMAP_SET(data->start_class,
3335                                              PL_fold_latin1[uc]);
3336                         }
3337                     }
3338                     data->start_class->flags &= ~ANYOF_EOS;
3339                 }
3340                 cl_and(data->start_class, and_withp);
3341             }
3342             flags &= ~SCF_DO_STCLASS;
3343         }
3344         else if (REGNODE_VARIES(OP(scan))) {
3345             I32 mincount, maxcount, minnext, deltanext, fl = 0;
3346             I32 f = flags, pos_before = 0;
3347             regnode * const oscan = scan;
3348             struct regnode_charclass_class this_class;
3349             struct regnode_charclass_class *oclass = NULL;
3350             I32 next_is_eval = 0;
3351
3352             switch (PL_regkind[OP(scan)]) {
3353             case WHILEM:                /* End of (?:...)* . */
3354                 scan = NEXTOPER(scan);
3355                 goto finish;
3356             case PLUS:
3357                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
3358                     next = NEXTOPER(scan);
3359                     if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
3360                         mincount = 1;
3361                         maxcount = REG_INFTY;
3362                         next = regnext(scan);
3363                         scan = NEXTOPER(scan);
3364                         goto do_curly;
3365                     }
3366                 }
3367                 if (flags & SCF_DO_SUBSTR)
3368                     data->pos_min++;
3369                 min++;
3370                 /* Fall through. */
3371             case STAR:
3372                 if (flags & SCF_DO_STCLASS) {
3373                     mincount = 0;
3374                     maxcount = REG_INFTY;
3375                     next = regnext(scan);
3376                     scan = NEXTOPER(scan);
3377                     goto do_curly;
3378                 }
3379                 is_inf = is_inf_internal = 1;
3380                 scan = regnext(scan);
3381                 if (flags & SCF_DO_SUBSTR) {
3382                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
3383                     data->longest = &(data->longest_float);
3384                 }
3385                 goto optimize_curly_tail;
3386             case CURLY:
3387                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
3388                     && (scan->flags == stopparen))
3389                 {
3390                     mincount = 1;
3391                     maxcount = 1;
3392                 } else {
3393                     mincount = ARG1(scan);
3394                     maxcount = ARG2(scan);
3395                 }
3396                 next = regnext(scan);
3397                 if (OP(scan) == CURLYX) {
3398                     I32 lp = (data ? *(data->last_closep) : 0);
3399                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
3400                 }
3401                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3402                 next_is_eval = (OP(scan) == EVAL);
3403               do_curly:
3404                 if (flags & SCF_DO_SUBSTR) {
3405                     if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
3406                     pos_before = data->pos_min;
3407                 }
3408                 if (data) {
3409                     fl = data->flags;
3410                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
3411                     if (is_inf)
3412                         data->flags |= SF_IS_INF;
3413                 }
3414                 if (flags & SCF_DO_STCLASS) {
3415                     cl_init(pRExC_state, &this_class);
3416                     oclass = data->start_class;
3417                     data->start_class = &this_class;
3418                     f |= SCF_DO_STCLASS_AND;
3419                     f &= ~SCF_DO_STCLASS_OR;
3420                 }
3421                 /* Exclude from super-linear cache processing any {n,m}
3422                    regops for which the combination of input pos and regex
3423                    pos is not enough information to determine if a match
3424                    will be possible.
3425
3426                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
3427                    regex pos at the \s*, the prospects for a match depend not
3428                    only on the input position but also on how many (bar\s*)
3429                    repeats into the {4,8} we are. */
3430                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
3431                     f &= ~SCF_WHILEM_VISITED_POS;
3432
3433                 /* This will finish on WHILEM, setting scan, or on NULL: */
3434                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, 
3435                                       last, data, stopparen, recursed, NULL,
3436                                       (mincount == 0
3437                                         ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
3438
3439                 if (flags & SCF_DO_STCLASS)
3440                     data->start_class = oclass;
3441                 if (mincount == 0 || minnext == 0) {
3442                     if (flags & SCF_DO_STCLASS_OR) {
3443                         cl_or(pRExC_state, data->start_class, &this_class);
3444                     }
3445                     else if (flags & SCF_DO_STCLASS_AND) {
3446                         /* Switch to OR mode: cache the old value of
3447                          * data->start_class */
3448                         INIT_AND_WITHP;
3449                         StructCopy(data->start_class, and_withp,
3450                                    struct regnode_charclass_class);
3451                         flags &= ~SCF_DO_STCLASS_AND;
3452                         StructCopy(&this_class, data->start_class,
3453                                    struct regnode_charclass_class);
3454                         flags |= SCF_DO_STCLASS_OR;
3455                         data->start_class->flags |= ANYOF_EOS;
3456                     }
3457                 } else {                /* Non-zero len */
3458                     if (flags & SCF_DO_STCLASS_OR) {
3459                         cl_or(pRExC_state, data->start_class, &this_class);
3460                         cl_and(data->start_class, and_withp);
3461                     }
3462                     else if (flags & SCF_DO_STCLASS_AND)
3463                         cl_and(data->start_class, &this_class);
3464                     flags &= ~SCF_DO_STCLASS;
3465                 }
3466                 if (!scan)              /* It was not CURLYX, but CURLY. */
3467                     scan = next;
3468                 if ( /* ? quantifier ok, except for (?{ ... }) */
3469                     (next_is_eval || !(mincount == 0 && maxcount == 1))
3470                     && (minnext == 0) && (deltanext == 0)
3471                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
3472                     && maxcount <= REG_INFTY/3) /* Complement check for big count */
3473                 {
3474                     ckWARNreg(RExC_parse,
3475                               "Quantifier unexpected on zero-length expression");
3476                 }
3477
3478                 min += minnext * mincount;
3479                 is_inf_internal |= ((maxcount == REG_INFTY
3480                                      && (minnext + deltanext) > 0)
3481                                     || deltanext == I32_MAX);
3482                 is_inf |= is_inf_internal;
3483                 delta += (minnext + deltanext) * maxcount - minnext * mincount;
3484
3485                 /* Try powerful optimization CURLYX => CURLYN. */
3486                 if (  OP(oscan) == CURLYX && data
3487                       && data->flags & SF_IN_PAR
3488                       && !(data->flags & SF_HAS_EVAL)
3489                       && !deltanext && minnext == 1 ) {
3490                     /* Try to optimize to CURLYN.  */
3491                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
3492                     regnode * const nxt1 = nxt;
3493 #ifdef DEBUGGING
3494                     regnode *nxt2;
3495 #endif
3496
3497                     /* Skip open. */
3498                     nxt = regnext(nxt);
3499                     if (!REGNODE_SIMPLE(OP(nxt))
3500                         && !(PL_regkind[OP(nxt)] == EXACT
3501                              && STR_LEN(nxt) == 1))
3502                         goto nogo;
3503 #ifdef DEBUGGING
3504                     nxt2 = nxt;
3505 #endif
3506                     nxt = regnext(nxt);
3507                     if (OP(nxt) != CLOSE)
3508                         goto nogo;
3509                     if (RExC_open_parens) {
3510                         RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3511                         RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
3512                     }
3513                     /* Now we know that nxt2 is the only contents: */
3514                     oscan->flags = (U8)ARG(nxt);
3515                     OP(oscan) = CURLYN;
3516                     OP(nxt1) = NOTHING; /* was OPEN. */
3517
3518 #ifdef DEBUGGING
3519                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3520                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
3521                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
3522                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
3523                     OP(nxt + 1) = OPTIMIZED; /* was count. */
3524                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
3525 #endif
3526                 }
3527               nogo:
3528
3529                 /* Try optimization CURLYX => CURLYM. */
3530                 if (  OP(oscan) == CURLYX && data
3531                       && !(data->flags & SF_HAS_PAR)
3532                       && !(data->flags & SF_HAS_EVAL)
3533                       && !deltanext     /* atom is fixed width */
3534                       && minnext != 0   /* CURLYM can't handle zero width */
3535                 ) {
3536                     /* XXXX How to optimize if data == 0? */
3537                     /* Optimize to a simpler form.  */
3538                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
3539                     regnode *nxt2;
3540
3541                     OP(oscan) = CURLYM;
3542                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
3543                             && (OP(nxt2) != WHILEM))
3544                         nxt = nxt2;
3545                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
3546                     /* Need to optimize away parenths. */
3547                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
3548                         /* Set the parenth number.  */
3549                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
3550
3551                         oscan->flags = (U8)ARG(nxt);
3552                         if (RExC_open_parens) {
3553                             RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3554                             RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
3555                         }
3556                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
3557                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
3558
3559 #ifdef DEBUGGING
3560                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3561                         OP(nxt + 1) = OPTIMIZED; /* was count. */
3562                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
3563                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
3564 #endif
3565 #if 0
3566                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
3567                             regnode *nnxt = regnext(nxt1);
3568                             if (nnxt == nxt) {
3569                                 if (reg_off_by_arg[OP(nxt1)])
3570                                     ARG_SET(nxt1, nxt2 - nxt1);
3571                                 else if (nxt2 - nxt1 < U16_MAX)
3572                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
3573                                 else
3574                                     OP(nxt) = NOTHING;  /* Cannot beautify */
3575                             }
3576                             nxt1 = nnxt;
3577                         }
3578 #endif
3579                         /* Optimize again: */
3580                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
3581                                     NULL, stopparen, recursed, NULL, 0,depth+1);
3582                     }
3583                     else
3584                         oscan->flags = 0;
3585                 }
3586                 else if ((OP(oscan) == CURLYX)
3587                          && (flags & SCF_WHILEM_VISITED_POS)
3588                          /* See the comment on a similar expression above.
3589                             However, this time it's not a subexpression
3590                             we care about, but the expression itself. */
3591                          && (maxcount == REG_INFTY)
3592                          && data && ++data->whilem_c < 16) {
3593                     /* This stays as CURLYX, we can put the count/of pair. */
3594                     /* Find WHILEM (as in regexec.c) */
3595                     regnode *nxt = oscan + NEXT_OFF(oscan);
3596
3597                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
3598                         nxt += ARG(nxt);
3599                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
3600                         | (RExC_whilem_seen << 4)); /* On WHILEM */
3601                 }
3602                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
3603                     pars++;
3604                 if (flags & SCF_DO_SUBSTR) {
3605                     SV *last_str = NULL;
3606                     int counted = mincount != 0;
3607
3608                     if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
3609 #if defined(SPARC64_GCC_WORKAROUND)
3610                         I32 b = 0;
3611                         STRLEN l = 0;
3612                         const char *s = NULL;
3613                         I32 old = 0;
3614
3615                         if (pos_before >= data->last_start_min)
3616                             b = pos_before;
3617                         else
3618                             b = data->last_start_min;
3619
3620                         l = 0;
3621                         s = SvPV_const(data->last_found, l);
3622                         old = b - data->last_start_min;
3623
3624 #else
3625                         I32 b = pos_before >= data->last_start_min
3626                             ? pos_before : data->last_start_min;
3627                         STRLEN l;
3628                         const char * const s = SvPV_const(data->last_found, l);
3629                         I32 old = b - data->last_start_min;
3630 #endif
3631
3632                         if (UTF)
3633                             old = utf8_hop((U8*)s, old) - (U8*)s;
3634                         l -= old;
3635                         /* Get the added string: */
3636                         last_str = newSVpvn_utf8(s  + old, l, UTF);
3637                         if (deltanext == 0 && pos_before == b) {
3638                             /* What was added is a constant string */
3639                             if (mincount > 1) {
3640                                 SvGROW(last_str, (mincount * l) + 1);
3641                                 repeatcpy(SvPVX(last_str) + l,
3642                                           SvPVX_const(last_str), l, mincount - 1);
3643                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
3644                                 /* Add additional parts. */
3645                                 SvCUR_set(data->last_found,
3646                                           SvCUR(data->last_found) - l);
3647                                 sv_catsv(data->last_found, last_str);
3648                                 {
3649                                     SV * sv = data->last_found;
3650                                     MAGIC *mg =
3651                                         SvUTF8(sv) && SvMAGICAL(sv) ?
3652                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
3653                                     if (mg && mg->mg_len >= 0)
3654                                         mg->mg_len += CHR_SVLEN(last_str) - l;
3655                                 }
3656                                 data->last_end += l * (mincount - 1);
3657                             }
3658                         } else {
3659                             /* start offset must point into the last copy */
3660                             data->last_start_min += minnext * (mincount - 1);
3661                             data->last_start_max += is_inf ? I32_MAX
3662                                 : (maxcount - 1) * (minnext + data->pos_delta);
3663                         }
3664                     }
3665                     /* It is counted once already... */
3666                     data->pos_min += minnext * (mincount - counted);
3667                     data->pos_delta += - counted * deltanext +
3668                         (minnext + deltanext) * maxcount - minnext * mincount;
3669                     if (mincount != maxcount) {
3670                          /* Cannot extend fixed substrings found inside
3671                             the group.  */
3672                         SCAN_COMMIT(pRExC_state,data,minlenp);
3673                         if (mincount && last_str) {
3674                             SV * const sv = data->last_found;
3675                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3676                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
3677
3678                             if (mg)
3679                                 mg->mg_len = -1;
3680                             sv_setsv(sv, last_str);
3681                             data->last_end = data->pos_min;
3682                             data->last_start_min =
3683                                 data->pos_min - CHR_SVLEN(last_str);
3684                             data->last_start_max = is_inf
3685                                 ? I32_MAX
3686                                 : data->pos_min + data->pos_delta
3687                                 - CHR_SVLEN(last_str);
3688                         }
3689                         data->longest = &(data->longest_float);
3690                     }
3691                     SvREFCNT_dec(last_str);
3692                 }
3693                 if (data && (fl & SF_HAS_EVAL))
3694                     data->flags |= SF_HAS_EVAL;
3695               optimize_curly_tail:
3696                 if (OP(oscan) != CURLYX) {
3697                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
3698                            && NEXT_OFF(next))
3699                         NEXT_OFF(oscan) += NEXT_OFF(next);
3700                 }
3701                 continue;
3702             default:                    /* REF, ANYOFV, and CLUMP only? */
3703                 if (flags & SCF_DO_SUBSTR) {
3704                     SCAN_COMMIT(pRExC_state,data,minlenp);      /* Cannot expect anything... */
3705                     data->longest = &(data->longest_float);
3706                 }
3707                 is_inf = is_inf_internal = 1;
3708                 if (flags & SCF_DO_STCLASS_OR)
3709                     cl_anything(pRExC_state, data->start_class);
3710                 flags &= ~SCF_DO_STCLASS;
3711                 break;
3712             }
3713         }
3714         else if (OP(scan) == LNBREAK) {
3715             if (flags & SCF_DO_STCLASS) {
3716                 int value = 0;
3717                 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
3718                 if (flags & SCF_DO_STCLASS_AND) {
3719                     for (value = 0; value < 256; value++)
3720                         if (!is_VERTWS_cp(value))
3721                             ANYOF_BITMAP_CLEAR(data->start_class, value);
3722                 }
3723                 else {
3724                     for (value = 0; value < 256; value++)
3725                         if (is_VERTWS_cp(value))
3726                             ANYOF_BITMAP_SET(data->start_class, value);
3727                 }
3728                 if (flags & SCF_DO_STCLASS_OR)
3729                     cl_and(data->start_class, and_withp);
3730                 flags &= ~SCF_DO_STCLASS;
3731             }
3732             min += 1;
3733             delta += 1;
3734             if (flags & SCF_DO_SUBSTR) {
3735                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
3736                 data->pos_min += 1;
3737                 data->pos_delta += 1;
3738                 data->longest = &(data->longest_float);
3739             }
3740         }
3741         else if (OP(scan) == FOLDCHAR) {
3742             int d = ARG(scan) == LATIN_SMALL_LETTER_SHARP_S ? 1 : 2;
3743             flags &= ~SCF_DO_STCLASS;
3744             min += 1;
3745             delta += d;
3746             if (flags & SCF_DO_SUBSTR) {
3747                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
3748                 data->pos_min += 1;
3749                 data->pos_delta += d;
3750                 data->longest = &(data->longest_float);
3751             }
3752         }
3753         else if (REGNODE_SIMPLE(OP(scan))) {
3754             int value = 0;
3755
3756             if (flags & SCF_DO_SUBSTR) {
3757                 SCAN_COMMIT(pRExC_state,data,minlenp);
3758                 data->pos_min++;
3759             }
3760             min++;
3761             if (flags & SCF_DO_STCLASS) {
3762                 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
3763
3764                 /* Some of the logic below assumes that switching
3765                    locale on will only add false positives. */
3766                 switch (PL_regkind[OP(scan)]) {
3767                 case SANY:
3768                 default:
3769                   do_default:
3770                     /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
3771                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3772                         cl_anything(pRExC_state, data->start_class);
3773                     break;
3774                 case REG_ANY:
3775                     if (OP(scan) == SANY)
3776                         goto do_default;
3777                     if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
3778                         value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
3779                                  || ANYOF_CLASS_TEST_ANY_SET(data->start_class));
3780                         cl_anything(pRExC_state, data->start_class);
3781                     }
3782                     if (flags & SCF_DO_STCLASS_AND || !value)
3783                         ANYOF_BITMAP_CLEAR(data->start_class,'\n');
3784                     break;
3785                 case ANYOF:
3786                     if (flags & SCF_DO_STCLASS_AND)
3787                         cl_and(data->start_class,
3788                                (struct regnode_charclass_class*)scan);
3789                     else
3790                         cl_or(pRExC_state, data->start_class,
3791                               (struct regnode_charclass_class*)scan);
3792                     break;
3793                 case ALNUM:
3794                     if (flags & SCF_DO_STCLASS_AND) {
3795                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3796                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
3797                             if (OP(scan) == ALNUMU) {
3798                                 for (value = 0; value < 256; value++) {
3799                                     if (!isWORDCHAR_L1(value)) {
3800                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3801                                     }
3802                                 }
3803                             } else {
3804                                 for (value = 0; value < 256; value++) {
3805                                     if (!isALNUM(value)) {
3806                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3807                                     }
3808                                 }
3809                             }
3810                         }
3811                     }
3812                     else {
3813                         if (data->start_class->flags & ANYOF_LOCALE)
3814                             ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
3815
3816                         /* Even if under locale, set the bits for non-locale
3817                          * in case it isn't a true locale-node.  This will
3818                          * create false positives if it truly is locale */
3819                         if (OP(scan) == ALNUMU) {
3820                             for (value = 0; value < 256; value++) {
3821                                 if (isWORDCHAR_L1(value)) {
3822                                     ANYOF_BITMAP_SET(data->start_class, value);
3823                                 }
3824                             }
3825                         } else {
3826                             for (value = 0; value < 256; value++) {
3827                                 if (isALNUM(value)) {
3828                                     ANYOF_BITMAP_SET(data->start_class, value);
3829                                 }
3830                             }
3831                         }
3832                     }
3833                     break;
3834                 case NALNUM:
3835                     if (flags & SCF_DO_STCLASS_AND) {
3836                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3837                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
3838                             if (OP(scan) == NALNUMU) {
3839                                 for (value = 0; value < 256; value++) {
3840                                     if (isWORDCHAR_L1(value)) {
3841                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3842                                     }
3843                                 }
3844                             } else {
3845                                 for (value = 0; value < 256; value++) {
3846                                     if (isALNUM(value)) {
3847                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3848                                     }
3849                                 }
3850                             }
3851                         }
3852                     }
3853                     else {
3854                         if (data->start_class->flags & ANYOF_LOCALE)
3855                             ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
3856
3857                         /* Even if under locale, set the bits for non-locale in
3858                          * case it isn't a true locale-node.  This will create
3859                          * false positives if it truly is locale */
3860                         if (OP(scan) == NALNUMU) {
3861                             for (value = 0; value < 256; value++) {
3862                                 if (! isWORDCHAR_L1(value)) {
3863                                     ANYOF_BITMAP_SET(data->start_class, value);
3864                                 }
3865                             }
3866                         } else {
3867                             for (value = 0; value < 256; value++) {
3868                                 if (! isALNUM(value)) {
3869                                     ANYOF_BITMAP_SET(data->start_class, value);
3870                                 }
3871                             }
3872                         }
3873                     }
3874                     break;
3875                 case SPACE:
3876                     if (flags & SCF_DO_STCLASS_AND) {
3877                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3878                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
3879                             if (OP(scan) == SPACEU) {
3880                                 for (value = 0; value < 256; value++) {
3881                                     if (!isSPACE_L1(value)) {
3882                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3883                                     }
3884                                 }
3885                             } else {
3886                                 for (value = 0; value < 256; value++) {
3887                                     if (!isSPACE(value)) {
3888                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3889                                     }
3890                                 }
3891                             }
3892                         }
3893                     }
3894                     else {
3895                         if (data->start_class->flags & ANYOF_LOCALE) {
3896                             ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
3897                         }
3898                         if (OP(scan) == SPACEU) {
3899                             for (value = 0; value < 256; value++) {
3900                                 if (isSPACE_L1(value)) {
3901                                     ANYOF_BITMAP_SET(data->start_class, value);
3902                                 }
3903                             }
3904                         } else {
3905                             for (value = 0; value < 256; value++) {
3906                                 if (isSPACE(value)) {
3907                                     ANYOF_BITMAP_SET(data->start_class, value);
3908                                 }
3909                             }
3910                         }
3911                     }
3912                     break;
3913                 case NSPACE:
3914                     if (flags & SCF_DO_STCLASS_AND) {
3915                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3916                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
3917                             if (OP(scan) == NSPACEU) {
3918                                 for (value = 0; value < 256; value++) {
3919                                     if (isSPACE_L1(value)) {
3920                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3921                                     }
3922                                 }
3923                             } else {
3924                                 for (value = 0; value < 256; value++) {
3925                                     if (isSPACE(value)) {
3926                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3927                                     }
3928                                 }
3929                             }
3930                         }
3931                     }
3932                     else {
3933                         if (data->start_class->flags & ANYOF_LOCALE)
3934                             ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
3935                         if (OP(scan) == NSPACEU) {
3936                             for (value = 0; value < 256; value++) {
3937                                 if (!isSPACE_L1(value)) {
3938                                     ANYOF_BITMAP_SET(data->start_class, value);
3939                                 }
3940                             }
3941                         }
3942                         else {
3943                             for (value = 0; value < 256; value++) {
3944                                 if (!isSPACE(value)) {
3945                                     ANYOF_BITMAP_SET(data->start_class, value);
3946                                 }
3947                             }
3948                         }
3949                     }
3950                     break;
3951                 case DIGIT:
3952                     if (flags & SCF_DO_STCLASS_AND) {
3953                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3954                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
3955                             for (value = 0; value < 256; value++)
3956                                 if (!isDIGIT(value))
3957                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
3958                         }
3959                     }
3960                     else {
3961                         if (data->start_class->flags & ANYOF_LOCALE)
3962                             ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
3963                         for (value = 0; value < 256; value++)
3964                             if (isDIGIT(value))
3965                                 ANYOF_BITMAP_SET(data->start_class, value);
3966                     }
3967                     break;
3968                 case NDIGIT:
3969                     if (flags & SCF_DO_STCLASS_AND) {
3970                         if (!(data->start_class->flags & ANYOF_LOCALE))
3971                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
3972                         for (value = 0; value < 256; value++)
3973                             if (isDIGIT(value))
3974                                 ANYOF_BITMAP_CLEAR(data->start_class, value);
3975                     }
3976                     else {
3977                         if (data->start_class->flags & ANYOF_LOCALE)
3978                             ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
3979                         for (value = 0; value < 256; value++)
3980                             if (!isDIGIT(value))
3981                                 ANYOF_BITMAP_SET(data->start_class, value);
3982                     }
3983                     break;
3984                 CASE_SYNST_FNC(VERTWS);
3985                 CASE_SYNST_FNC(HORIZWS);
3986                 
3987                 }
3988                 if (flags & SCF_DO_STCLASS_OR)
3989                     cl_and(data->start_class, and_withp);
3990                 flags &= ~SCF_DO_STCLASS;
3991             }
3992         }
3993         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
3994             data->flags |= (OP(scan) == MEOL
3995                             ? SF_BEFORE_MEOL
3996                             : SF_BEFORE_SEOL);
3997         }
3998         else if (  PL_regkind[OP(scan)] == BRANCHJ
3999                  /* Lookbehind, or need to calculate parens/evals/stclass: */
4000                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
4001                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
4002             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY 
4003                 || OP(scan) == UNLESSM )
4004             {
4005                 /* Negative Lookahead/lookbehind
4006                    In this case we can't do fixed string optimisation.
4007                 */
4008
4009                 I32 deltanext, minnext, fake = 0;
4010                 regnode *nscan;
4011                 struct regnode_charclass_class intrnl;
4012                 int f = 0;
4013
4014                 data_fake.flags = 0;
4015                 if (data) {
4016                     data_fake.whilem_c = data->whilem_c;
4017                     data_fake.last_closep = data->last_closep;
4018                 }
4019                 else
4020                     data_fake.last_closep = &fake;
4021                 data_fake.pos_delta = delta;
4022                 if ( flags & SCF_DO_STCLASS && !scan->flags
4023                      && OP(scan) == IFMATCH ) { /* Lookahead */
4024                     cl_init(pRExC_state, &intrnl);
4025                     data_fake.start_class = &intrnl;
4026                     f |= SCF_DO_STCLASS_AND;
4027                 }
4028                 if (flags & SCF_WHILEM_VISITED_POS)
4029                     f |= SCF_WHILEM_VISITED_POS;
4030                 next = regnext(scan);
4031                 nscan = NEXTOPER(NEXTOPER(scan));
4032                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext, 
4033                     last, &data_fake, stopparen, recursed, NULL, f, depth+1);
4034                 if (scan->flags) {
4035                     if (deltanext) {
4036                         FAIL("Variable length lookbehind not implemented");
4037                     }
4038                     else if (minnext > (I32)U8_MAX) {
4039                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4040                     }
4041                     scan->flags = (U8)minnext;
4042                 }
4043                 if (data) {
4044                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4045                         pars++;
4046                     if (data_fake.flags & SF_HAS_EVAL)
4047                         data->flags |= SF_HAS_EVAL;
4048                     data->whilem_c = data_fake.whilem_c;
4049                 }
4050                 if (f & SCF_DO_STCLASS_AND) {
4051                     if (flags & SCF_DO_STCLASS_OR) {
4052                         /* OR before, AND after: ideally we would recurse with
4053                          * data_fake to get the AND applied by study of the
4054                          * remainder of the pattern, and then derecurse;
4055                          * *** HACK *** for now just treat as "no information".
4056                          * See [perl #56690].
4057                          */
4058                         cl_init(pRExC_state, data->start_class);
4059                     }  else {
4060                         /* AND before and after: combine and continue */
4061                         const int was = (data->start_class->flags & ANYOF_EOS);
4062
4063                         cl_and(data->start_class, &intrnl);
4064                         if (was)
4065                             data->start_class->flags |= ANYOF_EOS;
4066                     }
4067                 }
4068             }
4069 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
4070             else {
4071                 /* Positive Lookahead/lookbehind
4072                    In this case we can do fixed string optimisation,
4073                    but we must be careful about it. Note in the case of
4074                    lookbehind the positions will be offset by the minimum
4075                    length of the pattern, something we won't know about
4076                    until after the recurse.
4077                 */
4078                 I32 deltanext, fake = 0;
4079                 regnode *nscan;
4080                 struct regnode_charclass_class intrnl;
4081                 int f = 0;
4082                 /* We use SAVEFREEPV so that when the full compile 
4083                     is finished perl will clean up the allocated 
4084                     minlens when it's all done. This way we don't
4085                     have to worry about freeing them when we know
4086                     they wont be used, which would be a pain.
4087                  */
4088                 I32 *minnextp;
4089                 Newx( minnextp, 1, I32 );
4090                 SAVEFREEPV(minnextp);
4091
4092                 if (data) {
4093                     StructCopy(data, &data_fake, scan_data_t);
4094                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
4095                         f |= SCF_DO_SUBSTR;
4096                         if (scan->flags) 
4097                             SCAN_COMMIT(pRExC_state, &data_fake,minlenp);
4098                         data_fake.last_found=newSVsv(data->last_found);
4099                     }
4100                 }
4101                 else
4102                     data_fake.last_closep = &fake;
4103                 data_fake.flags = 0;
4104                 data_fake.pos_delta = delta;
4105                 if (is_inf)
4106                     data_fake.flags |= SF_IS_INF;
4107                 if ( flags & SCF_DO_STCLASS && !scan->flags
4108                      && OP(scan) == IFMATCH ) { /* Lookahead */
4109                     cl_init(pRExC_state, &intrnl);
4110                     data_fake.start_class = &intrnl;
4111                     f |= SCF_DO_STCLASS_AND;
4112                 }
4113                 if (flags & SCF_WHILEM_VISITED_POS)
4114                     f |= SCF_WHILEM_VISITED_POS;
4115                 next = regnext(scan);
4116                 nscan = NEXTOPER(NEXTOPER(scan));
4117
4118                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext, 
4119                     last, &data_fake, stopparen, recursed, NULL, f,depth+1);
4120                 if (scan->flags) {
4121                     if (deltanext) {
4122                         FAIL("Variable length lookbehind not implemented");
4123                     }
4124                     else if (*minnextp > (I32)U8_MAX) {
4125                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4126                     }
4127                     scan->flags = (U8)*minnextp;
4128                 }
4129
4130                 *minnextp += min;
4131
4132                 if (f & SCF_DO_STCLASS_AND) {
4133                     const int was = (data->start_class->flags & ANYOF_EOS);
4134
4135                     cl_and(data->start_class, &intrnl);
4136                     if (was)
4137                         data->start_class->flags |= ANYOF_EOS;
4138                 }
4139                 if (data) {
4140                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4141                         pars++;
4142                     if (data_fake.flags & SF_HAS_EVAL)
4143                         data->flags |= SF_HAS_EVAL;
4144                     data->whilem_c = data_fake.whilem_c;
4145                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
4146                         if (RExC_rx->minlen<*minnextp)
4147                             RExC_rx->minlen=*minnextp;
4148                         SCAN_COMMIT(pRExC_state, &data_fake, minnextp);
4149                         SvREFCNT_dec(data_fake.last_found);
4150                         
4151                         if ( data_fake.minlen_fixed != minlenp ) 
4152                         {
4153                             data->offset_fixed= data_fake.offset_fixed;
4154                             data->minlen_fixed= data_fake.minlen_fixed;
4155                             data->lookbehind_fixed+= scan->flags;
4156                         }
4157                         if ( data_fake.minlen_float != minlenp )
4158                         {
4159                             data->minlen_float= data_fake.minlen_float;
4160                             data->offset_float_min=data_fake.offset_float_min;
4161                             data->offset_float_max=data_fake.offset_float_max;
4162                             data->lookbehind_float+= scan->flags;
4163                         }
4164                     }
4165                 }
4166
4167
4168             }
4169 #endif
4170         }
4171         else if (OP(scan) == OPEN) {
4172             if (stopparen != (I32)ARG(scan))
4173                 pars++;
4174         }
4175         else if (OP(scan) == CLOSE) {
4176             if (stopparen == (I32)ARG(scan)) {
4177                 break;
4178             }
4179             if ((I32)ARG(scan) == is_par) {
4180                 next = regnext(scan);
4181
4182                 if ( next && (OP(next) != WHILEM) && next < last)
4183                     is_par = 0;         /* Disable optimization */
4184             }
4185             if (data)
4186                 *(data->last_closep) = ARG(scan);
4187         }
4188         else if (OP(scan) == EVAL) {
4189                 if (data)
4190                     data->flags |= SF_HAS_EVAL;
4191         }
4192         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
4193             if (flags & SCF_DO_SUBSTR) {
4194                 SCAN_COMMIT(pRExC_state,data,minlenp);
4195                 flags &= ~SCF_DO_SUBSTR;
4196             }
4197             if (data && OP(scan)==ACCEPT) {
4198                 data->flags |= SCF_SEEN_ACCEPT;
4199                 if (stopmin > min)
4200                     stopmin = min;
4201             }
4202         }
4203         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
4204         {
4205                 if (flags & SCF_DO_SUBSTR) {
4206                     SCAN_COMMIT(pRExC_state,data,minlenp);
4207                     data->longest = &(data->longest_float);
4208                 }
4209                 is_inf = is_inf_internal = 1;
4210                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4211                     cl_anything(pRExC_state, data->start_class);
4212                 flags &= ~SCF_DO_STCLASS;
4213         }
4214         else if (OP(scan) == GPOS) {
4215             if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) &&
4216                 !(delta || is_inf || (data && data->pos_delta))) 
4217             {
4218                 if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR))
4219                     RExC_rx->extflags |= RXf_ANCH_GPOS;
4220                 if (RExC_rx->gofs < (U32)min)
4221                     RExC_rx->gofs = min;
4222             } else {
4223                 RExC_rx->extflags |= RXf_GPOS_FLOAT;
4224                 RExC_rx->gofs = 0;
4225             }       
4226         }
4227 #ifdef TRIE_STUDY_OPT
4228 #ifdef FULL_TRIE_STUDY
4229         else if (PL_regkind[OP(scan)] == TRIE) {
4230             /* NOTE - There is similar code to this block above for handling
4231                BRANCH nodes on the initial study.  If you change stuff here
4232                check there too. */
4233             regnode *trie_node= scan;
4234             regnode *tail= regnext(scan);
4235             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4236             I32 max1 = 0, min1 = I32_MAX;
4237             struct regnode_charclass_class accum;
4238
4239             if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
4240                 SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
4241             if (flags & SCF_DO_STCLASS)
4242                 cl_init_zero(pRExC_state, &accum);
4243                 
4244             if (!trie->jump) {
4245                 min1= trie->minlen;
4246                 max1= trie->maxlen;
4247             } else {
4248                 const regnode *nextbranch= NULL;
4249                 U32 word;
4250                 
4251                 for ( word=1 ; word <= trie->wordcount ; word++) 
4252                 {
4253                     I32 deltanext=0, minnext=0, f = 0, fake;
4254                     struct regnode_charclass_class this_class;
4255                     
4256                     data_fake.flags = 0;
4257                     if (data) {
4258                         data_fake.whilem_c = data->whilem_c;
4259                         data_fake.last_closep = data->last_closep;
4260                     }
4261                     else
4262                         data_fake.last_closep = &fake;
4263                     data_fake.pos_delta = delta;
4264                     if (flags & SCF_DO_STCLASS) {
4265                         cl_init(pRExC_state, &this_class);
4266                         data_fake.start_class = &this_class;
4267                         f = SCF_DO_STCLASS_AND;
4268                     }
4269                     if (flags & SCF_WHILEM_VISITED_POS)
4270                         f |= SCF_WHILEM_VISITED_POS;
4271     
4272                     if (trie->jump[word]) {
4273                         if (!nextbranch)
4274                             nextbranch = trie_node + trie->jump[0];
4275                         scan= trie_node + trie->jump[word];
4276                         /* We go from the jump point to the branch that follows
4277                            it. Note this means we need the vestigal unused branches
4278                            even though they arent otherwise used.
4279                          */
4280                         minnext = study_chunk(pRExC_state, &scan, minlenp, 
4281                             &deltanext, (regnode *)nextbranch, &data_fake, 
4282                             stopparen, recursed, NULL, f,depth+1);
4283                     }
4284                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
4285                         nextbranch= regnext((regnode*)nextbranch);
4286                     
4287                     if (min1 > (I32)(minnext + trie->minlen))
4288                         min1 = minnext + trie->minlen;
4289                     if (max1 < (I32)(minnext + deltanext + trie->maxlen))
4290                         max1 = minnext + deltanext + trie->maxlen;
4291                     if (deltanext == I32_MAX)
4292                         is_inf = is_inf_internal = 1;
4293                     
4294                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4295                         pars++;
4296                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4297                         if ( stopmin > min + min1) 
4298                             stopmin = min + min1;
4299                         flags &= ~SCF_DO_SUBSTR;
4300                         if (data)
4301                             data->flags |= SCF_SEEN_ACCEPT;
4302                     }
4303                     if (data) {
4304                         if (data_fake.flags & SF_HAS_EVAL)
4305                             data->flags |= SF_HAS_EVAL;
4306                         data->whilem_c = data_fake.whilem_c;
4307                     }
4308                     if (flags & SCF_DO_STCLASS)
4309                         cl_or(pRExC_state, &accum, &this_class);
4310                 }
4311             }
4312             if (flags & SCF_DO_SUBSTR) {
4313                 data->pos_min += min1;
4314                 data->pos_delta += max1 - min1;
4315                 if (max1 != min1 || is_inf)
4316                     data->longest = &(data->longest_float);
4317             }
4318             min += min1;
4319             delta += max1 - min1;
4320             if (flags & SCF_DO_STCLASS_OR) {
4321                 cl_or(pRExC_state, data->start_class, &accum);
4322                 if (min1) {
4323                     cl_and(data->start_class, and_withp);
4324                     flags &= ~SCF_DO_STCLASS;
4325                 }
4326             }
4327             else if (flags & SCF_DO_STCLASS_AND) {
4328                 if (min1) {
4329                     cl_and(data->start_class, &accum);
4330                     flags &= ~SCF_DO_STCLASS;
4331                 }
4332                 else {
4333                     /* Switch to OR mode: cache the old value of
4334                      * data->start_class */
4335                     INIT_AND_WITHP;
4336                     StructCopy(data->start_class, and_withp,
4337                                struct regnode_charclass_class);
4338                     flags &= ~SCF_DO_STCLASS_AND;
4339                     StructCopy(&accum, data->start_class,
4340                                struct regnode_charclass_class);
4341                     flags |= SCF_DO_STCLASS_OR;
4342                     data->start_class->flags |= ANYOF_EOS;
4343                 }
4344             }
4345             scan= tail;
4346             continue;
4347         }
4348 #else
4349         else if (PL_regkind[OP(scan)] == TRIE) {
4350             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4351             U8*bang=NULL;
4352             
4353             min += trie->minlen;
4354             delta += (trie->maxlen - trie->minlen);
4355             flags &= ~SCF_DO_STCLASS; /* xxx */
4356             if (flags & SCF_DO_SUBSTR) {
4357                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
4358                 data->pos_min += trie->minlen;
4359                 data->pos_delta += (trie->maxlen - trie->minlen);
4360                 if (trie->maxlen != trie->minlen)
4361                     data->longest = &(data->longest_float);
4362             }
4363             if (trie->jump) /* no more substrings -- for now /grr*/
4364                 flags &= ~SCF_DO_SUBSTR; 
4365         }
4366 #endif /* old or new */
4367 #endif /* TRIE_STUDY_OPT */     
4368
4369         /* Else: zero-length, ignore. */
4370         scan = regnext(scan);
4371     }
4372     if (frame) {
4373         last = frame->last;
4374         scan = frame->next;
4375         stopparen = frame->stop;
4376         frame = frame->prev;
4377         goto fake_study_recurse;
4378     }
4379
4380   finish:
4381     assert(!frame);
4382     DEBUG_STUDYDATA("pre-fin:",data,depth);
4383
4384     *scanp = scan;
4385     *deltap = is_inf_internal ? I32_MAX : delta;
4386     if (flags & SCF_DO_SUBSTR && is_inf)
4387         data->pos_delta = I32_MAX - data->pos_min;
4388     if (is_par > (I32)U8_MAX)
4389         is_par = 0;
4390     if (is_par && pars==1 && data) {
4391         data->flags |= SF_IN_PAR;
4392         data->flags &= ~SF_HAS_PAR;
4393     }
4394     else if (pars && data) {
4395         data->flags |= SF_HAS_PAR;
4396         data->flags &= ~SF_IN_PAR;
4397     }
4398     if (flags & SCF_DO_STCLASS_OR)
4399         cl_and(data->start_class, and_withp);
4400     if (flags & SCF_TRIE_RESTUDY)
4401         data->flags |=  SCF_TRIE_RESTUDY;
4402     
4403     DEBUG_STUDYDATA("post-fin:",data,depth);
4404     
4405     return min < stopmin ? min : stopmin;
4406 }
4407
4408 STATIC U32
4409 S_add_data(RExC_state_t *pRExC_state, U32 n, const char *s)
4410 {
4411     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
4412
4413     PERL_ARGS_ASSERT_ADD_DATA;
4414
4415     Renewc(RExC_rxi->data,
4416            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
4417            char, struct reg_data);
4418     if(count)
4419         Renew(RExC_rxi->data->what, count + n, U8);
4420     else
4421         Newx(RExC_rxi->data->what, n, U8);
4422     RExC_rxi->data->count = count + n;
4423     Copy(s, RExC_rxi->data->what + count, n, U8);
4424     return count;
4425 }
4426
4427 /*XXX: todo make this not included in a non debugging perl */
4428 #ifndef PERL_IN_XSUB_RE
4429 void
4430 Perl_reginitcolors(pTHX)
4431 {
4432     dVAR;
4433     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
4434     if (s) {
4435         char *t = savepv(s);
4436         int i = 0;
4437         PL_colors[0] = t;
4438         while (++i < 6) {
4439             t = strchr(t, '\t');
4440             if (t) {
4441                 *t = '\0';
4442                 PL_colors[i] = ++t;
4443             }
4444             else
4445                 PL_colors[i] = t = (char *)"";
4446         }
4447     } else {
4448         int i = 0;
4449         while (i < 6)
4450             PL_colors[i++] = (char *)"";
4451     }
4452     PL_colorset = 1;
4453 }
4454 #endif
4455
4456
4457 #ifdef TRIE_STUDY_OPT
4458 #define CHECK_RESTUDY_GOTO                                  \
4459         if (                                                \
4460               (data.flags & SCF_TRIE_RESTUDY)               \
4461               && ! restudied++                              \
4462         )     goto reStudy
4463 #else
4464 #define CHECK_RESTUDY_GOTO
4465 #endif        
4466
4467 /*
4468  - pregcomp - compile a regular expression into internal code
4469  *
4470  * We can't allocate space until we know how big the compiled form will be,
4471  * but we can't compile it (and thus know how big it is) until we've got a
4472  * place to put the code.  So we cheat:  we compile it twice, once with code
4473  * generation turned off and size counting turned on, and once "for real".
4474  * This also means that we don't allocate space until we are sure that the
4475  * thing really will compile successfully, and we never have to move the
4476  * code and thus invalidate pointers into it.  (Note that it has to be in
4477  * one piece because free() must be able to free it all.) [NB: not true in perl]
4478  *
4479  * Beware that the optimization-preparation code in here knows about some
4480  * of the structure of the compiled regexp.  [I'll say.]
4481  */
4482
4483
4484
4485 #ifndef PERL_IN_XSUB_RE
4486 #define RE_ENGINE_PTR &reh_regexp_engine
4487 #else
4488 extern const struct regexp_engine my_reg_engine;
4489 #define RE_ENGINE_PTR &my_reg_engine
4490 #endif
4491
4492 #ifndef PERL_IN_XSUB_RE 
4493 REGEXP *
4494 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
4495 {
4496     dVAR;
4497     HV * const table = GvHV(PL_hintgv);
4498
4499     PERL_ARGS_ASSERT_PREGCOMP;
4500
4501     /* Dispatch a request to compile a regexp to correct 
4502        regexp engine. */
4503     if (table) {
4504         SV **ptr= hv_fetchs(table, "regcomp", FALSE);
4505         GET_RE_DEBUG_FLAGS_DECL;
4506         if (ptr && SvIOK(*ptr) && SvIV(*ptr)) {
4507             const regexp_engine *eng=INT2PTR(regexp_engine*,SvIV(*ptr));
4508             DEBUG_COMPILE_r({
4509                 PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
4510                     SvIV(*ptr));
4511             });            
4512             return CALLREGCOMP_ENG(eng, pattern, flags);
4513         } 
4514     }
4515     return Perl_re_compile(aTHX_ pattern, flags);
4516 }
4517 #endif
4518
4519 REGEXP *
4520 Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags)
4521 {
4522     dVAR;
4523     REGEXP *rx;
4524     struct regexp *r;
4525     register regexp_internal *ri;
4526     STRLEN plen;
4527     char  *exp;
4528     char* xend;
4529     regnode *scan;
4530     I32 flags;
4531     I32 minlen = 0;
4532     U32 pm_flags;
4533
4534     /* these are all flags - maybe they should be turned
4535      * into a single int with different bit masks */
4536     I32 sawlookahead = 0;
4537     I32 sawplus = 0;
4538     I32 sawopen = 0;
4539     bool used_setjump = FALSE;
4540     regex_charset initial_charset = get_regex_charset(orig_pm_flags);
4541
4542     U8 jump_ret = 0;
4543     dJMPENV;
4544     scan_data_t data;
4545     RExC_state_t RExC_state;
4546     RExC_state_t * const pRExC_state = &RExC_state;
4547 #ifdef TRIE_STUDY_OPT    
4548     int restudied;
4549     RExC_state_t copyRExC_state;
4550 #endif    
4551     GET_RE_DEBUG_FLAGS_DECL;
4552
4553     PERL_ARGS_ASSERT_RE_COMPILE;
4554
4555     DEBUG_r(if (!PL_colorset) reginitcolors());
4556
4557     RExC_utf8 = RExC_orig_utf8 = SvUTF8(pattern);
4558     RExC_uni_semantics = 0;
4559     RExC_contains_locale = 0;
4560
4561     /****************** LONG JUMP TARGET HERE***********************/
4562     /* Longjmp back to here if have to switch in midstream to utf8 */
4563     if (! RExC_orig_utf8) {
4564         JMPENV_PUSH(jump_ret);
4565         used_setjump = TRUE;
4566     }
4567
4568     if (jump_ret == 0) {    /* First time through */
4569         exp = SvPV(pattern, plen);
4570         xend = exp + plen;
4571         /* ignore the utf8ness if the pattern is 0 length */
4572         if (plen == 0) {
4573             RExC_utf8 = RExC_orig_utf8 = 0;
4574         }
4575
4576         DEBUG_COMPILE_r({
4577             SV *dsv= sv_newmortal();
4578             RE_PV_QUOTED_DECL(s, RExC_utf8,
4579                 dsv, exp, plen, 60);
4580             PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
4581                            PL_colors[4],PL_colors[5],s);
4582         });
4583     }
4584     else {  /* longjumped back */
4585         STRLEN len = plen;
4586
4587         /* If the cause for the longjmp was other than changing to utf8, pop
4588          * our own setjmp, and longjmp to the correct handler */
4589         if (jump_ret != UTF8_LONGJMP) {
4590             JMPENV_POP;
4591             JMPENV_JUMP(jump_ret);
4592         }
4593
4594         GET_RE_DEBUG_FLAGS;
4595
4596         /* It's possible to write a regexp in ascii that represents Unicode
4597         codepoints outside of the byte range, such as via \x{100}. If we
4598         detect such a sequence we have to convert the entire pattern to utf8
4599         and then recompile, as our sizing calculation will have been based
4600         on 1 byte == 1 character, but we will need to use utf8 to encode
4601         at least some part of the pattern, and therefore must convert the whole
4602         thing.
4603         -- dmq */
4604         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
4605             "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
4606         exp = (char*)Perl_bytes_to_utf8(aTHX_ (U8*)SvPV(pattern, plen), &len);
4607         xend = exp + len;
4608         RExC_orig_utf8 = RExC_utf8 = 1;
4609         SAVEFREEPV(exp);
4610     }
4611
4612 #ifdef TRIE_STUDY_OPT
4613     restudied = 0;
4614 #endif
4615
4616     pm_flags = orig_pm_flags;
4617
4618     if (initial_charset == REGEX_LOCALE_CHARSET) {
4619         RExC_contains_locale = 1;
4620     }
4621     else if (RExC_utf8 && initial_charset == REGEX_DEPENDS_CHARSET) {
4622
4623         /* Set to use unicode semantics if the pattern is in utf8 and has the
4624          * 'depends' charset specified, as it means unicode when utf8  */
4625         set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
4626     }
4627
4628     RExC_precomp = exp;
4629     RExC_flags = pm_flags;
4630     RExC_sawback = 0;
4631
4632     RExC_seen = 0;
4633     RExC_in_lookbehind = 0;
4634     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
4635     RExC_seen_evals = 0;
4636     RExC_extralen = 0;
4637     RExC_override_recoding = 0;
4638
4639     /* First pass: determine size, legality. */
4640     RExC_parse = exp;
4641     RExC_start = exp;
4642     RExC_end = xend;
4643     RExC_naughty = 0;
4644     RExC_npar = 1;
4645     RExC_nestroot = 0;
4646     RExC_size = 0L;
4647     RExC_emit = &PL_regdummy;
4648     RExC_whilem_seen = 0;
4649     RExC_open_parens = NULL;
4650     RExC_close_parens = NULL;
4651     RExC_opend = NULL;
4652     RExC_paren_names = NULL;
4653 #ifdef DEBUGGING
4654     RExC_paren_name_list = NULL;
4655 #endif
4656     RExC_recurse = NULL;
4657     RExC_recurse_count = 0;
4658
4659 #if 0 /* REGC() is (currently) a NOP at the first pass.
4660        * Clever compilers notice this and complain. --jhi */
4661     REGC((U8)REG_MAGIC, (char*)RExC_emit);
4662 #endif
4663     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n"));
4664     if (reg(pRExC_state, 0, &flags,1) == NULL) {
4665         RExC_precomp = NULL;
4666         return(NULL);
4667     }
4668
4669     /* Here, finished first pass.  Get rid of any added setjmp */
4670     if (used_setjump) {
4671         JMPENV_POP;
4672     }
4673
4674     DEBUG_PARSE_r({
4675         PerlIO_printf(Perl_debug_log, 
4676             "Required size %"IVdf" nodes\n"
4677             "Starting second pass (creation)\n", 
4678             (IV)RExC_size);
4679         RExC_lastnum=0; 
4680         RExC_lastparse=NULL; 
4681     });
4682
4683     /* The first pass could have found things that force Unicode semantics */
4684     if ((RExC_utf8 || RExC_uni_semantics)
4685          && get_regex_charset(pm_flags) == REGEX_DEPENDS_CHARSET)
4686     {
4687         set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
4688     }
4689
4690     /* Small enough for pointer-storage convention?
4691        If extralen==0, this means that we will not need long jumps. */
4692     if (RExC_size >= 0x10000L && RExC_extralen)
4693         RExC_size += RExC_extralen;
4694     else
4695         RExC_extralen = 0;
4696     if (RExC_whilem_seen > 15)
4697         RExC_whilem_seen = 15;
4698
4699     /* Allocate space and zero-initialize. Note, the two step process 
4700        of zeroing when in debug mode, thus anything assigned has to 
4701        happen after that */
4702     rx = (REGEXP*) newSV_type(SVt_REGEXP);
4703     r = (struct regexp*)SvANY(rx);
4704     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
4705          char, regexp_internal);
4706     if ( r == NULL || ri == NULL )
4707         FAIL("Regexp out of space");
4708 #ifdef DEBUGGING
4709     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
4710     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char);
4711 #else 
4712     /* bulk initialize base fields with 0. */
4713     Zero(ri, sizeof(regexp_internal), char);        
4714 #endif
4715
4716     /* non-zero initialization begins here */
4717     RXi_SET( r, ri );
4718     r->engine= RE_ENGINE_PTR;
4719     r->extflags = pm_flags;
4720     {
4721         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
4722         bool has_charset = (get_regex_charset(r->extflags) != REGEX_DEPENDS_CHARSET);
4723
4724         /* The caret is output if there are any defaults: if not all the STD
4725          * flags are set, or if no character set specifier is needed */
4726         bool has_default =
4727                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
4728                     || ! has_charset);
4729         bool has_runon = ((RExC_seen & REG_SEEN_RUN_ON_COMMENT)==REG_SEEN_RUN_ON_COMMENT);
4730         U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD)
4731                             >> RXf_PMf_STD_PMMOD_SHIFT);
4732         const char *fptr = STD_PAT_MODS;        /*"msix"*/
4733         char *p;
4734         /* Allocate for the worst case, which is all the std flags are turned
4735          * on.  If more precision is desired, we could do a population count of
4736          * the flags set.  This could be done with a small lookup table, or by
4737          * shifting, masking and adding, or even, when available, assembly
4738          * language for a machine-language population count.
4739          * We never output a minus, as all those are defaults, so are
4740          * covered by the caret */
4741         const STRLEN wraplen = plen + has_p + has_runon
4742             + has_default       /* If needs a caret */
4743
4744                 /* If needs a character set specifier */
4745             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
4746             + (sizeof(STD_PAT_MODS) - 1)
4747             + (sizeof("(?:)") - 1);
4748
4749         p = sv_grow(MUTABLE_SV(rx), wraplen + 1); /* +1 for the ending NUL */
4750         SvPOK_on(rx);
4751         SvFLAGS(rx) |= SvUTF8(pattern);
4752         *p++='('; *p++='?';
4753
4754         /* If a default, cover it using the caret */
4755         if (has_default) {
4756             *p++= DEFAULT_PAT_MOD;
4757         }
4758         if (has_charset) {
4759             STRLEN len;
4760             const char* const name = get_regex_charset_name(r->extflags, &len);
4761             Copy(name, p, len, char);
4762             p += len;
4763         }
4764         if (has_p)
4765             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
4766         {
4767             char ch;
4768             while((ch = *fptr++)) {
4769                 if(reganch & 1)
4770                     *p++ = ch;
4771                 reganch >>= 1;
4772             }
4773         }
4774
4775         *p++ = ':';
4776         Copy(RExC_precomp, p, plen, char);
4777         assert ((RX_WRAPPED(rx) - p) < 16);
4778         r->pre_prefix = p - RX_WRAPPED(rx);
4779         p += plen;
4780         if (has_runon)
4781             *p++ = '\n';
4782         *p++ = ')';
4783         *p = 0;
4784         SvCUR_set(rx, p - SvPVX_const(rx));
4785     }
4786
4787     r->intflags = 0;
4788     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
4789     
4790     if (RExC_seen & REG_SEEN_RECURSE) {
4791         Newxz(RExC_open_parens, RExC_npar,regnode *);
4792         SAVEFREEPV(RExC_open_parens);
4793         Newxz(RExC_close_parens,RExC_npar,regnode *);
4794         SAVEFREEPV(RExC_close_parens);
4795     }
4796
4797     /* Useful during FAIL. */
4798 #ifdef RE_TRACK_PATTERN_OFFSETS
4799     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
4800     DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
4801                           "%s %"UVuf" bytes for offset annotations.\n",
4802                           ri->u.offsets ? "Got" : "Couldn't get",
4803                           (UV)((2*RExC_size+1) * sizeof(U32))));
4804 #endif
4805     SetProgLen(ri,RExC_size);
4806     RExC_rx_sv = rx;
4807     RExC_rx = r;
4808     RExC_rxi = ri;
4809     REH_CALL_COMP_BEGIN_HOOK(pRExC_state->rx);
4810
4811     /* Second pass: emit code. */
4812     RExC_flags = pm_flags;      /* don't let top level (?i) bleed */
4813     RExC_parse = exp;
4814     RExC_end = xend;
4815     RExC_naughty = 0;
4816     RExC_npar = 1;
4817     RExC_emit_start = ri->program;
4818     RExC_emit = ri->program;
4819     RExC_emit_bound = ri->program + RExC_size + 1;
4820
4821     /* Store the count of eval-groups for security checks: */
4822     RExC_rx->seen_evals = RExC_seen_evals;
4823     REGC((U8)REG_MAGIC, (char*) RExC_emit++);
4824     if (reg(pRExC_state, 0, &flags,1) == NULL) {
4825         ReREFCNT_dec(rx);   
4826         return(NULL);
4827     }
4828     /* XXXX To minimize changes to RE engine we always allocate
4829        3-units-long substrs field. */
4830     Newx(r->substrs, 1, struct reg_substr_data);
4831     if (RExC_recurse_count) {
4832         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
4833         SAVEFREEPV(RExC_recurse);
4834     }
4835
4836 reStudy:
4837     r->minlen = minlen = sawlookahead = sawplus = sawopen = 0;
4838     Zero(r->substrs, 1, struct reg_substr_data);
4839
4840 #ifdef TRIE_STUDY_OPT
4841     if (!restudied) {
4842         StructCopy(&zero_scan_data, &data, scan_data_t);
4843         copyRExC_state = RExC_state;
4844     } else {
4845         U32 seen=RExC_seen;
4846         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
4847         
4848         RExC_state = copyRExC_state;
4849         if (seen & REG_TOP_LEVEL_BRANCHES) 
4850             RExC_seen |= REG_TOP_LEVEL_BRANCHES;
4851         else
4852             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES;
4853         if (data.last_found) {
4854             SvREFCNT_dec(data.longest_fixed);
4855             SvREFCNT_dec(data.longest_float);
4856             SvREFCNT_dec(data.last_found);
4857         }
4858         StructCopy(&zero_scan_data, &data, scan_data_t);
4859     }
4860 #else
4861     StructCopy(&zero_scan_data, &data, scan_data_t);
4862 #endif    
4863
4864     /* Dig out information for optimizations. */
4865     r->extflags = RExC_flags; /* was pm_op */
4866     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
4867  
4868     if (UTF)
4869         SvUTF8_on(rx);  /* Unicode in it? */
4870     ri->regstclass = NULL;
4871     if (RExC_naughty >= 10)     /* Probably an expensive pattern. */
4872         r->intflags |= PREGf_NAUGHTY;
4873     scan = ri->program + 1;             /* First BRANCH. */
4874
4875     /* testing for BRANCH here tells us whether there is "must appear"
4876        data in the pattern. If there is then we can use it for optimisations */
4877     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /*  Only one top-level choice. */
4878         I32 fake;
4879         STRLEN longest_float_length, longest_fixed_length;
4880         struct regnode_charclass_class ch_class; /* pointed to by data */
4881         int stclass_flag;
4882         I32 last_close = 0; /* pointed to by data */
4883         regnode *first= scan;
4884         regnode *first_next= regnext(first);
4885         /*
4886          * Skip introductions and multiplicators >= 1
4887          * so that we can extract the 'meat' of the pattern that must 
4888          * match in the large if() sequence following.
4889          * NOTE that EXACT is NOT covered here, as it is normally
4890          * picked up by the optimiser separately. 
4891          *
4892          * This is unfortunate as the optimiser isnt handling lookahead
4893          * properly currently.
4894          *
4895          */
4896         while ((OP(first) == OPEN && (sawopen = 1)) ||
4897                /* An OR of *one* alternative - should not happen now. */
4898             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
4899             /* for now we can't handle lookbehind IFMATCH*/
4900             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
4901             (OP(first) == PLUS) ||
4902             (OP(first) == MINMOD) ||
4903                /* An {n,m} with n>0 */
4904             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
4905             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
4906         {
4907                 /* 
4908                  * the only op that could be a regnode is PLUS, all the rest
4909                  * will be regnode_1 or regnode_2.
4910                  *
4911                  */
4912                 if (OP(first) == PLUS)
4913                     sawplus = 1;
4914                 else
4915                     first += regarglen[OP(first)];
4916                 
4917                 first = NEXTOPER(first);
4918                 first_next= regnext(first);
4919         }
4920
4921         /* Starting-point info. */
4922       again:
4923         DEBUG_PEEP("first:",first,0);
4924         /* Ignore EXACT as we deal with it later. */
4925         if (PL_regkind[OP(first)] == EXACT) {
4926             if (OP(first) == EXACT)
4927                 NOOP;   /* Empty, get anchored substr later. */
4928             else
4929                 ri->regstclass = first;
4930         }
4931 #ifdef TRIE_STCLASS     
4932         else if (PL_regkind[OP(first)] == TRIE &&
4933                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0) 
4934         {
4935             regnode *trie_op;
4936             /* this can happen only on restudy */
4937             if ( OP(first) == TRIE ) {
4938                 struct regnode_1 *trieop = (struct regnode_1 *)
4939                     PerlMemShared_calloc(1, sizeof(struct regnode_1));
4940                 StructCopy(first,trieop,struct regnode_1);
4941                 trie_op=(regnode *)trieop;
4942             } else {
4943                 struct regnode_charclass *trieop = (struct regnode_charclass *)
4944                     PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
4945                 StructCopy(first,trieop,struct regnode_charclass);
4946                 trie_op=(regnode *)trieop;
4947             }
4948             OP(trie_op)+=2;
4949             make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
4950             ri->regstclass = trie_op;
4951         }
4952 #endif  
4953         else if (REGNODE_SIMPLE(OP(first)))
4954             ri->regstclass = first;
4955         else if (PL_regkind[OP(first)] == BOUND ||
4956                  PL_regkind[OP(first)] == NBOUND)
4957             ri->regstclass = first;
4958         else if (PL_regkind[OP(first)] == BOL) {
4959             r->extflags |= (OP(first) == MBOL
4960                            ? RXf_ANCH_MBOL
4961                            : (OP(first) == SBOL
4962                               ? RXf_ANCH_SBOL
4963                               : RXf_ANCH_BOL));
4964             first = NEXTOPER(first);
4965             goto again;
4966         }
4967         else if (OP(first) == GPOS) {
4968             r->extflags |= RXf_ANCH_GPOS;
4969             first = NEXTOPER(first);
4970             goto again;
4971         }
4972         else if ((!sawopen || !RExC_sawback) &&
4973             (OP(first) == STAR &&
4974             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
4975             !(r->extflags & RXf_ANCH) && !(RExC_seen & REG_SEEN_EVAL))
4976         {
4977             /* turn .* into ^.* with an implied $*=1 */
4978             const int type =
4979                 (OP(NEXTOPER(first)) == REG_ANY)
4980                     ? RXf_ANCH_MBOL
4981                     : RXf_ANCH_SBOL;
4982             r->extflags |= type;
4983             r->intflags |= PREGf_IMPLICIT;
4984             first = NEXTOPER(first);
4985             goto again;
4986         }
4987         if (sawplus && !sawlookahead && (!sawopen || !RExC_sawback)
4988             && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
4989             /* x+ must match at the 1st pos of run of x's */
4990             r->intflags |= PREGf_SKIP;
4991
4992         /* Scan is after the zeroth branch, first is atomic matcher. */
4993 #ifdef TRIE_STUDY_OPT
4994         DEBUG_PARSE_r(
4995             if (!restudied)
4996                 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
4997                               (IV)(first - scan + 1))
4998         );
4999 #else
5000         DEBUG_PARSE_r(
5001             PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
5002                 (IV)(first - scan + 1))
5003         );
5004 #endif
5005
5006
5007         /*
5008         * If there's something expensive in the r.e., find the
5009         * longest literal string that must appear and make it the
5010         * regmust.  Resolve ties in favor of later strings, since
5011         * the regstart check works with the beginning of the r.e.
5012         * and avoiding duplication strengthens checking.  Not a
5013         * strong reason, but sufficient in the absence of others.
5014         * [Now we resolve ties in favor of the earlier string if
5015         * it happens that c_offset_min has been invalidated, since the
5016         * earlier string may buy us something the later one won't.]
5017         */
5018         
5019         data.longest_fixed = newSVpvs("");
5020         data.longest_float = newSVpvs("");
5021         data.last_found = newSVpvs("");
5022         data.longest = &(data.longest_fixed);
5023         first = scan;
5024         if (!ri->regstclass) {
5025             cl_init(pRExC_state, &ch_class);
5026             data.start_class = &ch_class;
5027             stclass_flag = SCF_DO_STCLASS_AND;
5028         } else                          /* XXXX Check for BOUND? */
5029             stclass_flag = 0;
5030         data.last_closep = &last_close;
5031         
5032         minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */
5033             &data, -1, NULL, NULL,
5034             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
5035
5036         
5037         CHECK_RESTUDY_GOTO;
5038
5039
5040         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
5041              && data.last_start_min == 0 && data.last_end > 0
5042              && !RExC_seen_zerolen
5043              && !(RExC_seen & REG_SEEN_VERBARG)
5044              && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
5045             r->extflags |= RXf_CHECK_ALL;
5046         scan_commit(pRExC_state, &data,&minlen,0);
5047         SvREFCNT_dec(data.last_found);
5048
5049         /* Note that code very similar to this but for anchored string 
5050            follows immediately below, changes may need to be made to both. 
5051            Be careful. 
5052          */
5053         longest_float_length = CHR_SVLEN(data.longest_float);
5054         if (longest_float_length
5055             || (data.flags & SF_FL_BEFORE_EOL
5056                 && (!(data.flags & SF_FL_BEFORE_MEOL)
5057                     || (RExC_flags & RXf_PMf_MULTILINE)))) 
5058         {
5059             I32 t,ml;
5060
5061             if (SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
5062                 && data.offset_fixed == data.offset_float_min
5063                 && SvCUR(data.longest_fixed) == SvCUR(data.longest_float))
5064                     goto remove_float;          /* As in (a)+. */
5065
5066             /* copy the information about the longest float from the reg_scan_data
5067                over to the program. */
5068             if (SvUTF8(data.longest_float)) {
5069                 r->float_utf8 = data.longest_float;
5070                 r->float_substr = NULL;
5071             } else {
5072                 r->float_substr = data.longest_float;
5073                 r->float_utf8 = NULL;
5074             }
5075             /* float_end_shift is how many chars that must be matched that 
5076                follow this item. We calculate it ahead of time as once the
5077                lookbehind offset is added in we lose the ability to correctly
5078                calculate it.*/
5079             ml = data.minlen_float ? *(data.minlen_float) 
5080                                    : (I32)longest_float_length;
5081             r->float_end_shift = ml - data.offset_float_min
5082                 - longest_float_length + (SvTAIL(data.longest_float) != 0)
5083                 + data.lookbehind_float;
5084             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
5085             r->float_max_offset = data.offset_float_max;
5086             if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
5087                 r->float_max_offset -= data.lookbehind_float;
5088             
5089             t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
5090                        && (!(data.flags & SF_FL_BEFORE_MEOL)
5091                            || (RExC_flags & RXf_PMf_MULTILINE)));
5092             fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0);
5093         }
5094         else {
5095           remove_float:
5096             r->float_substr = r->float_utf8 = NULL;
5097             SvREFCNT_dec(data.longest_float);
5098             longest_float_length = 0;
5099         }
5100
5101         /* Note that code very similar to this but for floating string 
5102            is immediately above, changes may need to be made to both. 
5103            Be careful. 
5104          */
5105         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
5106         if (longest_fixed_length
5107             || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
5108                 && (!(data.flags & SF_FIX_BEFORE_MEOL)
5109                     || (RExC_flags & RXf_PMf_MULTILINE)))) 
5110         {
5111             I32 t,ml;
5112
5113             /* copy the information about the longest fixed 
5114                from the reg_scan_data over to the program. */
5115             if (SvUTF8(data.longest_fixed)) {
5116                 r->anchored_utf8 = data.longest_fixed;
5117                 r->anchored_substr = NULL;
5118             } else {
5119                 r->anchored_substr = data.longest_fixed;
5120                 r->anchored_utf8 = NULL;
5121             }
5122             /* fixed_end_shift is how many chars that must be matched that 
5123                follow this item. We calculate it ahead of time as once the
5124                lookbehind offset is added in we lose the ability to correctly
5125                calculate it.*/
5126             ml = data.minlen_fixed ? *(data.minlen_fixed) 
5127                                    : (I32)longest_fixed_length;
5128             r->anchored_end_shift = ml - data.offset_fixed
5129                 - longest_fixed_length + (SvTAIL(data.longest_fixed) != 0)
5130                 + data.lookbehind_fixed;
5131             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
5132
5133             t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
5134                  && (!(data.flags & SF_FIX_BEFORE_MEOL)
5135                      || (RExC_flags & RXf_PMf_MULTILINE)));
5136             fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0);
5137         }
5138         else {
5139             r->anchored_substr = r->anchored_utf8 = NULL;
5140             SvREFCNT_dec(data.longest_fixed);
5141             longest_fixed_length = 0;
5142         }
5143         if (ri->regstclass
5144             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
5145             ri->regstclass = NULL;
5146
5147         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
5148             && stclass_flag
5149             && !(data.start_class->flags & ANYOF_EOS)
5150             && !cl_is_anything(data.start_class))
5151         {
5152             const U32 n = add_data(pRExC_state, 1, "f");
5153             data.start_class->flags |= ANYOF_IS_SYNTHETIC;
5154
5155             Newx(RExC_rxi->data->data[n], 1,
5156                 struct regnode_charclass_class);
5157             StructCopy(data.start_class,
5158                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
5159                        struct regnode_charclass_class);
5160             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5161             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5162             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
5163                       regprop(r, sv, (regnode*)data.start_class);
5164                       PerlIO_printf(Perl_debug_log,
5165                                     "synthetic stclass \"%s\".\n",
5166                                     SvPVX_const(sv));});
5167         }
5168
5169         /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
5170         if (longest_fixed_length > longest_float_length) {
5171             r->check_end_shift = r->anchored_end_shift;
5172             r->check_substr = r->anchored_substr;
5173             r->check_utf8 = r->anchored_utf8;
5174             r->check_offset_min = r->check_offset_max = r->anchored_offset;
5175             if (r->extflags & RXf_ANCH_SINGLE)
5176                 r->extflags |= RXf_NOSCAN;
5177         }
5178         else {
5179             r->check_end_shift = r->float_end_shift;
5180             r->check_substr = r->float_substr;
5181             r->check_utf8 = r->float_utf8;
5182             r->check_offset_min = r->float_min_offset;
5183             r->check_offset_max = r->float_max_offset;
5184         }
5185         /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
5186            This should be changed ASAP!  */
5187         if ((r->check_substr || r->check_utf8) && !(r->extflags & RXf_ANCH_GPOS)) {
5188             r->extflags |= RXf_USE_INTUIT;
5189             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
5190                 r->extflags |= RXf_INTUIT_TAIL;
5191         }
5192         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
5193         if ( (STRLEN)minlen < longest_float_length )
5194             minlen= longest_float_length;
5195         if ( (STRLEN)minlen < longest_fixed_length )
5196             minlen= longest_fixed_length;     
5197         */
5198     }
5199     else {
5200         /* Several toplevels. Best we can is to set minlen. */
5201         I32 fake;
5202         struct regnode_charclass_class ch_class;
5203         I32 last_close = 0;
5204         
5205         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
5206
5207         scan = ri->program + 1;
5208         cl_init(pRExC_state, &ch_class);
5209         data.start_class = &ch_class;
5210         data.last_closep = &last_close;
5211
5212         
5213         minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
5214             &data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
5215         
5216         CHECK_RESTUDY_GOTO;
5217
5218         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
5219                 = r->float_substr = r->float_utf8 = NULL;
5220
5221         if (!(data.start_class->flags & ANYOF_EOS)
5222             && !cl_is_anything(data.start_class))
5223         {
5224             const U32 n = add_data(pRExC_state, 1, "f");
5225             data.start_class->flags |= ANYOF_IS_SYNTHETIC;
5226
5227             Newx(RExC_rxi->data->data[n], 1,
5228                 struct regnode_charclass_class);
5229             StructCopy(data.start_class,
5230                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
5231                        struct regnode_charclass_class);
5232             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5233             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5234             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
5235                       regprop(r, sv, (regnode*)data.start_class);
5236                       PerlIO_printf(Perl_debug_log,
5237                                     "synthetic stclass \"%s\".\n",
5238                                     SvPVX_const(sv));});
5239         }
5240     }
5241
5242     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
5243        the "real" pattern. */
5244     DEBUG_OPTIMISE_r({
5245         PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n",
5246                       (IV)minlen, (IV)r->minlen);
5247     });
5248     r->minlenret = minlen;
5249     if (r->minlen < minlen) 
5250         r->minlen = minlen;
5251     
5252     if (RExC_seen & REG_SEEN_GPOS)
5253         r->extflags |= RXf_GPOS_SEEN;
5254     if (RExC_seen & REG_SEEN_LOOKBEHIND)
5255         r->extflags |= RXf_LOOKBEHIND_SEEN;
5256     if (RExC_seen & REG_SEEN_EVAL)
5257         r->extflags |= RXf_EVAL_SEEN;
5258     if (RExC_seen & REG_SEEN_CANY)
5259         r->extflags |= RXf_CANY_SEEN;
5260     if (RExC_seen & REG_SEEN_VERBARG)
5261         r->intflags |= PREGf_VERBARG_SEEN;
5262     if (RExC_seen & REG_SEEN_CUTGROUP)
5263         r->intflags |= PREGf_CUTGROUP_SEEN;
5264     if (RExC_paren_names)
5265         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
5266     else
5267         RXp_PAREN_NAMES(r) = NULL;
5268
5269 #ifdef STUPID_PATTERN_CHECKS            
5270     if (RX_PRELEN(rx) == 0)
5271         r->extflags |= RXf_NULL;
5272     if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5273         /* XXX: this should happen BEFORE we compile */
5274         r->extflags |= (RXf_SKIPWHITE|RXf_WHITE); 
5275     else if (RX_PRELEN(rx) == 3 && memEQ("\\s+", RX_PRECOMP(rx), 3))
5276         r->extflags |= RXf_WHITE;
5277     else if (RX_PRELEN(rx) == 1 && RXp_PRECOMP(rx)[0] == '^')
5278         r->extflags |= RXf_START_ONLY;
5279 #else
5280     if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5281             /* XXX: this should happen BEFORE we compile */
5282             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE); 
5283     else {
5284         regnode *first = ri->program + 1;
5285         U8 fop = OP(first);
5286
5287         if (PL_regkind[fop] == NOTHING && OP(NEXTOPER(first)) == END)
5288             r->extflags |= RXf_NULL;
5289         else if (PL_regkind[fop] == BOL && OP(NEXTOPER(first)) == END)
5290             r->extflags |= RXf_START_ONLY;
5291         else if (fop == PLUS && OP(NEXTOPER(first)) == SPACE
5292                              && OP(regnext(first)) == END)
5293             r->extflags |= RXf_WHITE;    
5294     }
5295 #endif
5296 #ifdef DEBUGGING
5297     if (RExC_paren_names) {
5298         ri->name_list_idx = add_data( pRExC_state, 1, "a" );
5299         ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list);
5300     } else
5301 #endif
5302         ri->name_list_idx = 0;
5303
5304     if (RExC_recurse_count) {
5305         for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
5306             const regnode *scan = RExC_recurse[RExC_recurse_count-1];
5307             ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
5308         }
5309     }
5310     Newxz(r->offs, RExC_npar, regexp_paren_pair);
5311     /* assume we don't need to swap parens around before we match */
5312
5313     DEBUG_DUMP_r({
5314         PerlIO_printf(Perl_debug_log,"Final program:\n");
5315         regdump(r);
5316     });
5317 #ifdef RE_TRACK_PATTERN_OFFSETS
5318     DEBUG_OFFSETS_r(if (ri->u.offsets) {
5319         const U32 len = ri->u.offsets[0];
5320         U32 i;
5321         GET_RE_DEBUG_FLAGS_DECL;
5322         PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
5323         for (i = 1; i <= len; i++) {
5324             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
5325                 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
5326                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
5327             }
5328         PerlIO_printf(Perl_debug_log, "\n");
5329     });
5330 #endif
5331     return rx;
5332 }
5333
5334 #undef RE_ENGINE_PTR
5335
5336
5337 SV*
5338 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
5339                     const U32 flags)
5340 {
5341     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
5342
5343     PERL_UNUSED_ARG(value);
5344
5345     if (flags & RXapif_FETCH) {
5346         return reg_named_buff_fetch(rx, key, flags);
5347     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
5348         Perl_croak_no_modify(aTHX);
5349         return NULL;
5350     } else if (flags & RXapif_EXISTS) {
5351         return reg_named_buff_exists(rx, key, flags)
5352             ? &PL_sv_yes
5353             : &PL_sv_no;
5354     } else if (flags & RXapif_REGNAMES) {
5355         return reg_named_buff_all(rx, flags);
5356     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
5357         return reg_named_buff_scalar(rx, flags);
5358     } else {
5359         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
5360         return NULL;
5361     }
5362 }
5363
5364 SV*
5365 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
5366                          const U32 flags)
5367 {
5368     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
5369     PERL_UNUSED_ARG(lastkey);
5370
5371     if (flags & RXapif_FIRSTKEY)
5372         return reg_named_buff_firstkey(rx, flags);
5373     else if (flags & RXapif_NEXTKEY)
5374         return reg_named_buff_nextkey(rx, flags);
5375     else {
5376         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter", (int)flags);
5377         return NULL;
5378     }
5379 }
5380
5381 SV*
5382 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
5383                           const U32 flags)
5384 {
5385     AV *retarray = NULL;
5386     SV *ret;
5387     struct regexp *const rx = (struct regexp *)SvANY(r);
5388
5389     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
5390
5391     if (flags & RXapif_ALL)
5392         retarray=newAV();
5393
5394     if (rx && RXp_PAREN_NAMES(rx)) {
5395         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
5396         if (he_str) {
5397             IV i;
5398             SV* sv_dat=HeVAL(he_str);
5399             I32 *nums=(I32*)SvPVX(sv_dat);
5400             for ( i=0; i<SvIVX(sv_dat); i++ ) {
5401                 if ((I32)(rx->nparens) >= nums[i]
5402                     && rx->offs[nums[i]].start != -1
5403                     && rx->offs[nums[i]].end != -1)
5404                 {
5405                     ret = newSVpvs("");
5406                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
5407                     if (!retarray)
5408                         return ret;
5409                 } else {
5410                     ret = newSVsv(&PL_sv_undef);
5411                 }
5412                 if (retarray)
5413                     av_push(retarray, ret);
5414             }
5415             if (retarray)
5416                 return newRV_noinc(MUTABLE_SV(retarray));
5417         }
5418     }
5419     return NULL;
5420 }
5421
5422 bool
5423 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
5424                            const U32 flags)
5425 {
5426     struct regexp *const rx = (struct regexp *)SvANY(r);
5427
5428     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
5429
5430     if (rx && RXp_PAREN_NAMES(rx)) {
5431         if (flags & RXapif_ALL) {
5432             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
5433         } else {
5434             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
5435             if (sv) {
5436                 SvREFCNT_dec(sv);
5437                 return TRUE;
5438             } else {
5439                 return FALSE;
5440             }
5441         }
5442     } else {
5443         return FALSE;
5444     }
5445 }
5446
5447 SV*
5448 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
5449 {
5450     struct regexp *const rx = (struct regexp *)SvANY(r);
5451
5452     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
5453
5454     if ( rx && RXp_PAREN_NAMES(rx) ) {
5455         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
5456
5457         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
5458     } else {
5459         return FALSE;
5460     }
5461 }
5462
5463 SV*
5464 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
5465 {
5466     struct regexp *const rx = (struct regexp *)SvANY(r);
5467     GET_RE_DEBUG_FLAGS_DECL;
5468
5469     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
5470
5471     if (rx && RXp_PAREN_NAMES(rx)) {
5472         HV *hv = RXp_PAREN_NAMES(rx);
5473         HE *temphe;
5474         while ( (temphe = hv_iternext_flags(hv,0)) ) {
5475             IV i;
5476             IV parno = 0;
5477             SV* sv_dat = HeVAL(temphe);
5478             I32 *nums = (I32*)SvPVX(sv_dat);
5479             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5480                 if ((I32)(rx->lastparen) >= nums[i] &&
5481                     rx->offs[nums[i]].start != -1 &&
5482                     rx->offs[nums[i]].end != -1)
5483                 {
5484                     parno = nums[i];
5485                     break;
5486                 }
5487             }
5488             if (parno || flags & RXapif_ALL) {
5489                 return newSVhek(HeKEY_hek(temphe));
5490             }
5491         }
5492     }
5493     return NULL;
5494 }
5495
5496 SV*
5497 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
5498 {
5499     SV *ret;
5500     AV *av;
5501     I32 length;
5502     struct regexp *const rx = (struct regexp *)SvANY(r);
5503
5504     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
5505
5506     if (rx && RXp_PAREN_NAMES(rx)) {
5507         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
5508             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
5509         } else if (flags & RXapif_ONE) {
5510             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
5511             av = MUTABLE_AV(SvRV(ret));
5512             length = av_len(av);
5513             SvREFCNT_dec(ret);
5514             return newSViv(length + 1);
5515         } else {
5516             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", (int)flags);
5517             return NULL;
5518         }
5519     }
5520     return &PL_sv_undef;
5521 }
5522
5523 SV*
5524 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
5525 {
5526     struct regexp *const rx = (struct regexp *)SvANY(r);
5527     AV *av = newAV();
5528
5529     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
5530
5531     if (rx && RXp_PAREN_NAMES(rx)) {
5532         HV *hv= RXp_PAREN_NAMES(rx);
5533         HE *temphe;
5534         (void)hv_iterinit(hv);
5535         while ( (temphe = hv_iternext_flags(hv,0)) ) {
5536             IV i;
5537             IV parno = 0;
5538             SV* sv_dat = HeVAL(temphe);
5539             I32 *nums = (I32*)SvPVX(sv_dat);
5540             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5541                 if ((I32)(rx->lastparen) >= nums[i] &&
5542                     rx->offs[nums[i]].start != -1 &&
5543                     rx->offs[nums[i]].end != -1)
5544                 {
5545                     parno = nums[i];
5546                     break;
5547                 }
5548             }
5549             if (parno || flags & RXapif_ALL) {
5550                 av_push(av, newSVhek(HeKEY_hek(temphe)));
5551             }
5552         }
5553     }
5554
5555     return newRV_noinc(MUTABLE_SV(av));
5556 }
5557
5558 void
5559 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
5560                              SV * const sv)
5561 {
5562     struct regexp *const rx = (struct regexp *)SvANY(r);
5563     char *s = NULL;
5564     I32 i = 0;
5565     I32 s1, t1;
5566
5567     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
5568         
5569     if (!rx->subbeg) {
5570         sv_setsv(sv,&PL_sv_undef);
5571         return;
5572     } 
5573     else               
5574     if (paren == RX_BUFF_IDX_PREMATCH && rx->offs[0].start != -1) {
5575         /* $` */
5576         i = rx->offs[0].start;
5577         s = rx->subbeg;
5578     }
5579     else 
5580     if (paren == RX_BUFF_IDX_POSTMATCH && rx->offs[0].end != -1) {
5581         /* $' */
5582         s = rx->subbeg + rx->offs[0].end;
5583         i = rx->sublen - rx->offs[0].end;
5584     } 
5585     else
5586     if ( 0 <= paren && paren <= (I32)rx->nparens &&
5587         (s1 = rx->offs[paren].start) != -1 &&
5588         (t1 = rx->offs[paren].end) != -1)
5589     {
5590         /* $& $1 ... */
5591         i = t1 - s1;
5592         s = rx->subbeg + s1;
5593     } else {
5594         sv_setsv(sv,&PL_sv_undef);
5595         return;
5596     }          
5597     assert(rx->sublen >= (s - rx->subbeg) + i );
5598     if (i >= 0) {
5599         const int oldtainted = PL_tainted;
5600         TAINT_NOT;
5601         sv_setpvn(sv, s, i);
5602         PL_tainted = oldtainted;
5603         if ( (rx->extflags & RXf_CANY_SEEN)
5604             ? (RXp_MATCH_UTF8(rx)
5605                         && (!i || is_utf8_string((U8*)s, i)))
5606             : (RXp_MATCH_UTF8(rx)) )
5607         {
5608             SvUTF8_on(sv);
5609         }
5610         else
5611             SvUTF8_off(sv);
5612         if (PL_tainting) {
5613             if (RXp_MATCH_TAINTED(rx)) {
5614                 if (SvTYPE(sv) >= SVt_PVMG) {
5615                     MAGIC* const mg = SvMAGIC(sv);
5616                     MAGIC* mgt;
5617                     PL_tainted = 1;
5618                     SvMAGIC_set(sv, mg->mg_moremagic);
5619                     SvTAINT(sv);
5620                     if ((mgt = SvMAGIC(sv))) {
5621                         mg->mg_moremagic = mgt;
5622                         SvMAGIC_set(sv, mg);
5623                     }
5624                 } else {
5625                     PL_tainted = 1;
5626                     SvTAINT(sv);
5627                 }
5628             } else 
5629                 SvTAINTED_off(sv);
5630         }
5631     } else {
5632         sv_setsv(sv,&PL_sv_undef);
5633         return;
5634     }
5635 }
5636
5637 void
5638 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
5639                                                          SV const * const value)
5640 {
5641     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
5642
5643     PERL_UNUSED_ARG(rx);
5644     PERL_UNUSED_ARG(paren);
5645     PERL_UNUSED_ARG(value);
5646
5647     if (!PL_localizing)
5648         Perl_croak_no_modify(aTHX);
5649 }
5650
5651 I32
5652 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
5653                               const I32 paren)
5654 {
5655     struct regexp *const rx = (struct regexp *)SvANY(r);
5656     I32 i;
5657     I32 s1, t1;
5658
5659     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
5660
5661     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
5662         switch (paren) {
5663       /* $` / ${^PREMATCH} */
5664       case RX_BUFF_IDX_PREMATCH:
5665         if (rx->offs[0].start != -1) {
5666                         i = rx->offs[0].start;
5667                         if (i > 0) {
5668                                 s1 = 0;
5669                                 t1 = i;
5670                                 goto getlen;
5671                         }
5672             }
5673         return 0;
5674       /* $' / ${^POSTMATCH} */
5675       case RX_BUFF_IDX_POSTMATCH:
5676             if (rx->offs[0].end != -1) {
5677                         i = rx->sublen - rx->offs[0].end;
5678                         if (i > 0) {
5679                                 s1 = rx->offs[0].end;
5680                                 t1 = rx->sublen;
5681                                 goto getlen;
5682                         }
5683             }
5684         return 0;
5685       /* $& / ${^MATCH}, $1, $2, ... */
5686       default:
5687             if (paren <= (I32)rx->nparens &&
5688             (s1 = rx->offs[paren].start) != -1 &&
5689             (t1 = rx->offs[paren].end) != -1)
5690             {
5691             i = t1 - s1;
5692             goto getlen;
5693         } else {
5694             if (ckWARN(WARN_UNINITIALIZED))
5695                 report_uninit((const SV *)sv);
5696             return 0;
5697         }
5698     }
5699   getlen:
5700     if (i > 0 && RXp_MATCH_UTF8(rx)) {
5701         const char * const s = rx->subbeg + s1;
5702         const U8 *ep;
5703         STRLEN el;
5704
5705         i = t1 - s1;
5706         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
5707                         i = el;
5708     }
5709     return i;
5710 }
5711
5712 SV*
5713 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
5714 {
5715     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
5716         PERL_UNUSED_ARG(rx);
5717         if (0)
5718             return NULL;
5719         else
5720             return newSVpvs("Regexp");
5721 }
5722
5723 /* Scans the name of a named buffer from the pattern.
5724  * If flags is REG_RSN_RETURN_NULL returns null.
5725  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
5726  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
5727  * to the parsed name as looked up in the RExC_paren_names hash.
5728  * If there is an error throws a vFAIL().. type exception.
5729  */
5730
5731 #define REG_RSN_RETURN_NULL    0
5732 #define REG_RSN_RETURN_NAME    1
5733 #define REG_RSN_RETURN_DATA    2
5734
5735 STATIC SV*
5736 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
5737 {
5738     char *name_start = RExC_parse;
5739
5740     PERL_ARGS_ASSERT_REG_SCAN_NAME;
5741
5742     if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
5743          /* skip IDFIRST by using do...while */
5744         if (UTF)
5745             do {
5746                 RExC_parse += UTF8SKIP(RExC_parse);
5747             } while (isALNUM_utf8((U8*)RExC_parse));
5748         else
5749             do {
5750                 RExC_parse++;
5751             } while (isALNUM(*RExC_parse));
5752     }
5753
5754     if ( flags ) {
5755         SV* sv_name
5756             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
5757                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
5758         if ( flags == REG_RSN_RETURN_NAME)
5759             return sv_name;
5760         else if (flags==REG_RSN_RETURN_DATA) {
5761             HE *he_str = NULL;
5762             SV *sv_dat = NULL;
5763             if ( ! sv_name )      /* should not happen*/
5764                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
5765             if (RExC_paren_names)
5766                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
5767             if ( he_str )
5768                 sv_dat = HeVAL(he_str);
5769             if ( ! sv_dat )
5770                 vFAIL("Reference to nonexistent named group");
5771             return sv_dat;
5772         }
5773         else {
5774             Perl_croak(aTHX_ "panic: bad flag in reg_scan_name");
5775         }
5776         /* NOT REACHED */
5777     }
5778     return NULL;
5779 }
5780
5781 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
5782     int rem=(int)(RExC_end - RExC_parse);                       \
5783     int cut;                                                    \
5784     int num;                                                    \
5785     int iscut=0;                                                \
5786     if (rem>10) {                                               \
5787         rem=10;                                                 \
5788         iscut=1;                                                \
5789     }                                                           \
5790     cut=10-rem;                                                 \
5791     if (RExC_lastparse!=RExC_parse)                             \
5792         PerlIO_printf(Perl_debug_log," >%.*s%-*s",              \
5793             rem, RExC_parse,                                    \
5794             cut + 4,                                            \
5795             iscut ? "..." : "<"                                 \
5796         );                                                      \
5797     else                                                        \
5798         PerlIO_printf(Perl_debug_log,"%16s","");                \
5799                                                                 \
5800     if (SIZE_ONLY)                                              \
5801        num = RExC_size + 1;                                     \
5802     else                                                        \
5803        num=REG_NODE_NUM(RExC_emit);                             \
5804     if (RExC_lastnum!=num)                                      \
5805        PerlIO_printf(Perl_debug_log,"|%4d",num);                \
5806     else                                                        \
5807        PerlIO_printf(Perl_debug_log,"|%4s","");                 \
5808     PerlIO_printf(Perl_debug_log,"|%*s%-4s",                    \
5809         (int)((depth*2)), "",                                   \
5810         (funcname)                                              \
5811     );                                                          \
5812     RExC_lastnum=num;                                           \
5813     RExC_lastparse=RExC_parse;                                  \
5814 })
5815
5816
5817
5818 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
5819     DEBUG_PARSE_MSG((funcname));                            \
5820     PerlIO_printf(Perl_debug_log,"%4s","\n");               \
5821 })
5822 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({           \
5823     DEBUG_PARSE_MSG((funcname));                            \
5824     PerlIO_printf(Perl_debug_log,fmt "\n",args);               \
5825 })
5826
5827 /* This section of code defines the inversion list object and its methods.  The
5828  * interfaces are highly subject to change, so as much as possible is static to
5829  * this file.  An inversion list is here implemented as a malloc'd C array with
5830  * some added info.  More will be coming when functionality is added later.
5831  *
5832  * It is currently implemented as an HV to the outside world, but is actually
5833  * an SV pointing to an array of UVs that the SV thinks are bytes.  This allows
5834  * us to have an array of UV whose memory management is automatically handled
5835  * by the existing facilities for SV's.
5836  *
5837  * Some of the methods should always be private to the implementation, and some
5838  * should eventually be made public */
5839
5840 #define INVLIST_INITIAL_LEN 10
5841
5842 PERL_STATIC_INLINE UV*
5843 S_invlist_array(pTHX_ HV* const invlist)
5844 {
5845     /* Returns the pointer to the inversion list's array.  Every time the
5846      * length changes, this needs to be called in case malloc or realloc moved
5847      * it */
5848
5849     PERL_ARGS_ASSERT_INVLIST_ARRAY;
5850
5851     return (UV *) SvPVX(invlist);
5852 }
5853
5854 PERL_STATIC_INLINE UV
5855 S_invlist_len(pTHX_ HV* const invlist)
5856 {
5857     /* Returns the current number of elements in the inversion list's array */
5858
5859     PERL_ARGS_ASSERT_INVLIST_LEN;
5860
5861     return SvCUR(invlist) / sizeof(UV);
5862 }
5863
5864 PERL_STATIC_INLINE UV
5865 S_invlist_max(pTHX_ HV* const invlist)
5866 {
5867     /* Returns the maximum number of elements storable in the inversion list's
5868      * array, without having to realloc() */
5869
5870     PERL_ARGS_ASSERT_INVLIST_MAX;
5871
5872     return SvLEN(invlist) / sizeof(UV);
5873 }
5874
5875 PERL_STATIC_INLINE void
5876 S_invlist_set_len(pTHX_ HV* const invlist, const UV len)
5877 {
5878     /* Sets the current number of elements stored in the inversion list */
5879
5880     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
5881
5882     SvCUR_set(invlist, len * sizeof(UV));
5883 }
5884
5885 PERL_STATIC_INLINE void
5886 S_invlist_set_max(pTHX_ HV* const invlist, const UV max)
5887 {
5888
5889     /* Sets the maximum number of elements storable in the inversion list
5890      * without having to realloc() */
5891
5892     PERL_ARGS_ASSERT_INVLIST_SET_MAX;
5893
5894     if (max < invlist_len(invlist)) {
5895         Perl_croak(aTHX_ "panic: Can't make max size '%"UVuf"' less than current length %"UVuf" in inversion list", invlist_max(invlist), invlist_len(invlist));
5896     }
5897
5898     SvLEN_set(invlist, max * sizeof(UV));
5899 }
5900
5901 #ifndef PERL_IN_XSUB_RE
5902 HV*
5903 Perl__new_invlist(pTHX_ IV initial_size)
5904 {
5905
5906     /* Return a pointer to a newly constructed inversion list, with enough
5907      * space to store 'initial_size' elements.  If that number is negative, a
5908      * system default is used instead */
5909
5910     if (initial_size < 0) {
5911         initial_size = INVLIST_INITIAL_LEN;
5912     }
5913
5914     /* Allocate the initial space */
5915     return (HV *) newSV(initial_size * sizeof(UV));
5916 }
5917 #endif
5918
5919 PERL_STATIC_INLINE void
5920 S_invlist_destroy(pTHX_ HV* const invlist)
5921 {
5922    /* Inversion list destructor */
5923
5924     PERL_ARGS_ASSERT_INVLIST_DESTROY;
5925
5926     SvREFCNT_dec(invlist);
5927 }
5928
5929 STATIC void
5930 S_invlist_extend(pTHX_ HV* const invlist, const UV new_max)
5931 {
5932     /* Grow the maximum size of an inversion list */
5933
5934     PERL_ARGS_ASSERT_INVLIST_EXTEND;
5935
5936     SvGROW((SV *)invlist, new_max * sizeof(UV));
5937 }
5938
5939 PERL_STATIC_INLINE void
5940 S_invlist_trim(pTHX_ HV* const invlist)
5941 {
5942     PERL_ARGS_ASSERT_INVLIST_TRIM;
5943
5944     /* Change the length of the inversion list to how many entries it currently
5945      * has */
5946
5947     SvPV_shrink_to_cur((SV *) invlist);
5948 }
5949
5950 /* An element is in an inversion list iff its index is even numbered: 0, 2, 4,
5951  * etc */
5952
5953 #define ELEMENT_IN_INVLIST_SET(i) (! ((i) & 1))
5954 #define PREV_ELEMENT_IN_INVLIST_SET(i) ! ELEMENT_IN_INVLIST_SET(i)
5955
5956 #ifndef PERL_IN_XSUB_RE
5957 void
5958 Perl__append_range_to_invlist(pTHX_ HV* const invlist, const UV start, const UV end)
5959 {
5960    /* Subject to change or removal.  Append the range from 'start' to 'end' at
5961     * the end of the inversion list.  The range must be above any existing
5962     * ones. */
5963
5964     UV* array = invlist_array(invlist);
5965     UV max = invlist_max(invlist);
5966     UV len = invlist_len(invlist);
5967
5968     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
5969
5970     if (len > 0) {
5971
5972         /* Here, the existing list is non-empty. The current max entry in the
5973          * list is generally the first value not in the set, except when the
5974          * set extends to the end of permissible values, in which case it is
5975          * the first entry in that final set, and so this call is an attempt to
5976          * append out-of-order */
5977
5978         UV final_element = len - 1;
5979         if (array[final_element] > start
5980             || ELEMENT_IN_INVLIST_SET(final_element))
5981         {
5982             Perl_croak(aTHX_ "panic: attempting to append to an inversion list, but wasn't at the end of the list");
5983         }
5984
5985         /* Here, it is a legal append.  If the new range begins with the first
5986          * value not in the set, it is extending the set, so the new first
5987          * value not in the set is one greater than the newly extended range.
5988          * */
5989         if (array[final_element] == start) {
5990             if (end != UV_MAX) {
5991                 array[final_element] = end + 1;
5992             }
5993             else {
5994                 /* But if the end is the maximum representable on the machine,
5995                  * just let the range that this would extend have no end */
5996                 invlist_set_len(invlist, len - 1);
5997             }
5998             return;
5999         }
6000     }
6001
6002     /* Here the new range doesn't extend any existing set.  Add it */
6003
6004     len += 2;   /* Includes an element each for the start and end of range */
6005
6006     /* If overflows the existing space, extend, which may cause the array to be
6007      * moved */
6008     if (max < len) {
6009         invlist_extend(invlist, len);
6010         array = invlist_array(invlist);
6011     }
6012
6013     invlist_set_len(invlist, len);
6014
6015     /* The next item on the list starts the range, the one after that is
6016      * one past the new range.  */
6017     array[len - 2] = start;
6018     if (end != UV_MAX) {
6019         array[len - 1] = end + 1;
6020     }
6021     else {
6022         /* But if the end is the maximum representable on the machine, just let
6023          * the range have no end */
6024         invlist_set_len(invlist, len - 1);
6025     }
6026 }
6027 #endif
6028
6029 STATIC HV*
6030 S_invlist_union(pTHX_ HV* const a, HV* const b)
6031 {
6032     /* Return a new inversion list which is the union of two inversion lists.
6033      * The basis for this comes from "Unicode Demystified" Chapter 13 by
6034      * Richard Gillam, published by Addison-Wesley, and explained at some
6035      * length there.  The preface says to incorporate its examples into your
6036      * code at your own risk.
6037      *
6038      * The algorithm is like a merge sort.
6039      *
6040      * XXX A potential performance improvement is to keep track as we go along
6041      * if only one of the inputs contributes to the result, meaning the other
6042      * is a subset of that one.  In that case, we can skip the final copy and
6043      * return the larger of the input lists */
6044
6045     UV* array_a = invlist_array(a);   /* a's array */
6046     UV* array_b = invlist_array(b);
6047     UV len_a = invlist_len(a);  /* length of a's array */
6048     UV len_b = invlist_len(b);
6049
6050     HV* u;                      /* the resulting union */
6051     UV* array_u;
6052     UV len_u;
6053
6054     UV i_a = 0;             /* current index into a's array */
6055     UV i_b = 0;
6056     UV i_u = 0;
6057
6058     /* running count, as explained in the algorithm source book; items are
6059      * stopped accumulating and are output when the count changes to/from 0.
6060      * The count is incremented when we start a range that's in the set, and
6061      * decremented when we start a range that's not in the set.  So its range
6062      * is 0 to 2.  Only when the count is zero is something not in the set.
6063      */
6064     UV count = 0;
6065
6066     PERL_ARGS_ASSERT_INVLIST_UNION;
6067
6068     /* Size the union for the worst case: that the sets are completely
6069      * disjoint */
6070     u = _new_invlist(len_a + len_b);
6071     array_u = invlist_array(u);
6072
6073     /* Go through each list item by item, stopping when exhausted one of
6074      * them */
6075     while (i_a < len_a && i_b < len_b) {
6076         UV cp;      /* The element to potentially add to the union's array */
6077         bool cp_in_set;   /* is it in the the input list's set or not */
6078
6079         /* We need to take one or the other of the two inputs for the union.
6080          * Since we are merging two sorted lists, we take the smaller of the
6081          * next items.  In case of a tie, we take the one that is in its set
6082          * first.  If we took one not in the set first, it would decrement the
6083          * count, possibly to 0 which would cause it to be output as ending the
6084          * range, and the next time through we would take the same number, and
6085          * output it again as beginning the next range.  By doing it the
6086          * opposite way, there is no possibility that the count will be
6087          * momentarily decremented to 0, and thus the two adjoining ranges will
6088          * be seamlessly merged.  (In a tie and both are in the set or both not
6089          * in the set, it doesn't matter which we take first.) */
6090         if (array_a[i_a] < array_b[i_b]
6091             || (array_a[i_a] == array_b[i_b] && ELEMENT_IN_INVLIST_SET(i_a)))
6092         {
6093             cp_in_set = ELEMENT_IN_INVLIST_SET(i_a);
6094             cp= array_a[i_a++];
6095         }
6096         else {
6097             cp_in_set = ELEMENT_IN_INVLIST_SET(i_b);
6098             cp= array_b[i_b++];
6099         }
6100
6101         /* Here, have chosen which of the two inputs to look at.  Only output
6102          * if the running count changes to/from 0, which marks the
6103          * beginning/end of a range in that's in the set */
6104         if (cp_in_set) {
6105             if (count == 0) {
6106                 array_u[i_u++] = cp;
6107             }
6108             count++;
6109         }
6110         else {
6111             count--;
6112             if (count == 0) {
6113                 array_u[i_u++] = cp;
6114             }
6115         }
6116     }
6117
6118     /* Here, we are finished going through at least one of the lists, which
6119      * means there is something remaining in at most one.  We check if the list
6120      * that hasn't been exhausted is positioned such that we are in the middle
6121      * of a range in its set or not.  (i_a and i_b point to the element beyond
6122      * the one we care about.) If in the set, we decrement 'count'; if 0, there
6123      * is potentially more to output.
6124      * There are four cases:
6125      *  1) Both weren't in their sets, count is 0, and remains 0.  What's left
6126      *     in the union is entirely from the non-exhausted set.
6127      *  2) Both were in their sets, count is 2.  Nothing further should
6128      *     be output, as everything that remains will be in the exhausted
6129      *     list's set, hence in the union; decrementing to 1 but not 0 insures
6130      *     that
6131      *  3) the exhausted was in its set, non-exhausted isn't, count is 1.
6132      *     Nothing further should be output because the union includes
6133      *     everything from the exhausted set.  Not decrementing ensures that.
6134      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1;
6135      *     decrementing to 0 insures that we look at the remainder of the
6136      *     non-exhausted set */
6137     if ((i_a != len_a && PREV_ELEMENT_IN_INVLIST_SET(i_a))
6138         || (i_b != len_b && PREV_ELEMENT_IN_INVLIST_SET(i_b)))
6139     {
6140         count--;
6141     }
6142
6143     /* The final length is what we've output so far, plus what else is about to
6144      * be output.  (If 'count' is non-zero, then the input list we exhausted
6145      * has everything remaining up to the machine's limit in its set, and hence
6146      * in the union, so there will be no further output. */
6147     len_u = i_u;
6148     if (count == 0) {
6149         /* At most one of the subexpressions will be non-zero */
6150         len_u += (len_a - i_a) + (len_b - i_b);
6151     }
6152
6153     /* Set result to final length, which can change the pointer to array_u, so
6154      * re-find it */
6155     if (len_u != invlist_len(u)) {
6156         invlist_set_len(u, len_u);
6157         invlist_trim(u);
6158         array_u = invlist_array(u);
6159     }
6160
6161     /* When 'count' is 0, the list that was exhausted (if one was shorter than
6162      * the other) ended with everything above it not in its set.  That means
6163      * that the remaining part of the union is precisely the same as the
6164      * non-exhausted list, so can just copy it unchanged.  (If both list were
6165      * exhausted at the same time, then the operations below will be both 0.)
6166      */
6167     if (count == 0) {
6168         IV copy_count; /* At most one will have a non-zero copy count */
6169         if ((copy_count = len_a - i_a) > 0) {
6170             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
6171         }
6172         else if ((copy_count = len_b - i_b) > 0) {
6173             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
6174         }
6175     }
6176
6177     return u;
6178 }
6179
6180 STATIC HV*
6181 S_invlist_intersection(pTHX_ HV* const a, HV* const b)
6182 {
6183     /* Return the intersection of two inversion lists.  The basis for this
6184      * comes from "Unicode Demystified" Chapter 13 by Richard Gillam, published
6185      * by Addison-Wesley, and explained at some length there.  The preface says
6186      * to incorporate its examples into your code at your own risk.  In fact,
6187      * it had bugs
6188      *
6189      * The algorithm is like a merge sort, and is essentially the same as the
6190      * union above
6191      */
6192
6193     UV* array_a = invlist_array(a);   /* a's array */
6194     UV* array_b = invlist_array(b);
6195     UV len_a = invlist_len(a);  /* length of a's array */
6196     UV len_b = invlist_len(b);
6197
6198     HV* r;                   /* the resulting intersection */
6199     UV* array_r;
6200     UV len_r;
6201
6202     UV i_a = 0;             /* current index into a's array */
6203     UV i_b = 0;
6204     UV i_r = 0;
6205
6206     /* running count, as explained in the algorithm source book; items are
6207      * stopped accumulating and are output when the count changes to/from 2.
6208      * The count is incremented when we start a range that's in the set, and
6209      * decremented when we start a range that's not in the set.  So its range
6210      * is 0 to 2.  Only when the count is 2 is something in the intersection.
6211      */
6212     UV count = 0;
6213
6214     PERL_ARGS_ASSERT_INVLIST_INTERSECTION;
6215
6216     /* Size the intersection for the worst case: that the intersection ends up
6217      * fragmenting everything to be completely disjoint */
6218     r= _new_invlist(len_a + len_b);
6219     array_r = invlist_array(r);
6220
6221     /* Go through each list item by item, stopping when exhausted one of
6222      * them */
6223     while (i_a < len_a && i_b < len_b) {
6224         UV cp;      /* The element to potentially add to the intersection's
6225                        array */
6226         bool cp_in_set; /* Is it in the input list's set or not */
6227
6228         /* We need to take one or the other of the two inputs for the
6229          * intersection.  Since we are merging two sorted lists, we take the
6230          * smaller of the next items.  In case of a tie, we take the one that
6231          * is not in its set first (a difference from the union algorithm).  If
6232          * we took one in the set first, it would increment the count, possibly
6233          * to 2 which would cause it to be output as starting a range in the
6234          * intersection, and the next time through we would take that same
6235          * number, and output it again as ending the set.  By doing it the
6236          * opposite of this, there is no possibility that the count will be
6237          * momentarily incremented to 2.  (In a tie and both are in the set or
6238          * both not in the set, it doesn't matter which we take first.) */
6239         if (array_a[i_a] < array_b[i_b]
6240             || (array_a[i_a] == array_b[i_b] && ! ELEMENT_IN_INVLIST_SET(i_a)))
6241         {
6242             cp_in_set = ELEMENT_IN_INVLIST_SET(i_a);
6243             cp= array_a[i_a++];
6244         }
6245         else {
6246             cp_in_set = ELEMENT_IN_INVLIST_SET(i_b);
6247             cp= array_b[i_b++];
6248         }
6249
6250         /* Here, have chosen which of the two inputs to look at.  Only output
6251          * if the running count changes to/from 2, which marks the
6252          * beginning/end of a range that's in the intersection */
6253         if (cp_in_set) {
6254             count++;
6255             if (count == 2) {
6256                 array_r[i_r++] = cp;
6257             }
6258         }
6259         else {
6260             if (count == 2) {
6261                 array_r[i_r++] = cp;
6262             }
6263             count--;
6264         }
6265     }
6266
6267     /* Here, we are finished going through at least one of the lists, which
6268      * means there is something remaining in at most one.  We check if the list
6269      * that has been exhausted is positioned such that we are in the middle
6270      * of a range in its set or not.  (i_a and i_b point to elements 1 beyond
6271      * the ones we care about.)  There are four cases:
6272      *  1) Both weren't in their sets, count is 0, and remains 0.  There's
6273      *     nothing left in the intersection.
6274      *  2) Both were in their sets, count is 2 and perhaps is incremented to
6275      *     above 2.  What should be output is exactly that which is in the
6276      *     non-exhausted set, as everything it has is also in the intersection
6277      *     set, and everything it doesn't have can't be in the intersection
6278      *  3) The exhausted was in its set, non-exhausted isn't, count is 1, and
6279      *     gets incremented to 2.  Like the previous case, the intersection is
6280      *     everything that remains in the non-exhausted set.
6281      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1, and
6282      *     remains 1.  And the intersection has nothing more. */
6283     if ((i_a == len_a && PREV_ELEMENT_IN_INVLIST_SET(i_a))
6284         || (i_b == len_b && PREV_ELEMENT_IN_INVLIST_SET(i_b)))
6285     {
6286         count++;
6287     }
6288
6289     /* The final length is what we've output so far plus what else is in the
6290      * intersection.  At most one of the subexpressions below will be non-zero */
6291     len_r = i_r;
6292     if (count >= 2) {
6293         len_r += (len_a - i_a) + (len_b - i_b);
6294     }
6295
6296     /* Set result to final length, which can change the pointer to array_r, so
6297      * re-find it */
6298     if (len_r != invlist_len(r)) {
6299         invlist_set_len(r, len_r);
6300         invlist_trim(r);
6301         array_r = invlist_array(r);
6302     }
6303
6304     /* Finish outputting any remaining */
6305     if (count >= 2) { /* At most one will have a non-zero copy count */
6306         IV copy_count;
6307         if ((copy_count = len_a - i_a) > 0) {
6308             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
6309         }
6310         else if ((copy_count = len_b - i_b) > 0) {
6311             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
6312         }
6313     }
6314
6315     return r;
6316 }
6317
6318 STATIC HV*
6319 S_add_range_to_invlist(pTHX_ HV* invlist, const UV start, const UV end)
6320 {
6321     /* Add the range from 'start' to 'end' inclusive to the inversion list's
6322      * set.  A pointer to the inversion list is returned.  This may actually be
6323      * a new list, in which case the passed in one has been destroyed.  The
6324      * passed in inversion list can be NULL, in which case a new one is created
6325      * with just the one range in it */
6326
6327     HV* range_invlist;
6328     HV* added_invlist;
6329     UV len;
6330
6331     if (invlist == NULL) {
6332         invlist = _new_invlist(2);
6333         len = 0;
6334     }
6335     else {
6336         len = invlist_len(invlist);
6337     }
6338
6339     /* If comes after the final entry, can just append it to the end */
6340     if (len == 0
6341         || start >= invlist_array(invlist)
6342                                     [invlist_len(invlist) - 1])
6343     {
6344         _append_range_to_invlist(invlist, start, end);
6345         return invlist;
6346     }
6347
6348     /* Here, can't just append things, create and return a new inversion list
6349      * which is the union of this range and the existing inversion list */
6350     range_invlist = _new_invlist(2);
6351     _append_range_to_invlist(range_invlist, start, end);
6352
6353     added_invlist = invlist_union(invlist, range_invlist);
6354
6355     /* The passed in list can be freed, as well as our temporary */
6356     invlist_destroy(range_invlist);
6357     if (invlist != added_invlist) {
6358         invlist_destroy(invlist);
6359     }
6360
6361     return added_invlist;
6362 }
6363
6364 PERL_STATIC_INLINE HV*
6365 S_add_cp_to_invlist(pTHX_ HV* invlist, const UV cp) {
6366     return add_range_to_invlist(invlist, cp, cp);
6367 }
6368
6369 /* End of inversion list object */
6370
6371 /*
6372  - reg - regular expression, i.e. main body or parenthesized thing
6373  *
6374  * Caller must absorb opening parenthesis.
6375  *
6376  * Combining parenthesis handling with the base level of regular expression
6377  * is a trifle forced, but the need to tie the tails of the branches to what
6378  * follows makes it hard to avoid.
6379  */
6380 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
6381 #ifdef DEBUGGING
6382 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
6383 #else
6384 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
6385 #endif
6386
6387 STATIC regnode *
6388 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
6389     /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
6390 {
6391     dVAR;
6392     register regnode *ret;              /* Will be the head of the group. */
6393     register regnode *br;
6394     register regnode *lastbr;
6395     register regnode *ender = NULL;
6396     register I32 parno = 0;
6397     I32 flags;
6398     U32 oregflags = RExC_flags;
6399     bool have_branch = 0;
6400     bool is_open = 0;
6401     I32 freeze_paren = 0;
6402     I32 after_freeze = 0;
6403
6404     /* for (?g), (?gc), and (?o) warnings; warning
6405        about (?c) will warn about (?g) -- japhy    */
6406
6407 #define WASTED_O  0x01
6408 #define WASTED_G  0x02
6409 #define WASTED_C  0x04
6410 #define WASTED_GC (0x02|0x04)
6411     I32 wastedflags = 0x00;
6412
6413     char * parse_start = RExC_parse; /* MJD */
6414     char * const oregcomp_parse = RExC_parse;
6415
6416     GET_RE_DEBUG_FLAGS_DECL;
6417
6418     PERL_ARGS_ASSERT_REG;
6419     DEBUG_PARSE("reg ");
6420
6421     *flagp = 0;                         /* Tentatively. */
6422
6423
6424     /* Make an OPEN node, if parenthesized. */
6425     if (paren) {
6426         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
6427             char *start_verb = RExC_parse;
6428             STRLEN verb_len = 0;
6429             char *start_arg = NULL;
6430             unsigned char op = 0;
6431             int argok = 1;
6432             int internal_argval = 0; /* internal_argval is only useful if !argok */
6433             while ( *RExC_parse && *RExC_parse != ')' ) {
6434                 if ( *RExC_parse == ':' ) {
6435                     start_arg = RExC_parse + 1;
6436                     break;
6437                 }
6438                 RExC_parse++;
6439             }
6440             ++start_verb;
6441             verb_len = RExC_parse - start_verb;
6442             if ( start_arg ) {
6443                 RExC_parse++;
6444                 while ( *RExC_parse && *RExC_parse != ')' ) 
6445                     RExC_parse++;
6446                 if ( *RExC_parse != ')' ) 
6447                     vFAIL("Unterminated verb pattern argument");
6448                 if ( RExC_parse == start_arg )
6449                     start_arg = NULL;
6450             } else {
6451                 if ( *RExC_parse != ')' )
6452                     vFAIL("Unterminated verb pattern");
6453             }
6454             
6455             switch ( *start_verb ) {
6456             case 'A':  /* (*ACCEPT) */
6457                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
6458                     op = ACCEPT;
6459                     internal_argval = RExC_nestroot;
6460                 }
6461                 break;
6462             case 'C':  /* (*COMMIT) */
6463                 if ( memEQs(start_verb,verb_len,"COMMIT") )
6464                     op = COMMIT;
6465                 break;
6466             case 'F':  /* (*FAIL) */
6467                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
6468                     op = OPFAIL;
6469                     argok = 0;
6470                 }
6471                 break;
6472             case ':':  /* (*:NAME) */
6473             case 'M':  /* (*MARK:NAME) */
6474                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
6475                     op = MARKPOINT;
6476                     argok = -1;
6477                 }
6478                 break;
6479             case 'P':  /* (*PRUNE) */
6480                 if ( memEQs(start_verb,verb_len,"PRUNE") )
6481                     op = PRUNE;
6482                 break;
6483             case 'S':   /* (*SKIP) */  
6484                 if ( memEQs(start_verb,verb_len,"SKIP") ) 
6485                     op = SKIP;
6486                 break;
6487             case 'T':  /* (*THEN) */
6488                 /* [19:06] <TimToady> :: is then */
6489                 if ( memEQs(start_verb,verb_len,"THEN") ) {
6490                     op = CUTGROUP;
6491                     RExC_seen |= REG_SEEN_CUTGROUP;
6492                 }
6493                 break;
6494             }
6495             if ( ! op ) {
6496                 RExC_parse++;
6497                 vFAIL3("Unknown verb pattern '%.*s'",
6498                     verb_len, start_verb);
6499             }
6500             if ( argok ) {
6501                 if ( start_arg && internal_argval ) {
6502                     vFAIL3("Verb pattern '%.*s' may not have an argument",
6503                         verb_len, start_verb); 
6504                 } else if ( argok < 0 && !start_arg ) {
6505                     vFAIL3("Verb pattern '%.*s' has a mandatory argument",
6506                         verb_len, start_verb);    
6507                 } else {
6508                     ret = reganode(pRExC_state, op, internal_argval);
6509                     if ( ! internal_argval && ! SIZE_ONLY ) {
6510                         if (start_arg) {
6511                             SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
6512                             ARG(ret) = add_data( pRExC_state, 1, "S" );
6513                             RExC_rxi->data->data[ARG(ret)]=(void*)sv;
6514                             ret->flags = 0;
6515                         } else {
6516                             ret->flags = 1; 
6517                         }
6518                     }               
6519                 }
6520                 if (!internal_argval)
6521                     RExC_seen |= REG_SEEN_VERBARG;
6522             } else if ( start_arg ) {
6523                 vFAIL3("Verb pattern '%.*s' may not have an argument",
6524                         verb_len, start_verb);    
6525             } else {
6526                 ret = reg_node(pRExC_state, op);
6527             }
6528             nextchar(pRExC_state);
6529             return ret;
6530         } else 
6531         if (*RExC_parse == '?') { /* (?...) */
6532             bool is_logical = 0;
6533             const char * const seqstart = RExC_parse;
6534             bool has_use_defaults = FALSE;
6535
6536             RExC_parse++;
6537             paren = *RExC_parse++;
6538             ret = NULL;                 /* For look-ahead/behind. */
6539             switch (paren) {
6540
6541             case 'P':   /* (?P...) variants for those used to PCRE/Python */
6542                 paren = *RExC_parse++;
6543                 if ( paren == '<')         /* (?P<...>) named capture */
6544                     goto named_capture;
6545                 else if (paren == '>') {   /* (?P>name) named recursion */
6546                     goto named_recursion;
6547                 }
6548                 else if (paren == '=') {   /* (?P=...)  named backref */
6549                     /* this pretty much dupes the code for \k<NAME> in regatom(), if
6550                        you change this make sure you change that */
6551                     char* name_start = RExC_parse;
6552                     U32 num = 0;
6553                     SV *sv_dat = reg_scan_name(pRExC_state,
6554                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6555                     if (RExC_parse == name_start || *RExC_parse != ')')
6556                         vFAIL2("Sequence %.3s... not terminated",parse_start);
6557
6558                     if (!SIZE_ONLY) {
6559                         num = add_data( pRExC_state, 1, "S" );
6560                         RExC_rxi->data->data[num]=(void*)sv_dat;
6561                         SvREFCNT_inc_simple_void(sv_dat);
6562                     }
6563                     RExC_sawback = 1;
6564                     ret = reganode(pRExC_state,
6565                                    ((! FOLD)
6566                                      ? NREF
6567                                      : (MORE_ASCII_RESTRICTED)
6568                                        ? NREFFA
6569                                        : (AT_LEAST_UNI_SEMANTICS)
6570                                          ? NREFFU
6571                                          : (LOC)
6572                                            ? NREFFL
6573                                            : NREFF),
6574                                     num);
6575                     *flagp |= HASWIDTH;
6576
6577                     Set_Node_Offset(ret, parse_start+1);
6578                     Set_Node_Cur_Length(ret); /* MJD */
6579
6580                     nextchar(pRExC_state);
6581                     return ret;
6582                 }
6583                 RExC_parse++;
6584                 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
6585                 /*NOTREACHED*/
6586             case '<':           /* (?<...) */
6587                 if (*RExC_parse == '!')
6588                     paren = ',';
6589                 else if (*RExC_parse != '=') 
6590               named_capture:
6591                 {               /* (?<...>) */
6592                     char *name_start;
6593                     SV *svname;
6594                     paren= '>';
6595             case '\'':          /* (?'...') */
6596                     name_start= RExC_parse;
6597                     svname = reg_scan_name(pRExC_state,
6598                         SIZE_ONLY ?  /* reverse test from the others */
6599                         REG_RSN_RETURN_NAME : 
6600                         REG_RSN_RETURN_NULL);
6601                     if (RExC_parse == name_start) {
6602                         RExC_parse++;
6603                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
6604                         /*NOTREACHED*/
6605                     }
6606                     if (*RExC_parse != paren)
6607                         vFAIL2("Sequence (?%c... not terminated",
6608                             paren=='>' ? '<' : paren);
6609                     if (SIZE_ONLY) {
6610                         HE *he_str;
6611                         SV *sv_dat = NULL;
6612                         if (!svname) /* shouldn't happen */
6613                             Perl_croak(aTHX_
6614                                 "panic: reg_scan_name returned NULL");
6615                         if (!RExC_paren_names) {
6616                             RExC_paren_names= newHV();
6617                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
6618 #ifdef DEBUGGING
6619                             RExC_paren_name_list= newAV();
6620                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
6621 #endif
6622                         }
6623                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
6624                         if ( he_str )
6625                             sv_dat = HeVAL(he_str);
6626                         if ( ! sv_dat ) {
6627                             /* croak baby croak */
6628                             Perl_croak(aTHX_
6629                                 "panic: paren_name hash element allocation failed");
6630                         } else if ( SvPOK(sv_dat) ) {
6631                             /* (?|...) can mean we have dupes so scan to check
6632                                its already been stored. Maybe a flag indicating
6633                                we are inside such a construct would be useful,
6634                                but the arrays are likely to be quite small, so
6635                                for now we punt -- dmq */
6636                             IV count = SvIV(sv_dat);
6637                             I32 *pv = (I32*)SvPVX(sv_dat);
6638                             IV i;
6639                             for ( i = 0 ; i < count ; i++ ) {
6640                                 if ( pv[i] == RExC_npar ) {
6641                                     count = 0;
6642                                     break;
6643                                 }
6644                             }
6645                             if ( count ) {
6646                                 pv = (I32*)SvGROW(sv_dat, SvCUR(sv_dat) + sizeof(I32)+1);
6647                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
6648                                 pv[count] = RExC_npar;
6649                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
6650                             }
6651                         } else {
6652                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
6653                             sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
6654                             SvIOK_on(sv_dat);
6655                             SvIV_set(sv_dat, 1);
6656                         }
6657 #ifdef DEBUGGING
6658                         /* Yes this does cause a memory leak in debugging Perls */
6659                         if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
6660                             SvREFCNT_dec(svname);
6661 #endif
6662
6663                         /*sv_dump(sv_dat);*/
6664                     }
6665                     nextchar(pRExC_state);
6666                     paren = 1;
6667                     goto capturing_parens;
6668                 }
6669                 RExC_seen |= REG_SEEN_LOOKBEHIND;
6670                 RExC_in_lookbehind++;
6671                 RExC_parse++;
6672             case '=':           /* (?=...) */
6673                 RExC_seen_zerolen++;
6674                 break;
6675             case '!':           /* (?!...) */
6676                 RExC_seen_zerolen++;
6677                 if (*RExC_parse == ')') {
6678                     ret=reg_node(pRExC_state, OPFAIL);
6679                     nextchar(pRExC_state);
6680                     return ret;
6681                 }
6682                 break;
6683             case '|':           /* (?|...) */
6684                 /* branch reset, behave like a (?:...) except that
6685                    buffers in alternations share the same numbers */
6686                 paren = ':'; 
6687                 after_freeze = freeze_paren = RExC_npar;
6688                 break;
6689             case ':':           /* (?:...) */
6690             case '>':           /* (?>...) */
6691                 break;
6692             case '$':           /* (?$...) */
6693             case '@':           /* (?@...) */
6694                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
6695                 break;
6696             case '#':           /* (?#...) */
6697                 while (*RExC_parse && *RExC_parse != ')')
6698                     RExC_parse++;
6699                 if (*RExC_parse != ')')
6700                     FAIL("Sequence (?#... not terminated");
6701                 nextchar(pRExC_state);
6702                 *flagp = TRYAGAIN;
6703                 return NULL;
6704             case '0' :           /* (?0) */
6705             case 'R' :           /* (?R) */
6706                 if (*RExC_parse != ')')
6707                     FAIL("Sequence (?R) not terminated");
6708                 ret = reg_node(pRExC_state, GOSTART);
6709                 *flagp |= POSTPONED;
6710                 nextchar(pRExC_state);
6711                 return ret;
6712                 /*notreached*/
6713             { /* named and numeric backreferences */
6714                 I32 num;
6715             case '&':            /* (?&NAME) */
6716                 parse_start = RExC_parse - 1;
6717               named_recursion:
6718                 {
6719                     SV *sv_dat = reg_scan_name(pRExC_state,
6720                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6721                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
6722                 }
6723                 goto gen_recurse_regop;
6724                 /* NOT REACHED */
6725             case '+':
6726                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
6727                     RExC_parse++;
6728                     vFAIL("Illegal pattern");
6729                 }
6730                 goto parse_recursion;
6731                 /* NOT REACHED*/
6732             case '-': /* (?-1) */
6733                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
6734                     RExC_parse--; /* rewind to let it be handled later */
6735                     goto parse_flags;
6736                 } 
6737                 /*FALLTHROUGH */
6738             case '1': case '2': case '3': case '4': /* (?1) */
6739             case '5': case '6': case '7': case '8': case '9':
6740                 RExC_parse--;
6741               parse_recursion:
6742                 num = atoi(RExC_parse);
6743                 parse_start = RExC_parse - 1; /* MJD */
6744                 if (*RExC_parse == '-')
6745                     RExC_parse++;
6746                 while (isDIGIT(*RExC_parse))
6747                         RExC_parse++;
6748                 if (*RExC_parse!=')') 
6749                     vFAIL("Expecting close bracket");
6750                         
6751               gen_recurse_regop:
6752                 if ( paren == '-' ) {
6753                     /*
6754                     Diagram of capture buffer numbering.
6755                     Top line is the normal capture buffer numbers
6756                     Bottom line is the negative indexing as from
6757                     the X (the (?-2))
6758
6759                     +   1 2    3 4 5 X          6 7
6760                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
6761                     -   5 4    3 2 1 X          x x
6762
6763                     */
6764                     num = RExC_npar + num;
6765                     if (num < 1)  {
6766                         RExC_parse++;
6767                         vFAIL("Reference to nonexistent group");
6768                     }
6769                 } else if ( paren == '+' ) {
6770                     num = RExC_npar + num - 1;
6771                 }
6772
6773                 ret = reganode(pRExC_state, GOSUB, num);
6774                 if (!SIZE_ONLY) {
6775                     if (num > (I32)RExC_rx->nparens) {
6776                         RExC_parse++;
6777                         vFAIL("Reference to nonexistent group");
6778                     }
6779                     ARG2L_SET( ret, RExC_recurse_count++);
6780                     RExC_emit++;
6781                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
6782                         "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
6783                 } else {
6784                     RExC_size++;
6785                 }
6786                 RExC_seen |= REG_SEEN_RECURSE;
6787                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
6788                 Set_Node_Offset(ret, parse_start); /* MJD */
6789
6790                 *flagp |= POSTPONED;
6791                 nextchar(pRExC_state);
6792                 return ret;
6793             } /* named and numeric backreferences */
6794             /* NOT REACHED */
6795
6796             case '?':           /* (??...) */
6797                 is_logical = 1;
6798                 if (*RExC_parse != '{') {
6799                     RExC_parse++;
6800                     vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
6801                     /*NOTREACHED*/
6802                 }
6803                 *flagp |= POSTPONED;
6804                 paren = *RExC_parse++;
6805                 /* FALL THROUGH */
6806             case '{':           /* (?{...}) */
6807             {
6808                 I32 count = 1;
6809                 U32 n = 0;
6810                 char c;
6811                 char *s = RExC_parse;
6812
6813                 RExC_seen_zerolen++;
6814                 RExC_seen |= REG_SEEN_EVAL;
6815                 while (count && (c = *RExC_parse)) {
6816                     if (c == '\\') {
6817                         if (RExC_parse[1])
6818                             RExC_parse++;
6819                     }
6820                     else if (c == '{')
6821                         count++;
6822                     else if (c == '}')
6823                         count--;
6824                     RExC_parse++;
6825                 }
6826                 if (*RExC_parse != ')') {
6827                     RExC_parse = s;             
6828                     vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
6829                 }
6830                 if (!SIZE_ONLY) {
6831                     PAD *pad;
6832                     OP_4tree *sop, *rop;
6833                     SV * const sv = newSVpvn(s, RExC_parse - 1 - s);
6834
6835                     ENTER;
6836                     Perl_save_re_context(aTHX);
6837                     rop = Perl_sv_compile_2op_is_broken(aTHX_ sv, &sop, "re", &pad);
6838                     sop->op_private |= OPpREFCOUNTED;
6839                     /* re_dup will OpREFCNT_inc */
6840                     OpREFCNT_set(sop, 1);
6841                     LEAVE;
6842
6843                     n = add_data(pRExC_state, 3, "nop");
6844                     RExC_rxi->data->data[n] = (void*)rop;
6845                     RExC_rxi->data->data[n+1] = (void*)sop;
6846                     RExC_rxi->data->data[n+2] = (void*)pad;
6847                     SvREFCNT_dec(sv);
6848                 }
6849                 else {                                          /* First pass */
6850                     if (PL_reginterp_cnt < ++RExC_seen_evals
6851                         && IN_PERL_RUNTIME)
6852                         /* No compiled RE interpolated, has runtime
6853                            components ===> unsafe.  */
6854                         FAIL("Eval-group not allowed at runtime, use re 'eval'");
6855                     if (PL_tainting && PL_tainted)
6856                         FAIL("Eval-group in insecure regular expression");
6857 #if PERL_VERSION > 8
6858                     if (IN_PERL_COMPILETIME)
6859                         PL_cv_has_eval = 1;
6860 #endif
6861                 }
6862
6863                 nextchar(pRExC_state);
6864                 if (is_logical) {
6865                     ret = reg_node(pRExC_state, LOGICAL);
6866                     if (!SIZE_ONLY)
6867                         ret->flags = 2;
6868                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
6869                     /* deal with the length of this later - MJD */
6870                     return ret;
6871                 }
6872                 ret = reganode(pRExC_state, EVAL, n);
6873                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
6874                 Set_Node_Offset(ret, parse_start);
6875                 return ret;
6876             }
6877             case '(':           /* (?(?{...})...) and (?(?=...)...) */
6878             {
6879                 int is_define= 0;
6880                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
6881                     if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
6882                         || RExC_parse[1] == '<'
6883                         || RExC_parse[1] == '{') { /* Lookahead or eval. */
6884                         I32 flag;
6885                         
6886                         ret = reg_node(pRExC_state, LOGICAL);
6887                         if (!SIZE_ONLY)
6888                             ret->flags = 1;
6889                         REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
6890                         goto insert_if;
6891                     }
6892                 }
6893                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
6894                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
6895                 {
6896                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
6897                     char *name_start= RExC_parse++;
6898                     U32 num = 0;
6899                     SV *sv_dat=reg_scan_name(pRExC_state,
6900                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6901                     if (RExC_parse == name_start || *RExC_parse != ch)
6902                         vFAIL2("Sequence (?(%c... not terminated",
6903                             (ch == '>' ? '<' : ch));
6904                     RExC_parse++;
6905                     if (!SIZE_ONLY) {
6906                         num = add_data( pRExC_state, 1, "S" );
6907                         RExC_rxi->data->data[num]=(void*)sv_dat;
6908                         SvREFCNT_inc_simple_void(sv_dat);
6909                     }
6910                     ret = reganode(pRExC_state,NGROUPP,num);
6911                     goto insert_if_check_paren;
6912                 }
6913                 else if (RExC_parse[0] == 'D' &&
6914                          RExC_parse[1] == 'E' &&
6915                          RExC_parse[2] == 'F' &&
6916                          RExC_parse[3] == 'I' &&
6917                          RExC_parse[4] == 'N' &&
6918                          RExC_parse[5] == 'E')
6919                 {
6920                     ret = reganode(pRExC_state,DEFINEP,0);
6921                     RExC_parse +=6 ;
6922                     is_define = 1;
6923                     goto insert_if_check_paren;
6924                 }
6925                 else if (RExC_parse[0] == 'R') {
6926                     RExC_parse++;
6927                     parno = 0;
6928                     if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
6929                         parno = atoi(RExC_parse++);
6930                         while (isDIGIT(*RExC_parse))
6931                             RExC_parse++;
6932                     } else if (RExC_parse[0] == '&') {
6933                         SV *sv_dat;
6934                         RExC_parse++;
6935                         sv_dat = reg_scan_name(pRExC_state,
6936                             SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6937                         parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
6938                     }
6939                     ret = reganode(pRExC_state,INSUBP,parno); 
6940                     goto insert_if_check_paren;
6941                 }
6942                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
6943                     /* (?(1)...) */
6944                     char c;
6945                     parno = atoi(RExC_parse++);
6946
6947                     while (isDIGIT(*RExC_parse))
6948                         RExC_parse++;
6949                     ret = reganode(pRExC_state, GROUPP, parno);
6950
6951                  insert_if_check_paren:
6952                     if ((c = *nextchar(pRExC_state)) != ')')
6953                         vFAIL("Switch condition not recognized");
6954                   insert_if:
6955                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
6956                     br = regbranch(pRExC_state, &flags, 1,depth+1);
6957                     if (br == NULL)
6958                         br = reganode(pRExC_state, LONGJMP, 0);
6959                     else
6960                         REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
6961                     c = *nextchar(pRExC_state);
6962                     if (flags&HASWIDTH)
6963                         *flagp |= HASWIDTH;
6964                     if (c == '|') {
6965                         if (is_define) 
6966                             vFAIL("(?(DEFINE)....) does not allow branches");
6967                         lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
6968                         regbranch(pRExC_state, &flags, 1,depth+1);
6969                         REGTAIL(pRExC_state, ret, lastbr);
6970                         if (flags&HASWIDTH)
6971                             *flagp |= HASWIDTH;
6972                         c = *nextchar(pRExC_state);
6973                     }
6974                     else
6975                         lastbr = NULL;
6976                     if (c != ')')
6977                         vFAIL("Switch (?(condition)... contains too many branches");
6978                     ender = reg_node(pRExC_state, TAIL);
6979                     REGTAIL(pRExC_state, br, ender);
6980                     if (lastbr) {
6981                         REGTAIL(pRExC_state, lastbr, ender);
6982                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
6983                     }
6984                     else
6985                         REGTAIL(pRExC_state, ret, ender);
6986                     RExC_size++; /* XXX WHY do we need this?!!
6987                                     For large programs it seems to be required
6988                                     but I can't figure out why. -- dmq*/
6989                     return ret;
6990                 }
6991                 else {
6992                     vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
6993                 }
6994             }
6995             case 0:
6996                 RExC_parse--; /* for vFAIL to print correctly */
6997                 vFAIL("Sequence (? incomplete");
6998                 break;
6999             case DEFAULT_PAT_MOD:   /* Use default flags with the exceptions
7000                                        that follow */
7001                 has_use_defaults = TRUE;
7002                 STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
7003                 set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
7004                                                 ? REGEX_UNICODE_CHARSET
7005                                                 : REGEX_DEPENDS_CHARSET);
7006                 goto parse_flags;
7007             default:
7008                 --RExC_parse;
7009                 parse_flags:      /* (?i) */  
7010             {
7011                 U32 posflags = 0, negflags = 0;
7012                 U32 *flagsp = &posflags;
7013                 char has_charset_modifier = '\0';
7014                 regex_charset cs = (RExC_utf8 || RExC_uni_semantics)
7015                                     ? REGEX_UNICODE_CHARSET
7016                                     : REGEX_DEPENDS_CHARSET;
7017
7018                 while (*RExC_parse) {
7019                     /* && strchr("iogcmsx", *RExC_parse) */
7020                     /* (?g), (?gc) and (?o) are useless here
7021                        and must be globally applied -- japhy */
7022                     switch (*RExC_parse) {
7023                     CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
7024                     case LOCALE_PAT_MOD:
7025                         if (has_charset_modifier) {
7026                             goto excess_modifier;
7027                         }
7028                         else if (flagsp == &negflags) {
7029                             goto neg_modifier;
7030                         }
7031                         cs = REGEX_LOCALE_CHARSET;
7032                         has_charset_modifier = LOCALE_PAT_MOD;
7033                         RExC_contains_locale = 1;
7034                         break;
7035                     case UNICODE_PAT_MOD:
7036                         if (has_charset_modifier) {
7037                             goto excess_modifier;
7038                         }
7039                         else if (flagsp == &negflags) {
7040                             goto neg_modifier;
7041                         }
7042                         cs = REGEX_UNICODE_CHARSET;
7043                         has_charset_modifier = UNICODE_PAT_MOD;
7044                         break;
7045                     case ASCII_RESTRICT_PAT_MOD:
7046                         if (flagsp == &negflags) {
7047                             goto neg_modifier;
7048                         }
7049                         if (has_charset_modifier) {
7050                             if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
7051                                 goto excess_modifier;
7052                             }
7053                             /* Doubled modifier implies more restricted */
7054                             cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
7055                         }
7056                         else {
7057                             cs = REGEX_ASCII_RESTRICTED_CHARSET;
7058                         }
7059                         has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
7060                         break;
7061                     case DEPENDS_PAT_MOD:
7062                         if (has_use_defaults) {
7063                             goto fail_modifiers;
7064                         }
7065                         else if (flagsp == &negflags) {
7066                             goto neg_modifier;
7067                         }
7068                         else if (has_charset_modifier) {
7069                             goto excess_modifier;
7070                         }
7071
7072                         /* The dual charset means unicode semantics if the
7073                          * pattern (or target, not known until runtime) are
7074                          * utf8, or something in the pattern indicates unicode
7075                          * semantics */
7076                         cs = (RExC_utf8 || RExC_uni_semantics)
7077                              ? REGEX_UNICODE_CHARSET
7078                              : REGEX_DEPENDS_CHARSET;
7079                         has_charset_modifier = DEPENDS_PAT_MOD;
7080                         break;
7081                     excess_modifier:
7082                         RExC_parse++;
7083                         if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
7084                             vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
7085                         }
7086                         else if (has_charset_modifier == *(RExC_parse - 1)) {
7087                             vFAIL2("Regexp modifier \"%c\" may not appear twice", *(RExC_parse - 1));
7088                         }
7089                         else {
7090                             vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
7091                         }
7092                         /*NOTREACHED*/
7093                     neg_modifier:
7094                         RExC_parse++;
7095                         vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", *(RExC_parse - 1));
7096                         /*NOTREACHED*/
7097                     case ONCE_PAT_MOD: /* 'o' */
7098                     case GLOBAL_PAT_MOD: /* 'g' */
7099                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
7100                             const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
7101                             if (! (wastedflags & wflagbit) ) {
7102                                 wastedflags |= wflagbit;
7103                                 vWARN5(
7104                                     RExC_parse + 1,
7105                                     "Useless (%s%c) - %suse /%c modifier",
7106                                     flagsp == &negflags ? "?-" : "?",
7107                                     *RExC_parse,
7108                                     flagsp == &negflags ? "don't " : "",
7109                                     *RExC_parse
7110                                 );
7111                             }
7112                         }
7113                         break;
7114                         
7115                     case CONTINUE_PAT_MOD: /* 'c' */
7116                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
7117                             if (! (wastedflags & WASTED_C) ) {
7118                                 wastedflags |= WASTED_GC;
7119                                 vWARN3(
7120                                     RExC_parse + 1,
7121                                     "Useless (%sc) - %suse /gc modifier",
7122                                     flagsp == &negflags ? "?-" : "?",
7123                                     flagsp == &negflags ? "don't " : ""
7124                                 );
7125                             }
7126                         }
7127                         break;
7128                     case KEEPCOPY_PAT_MOD: /* 'p' */
7129                         if (flagsp == &negflags) {
7130                             if (SIZE_ONLY)
7131                                 ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
7132                         } else {
7133                             *flagsp |= RXf_PMf_KEEPCOPY;
7134                         }
7135                         break;
7136                     case '-':
7137                         /* A flag is a default iff it is following a minus, so
7138                          * if there is a minus, it means will be trying to
7139                          * re-specify a default which is an error */
7140                         if (has_use_defaults || flagsp == &negflags) {
7141             fail_modifiers:
7142                             RExC_parse++;
7143                             vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7144                             /*NOTREACHED*/
7145                         }
7146                         flagsp = &negflags;
7147                         wastedflags = 0;  /* reset so (?g-c) warns twice */
7148                         break;
7149                     case ':':
7150                         paren = ':';
7151                         /*FALLTHROUGH*/
7152                     case ')':
7153                         RExC_flags |= posflags;
7154                         RExC_flags &= ~negflags;
7155                         set_regex_charset(&RExC_flags, cs);
7156                         if (paren != ':') {
7157                             oregflags |= posflags;
7158                             oregflags &= ~negflags;
7159                             set_regex_charset(&oregflags, cs);
7160                         }
7161                         nextchar(pRExC_state);
7162                         if (paren != ':') {
7163                             *flagp = TRYAGAIN;
7164                             return NULL;
7165                         } else {
7166                             ret = NULL;
7167                             goto parse_rest;
7168                         }
7169                         /*NOTREACHED*/
7170                     default:
7171                         RExC_parse++;
7172                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7173                         /*NOTREACHED*/
7174                     }                           
7175                     ++RExC_parse;
7176                 }
7177             }} /* one for the default block, one for the switch */
7178         }
7179         else {                  /* (...) */
7180           capturing_parens:
7181             parno = RExC_npar;
7182             RExC_npar++;
7183             
7184             ret = reganode(pRExC_state, OPEN, parno);
7185             if (!SIZE_ONLY ){
7186                 if (!RExC_nestroot) 
7187                     RExC_nestroot = parno;
7188                 if (RExC_seen & REG_SEEN_RECURSE
7189                     && !RExC_open_parens[parno-1])
7190                 {
7191                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
7192                         "Setting open paren #%"IVdf" to %d\n", 
7193                         (IV)parno, REG_NODE_NUM(ret)));
7194                     RExC_open_parens[parno-1]= ret;
7195                 }
7196             }
7197             Set_Node_Length(ret, 1); /* MJD */
7198             Set_Node_Offset(ret, RExC_parse); /* MJD */
7199             is_open = 1;
7200         }
7201     }
7202     else                        /* ! paren */
7203         ret = NULL;
7204    
7205    parse_rest:
7206     /* Pick up the branches, linking them together. */
7207     parse_start = RExC_parse;   /* MJD */
7208     br = regbranch(pRExC_state, &flags, 1,depth+1);
7209
7210     /*     branch_len = (paren != 0); */
7211
7212     if (br == NULL)
7213         return(NULL);
7214     if (*RExC_parse == '|') {
7215         if (!SIZE_ONLY && RExC_extralen) {
7216             reginsert(pRExC_state, BRANCHJ, br, depth+1);
7217         }
7218         else {                  /* MJD */
7219             reginsert(pRExC_state, BRANCH, br, depth+1);
7220             Set_Node_Length(br, paren != 0);
7221             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
7222         }
7223         have_branch = 1;
7224         if (SIZE_ONLY)
7225             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
7226     }
7227     else if (paren == ':') {
7228         *flagp |= flags&SIMPLE;
7229     }
7230     if (is_open) {                              /* Starts with OPEN. */
7231         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
7232     }
7233     else if (paren != '?')              /* Not Conditional */
7234         ret = br;
7235     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
7236     lastbr = br;
7237     while (*RExC_parse == '|') {
7238         if (!SIZE_ONLY && RExC_extralen) {
7239             ender = reganode(pRExC_state, LONGJMP,0);
7240             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
7241         }
7242         if (SIZE_ONLY)
7243             RExC_extralen += 2;         /* Account for LONGJMP. */
7244         nextchar(pRExC_state);
7245         if (freeze_paren) {
7246             if (RExC_npar > after_freeze)
7247                 after_freeze = RExC_npar;
7248             RExC_npar = freeze_paren;       
7249         }
7250         br = regbranch(pRExC_state, &flags, 0, depth+1);
7251
7252         if (br == NULL)
7253             return(NULL);
7254         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
7255         lastbr = br;
7256         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
7257     }
7258
7259     if (have_branch || paren != ':') {
7260         /* Make a closing node, and hook it on the end. */
7261         switch (paren) {
7262         case ':':
7263             ender = reg_node(pRExC_state, TAIL);
7264             break;
7265         case 1:
7266             ender = reganode(pRExC_state, CLOSE, parno);
7267             if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
7268                 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
7269                         "Setting close paren #%"IVdf" to %d\n", 
7270                         (IV)parno, REG_NODE_NUM(ender)));
7271                 RExC_close_parens[parno-1]= ender;
7272                 if (RExC_nestroot == parno) 
7273                     RExC_nestroot = 0;
7274             }       
7275             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
7276             Set_Node_Length(ender,1); /* MJD */
7277             break;
7278         case '<':
7279         case ',':
7280         case '=':
7281         case '!':
7282             *flagp &= ~HASWIDTH;
7283             /* FALL THROUGH */
7284         case '>':
7285             ender = reg_node(pRExC_state, SUCCEED);
7286             break;
7287         case 0:
7288             ender = reg_node(pRExC_state, END);
7289             if (!SIZE_ONLY) {
7290                 assert(!RExC_opend); /* there can only be one! */
7291                 RExC_opend = ender;
7292             }
7293             break;
7294         }
7295         REGTAIL(pRExC_state, lastbr, ender);
7296
7297         if (have_branch && !SIZE_ONLY) {
7298             if (depth==1)
7299                 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
7300
7301             /* Hook the tails of the branches to the closing node. */
7302             for (br = ret; br; br = regnext(br)) {
7303                 const U8 op = PL_regkind[OP(br)];
7304                 if (op == BRANCH) {
7305                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
7306                 }
7307                 else if (op == BRANCHJ) {
7308                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
7309                 }
7310             }
7311         }
7312     }
7313
7314     {
7315         const char *p;
7316         static const char parens[] = "=!<,>";
7317
7318         if (paren && (p = strchr(parens, paren))) {
7319             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
7320             int flag = (p - parens) > 1;
7321
7322             if (paren == '>')
7323                 node = SUSPEND, flag = 0;
7324             reginsert(pRExC_state, node,ret, depth+1);
7325             Set_Node_Cur_Length(ret);
7326             Set_Node_Offset(ret, parse_start + 1);
7327             ret->flags = flag;
7328             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
7329         }
7330     }
7331
7332     /* Check for proper termination. */
7333     if (paren) {
7334         RExC_flags = oregflags;
7335         if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
7336             RExC_parse = oregcomp_parse;
7337             vFAIL("Unmatched (");
7338         }
7339     }
7340     else if (!paren && RExC_parse < RExC_end) {
7341         if (*RExC_parse == ')') {
7342             RExC_parse++;
7343             vFAIL("Unmatched )");
7344         }
7345         else
7346             FAIL("Junk on end of regexp");      /* "Can't happen". */
7347         /* NOTREACHED */
7348     }
7349
7350     if (RExC_in_lookbehind) {
7351         RExC_in_lookbehind--;
7352     }
7353     if (after_freeze > RExC_npar)
7354         RExC_npar = after_freeze;
7355     return(ret);
7356 }
7357
7358 /*
7359  - regbranch - one alternative of an | operator
7360  *
7361  * Implements the concatenation operator.
7362  */
7363 STATIC regnode *
7364 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
7365 {
7366     dVAR;
7367     register regnode *ret;
7368     register regnode *chain = NULL;
7369     register regnode *latest;
7370     I32 flags = 0, c = 0;
7371     GET_RE_DEBUG_FLAGS_DECL;
7372
7373     PERL_ARGS_ASSERT_REGBRANCH;
7374
7375     DEBUG_PARSE("brnc");
7376
7377     if (first)
7378         ret = NULL;
7379     else {
7380         if (!SIZE_ONLY && RExC_extralen)
7381             ret = reganode(pRExC_state, BRANCHJ,0);
7382         else {
7383             ret = reg_node(pRExC_state, BRANCH);
7384             Set_Node_Length(ret, 1);
7385         }
7386     }
7387         
7388     if (!first && SIZE_ONLY)
7389         RExC_extralen += 1;                     /* BRANCHJ */
7390
7391     *flagp = WORST;                     /* Tentatively. */
7392
7393     RExC_parse--;
7394     nextchar(pRExC_state);
7395     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
7396         flags &= ~TRYAGAIN;
7397         latest = regpiece(pRExC_state, &flags,depth+1);
7398         if (latest == NULL) {
7399             if (flags & TRYAGAIN)
7400                 continue;
7401             return(NULL);
7402         }
7403         else if (ret == NULL)
7404             ret = latest;
7405         *flagp |= flags&(HASWIDTH|POSTPONED);
7406         if (chain == NULL)      /* First piece. */
7407             *flagp |= flags&SPSTART;
7408         else {
7409             RExC_naughty++;
7410             REGTAIL(pRExC_state, chain, latest);
7411         }
7412         chain = latest;
7413         c++;
7414     }
7415     if (chain == NULL) {        /* Loop ran zero times. */
7416         chain = reg_node(pRExC_state, NOTHING);
7417         if (ret == NULL)
7418             ret = chain;
7419     }
7420     if (c == 1) {
7421         *flagp |= flags&SIMPLE;
7422     }
7423
7424     return ret;
7425 }
7426
7427 /*
7428  - regpiece - something followed by possible [*+?]
7429  *
7430  * Note that the branching code sequences used for ? and the general cases
7431  * of * and + are somewhat optimized:  they use the same NOTHING node as
7432  * both the endmarker for their branch list and the body of the last branch.
7433  * It might seem that this node could be dispensed with entirely, but the
7434  * endmarker role is not redundant.
7435  */
7436 STATIC regnode *
7437 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
7438 {
7439     dVAR;
7440     register regnode *ret;
7441     register char op;
7442     register char *next;
7443     I32 flags;
7444     const char * const origparse = RExC_parse;
7445     I32 min;
7446     I32 max = REG_INFTY;
7447 #ifdef RE_TRACK_PATTERN_OFFSETS
7448     char *parse_start;
7449 #endif
7450     const char *maxpos = NULL;
7451     GET_RE_DEBUG_FLAGS_DECL;
7452
7453     PERL_ARGS_ASSERT_REGPIECE;
7454
7455     DEBUG_PARSE("piec");
7456
7457     ret = regatom(pRExC_state, &flags,depth+1);
7458     if (ret == NULL) {
7459         if (flags & TRYAGAIN)
7460             *flagp |= TRYAGAIN;
7461         return(NULL);
7462     }
7463
7464     op = *RExC_parse;
7465
7466     if (op == '{' && regcurly(RExC_parse)) {
7467         maxpos = NULL;
7468 #ifdef RE_TRACK_PATTERN_OFFSETS
7469         parse_start = RExC_parse; /* MJD */
7470 #endif
7471         next = RExC_parse + 1;
7472         while (isDIGIT(*next) || *next == ',') {
7473             if (*next == ',') {
7474                 if (maxpos)
7475                     break;
7476                 else
7477                     maxpos = next;
7478             }
7479             next++;
7480         }
7481         if (*next == '}') {             /* got one */
7482             if (!maxpos)
7483                 maxpos = next;
7484             RExC_parse++;
7485             min = atoi(RExC_parse);
7486             if (*maxpos == ',')
7487                 maxpos++;
7488             else
7489                 maxpos = RExC_parse;
7490             max = atoi(maxpos);
7491             if (!max && *maxpos != '0')
7492                 max = REG_INFTY;                /* meaning "infinity" */
7493             else if (max >= REG_INFTY)
7494                 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
7495             RExC_parse = next;
7496             nextchar(pRExC_state);
7497
7498         do_curly:
7499             if ((flags&SIMPLE)) {
7500                 RExC_naughty += 2 + RExC_naughty / 2;
7501                 reginsert(pRExC_state, CURLY, ret, depth+1);
7502                 Set_Node_Offset(ret, parse_start+1); /* MJD */
7503                 Set_Node_Cur_Length(ret);
7504             }
7505             else {
7506                 regnode * const w = reg_node(pRExC_state, WHILEM);
7507
7508                 w->flags = 0;
7509                 REGTAIL(pRExC_state, ret, w);
7510                 if (!SIZE_ONLY && RExC_extralen) {
7511                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
7512                     reginsert(pRExC_state, NOTHING,ret, depth+1);
7513                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
7514                 }
7515                 reginsert(pRExC_state, CURLYX,ret, depth+1);
7516                                 /* MJD hk */
7517                 Set_Node_Offset(ret, parse_start+1);
7518                 Set_Node_Length(ret,
7519                                 op == '{' ? (RExC_parse - parse_start) : 1);
7520
7521                 if (!SIZE_ONLY && RExC_extralen)
7522                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
7523                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
7524                 if (SIZE_ONLY)
7525                     RExC_whilem_seen++, RExC_extralen += 3;
7526                 RExC_naughty += 4 + RExC_naughty;       /* compound interest */
7527             }
7528             ret->flags = 0;
7529
7530             if (min > 0)
7531                 *flagp = WORST;
7532             if (max > 0)
7533                 *flagp |= HASWIDTH;
7534             if (max < min)
7535                 vFAIL("Can't do {n,m} with n > m");
7536             if (!SIZE_ONLY) {
7537                 ARG1_SET(ret, (U16)min);
7538                 ARG2_SET(ret, (U16)max);
7539             }
7540
7541             goto nest_check;
7542         }
7543     }
7544
7545     if (!ISMULT1(op)) {
7546         *flagp = flags;
7547         return(ret);
7548     }
7549
7550 #if 0                           /* Now runtime fix should be reliable. */
7551
7552     /* if this is reinstated, don't forget to put this back into perldiag:
7553
7554             =item Regexp *+ operand could be empty at {#} in regex m/%s/
7555
7556            (F) The part of the regexp subject to either the * or + quantifier
7557            could match an empty string. The {#} shows in the regular
7558            expression about where the problem was discovered.
7559
7560     */
7561
7562     if (!(flags&HASWIDTH) && op != '?')
7563       vFAIL("Regexp *+ operand could be empty");
7564 #endif
7565
7566 #ifdef RE_TRACK_PATTERN_OFFSETS
7567     parse_start = RExC_parse;
7568 #endif
7569     nextchar(pRExC_state);
7570
7571     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
7572
7573     if (op == '*' && (flags&SIMPLE)) {
7574         reginsert(pRExC_state, STAR, ret, depth+1);
7575         ret->flags = 0;
7576         RExC_naughty += 4;
7577     }
7578     else if (op == '*') {
7579         min = 0;
7580         goto do_curly;
7581     }
7582     else if (op == '+' && (flags&SIMPLE)) {
7583         reginsert(pRExC_state, PLUS, ret, depth+1);
7584         ret->flags = 0;
7585         RExC_naughty += 3;
7586     }
7587     else if (op == '+') {
7588         min = 1;
7589         goto do_curly;
7590     }
7591     else if (op == '?') {
7592         min = 0; max = 1;
7593         goto do_curly;
7594     }
7595   nest_check:
7596     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
7597         ckWARN3reg(RExC_parse,
7598                    "%.*s matches null string many times",
7599                    (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
7600                    origparse);
7601     }
7602
7603     if (RExC_parse < RExC_end && *RExC_parse == '?') {
7604         nextchar(pRExC_state);
7605         reginsert(pRExC_state, MINMOD, ret, depth+1);
7606         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
7607     }
7608 #ifndef REG_ALLOW_MINMOD_SUSPEND
7609     else
7610 #endif
7611     if (RExC_parse < RExC_end && *RExC_parse == '+') {
7612         regnode *ender;
7613         nextchar(pRExC_state);
7614         ender = reg_node(pRExC_state, SUCCEED);
7615         REGTAIL(pRExC_state, ret, ender);
7616         reginsert(pRExC_state, SUSPEND, ret, depth+1);
7617         ret->flags = 0;
7618         ender = reg_node(pRExC_state, TAIL);
7619         REGTAIL(pRExC_state, ret, ender);
7620         /*ret= ender;*/
7621     }
7622
7623     if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
7624         RExC_parse++;
7625         vFAIL("Nested quantifiers");
7626     }
7627
7628     return(ret);
7629 }
7630
7631
7632 /* reg_namedseq(pRExC_state,UVp, UV depth)
7633    
7634    This is expected to be called by a parser routine that has 
7635    recognized '\N' and needs to handle the rest. RExC_parse is
7636    expected to point at the first char following the N at the time
7637    of the call.
7638
7639    The \N may be inside (indicated by valuep not being NULL) or outside a
7640    character class.
7641
7642    \N may begin either a named sequence, or if outside a character class, mean
7643    to match a non-newline.  For non single-quoted regexes, the tokenizer has
7644    attempted to decide which, and in the case of a named sequence converted it
7645    into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...},
7646    where c1... are the characters in the sequence.  For single-quoted regexes,
7647    the tokenizer passes the \N sequence through unchanged; this code will not
7648    attempt to determine this nor expand those.  The net effect is that if the
7649    beginning of the passed-in pattern isn't '{U+' or there is no '}', it
7650    signals that this \N occurrence means to match a non-newline.
7651    
7652    Only the \N{U+...} form should occur in a character class, for the same
7653    reason that '.' inside a character class means to just match a period: it
7654    just doesn't make sense.
7655    
7656    If valuep is non-null then it is assumed that we are parsing inside 
7657    of a charclass definition and the first codepoint in the resolved
7658    string is returned via *valuep and the routine will return NULL. 
7659    In this mode if a multichar string is returned from the charnames 
7660    handler, a warning will be issued, and only the first char in the 
7661    sequence will be examined. If the string returned is zero length
7662    then the value of *valuep is undefined and NON-NULL will 
7663    be returned to indicate failure. (This will NOT be a valid pointer 
7664    to a regnode.)
7665    
7666    If valuep is null then it is assumed that we are parsing normal text and a
7667    new EXACT node is inserted into the program containing the resolved string,
7668    and a pointer to the new node is returned.  But if the string is zero length
7669    a NOTHING node is emitted instead.
7670
7671    On success RExC_parse is set to the char following the endbrace.
7672    Parsing failures will generate a fatal error via vFAIL(...)
7673  */
7674 STATIC regnode *
7675 S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep, I32 *flagp, U32 depth)
7676 {
7677     char * endbrace;    /* '}' following the name */
7678     regnode *ret = NULL;
7679     char* p;
7680
7681     GET_RE_DEBUG_FLAGS_DECL;
7682  
7683     PERL_ARGS_ASSERT_REG_NAMEDSEQ;
7684
7685     GET_RE_DEBUG_FLAGS;
7686
7687     /* The [^\n] meaning of \N ignores spaces and comments under the /x
7688      * modifier.  The other meaning does not */
7689     p = (RExC_flags & RXf_PMf_EXTENDED)
7690         ? regwhite( pRExC_state, RExC_parse )
7691         : RExC_parse;
7692    
7693     /* Disambiguate between \N meaning a named character versus \N meaning
7694      * [^\n].  The former is assumed when it can't be the latter. */
7695     if (*p != '{' || regcurly(p)) {
7696         RExC_parse = p;
7697         if (valuep) {
7698             /* no bare \N in a charclass */
7699             vFAIL("\\N in a character class must be a named character: \\N{...}");
7700         }
7701         nextchar(pRExC_state);
7702         ret = reg_node(pRExC_state, REG_ANY);
7703         *flagp |= HASWIDTH|SIMPLE;
7704         RExC_naughty++;
7705         RExC_parse--;
7706         Set_Node_Length(ret, 1); /* MJD */
7707         return ret;
7708     }
7709
7710     /* Here, we have decided it should be a named sequence */
7711
7712     /* The test above made sure that the next real character is a '{', but
7713      * under the /x modifier, it could be separated by space (or a comment and
7714      * \n) and this is not allowed (for consistency with \x{...} and the
7715      * tokenizer handling of \N{NAME}). */
7716     if (*RExC_parse != '{') {
7717         vFAIL("Missing braces on \\N{}");
7718     }
7719
7720     RExC_parse++;       /* Skip past the '{' */
7721
7722     if (! (endbrace = strchr(RExC_parse, '}')) /* no trailing brace */
7723         || ! (endbrace == RExC_parse            /* nothing between the {} */
7724               || (endbrace - RExC_parse >= 2    /* U+ (bad hex is checked below */
7725                   && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg) */
7726     {
7727         if (endbrace) RExC_parse = endbrace;    /* position msg's '<--HERE' */
7728         vFAIL("\\N{NAME} must be resolved by the lexer");
7729     }
7730
7731     if (endbrace == RExC_parse) {   /* empty: \N{} */
7732         if (! valuep) {
7733             RExC_parse = endbrace + 1;  
7734             return reg_node(pRExC_state,NOTHING);
7735         }
7736
7737         if (SIZE_ONLY) {
7738             ckWARNreg(RExC_parse,
7739                     "Ignoring zero length \\N{} in character class"
7740             );
7741             RExC_parse = endbrace + 1;  
7742         }
7743         *valuep = 0;
7744         return (regnode *) &RExC_parse; /* Invalid regnode pointer */
7745     }
7746
7747     REQUIRE_UTF8;       /* named sequences imply Unicode semantics */
7748     RExC_parse += 2;    /* Skip past the 'U+' */
7749
7750     if (valuep) {   /* In a bracketed char class */
7751         /* We only pay attention to the first char of 
7752         multichar strings being returned. I kinda wonder
7753         if this makes sense as it does change the behaviour
7754         from earlier versions, OTOH that behaviour was broken
7755         as well. XXX Solution is to recharacterize as
7756         [rest-of-class]|multi1|multi2... */
7757
7758         STRLEN length_of_hex;
7759         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
7760             | PERL_SCAN_DISALLOW_PREFIX
7761             | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
7762     
7763         char * endchar = RExC_parse + strcspn(RExC_parse, ".}");
7764         if (endchar < endbrace) {
7765             ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
7766         }
7767
7768         length_of_hex = (STRLEN)(endchar - RExC_parse);
7769         *valuep = grok_hex(RExC_parse, &length_of_hex, &flags, NULL);
7770
7771         /* The tokenizer should have guaranteed validity, but it's possible to
7772          * bypass it by using single quoting, so check */
7773         if (length_of_hex == 0
7774             || length_of_hex != (STRLEN)(endchar - RExC_parse) )
7775         {
7776             RExC_parse += length_of_hex;        /* Includes all the valid */
7777             RExC_parse += (RExC_orig_utf8)      /* point to after 1st invalid */
7778                             ? UTF8SKIP(RExC_parse)
7779                             : 1;
7780             /* Guard against malformed utf8 */
7781             if (RExC_parse >= endchar) RExC_parse = endchar;
7782             vFAIL("Invalid hexadecimal number in \\N{U+...}");
7783         }    
7784
7785         RExC_parse = endbrace + 1;
7786         if (endchar == endbrace) return NULL;
7787
7788         ret = (regnode *) &RExC_parse;  /* Invalid regnode pointer */
7789     }
7790     else {      /* Not a char class */
7791
7792         /* What is done here is to convert this to a sub-pattern of the form
7793          * (?:\x{char1}\x{char2}...)
7794          * and then call reg recursively.  That way, it retains its atomicness,
7795          * while not having to worry about special handling that some code
7796          * points may have.  toke.c has converted the original Unicode values
7797          * to native, so that we can just pass on the hex values unchanged.  We
7798          * do have to set a flag to keep recoding from happening in the
7799          * recursion */
7800
7801         SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP);
7802         STRLEN len;
7803         char *endchar;      /* Points to '.' or '}' ending cur char in the input
7804                                stream */
7805         char *orig_end = RExC_end;
7806
7807         while (RExC_parse < endbrace) {
7808
7809             /* Code points are separated by dots.  If none, there is only one
7810              * code point, and is terminated by the brace */
7811             endchar = RExC_parse + strcspn(RExC_parse, ".}");
7812
7813             /* Convert to notation the rest of the code understands */
7814             sv_catpv(substitute_parse, "\\x{");
7815             sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
7816             sv_catpv(substitute_parse, "}");
7817
7818             /* Point to the beginning of the next character in the sequence. */
7819             RExC_parse = endchar + 1;
7820         }
7821         sv_catpv(substitute_parse, ")");
7822
7823         RExC_parse = SvPV(substitute_parse, len);
7824
7825         /* Don't allow empty number */
7826         if (len < 8) {
7827             vFAIL("Invalid hexadecimal number in \\N{U+...}");
7828         }
7829         RExC_end = RExC_parse + len;
7830
7831         /* The values are Unicode, and therefore not subject to recoding */
7832         RExC_override_recoding = 1;
7833
7834         ret = reg(pRExC_state, 1, flagp, depth+1);
7835
7836         RExC_parse = endbrace;
7837         RExC_end = orig_end;
7838         RExC_override_recoding = 0;
7839
7840         nextchar(pRExC_state);
7841     }
7842
7843     return ret;
7844 }
7845
7846
7847 /*
7848  * reg_recode
7849  *
7850  * It returns the code point in utf8 for the value in *encp.
7851  *    value: a code value in the source encoding
7852  *    encp:  a pointer to an Encode object
7853  *
7854  * If the result from Encode is not a single character,
7855  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
7856  */
7857 STATIC UV
7858 S_reg_recode(pTHX_ const char value, SV **encp)
7859 {
7860     STRLEN numlen = 1;
7861     SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP);
7862     const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
7863     const STRLEN newlen = SvCUR(sv);
7864     UV uv = UNICODE_REPLACEMENT;
7865
7866     PERL_ARGS_ASSERT_REG_RECODE;
7867
7868     if (newlen)
7869         uv = SvUTF8(sv)
7870              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
7871              : *(U8*)s;
7872
7873     if (!newlen || numlen != newlen) {
7874         uv = UNICODE_REPLACEMENT;
7875         *encp = NULL;
7876     }
7877     return uv;
7878 }
7879
7880
7881 /*
7882  - regatom - the lowest level
7883
7884    Try to identify anything special at the start of the pattern. If there
7885    is, then handle it as required. This may involve generating a single regop,
7886    such as for an assertion; or it may involve recursing, such as to
7887    handle a () structure.
7888
7889    If the string doesn't start with something special then we gobble up
7890    as much literal text as we can.
7891
7892    Once we have been able to handle whatever type of thing started the
7893    sequence, we return.
7894
7895    Note: we have to be careful with escapes, as they can be both literal
7896    and special, and in the case of \10 and friends can either, depending
7897    on context. Specifically there are two separate switches for handling
7898    escape sequences, with the one for handling literal escapes requiring
7899    a dummy entry for all of the special escapes that are actually handled
7900    by the other.
7901 */
7902
7903 STATIC regnode *
7904 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
7905 {
7906     dVAR;
7907     register regnode *ret = NULL;
7908     I32 flags;
7909     char *parse_start = RExC_parse;
7910     U8 op;
7911     GET_RE_DEBUG_FLAGS_DECL;
7912     DEBUG_PARSE("atom");
7913     *flagp = WORST;             /* Tentatively. */
7914
7915     PERL_ARGS_ASSERT_REGATOM;
7916
7917 tryagain:
7918     switch ((U8)*RExC_parse) {
7919     case '^':
7920         RExC_seen_zerolen++;
7921         nextchar(pRExC_state);
7922         if (RExC_flags & RXf_PMf_MULTILINE)
7923             ret = reg_node(pRExC_state, MBOL);
7924         else if (RExC_flags & RXf_PMf_SINGLELINE)
7925             ret = reg_node(pRExC_state, SBOL);
7926         else
7927             ret = reg_node(pRExC_state, BOL);
7928         Set_Node_Length(ret, 1); /* MJD */
7929         break;
7930     case '$':
7931         nextchar(pRExC_state);
7932         if (*RExC_parse)
7933             RExC_seen_zerolen++;
7934         if (RExC_flags & RXf_PMf_MULTILINE)
7935             ret = reg_node(pRExC_state, MEOL);
7936         else if (RExC_flags & RXf_PMf_SINGLELINE)
7937             ret = reg_node(pRExC_state, SEOL);
7938         else
7939             ret = reg_node(pRExC_state, EOL);
7940         Set_Node_Length(ret, 1); /* MJD */
7941         break;
7942     case '.':
7943         nextchar(pRExC_state);
7944         if (RExC_flags & RXf_PMf_SINGLELINE)
7945             ret = reg_node(pRExC_state, SANY);
7946         else
7947             ret = reg_node(pRExC_state, REG_ANY);
7948         *flagp |= HASWIDTH|SIMPLE;
7949         RExC_naughty++;
7950         Set_Node_Length(ret, 1); /* MJD */
7951         break;
7952     case '[':
7953     {
7954         char * const oregcomp_parse = ++RExC_parse;
7955         ret = regclass(pRExC_state,depth+1);
7956         if (*RExC_parse != ']') {
7957             RExC_parse = oregcomp_parse;
7958             vFAIL("Unmatched [");
7959         }
7960         nextchar(pRExC_state);
7961         *flagp |= HASWIDTH|SIMPLE;
7962         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
7963         break;
7964     }
7965     case '(':
7966         nextchar(pRExC_state);
7967         ret = reg(pRExC_state, 1, &flags,depth+1);
7968         if (ret == NULL) {
7969                 if (flags & TRYAGAIN) {
7970                     if (RExC_parse == RExC_end) {
7971                          /* Make parent create an empty node if needed. */
7972                         *flagp |= TRYAGAIN;
7973                         return(NULL);
7974                     }
7975                     goto tryagain;
7976                 }
7977                 return(NULL);
7978         }
7979         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
7980         break;
7981     case '|':
7982     case ')':
7983         if (flags & TRYAGAIN) {
7984             *flagp |= TRYAGAIN;
7985             return NULL;
7986         }
7987         vFAIL("Internal urp");
7988                                 /* Supposed to be caught earlier. */
7989         break;
7990     case '{':
7991         if (!regcurly(RExC_parse)) {
7992             RExC_parse++;
7993             goto defchar;
7994         }
7995         /* FALL THROUGH */
7996     case '?':
7997     case '+':
7998     case '*':
7999         RExC_parse++;
8000         vFAIL("Quantifier follows nothing");
8001         break;
8002     case '\\':
8003         /* Special Escapes
8004
8005            This switch handles escape sequences that resolve to some kind
8006            of special regop and not to literal text. Escape sequnces that
8007            resolve to literal text are handled below in the switch marked
8008            "Literal Escapes".
8009
8010            Every entry in this switch *must* have a corresponding entry
8011            in the literal escape switch. However, the opposite is not
8012            required, as the default for this switch is to jump to the
8013            literal text handling code.
8014         */
8015         switch ((U8)*++RExC_parse) {
8016         /* Special Escapes */
8017         case 'A':
8018             RExC_seen_zerolen++;
8019             ret = reg_node(pRExC_state, SBOL);
8020             *flagp |= SIMPLE;
8021             goto finish_meta_pat;
8022         case 'G':
8023             ret = reg_node(pRExC_state, GPOS);
8024             RExC_seen |= REG_SEEN_GPOS;
8025             *flagp |= SIMPLE;
8026             goto finish_meta_pat;
8027         case 'K':
8028             RExC_seen_zerolen++;
8029             ret = reg_node(pRExC_state, KEEPS);
8030             *flagp |= SIMPLE;
8031             /* XXX:dmq : disabling in-place substitution seems to
8032              * be necessary here to avoid cases of memory corruption, as
8033              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
8034              */
8035             RExC_seen |= REG_SEEN_LOOKBEHIND;
8036             goto finish_meta_pat;
8037         case 'Z':
8038             ret = reg_node(pRExC_state, SEOL);
8039             *flagp |= SIMPLE;
8040             RExC_seen_zerolen++;                /* Do not optimize RE away */
8041             goto finish_meta_pat;
8042         case 'z':
8043             ret = reg_node(pRExC_state, EOS);
8044             *flagp |= SIMPLE;
8045             RExC_seen_zerolen++;                /* Do not optimize RE away */
8046             goto finish_meta_pat;
8047         case 'C':
8048             ret = reg_node(pRExC_state, CANY);
8049             RExC_seen |= REG_SEEN_CANY;
8050             *flagp |= HASWIDTH|SIMPLE;
8051             goto finish_meta_pat;
8052         case 'X':
8053             ret = reg_node(pRExC_state, CLUMP);
8054             *flagp |= HASWIDTH;
8055             goto finish_meta_pat;
8056         case 'w':
8057             switch (get_regex_charset(RExC_flags)) {
8058                 case REGEX_LOCALE_CHARSET:
8059                     op = ALNUML;
8060                     break;
8061                 case REGEX_UNICODE_CHARSET:
8062                     op = ALNUMU;
8063                     break;
8064                 case REGEX_ASCII_RESTRICTED_CHARSET:
8065                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8066                     op = ALNUMA;
8067                     break;
8068                 case REGEX_DEPENDS_CHARSET:
8069                     op = ALNUM;
8070                     break;
8071                 default:
8072                     goto bad_charset;
8073             }
8074             ret = reg_node(pRExC_state, op);
8075             *flagp |= HASWIDTH|SIMPLE;
8076             goto finish_meta_pat;
8077         case 'W':
8078             switch (get_regex_charset(RExC_flags)) {
8079                 case REGEX_LOCALE_CHARSET:
8080                     op = NALNUML;
8081                     break;
8082                 case REGEX_UNICODE_CHARSET:
8083                     op = NALNUMU;
8084                     break;
8085                 case REGEX_ASCII_RESTRICTED_CHARSET:
8086                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8087                     op = NALNUMA;
8088                     break;
8089                 case REGEX_DEPENDS_CHARSET:
8090                     op = NALNUM;
8091                     break;
8092                 default:
8093                     goto bad_charset;
8094             }
8095             ret = reg_node(pRExC_state, op);
8096             *flagp |= HASWIDTH|SIMPLE;
8097             goto finish_meta_pat;
8098         case 'b':
8099             RExC_seen_zerolen++;
8100             RExC_seen |= REG_SEEN_LOOKBEHIND;
8101             switch (get_regex_charset(RExC_flags)) {
8102                 case REGEX_LOCALE_CHARSET:
8103                     op = BOUNDL;
8104                     break;
8105                 case REGEX_UNICODE_CHARSET:
8106                     op = BOUNDU;
8107                     break;
8108                 case REGEX_ASCII_RESTRICTED_CHARSET:
8109                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8110                     op = BOUNDA;
8111                     break;
8112                 case REGEX_DEPENDS_CHARSET:
8113                     op = BOUND;
8114                     break;
8115                 default:
8116                     goto bad_charset;
8117             }
8118             ret = reg_node(pRExC_state, op);
8119             FLAGS(ret) = get_regex_charset(RExC_flags);
8120             *flagp |= SIMPLE;
8121             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
8122                 ckWARNregdep(RExC_parse, "\"\\b{\" is deprecated; use \"\\b\\{\" instead");
8123             }
8124             goto finish_meta_pat;
8125         case 'B':
8126             RExC_seen_zerolen++;
8127             RExC_seen |= REG_SEEN_LOOKBEHIND;
8128             switch (get_regex_charset(RExC_flags)) {
8129                 case REGEX_LOCALE_CHARSET:
8130                     op = NBOUNDL;
8131                     break;
8132                 case REGEX_UNICODE_CHARSET:
8133                     op = NBOUNDU;
8134                     break;
8135                 case REGEX_ASCII_RESTRICTED_CHARSET:
8136                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8137                     op = NBOUNDA;
8138                     break;
8139                 case REGEX_DEPENDS_CHARSET:
8140                     op = NBOUND;
8141                     break;
8142                 default:
8143                     goto bad_charset;
8144             }
8145             ret = reg_node(pRExC_state, op);
8146             FLAGS(ret) = get_regex_charset(RExC_flags);
8147             *flagp |= SIMPLE;
8148             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
8149                 ckWARNregdep(RExC_parse, "\"\\B{\" is deprecated; use \"\\B\\{\" instead");
8150             }
8151             goto finish_meta_pat;
8152         case 's':
8153             switch (get_regex_charset(RExC_flags)) {
8154                 case REGEX_LOCALE_CHARSET:
8155                     op = SPACEL;
8156                     break;
8157                 case REGEX_UNICODE_CHARSET:
8158                     op = SPACEU;
8159                     break;
8160                 case REGEX_ASCII_RESTRICTED_CHARSET:
8161                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8162                     op = SPACEA;
8163                     break;
8164                 case REGEX_DEPENDS_CHARSET:
8165                     op = SPACE;
8166                     break;
8167                 default:
8168                     goto bad_charset;
8169             }
8170             ret = reg_node(pRExC_state, op);
8171             *flagp |= HASWIDTH|SIMPLE;
8172             goto finish_meta_pat;
8173         case 'S':
8174             switch (get_regex_charset(RExC_flags)) {
8175                 case REGEX_LOCALE_CHARSET:
8176                     op = NSPACEL;
8177                     break;
8178                 case REGEX_UNICODE_CHARSET:
8179                     op = NSPACEU;
8180                     break;
8181                 case REGEX_ASCII_RESTRICTED_CHARSET:
8182                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8183                     op = NSPACEA;
8184                     break;
8185                 case REGEX_DEPENDS_CHARSET:
8186                     op = NSPACE;
8187                     break;
8188                 default:
8189                     goto bad_charset;
8190             }
8191             ret = reg_node(pRExC_state, op);
8192             *flagp |= HASWIDTH|SIMPLE;
8193             goto finish_meta_pat;
8194         case 'd':
8195             switch (get_regex_charset(RExC_flags)) {
8196                 case REGEX_LOCALE_CHARSET:
8197                     op = DIGITL;
8198                     break;
8199                 case REGEX_ASCII_RESTRICTED_CHARSET:
8200                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8201                     op = DIGITA;
8202                     break;
8203                 case REGEX_DEPENDS_CHARSET: /* No difference between these */
8204                 case REGEX_UNICODE_CHARSET:
8205                     op = DIGIT;
8206                     break;
8207                 default:
8208                     goto bad_charset;
8209             }
8210             ret = reg_node(pRExC_state, op);
8211             *flagp |= HASWIDTH|SIMPLE;
8212             goto finish_meta_pat;
8213         case 'D':
8214             switch (get_regex_charset(RExC_flags)) {
8215                 case REGEX_LOCALE_CHARSET:
8216                     op = NDIGITL;
8217                     break;
8218                 case REGEX_ASCII_RESTRICTED_CHARSET:
8219                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8220                     op = NDIGITA;
8221                     break;
8222                 case REGEX_DEPENDS_CHARSET: /* No difference between these */
8223                 case REGEX_UNICODE_CHARSET:
8224                     op = NDIGIT;
8225                     break;
8226                 default:
8227                     goto bad_charset;
8228             }
8229             ret = reg_node(pRExC_state, op);
8230             *flagp |= HASWIDTH|SIMPLE;
8231             goto finish_meta_pat;
8232         case 'R':
8233             ret = reg_node(pRExC_state, LNBREAK);
8234             *flagp |= HASWIDTH|SIMPLE;
8235             goto finish_meta_pat;
8236         case 'h':
8237             ret = reg_node(pRExC_state, HORIZWS);
8238             *flagp |= HASWIDTH|SIMPLE;
8239             goto finish_meta_pat;
8240         case 'H':
8241             ret = reg_node(pRExC_state, NHORIZWS);
8242             *flagp |= HASWIDTH|SIMPLE;
8243             goto finish_meta_pat;
8244         case 'v':
8245             ret = reg_node(pRExC_state, VERTWS);
8246             *flagp |= HASWIDTH|SIMPLE;
8247             goto finish_meta_pat;
8248         case 'V':
8249             ret = reg_node(pRExC_state, NVERTWS);
8250             *flagp |= HASWIDTH|SIMPLE;
8251          finish_meta_pat:           
8252             nextchar(pRExC_state);
8253             Set_Node_Length(ret, 2); /* MJD */
8254             break;          
8255         case 'p':
8256         case 'P':
8257             {   
8258                 char* const oldregxend = RExC_end;
8259 #ifdef DEBUGGING
8260                 char* parse_start = RExC_parse - 2;
8261 #endif
8262
8263                 if (RExC_parse[1] == '{') {
8264                   /* a lovely hack--pretend we saw [\pX] instead */
8265                     RExC_end = strchr(RExC_parse, '}');
8266                     if (!RExC_end) {
8267                         const U8 c = (U8)*RExC_parse;
8268                         RExC_parse += 2;
8269                         RExC_end = oldregxend;
8270                         vFAIL2("Missing right brace on \\%c{}", c);
8271                     }
8272                     RExC_end++;
8273                 }
8274                 else {
8275                     RExC_end = RExC_parse + 2;
8276                     if (RExC_end > oldregxend)
8277                         RExC_end = oldregxend;
8278                 }
8279                 RExC_parse--;
8280
8281                 ret = regclass(pRExC_state,depth+1);
8282
8283                 RExC_end = oldregxend;
8284                 RExC_parse--;
8285
8286                 Set_Node_Offset(ret, parse_start + 2);
8287                 Set_Node_Cur_Length(ret);
8288                 nextchar(pRExC_state);
8289                 *flagp |= HASWIDTH|SIMPLE;
8290             }
8291             break;
8292         case 'N': 
8293             /* Handle \N and \N{NAME} here and not below because it can be
8294             multicharacter. join_exact() will join them up later on. 
8295             Also this makes sure that things like /\N{BLAH}+/ and 
8296             \N{BLAH} being multi char Just Happen. dmq*/
8297             ++RExC_parse;
8298             ret= reg_namedseq(pRExC_state, NULL, flagp, depth);
8299             break;
8300         case 'k':    /* Handle \k<NAME> and \k'NAME' */
8301         parse_named_seq:
8302         {   
8303             char ch= RExC_parse[1];         
8304             if (ch != '<' && ch != '\'' && ch != '{') {
8305                 RExC_parse++;
8306                 vFAIL2("Sequence %.2s... not terminated",parse_start);
8307             } else {
8308                 /* this pretty much dupes the code for (?P=...) in reg(), if
8309                    you change this make sure you change that */
8310                 char* name_start = (RExC_parse += 2);
8311                 U32 num = 0;
8312                 SV *sv_dat = reg_scan_name(pRExC_state,
8313                     SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8314                 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
8315                 if (RExC_parse == name_start || *RExC_parse != ch)
8316                     vFAIL2("Sequence %.3s... not terminated",parse_start);
8317
8318                 if (!SIZE_ONLY) {
8319                     num = add_data( pRExC_state, 1, "S" );
8320                     RExC_rxi->data->data[num]=(void*)sv_dat;
8321                     SvREFCNT_inc_simple_void(sv_dat);
8322                 }
8323
8324                 RExC_sawback = 1;
8325                 ret = reganode(pRExC_state,
8326                                ((! FOLD)
8327                                  ? NREF
8328                                  : (MORE_ASCII_RESTRICTED)
8329                                    ? NREFFA
8330                                    : (AT_LEAST_UNI_SEMANTICS)
8331                                      ? NREFFU
8332                                      : (LOC)
8333                                        ? NREFFL
8334                                        : NREFF),
8335                                 num);
8336                 *flagp |= HASWIDTH;
8337
8338                 /* override incorrect value set in reganode MJD */
8339                 Set_Node_Offset(ret, parse_start+1);
8340                 Set_Node_Cur_Length(ret); /* MJD */
8341                 nextchar(pRExC_state);
8342
8343             }
8344             break;
8345         }
8346         case 'g': 
8347         case '1': case '2': case '3': case '4':
8348         case '5': case '6': case '7': case '8': case '9':
8349             {
8350                 I32 num;
8351                 bool isg = *RExC_parse == 'g';
8352                 bool isrel = 0; 
8353                 bool hasbrace = 0;
8354                 if (isg) {
8355                     RExC_parse++;
8356                     if (*RExC_parse == '{') {
8357                         RExC_parse++;
8358                         hasbrace = 1;
8359                     }
8360                     if (*RExC_parse == '-') {
8361                         RExC_parse++;
8362                         isrel = 1;
8363                     }
8364                     if (hasbrace && !isDIGIT(*RExC_parse)) {
8365                         if (isrel) RExC_parse--;
8366                         RExC_parse -= 2;                            
8367                         goto parse_named_seq;
8368                 }   }
8369                 num = atoi(RExC_parse);
8370                 if (isg && num == 0)
8371                     vFAIL("Reference to invalid group 0");
8372                 if (isrel) {
8373                     num = RExC_npar - num;
8374                     if (num < 1)
8375                         vFAIL("Reference to nonexistent or unclosed group");
8376                 }
8377                 if (!isg && num > 9 && num >= RExC_npar)
8378                     goto defchar;
8379                 else {
8380                     char * const parse_start = RExC_parse - 1; /* MJD */
8381                     while (isDIGIT(*RExC_parse))
8382                         RExC_parse++;
8383                     if (parse_start == RExC_parse - 1) 
8384                         vFAIL("Unterminated \\g... pattern");
8385                     if (hasbrace) {
8386                         if (*RExC_parse != '}') 
8387                             vFAIL("Unterminated \\g{...} pattern");
8388                         RExC_parse++;
8389                     }    
8390                     if (!SIZE_ONLY) {
8391                         if (num > (I32)RExC_rx->nparens)
8392                             vFAIL("Reference to nonexistent group");
8393                     }
8394                     RExC_sawback = 1;
8395                     ret = reganode(pRExC_state,
8396                                    ((! FOLD)
8397                                      ? REF
8398                                      : (MORE_ASCII_RESTRICTED)
8399                                        ? REFFA
8400                                        : (AT_LEAST_UNI_SEMANTICS)
8401                                          ? REFFU
8402                                          : (LOC)
8403                                            ? REFFL
8404                                            : REFF),
8405                                     num);
8406                     *flagp |= HASWIDTH;
8407
8408                     /* override incorrect value set in reganode MJD */
8409                     Set_Node_Offset(ret, parse_start+1);
8410                     Set_Node_Cur_Length(ret); /* MJD */
8411                     RExC_parse--;
8412                     nextchar(pRExC_state);
8413                 }
8414             }
8415             break;
8416         case '\0':
8417             if (RExC_parse >= RExC_end)
8418                 FAIL("Trailing \\");
8419             /* FALL THROUGH */
8420         default:
8421             /* Do not generate "unrecognized" warnings here, we fall
8422                back into the quick-grab loop below */
8423             parse_start--;
8424             goto defchar;
8425         }
8426         break;
8427
8428     case '#':
8429         if (RExC_flags & RXf_PMf_EXTENDED) {
8430             if ( reg_skipcomment( pRExC_state ) )
8431                 goto tryagain;
8432         }
8433         /* FALL THROUGH */
8434
8435     default:
8436
8437             parse_start = RExC_parse - 1;
8438
8439             RExC_parse++;
8440
8441         defchar: {
8442             typedef enum {
8443                 generic_char = 0,
8444                 char_s,
8445                 upsilon_1,
8446                 upsilon_2,
8447                 iota_1,
8448                 iota_2,
8449             } char_state;
8450             char_state latest_char_state = generic_char;
8451             register STRLEN len;
8452             register UV ender;
8453             register char *p;
8454             char *s;
8455             STRLEN foldlen;
8456             U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
8457             regnode * orig_emit;
8458
8459             ender = 0;
8460             orig_emit = RExC_emit; /* Save the original output node position in
8461                                       case we need to output a different node
8462                                       type */
8463             ret = reg_node(pRExC_state,
8464                            (U8) ((! FOLD) ? EXACT
8465                                           : (LOC)
8466                                              ? EXACTFL
8467                                              : (MORE_ASCII_RESTRICTED)
8468                                                ? EXACTFA
8469                                                : (AT_LEAST_UNI_SEMANTICS)
8470                                                  ? EXACTFU
8471                                                  : EXACTF)
8472                     );
8473             s = STRING(ret);
8474             for (len = 0, p = RExC_parse - 1;
8475               len < 127 && p < RExC_end;
8476               len++)
8477             {
8478                 char * const oldp = p;
8479
8480                 if (RExC_flags & RXf_PMf_EXTENDED)
8481                     p = regwhite( pRExC_state, p );
8482                 switch ((U8)*p) {
8483                 case '^':
8484                 case '$':
8485                 case '.':
8486                 case '[':
8487                 case '(':
8488                 case ')':
8489                 case '|':
8490                     goto loopdone;
8491                 case '\\':
8492                     /* Literal Escapes Switch
8493
8494                        This switch is meant to handle escape sequences that
8495                        resolve to a literal character.
8496
8497                        Every escape sequence that represents something
8498                        else, like an assertion or a char class, is handled
8499                        in the switch marked 'Special Escapes' above in this
8500                        routine, but also has an entry here as anything that
8501                        isn't explicitly mentioned here will be treated as
8502                        an unescaped equivalent literal.
8503                     */
8504
8505                     switch ((U8)*++p) {
8506                     /* These are all the special escapes. */
8507                     case 'A':             /* Start assertion */
8508                     case 'b': case 'B':   /* Word-boundary assertion*/
8509                     case 'C':             /* Single char !DANGEROUS! */
8510                     case 'd': case 'D':   /* digit class */
8511                     case 'g': case 'G':   /* generic-backref, pos assertion */
8512                     case 'h': case 'H':   /* HORIZWS */
8513                     case 'k': case 'K':   /* named backref, keep marker */
8514                     case 'N':             /* named char sequence */
8515                     case 'p': case 'P':   /* Unicode property */
8516                               case 'R':   /* LNBREAK */
8517                     case 's': case 'S':   /* space class */
8518                     case 'v': case 'V':   /* VERTWS */
8519                     case 'w': case 'W':   /* word class */
8520                     case 'X':             /* eXtended Unicode "combining character sequence" */
8521                     case 'z': case 'Z':   /* End of line/string assertion */
8522                         --p;
8523                         goto loopdone;
8524
8525                     /* Anything after here is an escape that resolves to a
8526                        literal. (Except digits, which may or may not)
8527                      */
8528                     case 'n':
8529                         ender = '\n';
8530                         p++;
8531                         break;
8532                     case 'r':
8533                         ender = '\r';
8534                         p++;
8535                         break;
8536                     case 't':
8537                         ender = '\t';
8538                         p++;
8539                         break;
8540                     case 'f':
8541                         ender = '\f';
8542                         p++;
8543                         break;
8544                     case 'e':
8545                           ender = ASCII_TO_NATIVE('\033');
8546                         p++;
8547                         break;
8548                     case 'a':
8549                           ender = ASCII_TO_NATIVE('\007');
8550                         p++;
8551                         break;
8552                     case 'o':
8553                         {
8554                             STRLEN brace_len = len;
8555                             UV result;
8556                             const char* error_msg;
8557
8558                             bool valid = grok_bslash_o(p,
8559                                                        &result,
8560                                                        &brace_len,
8561                                                        &error_msg,
8562                                                        1);
8563                             p += brace_len;
8564                             if (! valid) {
8565                                 RExC_parse = p; /* going to die anyway; point
8566                                                    to exact spot of failure */
8567                                 vFAIL(error_msg);
8568                             }
8569                             else
8570                             {
8571                                 ender = result;
8572                             }
8573                             if (PL_encoding && ender < 0x100) {
8574                                 goto recode_encoding;
8575                             }
8576                             if (ender > 0xff) {
8577                                 REQUIRE_UTF8;
8578                             }
8579                             break;
8580                         }
8581                     case 'x':
8582                         if (*++p == '{') {
8583                             char* const e = strchr(p, '}');
8584         
8585                             if (!e) {
8586                                 RExC_parse = p + 1;
8587                                 vFAIL("Missing right brace on \\x{}");
8588                             }
8589                             else {
8590                                 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
8591                                     | PERL_SCAN_DISALLOW_PREFIX;
8592                                 STRLEN numlen = e - p - 1;
8593                                 ender = grok_hex(p + 1, &numlen, &flags, NULL);
8594                                 if (ender > 0xff)
8595                                     REQUIRE_UTF8;
8596                                 p = e + 1;
8597                             }
8598                         }
8599                         else {
8600                             I32 flags = PERL_SCAN_DISALLOW_PREFIX;
8601                             STRLEN numlen = 2;
8602                             ender = grok_hex(p, &numlen, &flags, NULL);
8603                             p += numlen;
8604                         }
8605                         if (PL_encoding && ender < 0x100)
8606                             goto recode_encoding;
8607                         break;
8608                     case 'c':
8609                         p++;
8610                         ender = grok_bslash_c(*p++, UTF, SIZE_ONLY);
8611                         break;
8612                     case '0': case '1': case '2': case '3':case '4':
8613                     case '5': case '6': case '7': case '8':case '9':
8614                         if (*p == '0' ||
8615                             (isDIGIT(p[1]) && atoi(p) >= RExC_npar))
8616                         {
8617                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
8618                             STRLEN numlen = 3;
8619                             ender = grok_oct(p, &numlen, &flags, NULL);
8620                             if (ender > 0xff) {
8621                                 REQUIRE_UTF8;
8622                             }
8623                             p += numlen;
8624                         }
8625                         else {
8626                             --p;
8627                             goto loopdone;
8628                         }
8629                         if (PL_encoding && ender < 0x100)
8630                             goto recode_encoding;
8631                         break;
8632                     recode_encoding:
8633                         if (! RExC_override_recoding) {
8634                             SV* enc = PL_encoding;
8635                             ender = reg_recode((const char)(U8)ender, &enc);
8636                             if (!enc && SIZE_ONLY)
8637                                 ckWARNreg(p, "Invalid escape in the specified encoding");
8638                             REQUIRE_UTF8;
8639                         }
8640                         break;
8641                     case '\0':
8642                         if (p >= RExC_end)
8643                             FAIL("Trailing \\");
8644                         /* FALL THROUGH */
8645                     default:
8646                         if (!SIZE_ONLY&& isALPHA(*p)) {
8647                             /* Include any { following the alpha to emphasize
8648                              * that it could be part of an escape at some point
8649                              * in the future */
8650                             int len = (*(p + 1) == '{') ? 2 : 1;
8651                             ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
8652                         }
8653                         goto normal_default;
8654                     }
8655                     break;
8656                 default:
8657                   normal_default:
8658                     if (UTF8_IS_START(*p) && UTF) {
8659                         STRLEN numlen;
8660                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
8661                                                &numlen, UTF8_ALLOW_DEFAULT);
8662                         p += numlen;
8663                     }
8664                     else
8665                         ender = (U8) *p++;
8666                     break;
8667                 } /* End of switch on the literal */
8668
8669                 /* Certain characters are problematic because their folded
8670                  * length is so different from their original length that it
8671                  * isn't handleable by the optimizer.  They are therefore not
8672                  * placed in an EXACTish node; and are here handled specially.
8673                  * (Even if the optimizer handled LATIN_SMALL_LETTER_SHARP_S,
8674                  * putting it in a special node keeps regexec from having to
8675                  * deal with a non-utf8 multi-char fold */
8676                 if (FOLD
8677                     && (ender > 255 || (! MORE_ASCII_RESTRICTED && ! LOC)))
8678                 {
8679                     /* We look for either side of the fold.  For example \xDF
8680                      * folds to 'ss'.  We look for both the single character
8681                      * \xDF and the sequence 'ss'.  When we find something that
8682                      * could be one of those, we stop and flush whatever we
8683                      * have output so far into the EXACTish node that was being
8684                      * built.  Then restore the input pointer to what it was.
8685                      * regatom will return that EXACT node, and will be called
8686                      * again, positioned so the first character is the one in
8687                      * question, which we return in a different node type.
8688                      * The multi-char folds are a sequence, so the occurrence
8689                      * of the first character in that sequence doesn't
8690                      * necessarily mean that what follows is the rest of the
8691                      * sequence.  We keep track of that with a state machine,
8692                      * with the state being set to the latest character
8693                      * processed before the current one.  Most characters will
8694                      * set the state to 0, but if one occurs that is part of a
8695                      * potential tricky fold sequence, the state is set to that
8696                      * character, and the next loop iteration sees if the state
8697                      * should progress towards the final folded-from character,
8698                      * or if it was a false alarm.  If it turns out to be a
8699                      * false alarm, the character(s) will be output in a new
8700                      * EXACTish node, and join_exact() will later combine them.
8701                      * In the case of the 'ss' sequence, which is more common
8702                      * and more easily checked, some look-ahead is done to
8703                      * save time by ruling-out some false alarms */
8704                     switch (ender) {
8705                         default:
8706                             latest_char_state = generic_char;
8707                             break;
8708                         case 's':
8709                         case 'S':
8710                         case 0x17F: /* LATIN SMALL LETTER LONG S */
8711                              if (AT_LEAST_UNI_SEMANTICS) {
8712                                 if (latest_char_state == char_s) {  /* 'ss' */
8713                                     ender = LATIN_SMALL_LETTER_SHARP_S;
8714                                     goto do_tricky;
8715                                 }
8716                                 else if (p < RExC_end) {
8717
8718                                     /* Look-ahead at the next character.  If it
8719                                      * is also an s, we handle as a sharp s
8720                                      * tricky regnode.  */
8721                                     if (*p == 's' || *p == 'S') {
8722
8723                                         /* But first flush anything in the
8724                                          * EXACTish buffer */
8725                                         if (len != 0) {
8726                                             p = oldp;
8727                                             goto loopdone;
8728                                         }
8729                                         p++;    /* Account for swallowing this
8730                                                    's' up */
8731                                         ender = LATIN_SMALL_LETTER_SHARP_S;
8732                                         goto do_tricky;
8733                                     }
8734                                         /* Here, the next character is not a
8735                                          * literal 's', but still could
8736                                          * evaluate to one if part of a \o{},
8737                                          * \x or \OCTAL-DIGIT.  The minimum
8738                                          * length required for that is 4, eg
8739                                          * \x53 or \123 */
8740                                     else if (*p == '\\'
8741                                              && p < RExC_end - 4
8742                                              && (isDIGIT(*(p + 1))
8743                                                  || *(p + 1) == 'x'
8744                                                  || *(p + 1) == 'o' ))
8745                                     {
8746
8747                                         /* Here, it could be an 's', too much
8748                                          * bother to figure it out here.  Flush
8749                                          * the buffer if any; when come back
8750                                          * here, set the state so know that the
8751                                          * previous char was an 's' */
8752                                         if (len != 0) {
8753                                             latest_char_state = generic_char;
8754                                             p = oldp;
8755                                             goto loopdone;
8756                                         }
8757                                         latest_char_state = char_s;
8758                                         break;
8759                                     }
8760                                 }
8761                             }
8762
8763                             /* Here, can't be an 'ss' sequence, or at least not
8764                              * one that could fold to/from the sharp ss */
8765                             latest_char_state = generic_char;
8766                             break;
8767                         case 0x03C5:    /* First char in upsilon series */
8768                         case 0x03A5:    /* Also capital UPSILON, which folds to
8769                                            03C5, and hence exhibits the same
8770                                            problem */
8771                             if (p < RExC_end - 4) { /* Need >= 4 bytes left */
8772                                 latest_char_state = upsilon_1;
8773                                 if (len != 0) {
8774                                     p = oldp;
8775                                     goto loopdone;
8776                                 }
8777                             }
8778                             else {
8779                                 latest_char_state = generic_char;
8780                             }
8781                             break;
8782                         case 0x03B9:    /* First char in iota series */
8783                         case 0x0399:    /* Also capital IOTA */
8784                         case 0x1FBE:    /* GREEK PROSGEGRAMMENI folds to 3B9 */
8785                         case 0x0345:    /* COMBINING GREEK YPOGEGRAMMENI folds
8786                                            to 3B9 */
8787                             if (p < RExC_end - 4) {
8788                                 latest_char_state = iota_1;
8789                                 if (len != 0) {
8790                                     p = oldp;
8791                                     goto loopdone;
8792                                 }
8793                             }
8794                             else {
8795                                 latest_char_state = generic_char;
8796                             }
8797                             break;
8798                         case 0x0308:
8799                             if (latest_char_state == upsilon_1) {
8800                                 latest_char_state = upsilon_2;
8801                             }
8802                             else if (latest_char_state == iota_1) {
8803                                 latest_char_state = iota_2;
8804                             }
8805                             else {
8806                                 latest_char_state = generic_char;
8807                             }
8808                             break;
8809                         case 0x301:
8810                             if (latest_char_state == upsilon_2) {
8811                                 ender = GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS;
8812                                 goto do_tricky;
8813                             }
8814                             else if (latest_char_state == iota_2) {
8815                                 ender = GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS;
8816                                 goto do_tricky;
8817                             }
8818                             latest_char_state = generic_char;
8819                             break;
8820
8821                         /* These are the tricky fold characters.  Flush any
8822                          * buffer first. (When adding to this list, also should
8823                          * add them to fold_grind.t to make sure get tested) */
8824                         case GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS:
8825                         case GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS:
8826                         case LATIN_SMALL_LETTER_SHARP_S:
8827                         case LATIN_CAPITAL_LETTER_SHARP_S:
8828                         case 0x1FD3: /* GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA */
8829                         case 0x1FE3: /* GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA */
8830                             if (len != 0) {
8831                                 p = oldp;
8832                                 goto loopdone;
8833                             }
8834                             /* FALL THROUGH */
8835                         do_tricky: {
8836                             char* const oldregxend = RExC_end;
8837                             U8 tmpbuf[UTF8_MAXBYTES+1];
8838
8839                             /* Here, we know we need to generate a special
8840                              * regnode, and 'ender' contains the tricky
8841                              * character.  What's done is to pretend it's in a
8842                              * [bracketed] class, and let the code that deals
8843                              * with those handle it, as that code has all the
8844                              * intelligence necessary.  First save the current
8845                              * parse state, get rid of the already allocated
8846                              * but empty EXACT node that the ANYOFV node will
8847                              * replace, and point the parse to a buffer which
8848                              * we fill with the character we want the regclass
8849                              * code to think is being parsed */
8850                             RExC_emit = orig_emit;
8851                             RExC_parse = (char *) tmpbuf;
8852                             if (UTF) {
8853                                 U8 *d = uvchr_to_utf8(tmpbuf, ender);
8854                                 *d = '\0';
8855                                 RExC_end = (char *) d;
8856                             }
8857                             else {  /* ender above 255 already excluded */
8858                                 tmpbuf[0] = (U8) ender;
8859                                 tmpbuf[1] = '\0';
8860                                 RExC_end = RExC_parse + 1;
8861                             }
8862
8863                             ret = regclass(pRExC_state,depth+1);
8864
8865                             /* Here, have parsed the buffer.  Reset the parse to
8866                              * the actual input, and return */
8867                             RExC_end = oldregxend;
8868                             RExC_parse = p - 1;
8869
8870                             Set_Node_Offset(ret, RExC_parse);
8871                             Set_Node_Cur_Length(ret);
8872                             nextchar(pRExC_state);
8873                             *flagp |= HASWIDTH|SIMPLE;
8874                             return ret;
8875                         }
8876                     }
8877                 }
8878
8879                 if ( RExC_flags & RXf_PMf_EXTENDED)
8880                     p = regwhite( pRExC_state, p );
8881                 if (UTF && FOLD) {
8882                     /* Prime the casefolded buffer.  Locale rules, which apply
8883                      * only to code points < 256, aren't known until execution,
8884                      * so for them, just output the original character using
8885                      * utf8 */
8886                     if (LOC && ender < 256) {
8887                         if (UNI_IS_INVARIANT(ender)) {
8888                             *tmpbuf = (U8) ender;
8889                             foldlen = 1;
8890                         } else {
8891                             *tmpbuf = UTF8_TWO_BYTE_HI(ender);
8892                             *(tmpbuf + 1) = UTF8_TWO_BYTE_LO(ender);
8893                             foldlen = 2;
8894                         }
8895                     }
8896                     else if (isASCII(ender)) {  /* Note: Here can't also be LOC
8897                                                  */
8898                         ender = toLOWER(ender);
8899                         *tmpbuf = (U8) ender;
8900                         foldlen = 1;
8901                     }
8902                     else if (! MORE_ASCII_RESTRICTED && ! LOC) {
8903
8904                         /* Locale and /aa require more selectivity about the
8905                          * fold, so are handled below.  Otherwise, here, just
8906                          * use the fold */
8907                         ender = toFOLD_uni(ender, tmpbuf, &foldlen);
8908                     }
8909                     else {
8910                         /* Under locale rules or /aa we are not to mix,
8911                          * respectively, ords < 256 or ASCII with non-.  So
8912                          * reject folds that mix them, using only the
8913                          * non-folded code point.  So do the fold to a
8914                          * temporary, and inspect each character in it. */
8915                         U8 trialbuf[UTF8_MAXBYTES_CASE+1];
8916                         U8* s = trialbuf;
8917                         UV tmpender = toFOLD_uni(ender, trialbuf, &foldlen);
8918                         U8* e = s + foldlen;
8919                         bool fold_ok = TRUE;
8920
8921                         while (s < e) {
8922                             if (isASCII(*s)
8923                                 || (LOC && (UTF8_IS_INVARIANT(*s)
8924                                            || UTF8_IS_DOWNGRADEABLE_START(*s))))
8925                             {
8926                                 fold_ok = FALSE;
8927                                 break;
8928                             }
8929                             s += UTF8SKIP(s);
8930                         }
8931                         if (fold_ok) {
8932                             Copy(trialbuf, tmpbuf, foldlen, U8);
8933                             ender = tmpender;
8934                         }
8935                         else {
8936                             uvuni_to_utf8(tmpbuf, ender);
8937                             foldlen = UNISKIP(ender);
8938                         }
8939                     }
8940                 }
8941                 if (p < RExC_end && ISMULT2(p)) { /* Back off on ?+*. */
8942                     if (len)
8943                         p = oldp;
8944                     else if (UTF) {
8945                          if (FOLD) {
8946                               /* Emit all the Unicode characters. */
8947                               STRLEN numlen;
8948                               for (foldbuf = tmpbuf;
8949                                    foldlen;
8950                                    foldlen -= numlen) {
8951                                    ender = utf8_to_uvchr(foldbuf, &numlen);
8952                                    if (numlen > 0) {
8953                                         const STRLEN unilen = reguni(pRExC_state, ender, s);
8954                                         s       += unilen;
8955                                         len     += unilen;
8956                                         /* In EBCDIC the numlen
8957                                          * and unilen can differ. */
8958                                         foldbuf += numlen;
8959                                         if (numlen >= foldlen)
8960                                              break;
8961                                    }
8962                                    else
8963                                         break; /* "Can't happen." */
8964                               }
8965                          }
8966                          else {
8967                               const STRLEN unilen = reguni(pRExC_state, ender, s);
8968                               if (unilen > 0) {
8969                                    s   += unilen;
8970                                    len += unilen;
8971                               }
8972                          }
8973                     }
8974                     else {
8975                         len++;
8976                         REGC((char)ender, s++);
8977                     }
8978                     break;
8979                 }
8980                 if (UTF) {
8981                      if (FOLD) {
8982                           /* Emit all the Unicode characters. */
8983                           STRLEN numlen;
8984                           for (foldbuf = tmpbuf;
8985                                foldlen;
8986                                foldlen -= numlen) {
8987                                ender = utf8_to_uvchr(foldbuf, &numlen);
8988                                if (numlen > 0) {
8989                                     const STRLEN unilen = reguni(pRExC_state, ender, s);
8990                                     len     += unilen;
8991                                     s       += unilen;
8992                                     /* In EBCDIC the numlen
8993                                      * and unilen can differ. */
8994                                     foldbuf += numlen;
8995                                     if (numlen >= foldlen)
8996                                          break;
8997                                }
8998                                else
8999                                     break;
9000                           }
9001                      }
9002                      else {
9003                           const STRLEN unilen = reguni(pRExC_state, ender, s);
9004                           if (unilen > 0) {
9005                                s   += unilen;
9006                                len += unilen;
9007                           }
9008                      }
9009                      len--;
9010                 }
9011                 else {
9012                     REGC((char)ender, s++);
9013                 }
9014             }
9015         loopdone:   /* Jumped to when encounters something that shouldn't be in
9016                        the node */
9017             RExC_parse = p - 1;
9018             Set_Node_Cur_Length(ret); /* MJD */
9019             nextchar(pRExC_state);
9020             {
9021                 /* len is STRLEN which is unsigned, need to copy to signed */
9022                 IV iv = len;
9023                 if (iv < 0)
9024                     vFAIL("Internal disaster");
9025             }
9026             if (len > 0)
9027                 *flagp |= HASWIDTH;
9028             if (len == 1 && UNI_IS_INVARIANT(ender))
9029                 *flagp |= SIMPLE;
9030                 
9031             if (SIZE_ONLY)
9032                 RExC_size += STR_SZ(len);
9033             else {
9034                 STR_LEN(ret) = len;
9035                 RExC_emit += STR_SZ(len);
9036             }
9037         }
9038         break;
9039     }
9040
9041     return(ret);
9042
9043 /* Jumped to when an unrecognized character set is encountered */
9044 bad_charset:
9045     Perl_croak(aTHX_ "panic: Unknown regex character set encoding: %u", get_regex_charset(RExC_flags));
9046     return(NULL);
9047 }
9048
9049 STATIC char *
9050 S_regwhite( RExC_state_t *pRExC_state, char *p )
9051 {
9052     const char *e = RExC_end;
9053
9054     PERL_ARGS_ASSERT_REGWHITE;
9055
9056     while (p < e) {
9057         if (isSPACE(*p))
9058             ++p;
9059         else if (*p == '#') {
9060             bool ended = 0;
9061             do {
9062                 if (*p++ == '\n') {
9063                     ended = 1;
9064                     break;
9065                 }
9066             } while (p < e);
9067             if (!ended)
9068                 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
9069         }
9070         else
9071             break;
9072     }
9073     return p;
9074 }
9075
9076 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
9077    Character classes ([:foo:]) can also be negated ([:^foo:]).
9078    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
9079    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
9080    but trigger failures because they are currently unimplemented. */
9081
9082 #define POSIXCC_DONE(c)   ((c) == ':')
9083 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
9084 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
9085
9086 STATIC I32
9087 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
9088 {
9089     dVAR;
9090     I32 namedclass = OOB_NAMEDCLASS;
9091
9092     PERL_ARGS_ASSERT_REGPPOSIXCC;
9093
9094     if (value == '[' && RExC_parse + 1 < RExC_end &&
9095         /* I smell either [: or [= or [. -- POSIX has been here, right? */
9096         POSIXCC(UCHARAT(RExC_parse))) {
9097         const char c = UCHARAT(RExC_parse);
9098         char* const s = RExC_parse++;
9099         
9100         while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
9101             RExC_parse++;
9102         if (RExC_parse == RExC_end)
9103             /* Grandfather lone [:, [=, [. */
9104             RExC_parse = s;
9105         else {
9106             const char* const t = RExC_parse++; /* skip over the c */
9107             assert(*t == c);
9108
9109             if (UCHARAT(RExC_parse) == ']') {
9110                 const char *posixcc = s + 1;
9111                 RExC_parse++; /* skip over the ending ] */
9112
9113                 if (*s == ':') {
9114                     const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
9115                     const I32 skip = t - posixcc;
9116
9117                     /* Initially switch on the length of the name.  */
9118                     switch (skip) {
9119                     case 4:
9120                         if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
9121                             namedclass = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
9122                         break;
9123                     case 5:
9124                         /* Names all of length 5.  */
9125                         /* alnum alpha ascii blank cntrl digit graph lower
9126                            print punct space upper  */
9127                         /* Offset 4 gives the best switch position.  */
9128                         switch (posixcc[4]) {
9129                         case 'a':
9130                             if (memEQ(posixcc, "alph", 4)) /* alpha */
9131                                 namedclass = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
9132                             break;
9133                         case 'e':
9134                             if (memEQ(posixcc, "spac", 4)) /* space */
9135                                 namedclass = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
9136                             break;
9137                         case 'h':
9138                             if (memEQ(posixcc, "grap", 4)) /* graph */
9139                                 namedclass = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
9140                             break;
9141                         case 'i':
9142                             if (memEQ(posixcc, "asci", 4)) /* ascii */
9143                                 namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII;
9144                             break;
9145                         case 'k':
9146                             if (memEQ(posixcc, "blan", 4)) /* blank */
9147                                 namedclass = complement ? ANYOF_NBLANK : ANYOF_BLANK;
9148                             break;
9149                         case 'l':
9150                             if (memEQ(posixcc, "cntr", 4)) /* cntrl */
9151                                 namedclass = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
9152                             break;
9153                         case 'm':
9154                             if (memEQ(posixcc, "alnu", 4)) /* alnum */
9155                                 namedclass = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
9156                             break;
9157                         case 'r':
9158                             if (memEQ(posixcc, "lowe", 4)) /* lower */
9159                                 namedclass = complement ? ANYOF_NLOWER : ANYOF_LOWER;
9160                             else if (memEQ(posixcc, "uppe", 4)) /* upper */
9161                                 namedclass = complement ? ANYOF_NUPPER : ANYOF_UPPER;
9162                             break;
9163                         case 't':
9164                             if (memEQ(posixcc, "digi", 4)) /* digit */
9165                                 namedclass = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
9166                             else if (memEQ(posixcc, "prin", 4)) /* print */
9167                                 namedclass = complement ? ANYOF_NPRINT : ANYOF_PRINT;
9168                             else if (memEQ(posixcc, "punc", 4)) /* punct */
9169                                 namedclass = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
9170                             break;
9171                         }
9172                         break;
9173                     case 6:
9174                         if (memEQ(posixcc, "xdigit", 6))
9175                             namedclass = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
9176                         break;
9177                     }
9178
9179                     if (namedclass == OOB_NAMEDCLASS)
9180                         Simple_vFAIL3("POSIX class [:%.*s:] unknown",
9181                                       t - s - 1, s + 1);
9182                     assert (posixcc[skip] == ':');
9183                     assert (posixcc[skip+1] == ']');
9184                 } else if (!SIZE_ONLY) {
9185                     /* [[=foo=]] and [[.foo.]] are still future. */
9186
9187                     /* adjust RExC_parse so the warning shows after
9188                        the class closes */
9189                     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
9190                         RExC_parse++;
9191                     Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
9192                 }
9193             } else {
9194                 /* Maternal grandfather:
9195                  * "[:" ending in ":" but not in ":]" */
9196                 RExC_parse = s;
9197             }
9198         }
9199     }
9200
9201     return namedclass;
9202 }
9203
9204 STATIC void
9205 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
9206 {
9207     dVAR;
9208
9209     PERL_ARGS_ASSERT_CHECKPOSIXCC;
9210
9211     if (POSIXCC(UCHARAT(RExC_parse))) {
9212         const char *s = RExC_parse;
9213         const char  c = *s++;
9214
9215         while (isALNUM(*s))
9216             s++;
9217         if (*s && c == *s && s[1] == ']') {
9218             ckWARN3reg(s+2,
9219                        "POSIX syntax [%c %c] belongs inside character classes",
9220                        c, c);
9221
9222             /* [[=foo=]] and [[.foo.]] are still future. */
9223             if (POSIXCC_NOTYET(c)) {
9224                 /* adjust RExC_parse so the error shows after
9225                    the class closes */
9226                 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
9227                     NOOP;
9228                 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
9229             }
9230         }
9231     }
9232 }
9233
9234 /* No locale test, and always Unicode semantics */
9235 #define _C_C_T_NOLOC_(NAME,TEST,WORD)                                          \
9236 ANYOF_##NAME:                                                                  \
9237         for (value = 0; value < 256; value++)                                  \
9238             if (TEST)                                                          \
9239             stored += set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);  \
9240     yesno = '+';                                                               \
9241     what = WORD;                                                               \
9242     break;                                                                     \
9243 case ANYOF_N##NAME:                                                            \
9244         for (value = 0; value < 256; value++)                                  \
9245             if (!TEST)                                                         \
9246             stored += set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);  \
9247     yesno = '!';                                                               \
9248     what = WORD;                                                               \
9249     break
9250
9251 /* Like the above, but there are differences if we are in uni-8-bit or not, so
9252  * there are two tests passed in, to use depending on that. There aren't any
9253  * cases where the label is different from the name, so no need for that
9254  * parameter */
9255 #define _C_C_T_(NAME, TEST_8, TEST_7, WORD)                                    \
9256 ANYOF_##NAME:                                                                  \
9257     if (LOC) ANYOF_CLASS_SET(ret, ANYOF_##NAME);                               \
9258     else if (UNI_SEMANTICS) {                                                  \
9259         for (value = 0; value < 256; value++) {                                \
9260             if (TEST_8(value)) stored +=                                       \
9261                       set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);  \
9262         }                                                                      \
9263     }                                                                          \
9264     else {                                                                     \
9265         for (value = 0; value < 128; value++) {                                \
9266             if (TEST_7(UNI_TO_NATIVE(value))) stored +=                        \
9267                 set_regclass_bit(pRExC_state, ret,                     \
9268                                    (U8) UNI_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate);                 \
9269         }                                                                      \
9270     }                                                                          \
9271     yesno = '+';                                                               \
9272     what = WORD;                                                               \
9273     break;                                                                     \
9274 case ANYOF_N##NAME:                                                            \
9275     if (LOC) ANYOF_CLASS_SET(ret, ANYOF_N##NAME);                              \
9276     else if (UNI_SEMANTICS) {                                                  \
9277         for (value = 0; value < 256; value++) {                                \
9278             if (! TEST_8(value)) stored +=                                     \
9279                     set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);    \
9280         }                                                                      \
9281     }                                                                          \
9282     else {                                                                     \
9283         for (value = 0; value < 128; value++) {                                \
9284             if (! TEST_7(UNI_TO_NATIVE(value))) stored += set_regclass_bit(  \
9285                         pRExC_state, ret, (U8) UNI_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate);    \
9286         }                                                                      \
9287         if (AT_LEAST_ASCII_RESTRICTED) {                                       \
9288             for (value = 128; value < 256; value++) {                          \
9289              stored += set_regclass_bit(                                     \
9290                            pRExC_state, ret, (U8) UNI_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate); \
9291             }                                                                  \
9292             ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;                             \
9293         }                                                                      \
9294         else {                                                                 \
9295             /* For a non-ut8 target string with DEPENDS semantics, all above   \
9296              * ASCII Latin1 code points match the complement of any of the     \
9297              * classes.  But in utf8, they have their Unicode semantics, so    \
9298              * can't just set them in the bitmap, or else regexec.c will think \
9299              * they matched when they shouldn't. */                            \
9300             ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL;                     \
9301         }                                                                      \
9302     }                                                                          \
9303     yesno = '!';                                                               \
9304     what = WORD;                                                               \
9305     break
9306
9307 STATIC U8
9308 S_set_regclass_bit_fold(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, HV** invlist_ptr, AV** alternate_ptr)
9309 {
9310
9311     /* Handle the setting of folds in the bitmap for non-locale ANYOF nodes.
9312      * Locale folding is done at run-time, so this function should not be
9313      * called for nodes that are for locales.
9314      *
9315      * This function sets the bit corresponding to the fold of the input
9316      * 'value', if not already set.  The fold of 'f' is 'F', and the fold of
9317      * 'F' is 'f'.
9318      *
9319      * It also knows about the characters that are in the bitmap that have
9320      * folds that are matchable only outside it, and sets the appropriate lists
9321      * and flags.
9322      *
9323      * It returns the number of bits that actually changed from 0 to 1 */
9324
9325     U8 stored = 0;
9326     U8 fold;
9327
9328     PERL_ARGS_ASSERT_SET_REGCLASS_BIT_FOLD;
9329
9330     fold = (AT_LEAST_UNI_SEMANTICS) ? PL_fold_latin1[value]
9331                                     : PL_fold[value];
9332
9333     /* It assumes the bit for 'value' has already been set */
9334     if (fold != value && ! ANYOF_BITMAP_TEST(node, fold)) {
9335         ANYOF_BITMAP_SET(node, fold);
9336         stored++;
9337     }
9338     if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value) && (! isASCII(value) || ! MORE_ASCII_RESTRICTED)) {
9339         /* Certain Latin1 characters have matches outside the bitmap.  To get
9340          * here, 'value' is one of those characters.   None of these matches is
9341          * valid for ASCII characters under /aa, which have been excluded by
9342          * the 'if' above.  The matches fall into three categories:
9343          * 1) They are singly folded-to or -from an above 255 character, as
9344          *    LATIN SMALL LETTER Y WITH DIAERESIS and LATIN CAPITAL LETTER Y
9345          *    WITH DIAERESIS;
9346          * 2) They are part of a multi-char fold with another character in the
9347          *    bitmap, only LATIN SMALL LETTER SHARP S => "ss" fits that bill;
9348          * 3) They are part of a multi-char fold with a character not in the
9349          *    bitmap, such as various ligatures.
9350          * We aren't dealing fully with multi-char folds, except we do deal
9351          * with the pattern containing a character that has a multi-char fold
9352          * (not so much the inverse).
9353          * For types 1) and 3), the matches only happen when the target string
9354          * is utf8; that's not true for 2), and we set a flag for it.
9355          *
9356          * The code below adds to the passed in inversion list the single fold
9357          * closures for 'value'.  The values are hard-coded here so that an
9358          * innocent-looking character class, like /[ks]/i won't have to go out
9359          * to disk to find the possible matches.  XXX It would be better to
9360          * generate these via regen, in case a new version of the Unicode
9361          * standard adds new mappings, though that is not really likely. */
9362         switch (value) {
9363             case 'k':
9364             case 'K':
9365                 /* KELVIN SIGN */
9366                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212A);
9367                 break;
9368             case 's':
9369             case 'S':
9370                 /* LATIN SMALL LETTER LONG S */
9371                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x017F);
9372                 break;
9373             case MICRO_SIGN:
9374                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9375                                                  GREEK_SMALL_LETTER_MU);
9376                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9377                                                  GREEK_CAPITAL_LETTER_MU);
9378                 break;
9379             case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
9380             case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
9381                 /* ANGSTROM SIGN */
9382                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212B);
9383                 if (DEPENDS_SEMANTICS) {    /* See DEPENDS comment below */
9384                     *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9385                                                      PL_fold_latin1[value]);
9386                 }
9387                 break;
9388             case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
9389                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9390                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
9391                 break;
9392             case LATIN_SMALL_LETTER_SHARP_S:
9393                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9394                                         LATIN_CAPITAL_LETTER_SHARP_S);
9395
9396                 /* Under /a, /d, and /u, this can match the two chars "ss" */
9397                 if (! MORE_ASCII_RESTRICTED) {
9398                     add_alternate(alternate_ptr, (U8 *) "ss", 2);
9399
9400                     /* And under /u or /a, it can match even if the target is
9401                      * not utf8 */
9402                     if (AT_LEAST_UNI_SEMANTICS) {
9403                         ANYOF_FLAGS(node) |= ANYOF_NONBITMAP_NON_UTF8;
9404                     }
9405                 }
9406                 break;
9407             case 'F': case 'f':
9408             case 'I': case 'i':
9409             case 'L': case 'l':
9410             case 'T': case 't':
9411             case 'A': case 'a':
9412             case 'H': case 'h':
9413             case 'J': case 'j':
9414             case 'N': case 'n':
9415             case 'W': case 'w':
9416             case 'Y': case 'y':
9417                 /* These all are targets of multi-character folds from code
9418                  * points that require UTF8 to express, so they can't match
9419                  * unless the target string is in UTF-8, so no action here is
9420                  * necessary, as regexec.c properly handles the general case
9421                  * for UTF-8 matching */
9422                 break;
9423             default:
9424                 /* Use deprecated warning to increase the chances of this
9425                  * being output */
9426                 ckWARN2regdep(RExC_parse, "Perl folding rules are not up-to-date for 0x%x; please use the perlbug utility to report;", value);
9427                 break;
9428         }
9429     }
9430     else if (DEPENDS_SEMANTICS
9431             && ! isASCII(value)
9432             && PL_fold_latin1[value] != value)
9433     {
9434            /* Under DEPENDS rules, non-ASCII Latin1 characters match their
9435             * folds only when the target string is in UTF-8.  We add the fold
9436             * here to the list of things to match outside the bitmap, which
9437             * won't be looked at unless it is UTF8 (or else if something else
9438             * says to look even if not utf8, but those things better not happen
9439             * under DEPENDS semantics. */
9440         *invlist_ptr = add_cp_to_invlist(*invlist_ptr, PL_fold_latin1[value]);
9441     }
9442
9443     return stored;
9444 }
9445
9446
9447 PERL_STATIC_INLINE U8
9448 S_set_regclass_bit(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, HV** invlist_ptr, AV** alternate_ptr)
9449 {
9450     /* This inline function sets a bit in the bitmap if not already set, and if
9451      * appropriate, its fold, returning the number of bits that actually
9452      * changed from 0 to 1 */
9453
9454     U8 stored;
9455
9456     PERL_ARGS_ASSERT_SET_REGCLASS_BIT;
9457
9458     if (ANYOF_BITMAP_TEST(node, value)) {   /* Already set */
9459         return 0;
9460     }
9461
9462     ANYOF_BITMAP_SET(node, value);
9463     stored = 1;
9464
9465     if (FOLD && ! LOC) {        /* Locale folds aren't known until runtime */
9466         stored += set_regclass_bit_fold(pRExC_state, node, value, invlist_ptr, alternate_ptr);
9467     }
9468
9469     return stored;
9470 }
9471
9472 STATIC void
9473 S_add_alternate(pTHX_ AV** alternate_ptr, U8* string, STRLEN len)
9474 {
9475     /* Adds input 'string' with length 'len' to the ANYOF node's unicode
9476      * alternate list, pointed to by 'alternate_ptr'.  This is an array of
9477      * the multi-character folds of characters in the node */
9478     SV *sv;
9479
9480     PERL_ARGS_ASSERT_ADD_ALTERNATE;
9481
9482     if (! *alternate_ptr) {
9483         *alternate_ptr = newAV();
9484     }
9485     sv = newSVpvn_utf8((char*)string, len, TRUE);
9486     av_push(*alternate_ptr, sv);
9487     return;
9488 }
9489
9490 /*
9491    parse a class specification and produce either an ANYOF node that
9492    matches the pattern or perhaps will be optimized into an EXACTish node
9493    instead. The node contains a bit map for the first 256 characters, with the
9494    corresponding bit set if that character is in the list.  For characters
9495    above 255, a range list is used */
9496
9497 STATIC regnode *
9498 S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
9499 {
9500     dVAR;
9501     register UV nextvalue;
9502     register IV prevvalue = OOB_UNICODE;
9503     register IV range = 0;
9504     UV value = 0; /* XXX:dmq: needs to be referenceable (unfortunately) */
9505     register regnode *ret;
9506     STRLEN numlen;
9507     IV namedclass;
9508     char *rangebegin = NULL;
9509     bool need_class = 0;
9510     bool allow_full_fold = TRUE;   /* Assume wants multi-char folding */
9511     SV *listsv = NULL;
9512     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
9513                                       than just initialized.  */
9514     UV n;
9515
9516     /* code points this node matches that can't be stored in the bitmap */
9517     HV* nonbitmap = NULL;
9518
9519     /* The items that are to match that aren't stored in the bitmap, but are a
9520      * result of things that are stored there.  This is the fold closure of
9521      * such a character, either because it has DEPENDS semantics and shouldn't
9522      * be matched unless the target string is utf8, or is a code point that is
9523      * too large for the bit map, as for example, the fold of the MICRO SIGN is
9524      * above 255.  This all is solely for performance reasons.  By having this
9525      * code know the outside-the-bitmap folds that the bitmapped characters are
9526      * involved with, we don't have to go out to disk to find the list of
9527      * matches, unless the character class includes code points that aren't
9528      * storable in the bit map.  That means that a character class with an 's'
9529      * in it, for example, doesn't need to go out to disk to find everything
9530      * that matches.  A 2nd list is used so that the 'nonbitmap' list is kept
9531      * empty unless there is something whose fold we don't know about, and will
9532      * have to go out to the disk to find. */
9533     HV* l1_fold_invlist = NULL;
9534
9535     /* List of multi-character folds that are matched by this node */
9536     AV* unicode_alternate  = NULL;
9537 #ifdef EBCDIC
9538     UV literal_endpoint = 0;
9539 #endif
9540     UV stored = 0;  /* how many chars stored in the bitmap */
9541
9542     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
9543         case we need to change the emitted regop to an EXACT. */
9544     const char * orig_parse = RExC_parse;
9545     GET_RE_DEBUG_FLAGS_DECL;
9546
9547     PERL_ARGS_ASSERT_REGCLASS;
9548 #ifndef DEBUGGING
9549     PERL_UNUSED_ARG(depth);
9550 #endif
9551
9552     DEBUG_PARSE("clas");
9553
9554     /* Assume we are going to generate an ANYOF node. */
9555     ret = reganode(pRExC_state, ANYOF, 0);
9556
9557
9558     if (!SIZE_ONLY) {
9559         ANYOF_FLAGS(ret) = 0;
9560     }
9561
9562     if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
9563         RExC_naughty++;
9564         RExC_parse++;
9565         if (!SIZE_ONLY)
9566             ANYOF_FLAGS(ret) |= ANYOF_INVERT;
9567
9568         /* We have decided to not allow multi-char folds in inverted character
9569          * classes, due to the confusion that can happen, especially with
9570          * classes that are designed for a non-Unicode world:  You have the
9571          * peculiar case that:
9572             "s s" =~ /^[^\xDF]+$/i => Y
9573             "ss"  =~ /^[^\xDF]+$/i => N
9574          *
9575          * See [perl #89750] */
9576         allow_full_fold = FALSE;
9577     }
9578
9579     if (SIZE_ONLY) {
9580         RExC_size += ANYOF_SKIP;
9581         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
9582     }
9583     else {
9584         RExC_emit += ANYOF_SKIP;
9585         if (LOC) {
9586             ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
9587         }
9588         ANYOF_BITMAP_ZERO(ret);
9589         listsv = newSVpvs("# comment\n");
9590         initial_listsv_len = SvCUR(listsv);
9591     }
9592
9593     nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
9594
9595     if (!SIZE_ONLY && POSIXCC(nextvalue))
9596         checkposixcc(pRExC_state);
9597
9598     /* allow 1st char to be ] (allowing it to be - is dealt with later) */
9599     if (UCHARAT(RExC_parse) == ']')
9600         goto charclassloop;
9601
9602 parseit:
9603     while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
9604
9605     charclassloop:
9606
9607         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
9608
9609         if (!range)
9610             rangebegin = RExC_parse;
9611         if (UTF) {
9612             value = utf8n_to_uvchr((U8*)RExC_parse,
9613                                    RExC_end - RExC_parse,
9614                                    &numlen, UTF8_ALLOW_DEFAULT);
9615             RExC_parse += numlen;
9616         }
9617         else
9618             value = UCHARAT(RExC_parse++);
9619
9620         nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
9621         if (value == '[' && POSIXCC(nextvalue))
9622             namedclass = regpposixcc(pRExC_state, value);
9623         else if (value == '\\') {
9624             if (UTF) {
9625                 value = utf8n_to_uvchr((U8*)RExC_parse,
9626                                    RExC_end - RExC_parse,
9627                                    &numlen, UTF8_ALLOW_DEFAULT);
9628                 RExC_parse += numlen;
9629             }
9630             else
9631                 value = UCHARAT(RExC_parse++);
9632             /* Some compilers cannot handle switching on 64-bit integer
9633              * values, therefore value cannot be an UV.  Yes, this will
9634              * be a problem later if we want switch on Unicode.
9635              * A similar issue a little bit later when switching on
9636              * namedclass. --jhi */
9637             switch ((I32)value) {
9638             case 'w':   namedclass = ANYOF_ALNUM;       break;
9639             case 'W':   namedclass = ANYOF_NALNUM;      break;
9640             case 's':   namedclass = ANYOF_SPACE;       break;
9641             case 'S':   namedclass = ANYOF_NSPACE;      break;
9642             case 'd':   namedclass = ANYOF_DIGIT;       break;
9643             case 'D':   namedclass = ANYOF_NDIGIT;      break;
9644             case 'v':   namedclass = ANYOF_VERTWS;      break;
9645             case 'V':   namedclass = ANYOF_NVERTWS;     break;
9646             case 'h':   namedclass = ANYOF_HORIZWS;     break;
9647             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
9648             case 'N':  /* Handle \N{NAME} in class */
9649                 {
9650                     /* We only pay attention to the first char of 
9651                     multichar strings being returned. I kinda wonder
9652                     if this makes sense as it does change the behaviour
9653                     from earlier versions, OTOH that behaviour was broken
9654                     as well. */
9655                     UV v; /* value is register so we cant & it /grrr */
9656                     if (reg_namedseq(pRExC_state, &v, NULL, depth)) {
9657                         goto parseit;
9658                     }
9659                     value= v; 
9660                 }
9661                 break;
9662             case 'p':
9663             case 'P':
9664                 {
9665                 char *e;
9666                 if (RExC_parse >= RExC_end)
9667                     vFAIL2("Empty \\%c{}", (U8)value);
9668                 if (*RExC_parse == '{') {
9669                     const U8 c = (U8)value;
9670                     e = strchr(RExC_parse++, '}');
9671                     if (!e)
9672                         vFAIL2("Missing right brace on \\%c{}", c);
9673                     while (isSPACE(UCHARAT(RExC_parse)))
9674                         RExC_parse++;
9675                     if (e == RExC_parse)
9676                         vFAIL2("Empty \\%c{}", c);
9677                     n = e - RExC_parse;
9678                     while (isSPACE(UCHARAT(RExC_parse + n - 1)))
9679                         n--;
9680                 }
9681                 else {
9682                     e = RExC_parse;
9683                     n = 1;
9684                 }
9685                 if (!SIZE_ONLY) {
9686                     if (UCHARAT(RExC_parse) == '^') {
9687                          RExC_parse++;
9688                          n--;
9689                          value = value == 'p' ? 'P' : 'p'; /* toggle */
9690                          while (isSPACE(UCHARAT(RExC_parse))) {
9691                               RExC_parse++;
9692                               n--;
9693                          }
9694                     }
9695
9696                     /* Add the property name to the list.  If /i matching, give
9697                      * a different name which consists of the normal name
9698                      * sandwiched between two underscores and '_i'.  The design
9699                      * is discussed in the commit message for this. */
9700                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s%.*s%s\n",
9701                                         (value=='p' ? '+' : '!'),
9702                                         (FOLD) ? "__" : "",
9703                                         (int)n,
9704                                         RExC_parse,
9705                                         (FOLD) ? "_i" : ""
9706                                     );
9707                 }
9708                 RExC_parse = e + 1;
9709
9710                 /* The \p could match something in the Latin1 range, hence
9711                  * something that isn't utf8 */
9712                 ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
9713                 namedclass = ANYOF_MAX;  /* no official name, but it's named */
9714
9715                 /* \p means they want Unicode semantics */
9716                 RExC_uni_semantics = 1;
9717                 }
9718                 break;
9719             case 'n':   value = '\n';                   break;
9720             case 'r':   value = '\r';                   break;
9721             case 't':   value = '\t';                   break;
9722             case 'f':   value = '\f';                   break;
9723             case 'b':   value = '\b';                   break;
9724             case 'e':   value = ASCII_TO_NATIVE('\033');break;
9725             case 'a':   value = ASCII_TO_NATIVE('\007');break;
9726             case 'o':
9727                 RExC_parse--;   /* function expects to be pointed at the 'o' */
9728                 {
9729                     const char* error_msg;
9730                     bool valid = grok_bslash_o(RExC_parse,
9731                                                &value,
9732                                                &numlen,
9733                                                &error_msg,
9734                                                SIZE_ONLY);
9735                     RExC_parse += numlen;
9736                     if (! valid) {
9737                         vFAIL(error_msg);
9738                     }
9739                 }
9740                 if (PL_encoding && value < 0x100) {
9741                     goto recode_encoding;
9742                 }
9743                 break;
9744             case 'x':
9745                 if (*RExC_parse == '{') {
9746                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
9747                         | PERL_SCAN_DISALLOW_PREFIX;
9748                     char * const e = strchr(RExC_parse++, '}');
9749                     if (!e)
9750                         vFAIL("Missing right brace on \\x{}");
9751
9752                     numlen = e - RExC_parse;
9753                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
9754                     RExC_parse = e + 1;
9755                 }
9756                 else {
9757                     I32 flags = PERL_SCAN_DISALLOW_PREFIX;
9758                     numlen = 2;
9759                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
9760                     RExC_parse += numlen;
9761                 }
9762                 if (PL_encoding && value < 0x100)
9763                     goto recode_encoding;
9764                 break;
9765             case 'c':
9766                 value = grok_bslash_c(*RExC_parse++, UTF, SIZE_ONLY);
9767                 break;
9768             case '0': case '1': case '2': case '3': case '4':
9769             case '5': case '6': case '7':
9770                 {
9771                     /* Take 1-3 octal digits */
9772                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
9773                     numlen = 3;
9774                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
9775                     RExC_parse += numlen;
9776                     if (PL_encoding && value < 0x100)
9777                         goto recode_encoding;
9778                     break;
9779                 }
9780             recode_encoding:
9781                 if (! RExC_override_recoding) {
9782                     SV* enc = PL_encoding;
9783                     value = reg_recode((const char)(U8)value, &enc);
9784                     if (!enc && SIZE_ONLY)
9785                         ckWARNreg(RExC_parse,
9786                                   "Invalid escape in the specified encoding");
9787                     break;
9788                 }
9789             default:
9790                 /* Allow \_ to not give an error */
9791                 if (!SIZE_ONLY && isALNUM(value) && value != '_') {
9792                     ckWARN2reg(RExC_parse,
9793                                "Unrecognized escape \\%c in character class passed through",
9794                                (int)value);
9795                 }
9796                 break;
9797             }
9798         } /* end of \blah */
9799 #ifdef EBCDIC
9800         else
9801             literal_endpoint++;
9802 #endif
9803
9804         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
9805
9806             /* What matches in a locale is not known until runtime, so need to
9807              * (one time per class) allocate extra space to pass to regexec.
9808              * The space will contain a bit for each named class that is to be
9809              * matched against.  This isn't needed for \p{} and pseudo-classes,
9810              * as they are not affected by locale, and hence are dealt with
9811              * separately */
9812             if (LOC && namedclass < ANYOF_MAX && ! need_class) {
9813                 need_class = 1;
9814                 if (SIZE_ONLY) {
9815                     RExC_size += ANYOF_CLASS_SKIP - ANYOF_SKIP;
9816                 }
9817                 else {
9818                     RExC_emit += ANYOF_CLASS_SKIP - ANYOF_SKIP;
9819                     ANYOF_CLASS_ZERO(ret);
9820                 }
9821                 ANYOF_FLAGS(ret) |= ANYOF_CLASS;
9822             }
9823
9824             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
9825              * literal, as is the character that began the false range, i.e.
9826              * the 'a' in the examples */
9827             if (range) {
9828                 if (!SIZE_ONLY) {
9829                     const int w =
9830                         RExC_parse >= rangebegin ?
9831                         RExC_parse - rangebegin : 0;
9832                     ckWARN4reg(RExC_parse,
9833                                "False [] range \"%*.*s\"",
9834                                w, w, rangebegin);
9835
9836                     stored +=
9837                          set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
9838                     if (prevvalue < 256) {
9839                         stored +=
9840                          set_regclass_bit(pRExC_state, ret, (U8) prevvalue, &l1_fold_invlist, &unicode_alternate);
9841                     }
9842                     else {
9843                         nonbitmap = add_cp_to_invlist(nonbitmap, prevvalue);
9844                     }
9845                 }
9846
9847                 range = 0; /* this was not a true range */
9848             }
9849
9850
9851     
9852             if (!SIZE_ONLY) {
9853                 const char *what = NULL;
9854                 char yesno = 0;
9855
9856                 /* Possible truncation here but in some 64-bit environments
9857                  * the compiler gets heartburn about switch on 64-bit values.
9858                  * A similar issue a little earlier when switching on value.
9859                  * --jhi */
9860                 switch ((I32)namedclass) {
9861                 
9862                 case _C_C_T_(ALNUMC, isALNUMC_L1, isALNUMC, "XPosixAlnum");
9863                 case _C_C_T_(ALPHA, isALPHA_L1, isALPHA, "XPosixAlpha");
9864                 case _C_C_T_(BLANK, isBLANK_L1, isBLANK, "XPosixBlank");
9865                 case _C_C_T_(CNTRL, isCNTRL_L1, isCNTRL, "XPosixCntrl");
9866                 case _C_C_T_(GRAPH, isGRAPH_L1, isGRAPH, "XPosixGraph");
9867                 case _C_C_T_(LOWER, isLOWER_L1, isLOWER, "XPosixLower");
9868                 case _C_C_T_(PRINT, isPRINT_L1, isPRINT, "XPosixPrint");
9869                 case _C_C_T_(PSXSPC, isPSXSPC_L1, isPSXSPC, "XPosixSpace");
9870                 case _C_C_T_(PUNCT, isPUNCT_L1, isPUNCT, "XPosixPunct");
9871                 case _C_C_T_(UPPER, isUPPER_L1, isUPPER, "XPosixUpper");
9872                 /* \s, \w match all unicode if utf8. */
9873                 case _C_C_T_(SPACE, isSPACE_L1, isSPACE, "SpacePerl");
9874                 case _C_C_T_(ALNUM, isWORDCHAR_L1, isALNUM, "Word");
9875                 case _C_C_T_(XDIGIT, isXDIGIT_L1, isXDIGIT, "XPosixXDigit");
9876                 case _C_C_T_NOLOC_(VERTWS, is_VERTWS_latin1(&value), "VertSpace");
9877                 case _C_C_T_NOLOC_(HORIZWS, is_HORIZWS_latin1(&value), "HorizSpace");
9878                 case ANYOF_ASCII:
9879                     if (LOC)
9880                         ANYOF_CLASS_SET(ret, ANYOF_ASCII);
9881                     else {
9882                         for (value = 0; value < 128; value++)
9883                             stored +=
9884                               set_regclass_bit(pRExC_state, ret, (U8) ASCII_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate);
9885                     }
9886                     yesno = '+';
9887                     what = NULL;        /* Doesn't match outside ascii, so
9888                                            don't want to add +utf8:: */
9889                     break;
9890                 case ANYOF_NASCII:
9891                     if (LOC)
9892                         ANYOF_CLASS_SET(ret, ANYOF_NASCII);
9893                     else {
9894                         for (value = 128; value < 256; value++)
9895                             stored +=
9896                               set_regclass_bit(pRExC_state, ret, (U8) ASCII_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate);
9897                     }
9898                     ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
9899                     yesno = '!';
9900                     what = "ASCII";
9901                     break;              
9902                 case ANYOF_DIGIT:
9903                     if (LOC)
9904                         ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
9905                     else {
9906                         /* consecutive digits assumed */
9907                         for (value = '0'; value <= '9'; value++)
9908                             stored +=
9909                               set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);
9910                     }
9911                     yesno = '+';
9912                     what = "Digit";
9913                     break;
9914                 case ANYOF_NDIGIT:
9915                     if (LOC)
9916                         ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
9917                     else {
9918                         /* consecutive digits assumed */
9919                         for (value = 0; value < '0'; value++)
9920                             stored +=
9921                               set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);
9922                         for (value = '9' + 1; value < 256; value++)
9923                             stored +=
9924                               set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);
9925                     }
9926                     yesno = '!';
9927                     what = "Digit";
9928                     if (AT_LEAST_ASCII_RESTRICTED ) {
9929                         ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
9930                     }
9931                     break;              
9932                 case ANYOF_MAX:
9933                     /* this is to handle \p and \P */
9934                     break;
9935                 default:
9936                     vFAIL("Invalid [::] class");
9937                     break;
9938                 }
9939                 if (what && ! (AT_LEAST_ASCII_RESTRICTED)) {
9940                     /* Strings such as "+utf8::isWord\n" */
9941                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::Is%s\n", yesno, what);
9942                 }
9943
9944                 continue;
9945             }
9946         } /* end of namedclass \blah */
9947
9948         if (range) {
9949             if (prevvalue > (IV)value) /* b-a */ {
9950                 const int w = RExC_parse - rangebegin;
9951                 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
9952                 range = 0; /* not a valid range */
9953             }
9954         }
9955         else {
9956             prevvalue = value; /* save the beginning of the range */
9957             if (RExC_parse+1 < RExC_end
9958                 && *RExC_parse == '-'
9959                 && RExC_parse[1] != ']')
9960             {
9961                 RExC_parse++;
9962
9963                 /* a bad range like \w-, [:word:]- ? */
9964                 if (namedclass > OOB_NAMEDCLASS) {
9965                     if (ckWARN(WARN_REGEXP)) {
9966                         const int w =
9967                             RExC_parse >= rangebegin ?
9968                             RExC_parse - rangebegin : 0;
9969                         vWARN4(RExC_parse,
9970                                "False [] range \"%*.*s\"",
9971                                w, w, rangebegin);
9972                     }
9973                     if (!SIZE_ONLY)
9974                         stored +=
9975                             set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
9976                 } else
9977                     range = 1;  /* yeah, it's a range! */
9978                 continue;       /* but do it the next time */
9979             }
9980         }
9981
9982         /* non-Latin1 code point implies unicode semantics.  Must be set in
9983          * pass1 so is there for the whole of pass 2 */
9984         if (value > 255) {
9985             RExC_uni_semantics = 1;
9986         }
9987
9988         /* now is the next time */
9989         if (!SIZE_ONLY) {
9990             if (prevvalue < 256) {
9991                 const IV ceilvalue = value < 256 ? value : 255;
9992                 IV i;
9993 #ifdef EBCDIC
9994                 /* In EBCDIC [\x89-\x91] should include
9995                  * the \x8e but [i-j] should not. */
9996                 if (literal_endpoint == 2 &&
9997                     ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
9998                      (isUPPER(prevvalue) && isUPPER(ceilvalue))))
9999                 {
10000                     if (isLOWER(prevvalue)) {
10001                         for (i = prevvalue; i <= ceilvalue; i++)
10002                             if (isLOWER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
10003                                 stored +=
10004                                   set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
10005                             }
10006                     } else {
10007                         for (i = prevvalue; i <= ceilvalue; i++)
10008                             if (isUPPER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
10009                                 stored +=
10010                                   set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
10011                             }
10012                     }
10013                 }
10014                 else
10015 #endif
10016                       for (i = prevvalue; i <= ceilvalue; i++) {
10017                         stored += set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
10018                       }
10019           }
10020           if (value > 255) {
10021             const UV prevnatvalue  = NATIVE_TO_UNI(prevvalue);
10022             const UV natvalue      = NATIVE_TO_UNI(value);
10023             nonbitmap = add_range_to_invlist(nonbitmap, prevnatvalue, natvalue);
10024         }
10025 #ifdef EBCDIC
10026             literal_endpoint = 0;
10027 #endif
10028         }
10029
10030         range = 0; /* this range (if it was one) is done now */
10031     }
10032
10033
10034
10035     if (SIZE_ONLY)
10036         return ret;
10037     /****** !SIZE_ONLY AFTER HERE *********/
10038
10039     /* If folding and there are code points above 255, we calculate all
10040      * characters that could fold to or from the ones already on the list */
10041     if (FOLD && nonbitmap) {
10042         UV i;
10043
10044         HV* fold_intersection;
10045         UV* fold_list;
10046
10047         /* This is a list of all the characters that participate in folds
10048             * (except marks, etc in multi-char folds */
10049         if (! PL_utf8_foldable) {
10050             SV* swash = swash_init("utf8", "Cased", &PL_sv_undef, 1, 0);
10051             PL_utf8_foldable = _swash_to_invlist(swash);
10052         }
10053
10054         /* This is a hash that for a particular fold gives all characters
10055             * that are involved in it */
10056         if (! PL_utf8_foldclosures) {
10057
10058             /* If we were unable to find any folds, then we likely won't be
10059              * able to find the closures.  So just create an empty list.
10060              * Folding will effectively be restricted to the non-Unicode rules
10061              * hard-coded into Perl.  (This case happens legitimately during
10062              * compilation of Perl itself before the Unicode tables are
10063              * generated) */
10064             if (invlist_len(PL_utf8_foldable) == 0) {
10065                 PL_utf8_foldclosures = _new_invlist(0);
10066             } else {
10067                 /* If the folds haven't been read in, call a fold function
10068                     * to force that */
10069                 if (! PL_utf8_tofold) {
10070                     U8 dummy[UTF8_MAXBYTES+1];
10071                     STRLEN dummy_len;
10072                     to_utf8_fold((U8*) "A", dummy, &dummy_len);
10073                 }
10074                 PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
10075             }
10076         }
10077
10078         /* Only the characters in this class that participate in folds need
10079             * be checked.  Get the intersection of this class and all the
10080             * possible characters that are foldable.  This can quickly narrow
10081             * down a large class */
10082         fold_intersection = invlist_intersection(PL_utf8_foldable, nonbitmap);
10083
10084         /* Now look at the foldable characters in this class individually */
10085         fold_list = invlist_array(fold_intersection);
10086         for (i = 0; i < invlist_len(fold_intersection); i++) {
10087             UV j;
10088
10089             /* The next entry is the beginning of the range that is in the
10090              * class */
10091             UV start = fold_list[i++];
10092
10093
10094             /* The next entry is the beginning of the next range, which
10095                 * isn't in the class, so the end of the current range is one
10096                 * less than that */
10097             UV end = fold_list[i] - 1;
10098
10099             /* Look at every character in the range */
10100             for (j = start; j <= end; j++) {
10101
10102                 /* Get its fold */
10103                 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
10104                 STRLEN foldlen;
10105                 const UV f =
10106                     _to_uni_fold_flags(j, foldbuf, &foldlen, allow_full_fold);
10107
10108                 if (foldlen > (STRLEN)UNISKIP(f)) {
10109
10110                     /* Any multicharacter foldings (disallowed in
10111                         * lookbehind patterns) require the following
10112                         * transform: [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst) where
10113                         * E folds into "pq" and F folds into "rst", all other
10114                         * characters fold to single characters.  We save away
10115                         * these multicharacter foldings, to be later saved as
10116                         * part of the additional "s" data. */
10117                     if (! RExC_in_lookbehind) {
10118                         U8* loc = foldbuf;
10119                         U8* e = foldbuf + foldlen;
10120
10121                         /* If any of the folded characters of this are in
10122                             * the Latin1 range, tell the regex engine that
10123                             * this can match a non-utf8 target string.  The
10124                             * only multi-byte fold whose source is in the
10125                             * Latin1 range (U+00DF) applies only when the
10126                             * target string is utf8, or under unicode rules */
10127                         if (j > 255 || AT_LEAST_UNI_SEMANTICS) {
10128                             while (loc < e) {
10129
10130                                 /* Can't mix ascii with non- under /aa */
10131                                 if (MORE_ASCII_RESTRICTED
10132                                     && (isASCII(*loc) != isASCII(j)))
10133                                 {
10134                                     goto end_multi_fold;
10135                                 }
10136                                 if (UTF8_IS_INVARIANT(*loc)
10137                                     || UTF8_IS_DOWNGRADEABLE_START(*loc))
10138                                 {
10139                                     /* Can't mix above and below 256 under
10140                                         * LOC */
10141                                     if (LOC) {
10142                                         goto end_multi_fold;
10143                                     }
10144                                     ANYOF_FLAGS(ret)
10145                                             |= ANYOF_NONBITMAP_NON_UTF8;
10146                                     break;
10147                                 }
10148                                 loc += UTF8SKIP(loc);
10149                             }
10150                         }
10151
10152                         add_alternate(&unicode_alternate, foldbuf, foldlen);
10153                     end_multi_fold: ;
10154                     }
10155
10156                     /* This is special-cased, as it is the only letter which
10157                      * has both a multi-fold and single-fold in Latin1.  All
10158                      * the other chars that have single and multi-folds are
10159                      * always in utf8, and the utf8 folding algorithm catches
10160                      * them */
10161                     if (! LOC && j == LATIN_CAPITAL_LETTER_SHARP_S) {
10162                         stored += set_regclass_bit(pRExC_state,
10163                                         ret,
10164                                         LATIN_SMALL_LETTER_SHARP_S,
10165                                         &l1_fold_invlist, &unicode_alternate);
10166                     }
10167                 }
10168                 else {
10169                     /* Single character fold.  Add everything in its fold
10170                         * closure to the list that this node should match */
10171                     SV** listp;
10172
10173                     /* The fold closures data structure is a hash with the
10174                         * keys being every character that is folded to, like
10175                         * 'k', and the values each an array of everything that
10176                         * folds to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ] */
10177                     if ((listp = hv_fetch(PL_utf8_foldclosures,
10178                                     (char *) foldbuf, foldlen, FALSE)))
10179                     {
10180                         AV* list = (AV*) *listp;
10181                         IV k;
10182                         for (k = 0; k <= av_len(list); k++) {
10183                             SV** c_p = av_fetch(list, k, FALSE);
10184                             UV c;
10185                             if (c_p == NULL) {
10186                                 Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
10187                             }
10188                             c = SvUV(*c_p);
10189
10190                             /* /aa doesn't allow folds between ASCII and
10191                                 * non-; /l doesn't allow them between above
10192                                 * and below 256 */
10193                             if ((MORE_ASCII_RESTRICTED
10194                                  && (isASCII(c) != isASCII(j)))
10195                                     || (LOC && ((c < 256) != (j < 256))))
10196                             {
10197                                 continue;
10198                             }
10199
10200                             if (c < 256 && AT_LEAST_UNI_SEMANTICS) {
10201                                 stored += set_regclass_bit(pRExC_state,
10202                                         ret,
10203                                         (U8) c,
10204                                         &l1_fold_invlist, &unicode_alternate);
10205                             }
10206                                 /* It may be that the code point is already
10207                                     * in this range or already in the bitmap,
10208                                     * in which case we need do nothing */
10209                             else if ((c < start || c > end)
10210                                         && (c > 255
10211                                             || ! ANYOF_BITMAP_TEST(ret, c)))
10212                             {
10213                                 nonbitmap = add_cp_to_invlist(nonbitmap, c);
10214                             }
10215                         }
10216                     }
10217                 }
10218             }
10219         }
10220         invlist_destroy(fold_intersection);
10221     }
10222
10223     /* Combine the two lists into one. */
10224     if (l1_fold_invlist) {
10225         if (nonbitmap) {
10226             HV* temp = invlist_union(nonbitmap, l1_fold_invlist);
10227             invlist_destroy(nonbitmap);
10228             nonbitmap = temp;
10229             invlist_destroy(l1_fold_invlist);
10230         }
10231         else {
10232             nonbitmap = l1_fold_invlist;
10233         }
10234     }
10235
10236     /* Here, we have calculated what code points should be in the character
10237      * class.   Now we can see about various optimizations.  Fold calculation
10238      * needs to take place before inversion.  Otherwise /[^k]/i would invert to
10239      * include K, which under /i would match k. */
10240
10241     /* Optimize inverted simple patterns (e.g. [^a-z]).  Note that we haven't
10242      * set the FOLD flag yet, so this this does optimize those.  It doesn't
10243      * optimize locale.  Doing so perhaps could be done as long as there is
10244      * nothing like \w in it; some thought also would have to be given to the
10245      * interaction with above 0x100 chars */
10246     if (! LOC
10247         && (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT
10248         && ! unicode_alternate
10249         && ! nonbitmap
10250         && SvCUR(listsv) == initial_listsv_len)
10251     {
10252         for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
10253             ANYOF_BITMAP(ret)[value] ^= 0xFF;
10254         stored = 256 - stored;
10255
10256         /* The inversion means that everything above 255 is matched; and at the
10257          * same time we clear the invert flag */
10258         ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL;
10259     }
10260
10261     /* Folding in the bitmap is taken care of above, but not for locale (for
10262      * which we have to wait to see what folding is in effect at runtime), and
10263      * for things not in the bitmap.  Set run-time fold flag for these */
10264     if (FOLD && (LOC || nonbitmap || unicode_alternate)) {
10265         ANYOF_FLAGS(ret) |= ANYOF_LOC_NONBITMAP_FOLD;
10266     }
10267
10268     /* A single character class can be "optimized" into an EXACTish node.
10269      * Note that since we don't currently count how many characters there are
10270      * outside the bitmap, we are XXX missing optimization possibilities for
10271      * them.  This optimization can't happen unless this is a truly single
10272      * character class, which means that it can't be an inversion into a
10273      * many-character class, and there must be no possibility of there being
10274      * things outside the bitmap.  'stored' (only) for locales doesn't include
10275      * \w, etc, so have to make a special test that they aren't present
10276      *
10277      * Similarly A 2-character class of the very special form like [bB] can be
10278      * optimized into an EXACTFish node, but only for non-locales, and for
10279      * characters which only have the two folds; so things like 'fF' and 'Ii'
10280      * wouldn't work because they are part of the fold of 'LATIN SMALL LIGATURE
10281      * FI'. */
10282     if (! nonbitmap
10283         && ! unicode_alternate
10284         && SvCUR(listsv) == initial_listsv_len
10285         && ! (ANYOF_FLAGS(ret) & (ANYOF_INVERT|ANYOF_UNICODE_ALL))
10286         && (((stored == 1 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
10287                               || (! ANYOF_CLASS_TEST_ANY_SET(ret)))))
10288             || (stored == 2 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
10289                                  && (! _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value))
10290                                  /* If the latest code point has a fold whose
10291                                   * bit is set, it must be the only other one */
10292                                 && ((prevvalue = PL_fold_latin1[value]) != (IV)value)
10293                                  && ANYOF_BITMAP_TEST(ret, prevvalue)))))
10294     {
10295         /* Note that the information needed to decide to do this optimization
10296          * is not currently available until the 2nd pass, and that the actually
10297          * used EXACTish node takes less space than the calculated ANYOF node,
10298          * and hence the amount of space calculated in the first pass is larger
10299          * than actually used, so this optimization doesn't gain us any space.
10300          * But an EXACT node is faster than an ANYOF node, and can be combined
10301          * with any adjacent EXACT nodes later by the optimizer for further
10302          * gains.  The speed of executing an EXACTF is similar to an ANYOF
10303          * node, so the optimization advantage comes from the ability to join
10304          * it to adjacent EXACT nodes */
10305
10306         const char * cur_parse= RExC_parse;
10307         U8 op;
10308         RExC_emit = (regnode *)orig_emit;
10309         RExC_parse = (char *)orig_parse;
10310
10311         if (stored == 1) {
10312
10313             /* A locale node with one point can be folded; all the other cases
10314              * with folding will have two points, since we calculate them above
10315              */
10316             if (ANYOF_FLAGS(ret) & ANYOF_LOC_NONBITMAP_FOLD) {
10317                  op = EXACTFL;
10318             }
10319             else {
10320                 op = EXACT;
10321             }
10322         }   /* else 2 chars in the bit map: the folds of each other */
10323         else if (AT_LEAST_UNI_SEMANTICS || !isASCII(value)) {
10324
10325             /* To join adjacent nodes, they must be the exact EXACTish type.
10326              * Try to use the most likely type, by using EXACTFU if the regex
10327              * calls for them, or is required because the character is
10328              * non-ASCII */
10329             op = EXACTFU;
10330         }
10331         else {    /* Otherwise, more likely to be EXACTF type */
10332             op = EXACTF;
10333         }
10334
10335         ret = reg_node(pRExC_state, op);
10336         RExC_parse = (char *)cur_parse;
10337         if (UTF && ! NATIVE_IS_INVARIANT(value)) {
10338             *STRING(ret)= UTF8_EIGHT_BIT_HI((U8) value);
10339             *(STRING(ret) + 1)= UTF8_EIGHT_BIT_LO((U8) value);
10340             STR_LEN(ret)= 2;
10341             RExC_emit += STR_SZ(2);
10342         }
10343         else {
10344             *STRING(ret)= (char)value;
10345             STR_LEN(ret)= 1;
10346             RExC_emit += STR_SZ(1);
10347         }
10348         SvREFCNT_dec(listsv);
10349         return ret;
10350     }
10351
10352     if (nonbitmap) {
10353         UV* nonbitmap_array = invlist_array(nonbitmap);
10354         UV nonbitmap_len = invlist_len(nonbitmap);
10355         UV i;
10356
10357         /*  Here have the full list of items to match that aren't in the
10358          *  bitmap.  Convert to the structure that the rest of the code is
10359          *  expecting.   XXX That rest of the code should convert to this
10360          *  structure */
10361         for (i = 0; i < nonbitmap_len; i++) {
10362
10363             /* The next entry is the beginning of the range that is in the
10364              * class */
10365             UV start = nonbitmap_array[i++];
10366             UV end;
10367
10368             /* The next entry is the beginning of the next range, which isn't
10369              * in the class, so the end of the current range is one less than
10370              * that.  But if there is no next range, it means that the range
10371              * begun by 'start' extends to infinity, which for this platform
10372              * ends at UV_MAX */
10373             if (i == nonbitmap_len) {
10374                 end = UV_MAX;
10375             }
10376             else {
10377                 end = nonbitmap_array[i] - 1;
10378             }
10379
10380             if (start == end) {
10381                 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", start);
10382             }
10383             else {
10384                 /* The \t sets the whole range */
10385                 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
10386                         /* XXX EBCDIC */
10387                                    start, end);
10388             }
10389         }
10390         invlist_destroy(nonbitmap);
10391     }
10392
10393     if (SvCUR(listsv) == initial_listsv_len && ! unicode_alternate) {
10394         ARG_SET(ret, ANYOF_NONBITMAP_EMPTY);
10395         SvREFCNT_dec(listsv);
10396         SvREFCNT_dec(unicode_alternate);
10397     }
10398     else {
10399
10400         AV * const av = newAV();
10401         SV *rv;
10402         /* The 0th element stores the character class description
10403          * in its textual form: used later (regexec.c:Perl_regclass_swash())
10404          * to initialize the appropriate swash (which gets stored in
10405          * the 1st element), and also useful for dumping the regnode.
10406          * The 2nd element stores the multicharacter foldings,
10407          * used later (regexec.c:S_reginclass()). */
10408         av_store(av, 0, listsv);
10409         av_store(av, 1, NULL);
10410
10411         /* Store any computed multi-char folds only if we are allowing
10412          * them */
10413         if (allow_full_fold) {
10414             av_store(av, 2, MUTABLE_SV(unicode_alternate));
10415             if (unicode_alternate) { /* This node is variable length */
10416                 OP(ret) = ANYOFV;
10417             }
10418         }
10419         else {
10420             av_store(av, 2, NULL);
10421         }
10422         rv = newRV_noinc(MUTABLE_SV(av));
10423         n = add_data(pRExC_state, 1, "s");
10424         RExC_rxi->data->data[n] = (void*)rv;
10425         ARG_SET(ret, n);
10426     }
10427     return ret;
10428 }
10429 #undef _C_C_T_
10430
10431
10432 /* reg_skipcomment()
10433
10434    Absorbs an /x style # comments from the input stream.
10435    Returns true if there is more text remaining in the stream.
10436    Will set the REG_SEEN_RUN_ON_COMMENT flag if the comment
10437    terminates the pattern without including a newline.
10438
10439    Note its the callers responsibility to ensure that we are
10440    actually in /x mode
10441
10442 */
10443
10444 STATIC bool
10445 S_reg_skipcomment(pTHX_ RExC_state_t *pRExC_state)
10446 {
10447     bool ended = 0;
10448
10449     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
10450
10451     while (RExC_parse < RExC_end)
10452         if (*RExC_parse++ == '\n') {
10453             ended = 1;
10454             break;
10455         }
10456     if (!ended) {
10457         /* we ran off the end of the pattern without ending
10458            the comment, so we have to add an \n when wrapping */
10459         RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
10460         return 0;
10461     } else
10462         return 1;
10463 }
10464
10465 /* nextchar()
10466
10467    Advances the parse position, and optionally absorbs
10468    "whitespace" from the inputstream.
10469
10470    Without /x "whitespace" means (?#...) style comments only,
10471    with /x this means (?#...) and # comments and whitespace proper.
10472
10473    Returns the RExC_parse point from BEFORE the scan occurs.
10474
10475    This is the /x friendly way of saying RExC_parse++.
10476 */
10477
10478 STATIC char*
10479 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
10480 {
10481     char* const retval = RExC_parse++;
10482
10483     PERL_ARGS_ASSERT_NEXTCHAR;
10484
10485     for (;;) {
10486         if (*RExC_parse == '(' && RExC_parse[1] == '?' &&
10487                 RExC_parse[2] == '#') {
10488             while (*RExC_parse != ')') {
10489                 if (RExC_parse == RExC_end)
10490                     FAIL("Sequence (?#... not terminated");
10491                 RExC_parse++;
10492             }
10493             RExC_parse++;
10494             continue;
10495         }
10496         if (RExC_flags & RXf_PMf_EXTENDED) {
10497             if (isSPACE(*RExC_parse)) {
10498                 RExC_parse++;
10499                 continue;
10500             }
10501             else if (*RExC_parse == '#') {
10502                 if ( reg_skipcomment( pRExC_state ) )
10503                     continue;
10504             }
10505         }
10506         return retval;
10507     }
10508 }
10509
10510 /*
10511 - reg_node - emit a node
10512 */
10513 STATIC regnode *                        /* Location. */
10514 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
10515 {
10516     dVAR;
10517     register regnode *ptr;
10518     regnode * const ret = RExC_emit;
10519     GET_RE_DEBUG_FLAGS_DECL;
10520
10521     PERL_ARGS_ASSERT_REG_NODE;
10522
10523     if (SIZE_ONLY) {
10524         SIZE_ALIGN(RExC_size);
10525         RExC_size += 1;
10526         return(ret);
10527     }
10528     if (RExC_emit >= RExC_emit_bound)
10529         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d", op);
10530
10531     NODE_ALIGN_FILL(ret);
10532     ptr = ret;
10533     FILL_ADVANCE_NODE(ptr, op);
10534     REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (ptr) - 1);
10535 #ifdef RE_TRACK_PATTERN_OFFSETS
10536     if (RExC_offsets) {         /* MJD */
10537         MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n", 
10538               "reg_node", __LINE__, 
10539               PL_reg_name[op],
10540               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] 
10541                 ? "Overwriting end of array!\n" : "OK",
10542               (UV)(RExC_emit - RExC_emit_start),
10543               (UV)(RExC_parse - RExC_start),
10544               (UV)RExC_offsets[0])); 
10545         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
10546     }
10547 #endif
10548     RExC_emit = ptr;
10549     return(ret);
10550 }
10551
10552 /*
10553 - reganode - emit a node with an argument
10554 */
10555 STATIC regnode *                        /* Location. */
10556 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
10557 {
10558     dVAR;
10559     register regnode *ptr;
10560     regnode * const ret = RExC_emit;
10561     GET_RE_DEBUG_FLAGS_DECL;
10562
10563     PERL_ARGS_ASSERT_REGANODE;
10564
10565     if (SIZE_ONLY) {
10566         SIZE_ALIGN(RExC_size);
10567         RExC_size += 2;
10568         /* 
10569            We can't do this:
10570            
10571            assert(2==regarglen[op]+1); 
10572         
10573            Anything larger than this has to allocate the extra amount.
10574            If we changed this to be:
10575            
10576            RExC_size += (1 + regarglen[op]);
10577            
10578            then it wouldn't matter. Its not clear what side effect
10579            might come from that so its not done so far.
10580            -- dmq
10581         */
10582         return(ret);
10583     }
10584     if (RExC_emit >= RExC_emit_bound)
10585         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d", op);
10586
10587     NODE_ALIGN_FILL(ret);
10588     ptr = ret;
10589     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
10590     REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (ptr) - 2);
10591 #ifdef RE_TRACK_PATTERN_OFFSETS
10592     if (RExC_offsets) {         /* MJD */
10593         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
10594               "reganode",
10595               __LINE__,
10596               PL_reg_name[op],
10597               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? 
10598               "Overwriting end of array!\n" : "OK",
10599               (UV)(RExC_emit - RExC_emit_start),
10600               (UV)(RExC_parse - RExC_start),
10601               (UV)RExC_offsets[0])); 
10602         Set_Cur_Node_Offset;
10603     }
10604 #endif            
10605     RExC_emit = ptr;
10606     return(ret);
10607 }
10608
10609 /*
10610 - reguni - emit (if appropriate) a Unicode character
10611 */
10612 STATIC STRLEN
10613 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
10614 {
10615     dVAR;
10616
10617     PERL_ARGS_ASSERT_REGUNI;
10618
10619     return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
10620 }
10621
10622 /*
10623 - reginsert - insert an operator in front of already-emitted operand
10624 *
10625 * Means relocating the operand.
10626 */
10627 STATIC void
10628 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
10629 {
10630     dVAR;
10631     register regnode *src;
10632     register regnode *dst;
10633     register regnode *place;
10634     const int offset = regarglen[(U8)op];
10635     const int size = NODE_STEP_REGNODE + offset;
10636     GET_RE_DEBUG_FLAGS_DECL;
10637
10638     PERL_ARGS_ASSERT_REGINSERT;
10639     PERL_UNUSED_ARG(depth);
10640 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
10641     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
10642     if (SIZE_ONLY) {
10643         RExC_size += size;
10644         return;
10645     }
10646
10647     src = RExC_emit;
10648     RExC_emit += size;
10649     dst = RExC_emit;
10650     if (RExC_open_parens) {
10651         int paren;
10652         /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
10653         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
10654             if ( RExC_open_parens[paren] >= opnd ) {
10655                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
10656                 RExC_open_parens[paren] += size;
10657             } else {
10658                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
10659             }
10660             if ( RExC_close_parens[paren] >= opnd ) {
10661                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
10662                 RExC_close_parens[paren] += size;
10663             } else {
10664                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
10665             }
10666         }
10667     }
10668
10669     while (src > opnd) {
10670         StructCopy(--src, --dst, regnode);
10671 #ifdef RE_TRACK_PATTERN_OFFSETS
10672         if (RExC_offsets) {     /* MJD 20010112 */
10673             MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
10674                   "reg_insert",
10675                   __LINE__,
10676                   PL_reg_name[op],
10677                   (UV)(dst - RExC_emit_start) > RExC_offsets[0] 
10678                     ? "Overwriting end of array!\n" : "OK",
10679                   (UV)(src - RExC_emit_start),
10680                   (UV)(dst - RExC_emit_start),
10681                   (UV)RExC_offsets[0])); 
10682             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
10683             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
10684         }
10685 #endif
10686     }
10687     
10688
10689     place = opnd;               /* Op node, where operand used to be. */
10690 #ifdef RE_TRACK_PATTERN_OFFSETS
10691     if (RExC_offsets) {         /* MJD */
10692         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
10693               "reginsert",
10694               __LINE__,
10695               PL_reg_name[op],
10696               (UV)(place - RExC_emit_start) > RExC_offsets[0] 
10697               ? "Overwriting end of array!\n" : "OK",
10698               (UV)(place - RExC_emit_start),
10699               (UV)(RExC_parse - RExC_start),
10700               (UV)RExC_offsets[0]));
10701         Set_Node_Offset(place, RExC_parse);
10702         Set_Node_Length(place, 1);
10703     }
10704 #endif    
10705     src = NEXTOPER(place);
10706     FILL_ADVANCE_NODE(place, op);
10707     REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (place) - 1);
10708     Zero(src, offset, regnode);
10709 }
10710
10711 /*
10712 - regtail - set the next-pointer at the end of a node chain of p to val.
10713 - SEE ALSO: regtail_study
10714 */
10715 /* TODO: All three parms should be const */
10716 STATIC void
10717 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
10718 {
10719     dVAR;
10720     register regnode *scan;
10721     GET_RE_DEBUG_FLAGS_DECL;
10722
10723     PERL_ARGS_ASSERT_REGTAIL;
10724 #ifndef DEBUGGING
10725     PERL_UNUSED_ARG(depth);
10726 #endif
10727
10728     if (SIZE_ONLY)
10729         return;
10730
10731     /* Find last node. */
10732     scan = p;
10733     for (;;) {
10734         regnode * const temp = regnext(scan);
10735         DEBUG_PARSE_r({
10736             SV * const mysv=sv_newmortal();
10737             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
10738             regprop(RExC_rx, mysv, scan);
10739             PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
10740                 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
10741                     (temp == NULL ? "->" : ""),
10742                     (temp == NULL ? PL_reg_name[OP(val)] : "")
10743             );
10744         });
10745         if (temp == NULL)
10746             break;
10747         scan = temp;
10748     }
10749
10750     if (reg_off_by_arg[OP(scan)]) {
10751         ARG_SET(scan, val - scan);
10752     }
10753     else {
10754         NEXT_OFF(scan) = val - scan;
10755     }
10756 }
10757
10758 #ifdef DEBUGGING
10759 /*
10760 - regtail_study - set the next-pointer at the end of a node chain of p to val.
10761 - Look for optimizable sequences at the same time.
10762 - currently only looks for EXACT chains.
10763
10764 This is experimental code. The idea is to use this routine to perform 
10765 in place optimizations on branches and groups as they are constructed,
10766 with the long term intention of removing optimization from study_chunk so
10767 that it is purely analytical.
10768
10769 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
10770 to control which is which.
10771
10772 */
10773 /* TODO: All four parms should be const */
10774
10775 STATIC U8
10776 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
10777 {
10778     dVAR;
10779     register regnode *scan;
10780     U8 exact = PSEUDO;
10781 #ifdef EXPERIMENTAL_INPLACESCAN
10782     I32 min = 0;
10783 #endif
10784     GET_RE_DEBUG_FLAGS_DECL;
10785
10786     PERL_ARGS_ASSERT_REGTAIL_STUDY;
10787
10788
10789     if (SIZE_ONLY)
10790         return exact;
10791
10792     /* Find last node. */
10793
10794     scan = p;
10795     for (;;) {
10796         regnode * const temp = regnext(scan);
10797 #ifdef EXPERIMENTAL_INPLACESCAN
10798         if (PL_regkind[OP(scan)] == EXACT)
10799             if (join_exact(pRExC_state,scan,&min,1,val,depth+1))
10800                 return EXACT;
10801 #endif
10802         if ( exact ) {
10803             switch (OP(scan)) {
10804                 case EXACT:
10805                 case EXACTF:
10806                 case EXACTFA:
10807                 case EXACTFU:
10808                 case EXACTFL:
10809                         if( exact == PSEUDO )
10810                             exact= OP(scan);
10811                         else if ( exact != OP(scan) )
10812                             exact= 0;
10813                 case NOTHING:
10814                     break;
10815                 default:
10816                     exact= 0;
10817             }
10818         }
10819         DEBUG_PARSE_r({
10820             SV * const mysv=sv_newmortal();
10821             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
10822             regprop(RExC_rx, mysv, scan);
10823             PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
10824                 SvPV_nolen_const(mysv),
10825                 REG_NODE_NUM(scan),
10826                 PL_reg_name[exact]);
10827         });
10828         if (temp == NULL)
10829             break;
10830         scan = temp;
10831     }
10832     DEBUG_PARSE_r({
10833         SV * const mysv_val=sv_newmortal();
10834         DEBUG_PARSE_MSG("");
10835         regprop(RExC_rx, mysv_val, val);
10836         PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
10837                       SvPV_nolen_const(mysv_val),
10838                       (IV)REG_NODE_NUM(val),
10839                       (IV)(val - scan)
10840         );
10841     });
10842     if (reg_off_by_arg[OP(scan)]) {
10843         ARG_SET(scan, val - scan);
10844     }
10845     else {
10846         NEXT_OFF(scan) = val - scan;
10847     }
10848
10849     return exact;
10850 }
10851 #endif
10852
10853 /*
10854  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
10855  */
10856 #ifdef DEBUGGING
10857 static void 
10858 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
10859 {
10860     int bit;
10861     int set=0;
10862     regex_charset cs;
10863
10864     for (bit=0; bit<32; bit++) {
10865         if (flags & (1<<bit)) {
10866             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
10867                 continue;
10868             }
10869             if (!set++ && lead) 
10870                 PerlIO_printf(Perl_debug_log, "%s",lead);
10871             PerlIO_printf(Perl_debug_log, "%s ",PL_reg_extflags_name[bit]);
10872         }               
10873     }      
10874     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
10875             if (!set++ && lead) {
10876                 PerlIO_printf(Perl_debug_log, "%s",lead);
10877             }
10878             switch (cs) {
10879                 case REGEX_UNICODE_CHARSET:
10880                     PerlIO_printf(Perl_debug_log, "UNICODE");
10881                     break;
10882                 case REGEX_LOCALE_CHARSET:
10883                     PerlIO_printf(Perl_debug_log, "LOCALE");
10884                     break;
10885                 case REGEX_ASCII_RESTRICTED_CHARSET:
10886                     PerlIO_printf(Perl_debug_log, "ASCII-RESTRICTED");
10887                     break;
10888                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
10889                     PerlIO_printf(Perl_debug_log, "ASCII-MORE_RESTRICTED");
10890                     break;
10891                 default:
10892                     PerlIO_printf(Perl_debug_log, "UNKNOWN CHARACTER SET");
10893                     break;
10894             }
10895     }
10896     if (lead)  {
10897         if (set) 
10898             PerlIO_printf(Perl_debug_log, "\n");
10899         else 
10900             PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
10901     }            
10902 }   
10903 #endif
10904
10905 void
10906 Perl_regdump(pTHX_ const regexp *r)
10907 {
10908 #ifdef DEBUGGING
10909     dVAR;
10910     SV * const sv = sv_newmortal();
10911     SV *dsv= sv_newmortal();
10912     RXi_GET_DECL(r,ri);
10913     GET_RE_DEBUG_FLAGS_DECL;
10914
10915     PERL_ARGS_ASSERT_REGDUMP;
10916
10917     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
10918
10919     /* Header fields of interest. */
10920     if (r->anchored_substr) {
10921         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr), 
10922             RE_SV_DUMPLEN(r->anchored_substr), 30);
10923         PerlIO_printf(Perl_debug_log,
10924                       "anchored %s%s at %"IVdf" ",
10925                       s, RE_SV_TAIL(r->anchored_substr),
10926                       (IV)r->anchored_offset);
10927     } else if (r->anchored_utf8) {
10928         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8), 
10929             RE_SV_DUMPLEN(r->anchored_utf8), 30);
10930         PerlIO_printf(Perl_debug_log,
10931                       "anchored utf8 %s%s at %"IVdf" ",
10932                       s, RE_SV_TAIL(r->anchored_utf8),
10933                       (IV)r->anchored_offset);
10934     }                 
10935     if (r->float_substr) {
10936         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr), 
10937             RE_SV_DUMPLEN(r->float_substr), 30);
10938         PerlIO_printf(Perl_debug_log,
10939                       "floating %s%s at %"IVdf"..%"UVuf" ",
10940                       s, RE_SV_TAIL(r->float_substr),
10941                       (IV)r->float_min_offset, (UV)r->float_max_offset);
10942     } else if (r->float_utf8) {
10943         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8), 
10944             RE_SV_DUMPLEN(r->float_utf8), 30);
10945         PerlIO_printf(Perl_debug_log,
10946                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
10947                       s, RE_SV_TAIL(r->float_utf8),
10948                       (IV)r->float_min_offset, (UV)r->float_max_offset);
10949     }
10950     if (r->check_substr || r->check_utf8)
10951         PerlIO_printf(Perl_debug_log,
10952                       (const char *)
10953                       (r->check_substr == r->float_substr
10954                        && r->check_utf8 == r->float_utf8
10955                        ? "(checking floating" : "(checking anchored"));
10956     if (r->extflags & RXf_NOSCAN)
10957         PerlIO_printf(Perl_debug_log, " noscan");
10958     if (r->extflags & RXf_CHECK_ALL)
10959         PerlIO_printf(Perl_debug_log, " isall");
10960     if (r->check_substr || r->check_utf8)
10961         PerlIO_printf(Perl_debug_log, ") ");
10962
10963     if (ri->regstclass) {
10964         regprop(r, sv, ri->regstclass);
10965         PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
10966     }
10967     if (r->extflags & RXf_ANCH) {
10968         PerlIO_printf(Perl_debug_log, "anchored");
10969         if (r->extflags & RXf_ANCH_BOL)
10970             PerlIO_printf(Perl_debug_log, "(BOL)");
10971         if (r->extflags & RXf_ANCH_MBOL)
10972             PerlIO_printf(Perl_debug_log, "(MBOL)");
10973         if (r->extflags & RXf_ANCH_SBOL)
10974             PerlIO_printf(Perl_debug_log, "(SBOL)");
10975         if (r->extflags & RXf_ANCH_GPOS)
10976             PerlIO_printf(Perl_debug_log, "(GPOS)");
10977         PerlIO_putc(Perl_debug_log, ' ');
10978     }
10979     if (r->extflags & RXf_GPOS_SEEN)
10980         PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
10981     if (r->intflags & PREGf_SKIP)
10982         PerlIO_printf(Perl_debug_log, "plus ");
10983     if (r->intflags & PREGf_IMPLICIT)
10984         PerlIO_printf(Perl_debug_log, "implicit ");
10985     PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
10986     if (r->extflags & RXf_EVAL_SEEN)
10987         PerlIO_printf(Perl_debug_log, "with eval ");
10988     PerlIO_printf(Perl_debug_log, "\n");
10989     DEBUG_FLAGS_r(regdump_extflags("r->extflags: ",r->extflags));            
10990 #else
10991     PERL_ARGS_ASSERT_REGDUMP;
10992     PERL_UNUSED_CONTEXT;
10993     PERL_UNUSED_ARG(r);
10994 #endif  /* DEBUGGING */
10995 }
10996
10997 /*
10998 - regprop - printable representation of opcode
10999 */
11000 #define EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags) \
11001 STMT_START { \
11002         if (do_sep) {                           \
11003             Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]); \
11004             if (flags & ANYOF_INVERT)           \
11005                 /*make sure the invert info is in each */ \
11006                 sv_catpvs(sv, "^");             \
11007             do_sep = 0;                         \
11008         }                                       \
11009 } STMT_END
11010
11011 void
11012 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
11013 {
11014 #ifdef DEBUGGING
11015     dVAR;
11016     register int k;
11017     RXi_GET_DECL(prog,progi);
11018     GET_RE_DEBUG_FLAGS_DECL;
11019     
11020     PERL_ARGS_ASSERT_REGPROP;
11021
11022     sv_setpvs(sv, "");
11023
11024     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
11025         /* It would be nice to FAIL() here, but this may be called from
11026            regexec.c, and it would be hard to supply pRExC_state. */
11027         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
11028     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
11029
11030     k = PL_regkind[OP(o)];
11031
11032     if (k == EXACT) {
11033         sv_catpvs(sv, " ");
11034         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT) 
11035          * is a crude hack but it may be the best for now since 
11036          * we have no flag "this EXACTish node was UTF-8" 
11037          * --jhi */
11038         pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
11039                   PERL_PV_ESCAPE_UNI_DETECT |
11040                   PERL_PV_ESCAPE_NONASCII   |
11041                   PERL_PV_PRETTY_ELLIPSES   |
11042                   PERL_PV_PRETTY_LTGT       |
11043                   PERL_PV_PRETTY_NOCLEAR
11044                   );
11045     } else if (k == TRIE) {
11046         /* print the details of the trie in dumpuntil instead, as
11047          * progi->data isn't available here */
11048         const char op = OP(o);
11049         const U32 n = ARG(o);
11050         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
11051                (reg_ac_data *)progi->data->data[n] :
11052                NULL;
11053         const reg_trie_data * const trie
11054             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
11055         
11056         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
11057         DEBUG_TRIE_COMPILE_r(
11058             Perl_sv_catpvf(aTHX_ sv,
11059                 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
11060                 (UV)trie->startstate,
11061                 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
11062                 (UV)trie->wordcount,
11063                 (UV)trie->minlen,
11064                 (UV)trie->maxlen,
11065                 (UV)TRIE_CHARCOUNT(trie),
11066                 (UV)trie->uniquecharcount
11067             )
11068         );
11069         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
11070             int i;
11071             int rangestart = -1;
11072             U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
11073             sv_catpvs(sv, "[");
11074             for (i = 0; i <= 256; i++) {
11075                 if (i < 256 && BITMAP_TEST(bitmap,i)) {
11076                     if (rangestart == -1)
11077                         rangestart = i;
11078                 } else if (rangestart != -1) {
11079                     if (i <= rangestart + 3)
11080                         for (; rangestart < i; rangestart++)
11081                             put_byte(sv, rangestart);
11082                     else {
11083                         put_byte(sv, rangestart);
11084                         sv_catpvs(sv, "-");
11085                         put_byte(sv, i - 1);
11086                     }
11087                     rangestart = -1;
11088                 }
11089             }
11090             sv_catpvs(sv, "]");
11091         } 
11092          
11093     } else if (k == CURLY) {
11094         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
11095             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
11096         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
11097     }
11098     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
11099         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
11100     else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
11101         Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
11102         if ( RXp_PAREN_NAMES(prog) ) {
11103             if ( k != REF || (OP(o) < NREF)) {
11104                 AV *list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
11105                 SV **name= av_fetch(list, ARG(o), 0 );
11106                 if (name)
11107                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
11108             }       
11109             else {
11110                 AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]);
11111                 SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]);
11112                 I32 *nums=(I32*)SvPVX(sv_dat);
11113                 SV **name= av_fetch(list, nums[0], 0 );
11114                 I32 n;
11115                 if (name) {
11116                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
11117                         Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
11118                                     (n ? "," : ""), (IV)nums[n]);
11119                     }
11120                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
11121                 }
11122             }
11123         }            
11124     } else if (k == GOSUB) 
11125         Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
11126     else if (k == VERB) {
11127         if (!o->flags) 
11128             Perl_sv_catpvf(aTHX_ sv, ":%"SVf, 
11129                            SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
11130     } else if (k == LOGICAL)
11131         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);     /* 2: embedded, otherwise 1 */
11132     else if (k == FOLDCHAR)
11133         Perl_sv_catpvf(aTHX_ sv, "[0x%"UVXf"]", PTR2UV(ARG(o)) );
11134     else if (k == ANYOF) {
11135         int i, rangestart = -1;
11136         const U8 flags = ANYOF_FLAGS(o);
11137         int do_sep = 0;
11138
11139         /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
11140         static const char * const anyofs[] = {
11141             "\\w",
11142             "\\W",
11143             "\\s",
11144             "\\S",
11145             "\\d",
11146             "\\D",
11147             "[:alnum:]",
11148             "[:^alnum:]",
11149             "[:alpha:]",
11150             "[:^alpha:]",
11151             "[:ascii:]",
11152             "[:^ascii:]",
11153             "[:cntrl:]",
11154             "[:^cntrl:]",
11155             "[:graph:]",
11156             "[:^graph:]",
11157             "[:lower:]",
11158             "[:^lower:]",
11159             "[:print:]",
11160             "[:^print:]",
11161             "[:punct:]",
11162             "[:^punct:]",
11163             "[:upper:]",
11164             "[:^upper:]",
11165             "[:xdigit:]",
11166             "[:^xdigit:]",
11167             "[:space:]",
11168             "[:^space:]",
11169             "[:blank:]",
11170             "[:^blank:]"
11171         };
11172
11173         if (flags & ANYOF_LOCALE)
11174             sv_catpvs(sv, "{loc}");
11175         if (flags & ANYOF_LOC_NONBITMAP_FOLD)
11176             sv_catpvs(sv, "{i}");
11177         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
11178         if (flags & ANYOF_INVERT)
11179             sv_catpvs(sv, "^");
11180         
11181         /* output what the standard cp 0-255 bitmap matches */
11182         for (i = 0; i <= 256; i++) {
11183             if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
11184                 if (rangestart == -1)
11185                     rangestart = i;
11186             } else if (rangestart != -1) {
11187                 if (i <= rangestart + 3)
11188                     for (; rangestart < i; rangestart++)
11189                         put_byte(sv, rangestart);
11190                 else {
11191                     put_byte(sv, rangestart);
11192                     sv_catpvs(sv, "-");
11193                     put_byte(sv, i - 1);
11194                 }
11195                 do_sep = 1;
11196                 rangestart = -1;
11197             }
11198         }
11199         
11200         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
11201         /* output any special charclass tests (used entirely under use locale) */
11202         if (ANYOF_CLASS_TEST_ANY_SET(o))
11203             for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
11204                 if (ANYOF_CLASS_TEST(o,i)) {
11205                     sv_catpv(sv, anyofs[i]);
11206                     do_sep = 1;
11207                 }
11208         
11209         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
11210         
11211         if (flags & ANYOF_NON_UTF8_LATIN1_ALL) {
11212             sv_catpvs(sv, "{non-utf8-latin1-all}");
11213         }
11214
11215         /* output information about the unicode matching */
11216         if (flags & ANYOF_UNICODE_ALL)
11217             sv_catpvs(sv, "{unicode_all}");
11218         else if (ANYOF_NONBITMAP(o))
11219             sv_catpvs(sv, "{unicode}");
11220         if (flags & ANYOF_NONBITMAP_NON_UTF8)
11221             sv_catpvs(sv, "{outside bitmap}");
11222
11223         if (ANYOF_NONBITMAP(o)) {
11224             SV *lv;
11225             SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
11226         
11227             if (lv) {
11228                 if (sw) {
11229                     U8 s[UTF8_MAXBYTES_CASE+1];
11230
11231                     for (i = 0; i <= 256; i++) { /* just the first 256 */
11232                         uvchr_to_utf8(s, i);
11233                         
11234                         if (i < 256 && swash_fetch(sw, s, TRUE)) {
11235                             if (rangestart == -1)
11236                                 rangestart = i;
11237                         } else if (rangestart != -1) {
11238                             if (i <= rangestart + 3)
11239                                 for (; rangestart < i; rangestart++) {
11240                                     const U8 * const e = uvchr_to_utf8(s,rangestart);
11241                                     U8 *p;
11242                                     for(p = s; p < e; p++)
11243                                         put_byte(sv, *p);
11244                                 }
11245                             else {
11246                                 const U8 *e = uvchr_to_utf8(s,rangestart);
11247                                 U8 *p;
11248                                 for (p = s; p < e; p++)
11249                                     put_byte(sv, *p);
11250                                 sv_catpvs(sv, "-");
11251                                 e = uvchr_to_utf8(s, i-1);
11252                                 for (p = s; p < e; p++)
11253                                     put_byte(sv, *p);
11254                                 }
11255                                 rangestart = -1;
11256                             }
11257                         }
11258                         
11259                     sv_catpvs(sv, "..."); /* et cetera */
11260                 }
11261
11262                 {
11263                     char *s = savesvpv(lv);
11264                     char * const origs = s;
11265                 
11266                     while (*s && *s != '\n')
11267                         s++;
11268                 
11269                     if (*s == '\n') {
11270                         const char * const t = ++s;
11271                         
11272                         while (*s) {
11273                             if (*s == '\n')
11274                                 *s = ' ';
11275                             s++;
11276                         }
11277                         if (s[-1] == ' ')
11278                             s[-1] = 0;
11279                         
11280                         sv_catpv(sv, t);
11281                     }
11282                 
11283                     Safefree(origs);
11284                 }
11285             }
11286         }
11287
11288         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
11289     }
11290     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
11291         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
11292 #else
11293     PERL_UNUSED_CONTEXT;
11294     PERL_UNUSED_ARG(sv);
11295     PERL_UNUSED_ARG(o);
11296     PERL_UNUSED_ARG(prog);
11297 #endif  /* DEBUGGING */
11298 }
11299
11300 SV *
11301 Perl_re_intuit_string(pTHX_ REGEXP * const r)
11302 {                               /* Assume that RE_INTUIT is set */
11303     dVAR;
11304     struct regexp *const prog = (struct regexp *)SvANY(r);
11305     GET_RE_DEBUG_FLAGS_DECL;
11306
11307     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
11308     PERL_UNUSED_CONTEXT;
11309
11310     DEBUG_COMPILE_r(
11311         {
11312             const char * const s = SvPV_nolen_const(prog->check_substr
11313                       ? prog->check_substr : prog->check_utf8);
11314
11315             if (!PL_colorset) reginitcolors();
11316             PerlIO_printf(Perl_debug_log,
11317                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
11318                       PL_colors[4],
11319                       prog->check_substr ? "" : "utf8 ",
11320                       PL_colors[5],PL_colors[0],
11321                       s,
11322                       PL_colors[1],
11323                       (strlen(s) > 60 ? "..." : ""));
11324         } );
11325
11326     return prog->check_substr ? prog->check_substr : prog->check_utf8;
11327 }
11328
11329 /* 
11330    pregfree() 
11331    
11332    handles refcounting and freeing the perl core regexp structure. When 
11333    it is necessary to actually free the structure the first thing it 
11334    does is call the 'free' method of the regexp_engine associated to
11335    the regexp, allowing the handling of the void *pprivate; member 
11336    first. (This routine is not overridable by extensions, which is why 
11337    the extensions free is called first.)
11338    
11339    See regdupe and regdupe_internal if you change anything here. 
11340 */
11341 #ifndef PERL_IN_XSUB_RE
11342 void
11343 Perl_pregfree(pTHX_ REGEXP *r)
11344 {
11345     SvREFCNT_dec(r);
11346 }
11347
11348 void
11349 Perl_pregfree2(pTHX_ REGEXP *rx)
11350 {
11351     dVAR;
11352     struct regexp *const r = (struct regexp *)SvANY(rx);
11353     GET_RE_DEBUG_FLAGS_DECL;
11354
11355     PERL_ARGS_ASSERT_PREGFREE2;
11356
11357     if (r->mother_re) {
11358         ReREFCNT_dec(r->mother_re);
11359     } else {
11360         CALLREGFREE_PVT(rx); /* free the private data */
11361         SvREFCNT_dec(RXp_PAREN_NAMES(r));
11362     }        
11363     if (r->substrs) {
11364         SvREFCNT_dec(r->anchored_substr);
11365         SvREFCNT_dec(r->anchored_utf8);
11366         SvREFCNT_dec(r->float_substr);
11367         SvREFCNT_dec(r->float_utf8);
11368         Safefree(r->substrs);
11369     }
11370     RX_MATCH_COPY_FREE(rx);
11371 #ifdef PERL_OLD_COPY_ON_WRITE
11372     SvREFCNT_dec(r->saved_copy);
11373 #endif
11374     Safefree(r->offs);
11375 }
11376
11377 /*  reg_temp_copy()
11378     
11379     This is a hacky workaround to the structural issue of match results
11380     being stored in the regexp structure which is in turn stored in
11381     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
11382     could be PL_curpm in multiple contexts, and could require multiple
11383     result sets being associated with the pattern simultaneously, such
11384     as when doing a recursive match with (??{$qr})
11385     
11386     The solution is to make a lightweight copy of the regexp structure 
11387     when a qr// is returned from the code executed by (??{$qr}) this
11388     lightweight copy doesn't actually own any of its data except for
11389     the starp/end and the actual regexp structure itself. 
11390     
11391 */    
11392     
11393     
11394 REGEXP *
11395 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
11396 {
11397     struct regexp *ret;
11398     struct regexp *const r = (struct regexp *)SvANY(rx);
11399     register const I32 npar = r->nparens+1;
11400
11401     PERL_ARGS_ASSERT_REG_TEMP_COPY;
11402
11403     if (!ret_x)
11404         ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
11405     ret = (struct regexp *)SvANY(ret_x);
11406     
11407     (void)ReREFCNT_inc(rx);
11408     /* We can take advantage of the existing "copied buffer" mechanism in SVs
11409        by pointing directly at the buffer, but flagging that the allocated
11410        space in the copy is zero. As we've just done a struct copy, it's now
11411        a case of zero-ing that, rather than copying the current length.  */
11412     SvPV_set(ret_x, RX_WRAPPED(rx));
11413     SvFLAGS(ret_x) |= SvFLAGS(rx) & (SVf_POK|SVp_POK|SVf_UTF8);
11414     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
11415            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
11416     SvLEN_set(ret_x, 0);
11417     SvSTASH_set(ret_x, NULL);
11418     SvMAGIC_set(ret_x, NULL);
11419     Newx(ret->offs, npar, regexp_paren_pair);
11420     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
11421     if (r->substrs) {
11422         Newx(ret->substrs, 1, struct reg_substr_data);
11423         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
11424
11425         SvREFCNT_inc_void(ret->anchored_substr);
11426         SvREFCNT_inc_void(ret->anchored_utf8);
11427         SvREFCNT_inc_void(ret->float_substr);
11428         SvREFCNT_inc_void(ret->float_utf8);
11429
11430         /* check_substr and check_utf8, if non-NULL, point to either their
11431            anchored or float namesakes, and don't hold a second reference.  */
11432     }
11433     RX_MATCH_COPIED_off(ret_x);
11434 #ifdef PERL_OLD_COPY_ON_WRITE
11435     ret->saved_copy = NULL;
11436 #endif
11437     ret->mother_re = rx;
11438     
11439     return ret_x;
11440 }
11441 #endif
11442
11443 /* regfree_internal() 
11444
11445    Free the private data in a regexp. This is overloadable by 
11446    extensions. Perl takes care of the regexp structure in pregfree(), 
11447    this covers the *pprivate pointer which technically perl doesn't 
11448    know about, however of course we have to handle the 
11449    regexp_internal structure when no extension is in use. 
11450    
11451    Note this is called before freeing anything in the regexp 
11452    structure. 
11453  */
11454  
11455 void
11456 Perl_regfree_internal(pTHX_ REGEXP * const rx)
11457 {
11458     dVAR;
11459     struct regexp *const r = (struct regexp *)SvANY(rx);
11460     RXi_GET_DECL(r,ri);
11461     GET_RE_DEBUG_FLAGS_DECL;
11462
11463     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
11464
11465     DEBUG_COMPILE_r({
11466         if (!PL_colorset)
11467             reginitcolors();
11468         {
11469             SV *dsv= sv_newmortal();
11470             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
11471                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
11472             PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n", 
11473                 PL_colors[4],PL_colors[5],s);
11474         }
11475     });
11476 #ifdef RE_TRACK_PATTERN_OFFSETS
11477     if (ri->u.offsets)
11478         Safefree(ri->u.offsets);             /* 20010421 MJD */
11479 #endif
11480     if (ri->data) {
11481         int n = ri->data->count;
11482         PAD* new_comppad = NULL;
11483         PAD* old_comppad;
11484         PADOFFSET refcnt;
11485
11486         while (--n >= 0) {
11487           /* If you add a ->what type here, update the comment in regcomp.h */
11488             switch (ri->data->what[n]) {
11489             case 'a':
11490             case 's':
11491             case 'S':
11492             case 'u':
11493                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
11494                 break;
11495             case 'f':
11496                 Safefree(ri->data->data[n]);
11497                 break;
11498             case 'p':
11499                 new_comppad = MUTABLE_AV(ri->data->data[n]);
11500                 break;
11501             case 'o':
11502                 if (new_comppad == NULL)
11503                     Perl_croak(aTHX_ "panic: pregfree comppad");
11504                 PAD_SAVE_LOCAL(old_comppad,
11505                     /* Watch out for global destruction's random ordering. */
11506                     (SvTYPE(new_comppad) == SVt_PVAV) ? new_comppad : NULL
11507                 );
11508                 OP_REFCNT_LOCK;
11509                 refcnt = OpREFCNT_dec((OP_4tree*)ri->data->data[n]);
11510                 OP_REFCNT_UNLOCK;
11511                 if (!refcnt)
11512                     op_free((OP_4tree*)ri->data->data[n]);
11513
11514                 PAD_RESTORE_LOCAL(old_comppad);
11515                 SvREFCNT_dec(MUTABLE_SV(new_comppad));
11516                 new_comppad = NULL;
11517                 break;
11518             case 'n':
11519                 break;
11520             case 'T':           
11521                 { /* Aho Corasick add-on structure for a trie node.
11522                      Used in stclass optimization only */
11523                     U32 refcount;
11524                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
11525                     OP_REFCNT_LOCK;
11526                     refcount = --aho->refcount;
11527                     OP_REFCNT_UNLOCK;
11528                     if ( !refcount ) {
11529                         PerlMemShared_free(aho->states);
11530                         PerlMemShared_free(aho->fail);
11531                          /* do this last!!!! */
11532                         PerlMemShared_free(ri->data->data[n]);
11533                         PerlMemShared_free(ri->regstclass);
11534                     }
11535                 }
11536                 break;
11537             case 't':
11538                 {
11539                     /* trie structure. */
11540                     U32 refcount;
11541                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
11542                     OP_REFCNT_LOCK;
11543                     refcount = --trie->refcount;
11544                     OP_REFCNT_UNLOCK;
11545                     if ( !refcount ) {
11546                         PerlMemShared_free(trie->charmap);
11547                         PerlMemShared_free(trie->states);
11548                         PerlMemShared_free(trie->trans);
11549                         if (trie->bitmap)
11550                             PerlMemShared_free(trie->bitmap);
11551                         if (trie->jump)
11552                             PerlMemShared_free(trie->jump);
11553                         PerlMemShared_free(trie->wordinfo);
11554                         /* do this last!!!! */
11555                         PerlMemShared_free(ri->data->data[n]);
11556                     }
11557                 }
11558                 break;
11559             default:
11560                 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
11561             }
11562         }
11563         Safefree(ri->data->what);
11564         Safefree(ri->data);
11565     }
11566
11567     Safefree(ri);
11568 }
11569
11570 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
11571 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
11572 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
11573
11574 /* 
11575    re_dup - duplicate a regexp. 
11576    
11577    This routine is expected to clone a given regexp structure. It is only
11578    compiled under USE_ITHREADS.
11579
11580    After all of the core data stored in struct regexp is duplicated
11581    the regexp_engine.dupe method is used to copy any private data
11582    stored in the *pprivate pointer. This allows extensions to handle
11583    any duplication it needs to do.
11584
11585    See pregfree() and regfree_internal() if you change anything here. 
11586 */
11587 #if defined(USE_ITHREADS)
11588 #ifndef PERL_IN_XSUB_RE
11589 void
11590 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
11591 {
11592     dVAR;
11593     I32 npar;
11594     const struct regexp *r = (const struct regexp *)SvANY(sstr);
11595     struct regexp *ret = (struct regexp *)SvANY(dstr);
11596     
11597     PERL_ARGS_ASSERT_RE_DUP_GUTS;
11598
11599     npar = r->nparens+1;
11600     Newx(ret->offs, npar, regexp_paren_pair);
11601     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
11602     if(ret->swap) {
11603         /* no need to copy these */
11604         Newx(ret->swap, npar, regexp_paren_pair);
11605     }
11606
11607     if (ret->substrs) {
11608         /* Do it this way to avoid reading from *r after the StructCopy().
11609            That way, if any of the sv_dup_inc()s dislodge *r from the L1
11610            cache, it doesn't matter.  */
11611         const bool anchored = r->check_substr
11612             ? r->check_substr == r->anchored_substr
11613             : r->check_utf8 == r->anchored_utf8;
11614         Newx(ret->substrs, 1, struct reg_substr_data);
11615         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
11616
11617         ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
11618         ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
11619         ret->float_substr = sv_dup_inc(ret->float_substr, param);
11620         ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
11621
11622         /* check_substr and check_utf8, if non-NULL, point to either their
11623            anchored or float namesakes, and don't hold a second reference.  */
11624
11625         if (ret->check_substr) {
11626             if (anchored) {
11627                 assert(r->check_utf8 == r->anchored_utf8);
11628                 ret->check_substr = ret->anchored_substr;
11629                 ret->check_utf8 = ret->anchored_utf8;
11630             } else {
11631                 assert(r->check_substr == r->float_substr);
11632                 assert(r->check_utf8 == r->float_utf8);
11633                 ret->check_substr = ret->float_substr;
11634                 ret->check_utf8 = ret->float_utf8;
11635             }
11636         } else if (ret->check_utf8) {
11637             if (anchored) {
11638                 ret->check_utf8 = ret->anchored_utf8;
11639             } else {
11640                 ret->check_utf8 = ret->float_utf8;
11641             }
11642         }
11643     }
11644
11645     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
11646
11647     if (ret->pprivate)
11648         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
11649
11650     if (RX_MATCH_COPIED(dstr))
11651         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
11652     else
11653         ret->subbeg = NULL;
11654 #ifdef PERL_OLD_COPY_ON_WRITE
11655     ret->saved_copy = NULL;
11656 #endif
11657
11658     if (ret->mother_re) {
11659         if (SvPVX_const(dstr) == SvPVX_const(ret->mother_re)) {
11660             /* Our storage points directly to our mother regexp, but that's
11661                1: a buffer in a different thread
11662                2: something we no longer hold a reference on
11663                so we need to copy it locally.  */
11664             /* Note we need to sue SvCUR() on our mother_re, because it, in
11665                turn, may well be pointing to its own mother_re.  */
11666             SvPV_set(dstr, SAVEPVN(SvPVX_const(ret->mother_re),
11667                                    SvCUR(ret->mother_re)+1));
11668             SvLEN_set(dstr, SvCUR(ret->mother_re)+1);
11669         }
11670         ret->mother_re      = NULL;
11671     }
11672     ret->gofs = 0;
11673 }
11674 #endif /* PERL_IN_XSUB_RE */
11675
11676 /*
11677    regdupe_internal()
11678    
11679    This is the internal complement to regdupe() which is used to copy
11680    the structure pointed to by the *pprivate pointer in the regexp.
11681    This is the core version of the extension overridable cloning hook.
11682    The regexp structure being duplicated will be copied by perl prior
11683    to this and will be provided as the regexp *r argument, however 
11684    with the /old/ structures pprivate pointer value. Thus this routine
11685    may override any copying normally done by perl.
11686    
11687    It returns a pointer to the new regexp_internal structure.
11688 */
11689
11690 void *
11691 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
11692 {
11693     dVAR;
11694     struct regexp *const r = (struct regexp *)SvANY(rx);
11695     regexp_internal *reti;
11696     int len;
11697     RXi_GET_DECL(r,ri);
11698
11699     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
11700     
11701     len = ProgLen(ri);
11702     
11703     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), char, regexp_internal);
11704     Copy(ri->program, reti->program, len+1, regnode);
11705     
11706
11707     reti->regstclass = NULL;
11708
11709     if (ri->data) {
11710         struct reg_data *d;
11711         const int count = ri->data->count;
11712         int i;
11713
11714         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
11715                 char, struct reg_data);
11716         Newx(d->what, count, U8);
11717
11718         d->count = count;
11719         for (i = 0; i < count; i++) {
11720             d->what[i] = ri->data->what[i];
11721             switch (d->what[i]) {
11722                 /* legal options are one of: sSfpontTua
11723                    see also regcomp.h and pregfree() */
11724             case 'a': /* actually an AV, but the dup function is identical.  */
11725             case 's':
11726             case 'S':
11727             case 'p': /* actually an AV, but the dup function is identical.  */
11728             case 'u': /* actually an HV, but the dup function is identical.  */
11729                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
11730                 break;
11731             case 'f':
11732                 /* This is cheating. */
11733                 Newx(d->data[i], 1, struct regnode_charclass_class);
11734                 StructCopy(ri->data->data[i], d->data[i],
11735                             struct regnode_charclass_class);
11736                 reti->regstclass = (regnode*)d->data[i];
11737                 break;
11738             case 'o':
11739                 /* Compiled op trees are readonly and in shared memory,
11740                    and can thus be shared without duplication. */
11741                 OP_REFCNT_LOCK;
11742                 d->data[i] = (void*)OpREFCNT_inc((OP*)ri->data->data[i]);
11743                 OP_REFCNT_UNLOCK;
11744                 break;
11745             case 'T':
11746                 /* Trie stclasses are readonly and can thus be shared
11747                  * without duplication. We free the stclass in pregfree
11748                  * when the corresponding reg_ac_data struct is freed.
11749                  */
11750                 reti->regstclass= ri->regstclass;
11751                 /* Fall through */
11752             case 't':
11753                 OP_REFCNT_LOCK;
11754                 ((reg_trie_data*)ri->data->data[i])->refcount++;
11755                 OP_REFCNT_UNLOCK;
11756                 /* Fall through */
11757             case 'n':
11758                 d->data[i] = ri->data->data[i];
11759                 break;
11760             default:
11761                 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
11762             }
11763         }
11764
11765         reti->data = d;
11766     }
11767     else
11768         reti->data = NULL;
11769
11770     reti->name_list_idx = ri->name_list_idx;
11771
11772 #ifdef RE_TRACK_PATTERN_OFFSETS
11773     if (ri->u.offsets) {
11774         Newx(reti->u.offsets, 2*len+1, U32);
11775         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
11776     }
11777 #else
11778     SetProgLen(reti,len);
11779 #endif
11780
11781     return (void*)reti;
11782 }
11783
11784 #endif    /* USE_ITHREADS */
11785
11786 #ifndef PERL_IN_XSUB_RE
11787
11788 /*
11789  - regnext - dig the "next" pointer out of a node
11790  */
11791 regnode *
11792 Perl_regnext(pTHX_ register regnode *p)
11793 {
11794     dVAR;
11795     register I32 offset;
11796
11797     if (!p)
11798         return(NULL);
11799
11800     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
11801         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(p), (int)REGNODE_MAX);
11802     }
11803
11804     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
11805     if (offset == 0)
11806         return(NULL);
11807
11808     return(p+offset);
11809 }
11810 #endif
11811
11812 STATIC void     
11813 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
11814 {
11815     va_list args;
11816     STRLEN l1 = strlen(pat1);
11817     STRLEN l2 = strlen(pat2);
11818     char buf[512];
11819     SV *msv;
11820     const char *message;
11821
11822     PERL_ARGS_ASSERT_RE_CROAK2;
11823
11824     if (l1 > 510)
11825         l1 = 510;
11826     if (l1 + l2 > 510)
11827         l2 = 510 - l1;
11828     Copy(pat1, buf, l1 , char);
11829     Copy(pat2, buf + l1, l2 , char);
11830     buf[l1 + l2] = '\n';
11831     buf[l1 + l2 + 1] = '\0';
11832 #ifdef I_STDARG
11833     /* ANSI variant takes additional second argument */
11834     va_start(args, pat2);
11835 #else
11836     va_start(args);
11837 #endif
11838     msv = vmess(buf, &args);
11839     va_end(args);
11840     message = SvPV_const(msv,l1);
11841     if (l1 > 512)
11842         l1 = 512;
11843     Copy(message, buf, l1 , char);
11844     buf[l1-1] = '\0';                   /* Overwrite \n */
11845     Perl_croak(aTHX_ "%s", buf);
11846 }
11847
11848 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
11849
11850 #ifndef PERL_IN_XSUB_RE
11851 void
11852 Perl_save_re_context(pTHX)
11853 {
11854     dVAR;
11855
11856     struct re_save_state *state;
11857
11858     SAVEVPTR(PL_curcop);
11859     SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
11860
11861     state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
11862     PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
11863     SSPUSHUV(SAVEt_RE_STATE);
11864
11865     Copy(&PL_reg_state, state, 1, struct re_save_state);
11866
11867     PL_reg_start_tmp = 0;
11868     PL_reg_start_tmpl = 0;
11869     PL_reg_oldsaved = NULL;
11870     PL_reg_oldsavedlen = 0;
11871     PL_reg_maxiter = 0;
11872     PL_reg_leftiter = 0;
11873     PL_reg_poscache = NULL;
11874     PL_reg_poscache_size = 0;
11875 #ifdef PERL_OLD_COPY_ON_WRITE
11876     PL_nrs = NULL;
11877 #endif
11878
11879     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
11880     if (PL_curpm) {
11881         const REGEXP * const rx = PM_GETRE(PL_curpm);
11882         if (rx) {
11883             U32 i;
11884             for (i = 1; i <= RX_NPARENS(rx); i++) {
11885                 char digits[TYPE_CHARS(long)];
11886                 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
11887                 GV *const *const gvp
11888                     = (GV**)hv_fetch(PL_defstash, digits, len, 0);
11889
11890                 if (gvp) {
11891                     GV * const gv = *gvp;
11892                     if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
11893                         save_scalar(gv);
11894                 }
11895             }
11896         }
11897     }
11898 }
11899 #endif
11900
11901 static void
11902 clear_re(pTHX_ void *r)
11903 {
11904     dVAR;
11905     ReREFCNT_dec((REGEXP *)r);
11906 }
11907
11908 #ifdef DEBUGGING
11909
11910 STATIC void
11911 S_put_byte(pTHX_ SV *sv, int c)
11912 {
11913     PERL_ARGS_ASSERT_PUT_BYTE;
11914
11915     /* Our definition of isPRINT() ignores locales, so only bytes that are
11916        not part of UTF-8 are considered printable. I assume that the same
11917        holds for UTF-EBCDIC.
11918        Also, code point 255 is not printable in either (it's E0 in EBCDIC,
11919        which Wikipedia says:
11920
11921        EO, or Eight Ones, is an 8-bit EBCDIC character code represented as all
11922        ones (binary 1111 1111, hexadecimal FF). It is similar, but not
11923        identical, to the ASCII delete (DEL) or rubout control character.
11924        ) So the old condition can be simplified to !isPRINT(c)  */
11925     if (!isPRINT(c)) {
11926         if (c < 256) {
11927             Perl_sv_catpvf(aTHX_ sv, "\\x%02x", c);
11928         }
11929         else {
11930             Perl_sv_catpvf(aTHX_ sv, "\\x{%x}", c);
11931         }
11932     }
11933     else {
11934         const char string = c;
11935         if (c == '-' || c == ']' || c == '\\' || c == '^')
11936             sv_catpvs(sv, "\\");
11937         sv_catpvn(sv, &string, 1);
11938     }
11939 }
11940
11941
11942 #define CLEAR_OPTSTART \
11943     if (optstart) STMT_START { \
11944             DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
11945             optstart=NULL; \
11946     } STMT_END
11947
11948 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
11949
11950 STATIC const regnode *
11951 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
11952             const regnode *last, const regnode *plast, 
11953             SV* sv, I32 indent, U32 depth)
11954 {
11955     dVAR;
11956     register U8 op = PSEUDO;    /* Arbitrary non-END op. */
11957     register const regnode *next;
11958     const regnode *optstart= NULL;
11959     
11960     RXi_GET_DECL(r,ri);
11961     GET_RE_DEBUG_FLAGS_DECL;
11962
11963     PERL_ARGS_ASSERT_DUMPUNTIL;
11964
11965 #ifdef DEBUG_DUMPUNTIL
11966     PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
11967         last ? last-start : 0,plast ? plast-start : 0);
11968 #endif
11969             
11970     if (plast && plast < last) 
11971         last= plast;
11972
11973     while (PL_regkind[op] != END && (!last || node < last)) {
11974         /* While that wasn't END last time... */
11975         NODE_ALIGN(node);
11976         op = OP(node);
11977         if (op == CLOSE || op == WHILEM)
11978             indent--;
11979         next = regnext((regnode *)node);
11980
11981         /* Where, what. */
11982         if (OP(node) == OPTIMIZED) {
11983             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
11984                 optstart = node;
11985             else
11986                 goto after_print;
11987         } else
11988             CLEAR_OPTSTART;
11989         
11990         regprop(r, sv, node);
11991         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
11992                       (int)(2*indent + 1), "", SvPVX_const(sv));
11993         
11994         if (OP(node) != OPTIMIZED) {                  
11995             if (next == NULL)           /* Next ptr. */
11996                 PerlIO_printf(Perl_debug_log, " (0)");
11997             else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
11998                 PerlIO_printf(Perl_debug_log, " (FAIL)");
11999             else 
12000                 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
12001             (void)PerlIO_putc(Perl_debug_log, '\n'); 
12002         }
12003         
12004       after_print:
12005         if (PL_regkind[(U8)op] == BRANCHJ) {
12006             assert(next);
12007             {
12008                 register const regnode *nnode = (OP(next) == LONGJMP
12009                                              ? regnext((regnode *)next)
12010                                              : next);
12011                 if (last && nnode > last)
12012                     nnode = last;
12013                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
12014             }
12015         }
12016         else if (PL_regkind[(U8)op] == BRANCH) {
12017             assert(next);
12018             DUMPUNTIL(NEXTOPER(node), next);
12019         }
12020         else if ( PL_regkind[(U8)op]  == TRIE ) {
12021             const regnode *this_trie = node;
12022             const char op = OP(node);
12023             const U32 n = ARG(node);
12024             const reg_ac_data * const ac = op>=AHOCORASICK ?
12025                (reg_ac_data *)ri->data->data[n] :
12026                NULL;
12027             const reg_trie_data * const trie =
12028                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
12029 #ifdef DEBUGGING
12030             AV *const trie_words = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
12031 #endif
12032             const regnode *nextbranch= NULL;
12033             I32 word_idx;
12034             sv_setpvs(sv, "");
12035             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
12036                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
12037                 
12038                 PerlIO_printf(Perl_debug_log, "%*s%s ",
12039                    (int)(2*(indent+3)), "",
12040                     elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
12041                             PL_colors[0], PL_colors[1],
12042                             (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
12043                             PERL_PV_PRETTY_ELLIPSES    |
12044                             PERL_PV_PRETTY_LTGT
12045                             )
12046                             : "???"
12047                 );
12048                 if (trie->jump) {
12049                     U16 dist= trie->jump[word_idx+1];
12050                     PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
12051                                   (UV)((dist ? this_trie + dist : next) - start));
12052                     if (dist) {
12053                         if (!nextbranch)
12054                             nextbranch= this_trie + trie->jump[0];    
12055                         DUMPUNTIL(this_trie + dist, nextbranch);
12056                     }
12057                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
12058                         nextbranch= regnext((regnode *)nextbranch);
12059                 } else {
12060                     PerlIO_printf(Perl_debug_log, "\n");
12061                 }
12062             }
12063             if (last && next > last)
12064                 node= last;
12065             else
12066                 node= next;
12067         }
12068         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
12069             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
12070                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
12071         }
12072         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
12073             assert(next);
12074             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
12075         }
12076         else if ( op == PLUS || op == STAR) {
12077             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
12078         }
12079         else if (PL_regkind[(U8)op] == ANYOF) {
12080             /* arglen 1 + class block */
12081             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_CLASS)
12082                     ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
12083             node = NEXTOPER(node);
12084         }
12085         else if (PL_regkind[(U8)op] == EXACT) {
12086             /* Literal string, where present. */
12087             node += NODE_SZ_STR(node) - 1;
12088             node = NEXTOPER(node);
12089         }
12090         else {
12091             node = NEXTOPER(node);
12092             node += regarglen[(U8)op];
12093         }
12094         if (op == CURLYX || op == OPEN)
12095             indent++;
12096     }
12097     CLEAR_OPTSTART;
12098 #ifdef DEBUG_DUMPUNTIL    
12099     PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
12100 #endif
12101     return node;
12102 }
12103
12104 #endif  /* DEBUGGING */
12105
12106 /*
12107  * Local variables:
12108  * c-indentation-style: bsd
12109  * c-basic-offset: 4
12110  * indent-tabs-mode: t
12111  * End:
12112  *
12113  * ex: set ts=8 sts=4 sw=4 noet:
12114  */