]> git.vpit.fr Git - perl/modules/re-engine-Hooks.git/blob - src/5014000/regcomp.c
Attach the callbacks to every regexps in a thread-safe way
[perl/modules/re-engine-Hooks.git] / src / 5014000 / 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
2325     /*  Finish populating the prev field of the wordinfo array.  Walk back
2326      *  from each accept state until we find another accept state, and if
2327      *  so, point the first word's .prev field at the second word. If the
2328      *  second already has a .prev field set, stop now. This will be the
2329      *  case either if we've already processed that word's accept state,
2330      *  or that state had multiple words, and the overspill words were
2331      *  already linked up earlier.
2332      */
2333     {
2334         U16 word;
2335         U32 state;
2336         U16 prev;
2337
2338         for (word=1; word <= trie->wordcount; word++) {
2339             prev = 0;
2340             if (trie->wordinfo[word].prev)
2341                 continue;
2342             state = trie->wordinfo[word].accept;
2343             while (state) {
2344                 state = prev_states[state];
2345                 if (!state)
2346                     break;
2347                 prev = trie->states[state].wordnum;
2348                 if (prev)
2349                     break;
2350             }
2351             trie->wordinfo[word].prev = prev;
2352         }
2353         Safefree(prev_states);
2354     }
2355
2356
2357     /* and now dump out the compressed format */
2358     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
2359
2360     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
2361 #ifdef DEBUGGING
2362     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
2363     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
2364 #else
2365     SvREFCNT_dec(revcharmap);
2366 #endif
2367     return trie->jump 
2368            ? MADE_JUMP_TRIE 
2369            : trie->startstate>1 
2370              ? MADE_EXACT_TRIE 
2371              : MADE_TRIE;
2372 }
2373
2374 STATIC void
2375 S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source,  regnode *stclass, U32 depth)
2376 {
2377 /* The Trie is constructed and compressed now so we can build a fail array if it's needed
2378
2379    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
2380    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
2381    ISBN 0-201-10088-6
2382
2383    We find the fail state for each state in the trie, this state is the longest proper
2384    suffix of the current state's 'word' that is also a proper prefix of another word in our
2385    trie. State 1 represents the word '' and is thus the default fail state. This allows
2386    the DFA not to have to restart after its tried and failed a word at a given point, it
2387    simply continues as though it had been matching the other word in the first place.
2388    Consider
2389       'abcdgu'=~/abcdefg|cdgu/
2390    When we get to 'd' we are still matching the first word, we would encounter 'g' which would
2391    fail, which would bring us to the state representing 'd' in the second word where we would
2392    try 'g' and succeed, proceeding to match 'cdgu'.
2393  */
2394  /* add a fail transition */
2395     const U32 trie_offset = ARG(source);
2396     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
2397     U32 *q;
2398     const U32 ucharcount = trie->uniquecharcount;
2399     const U32 numstates = trie->statecount;
2400     const U32 ubound = trie->lasttrans + ucharcount;
2401     U32 q_read = 0;
2402     U32 q_write = 0;
2403     U32 charid;
2404     U32 base = trie->states[ 1 ].trans.base;
2405     U32 *fail;
2406     reg_ac_data *aho;
2407     const U32 data_slot = add_data( pRExC_state, 1, "T" );
2408     GET_RE_DEBUG_FLAGS_DECL;
2409
2410     PERL_ARGS_ASSERT_MAKE_TRIE_FAILTABLE;
2411 #ifndef DEBUGGING
2412     PERL_UNUSED_ARG(depth);
2413 #endif
2414
2415
2416     ARG_SET( stclass, data_slot );
2417     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
2418     RExC_rxi->data->data[ data_slot ] = (void*)aho;
2419     aho->trie=trie_offset;
2420     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
2421     Copy( trie->states, aho->states, numstates, reg_trie_state );
2422     Newxz( q, numstates, U32);
2423     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
2424     aho->refcount = 1;
2425     fail = aho->fail;
2426     /* initialize fail[0..1] to be 1 so that we always have
2427        a valid final fail state */
2428     fail[ 0 ] = fail[ 1 ] = 1;
2429
2430     for ( charid = 0; charid < ucharcount ; charid++ ) {
2431         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
2432         if ( newstate ) {
2433             q[ q_write ] = newstate;
2434             /* set to point at the root */
2435             fail[ q[ q_write++ ] ]=1;
2436         }
2437     }
2438     while ( q_read < q_write) {
2439         const U32 cur = q[ q_read++ % numstates ];
2440         base = trie->states[ cur ].trans.base;
2441
2442         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
2443             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
2444             if (ch_state) {
2445                 U32 fail_state = cur;
2446                 U32 fail_base;
2447                 do {
2448                     fail_state = fail[ fail_state ];
2449                     fail_base = aho->states[ fail_state ].trans.base;
2450                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
2451
2452                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
2453                 fail[ ch_state ] = fail_state;
2454                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
2455                 {
2456                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
2457                 }
2458                 q[ q_write++ % numstates] = ch_state;
2459             }
2460         }
2461     }
2462     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
2463        when we fail in state 1, this allows us to use the
2464        charclass scan to find a valid start char. This is based on the principle
2465        that theres a good chance the string being searched contains lots of stuff
2466        that cant be a start char.
2467      */
2468     fail[ 0 ] = fail[ 1 ] = 0;
2469     DEBUG_TRIE_COMPILE_r({
2470         PerlIO_printf(Perl_debug_log,
2471                       "%*sStclass Failtable (%"UVuf" states): 0", 
2472                       (int)(depth * 2), "", (UV)numstates
2473         );
2474         for( q_read=1; q_read<numstates; q_read++ ) {
2475             PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
2476         }
2477         PerlIO_printf(Perl_debug_log, "\n");
2478     });
2479     Safefree(q);
2480     /*RExC_seen |= REG_SEEN_TRIEDFA;*/
2481 }
2482
2483
2484 /*
2485  * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2486  * These need to be revisited when a newer toolchain becomes available.
2487  */
2488 #if defined(__sparc64__) && defined(__GNUC__)
2489 #   if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2490 #       undef  SPARC64_GCC_WORKAROUND
2491 #       define SPARC64_GCC_WORKAROUND 1
2492 #   endif
2493 #endif
2494
2495 #define DEBUG_PEEP(str,scan,depth) \
2496     DEBUG_OPTIMISE_r({if (scan){ \
2497        SV * const mysv=sv_newmortal(); \
2498        regnode *Next = regnext(scan); \
2499        regprop(RExC_rx, mysv, scan); \
2500        PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
2501        (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
2502        Next ? (REG_NODE_NUM(Next)) : 0 ); \
2503    }});
2504
2505
2506
2507
2508
2509 #define JOIN_EXACT(scan,min,flags) \
2510     if (PL_regkind[OP(scan)] == EXACT) \
2511         join_exact(pRExC_state,(scan),(min),(flags),NULL,depth+1)
2512
2513 STATIC U32
2514 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, I32 *min, U32 flags,regnode *val, U32 depth) {
2515     /* Merge several consecutive EXACTish nodes into one. */
2516     regnode *n = regnext(scan);
2517     U32 stringok = 1;
2518     regnode *next = scan + NODE_SZ_STR(scan);
2519     U32 merged = 0;
2520     U32 stopnow = 0;
2521 #ifdef DEBUGGING
2522     regnode *stop = scan;
2523     GET_RE_DEBUG_FLAGS_DECL;
2524 #else
2525     PERL_UNUSED_ARG(depth);
2526 #endif
2527
2528     PERL_ARGS_ASSERT_JOIN_EXACT;
2529 #ifndef EXPERIMENTAL_INPLACESCAN
2530     PERL_UNUSED_ARG(flags);
2531     PERL_UNUSED_ARG(val);
2532 #endif
2533     DEBUG_PEEP("join",scan,depth);
2534     
2535     /* Skip NOTHING, merge EXACT*. */
2536     while (n &&
2537            ( PL_regkind[OP(n)] == NOTHING ||
2538              (stringok && (OP(n) == OP(scan))))
2539            && NEXT_OFF(n)
2540            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
2541         
2542         if (OP(n) == TAIL || n > next)
2543             stringok = 0;
2544         if (PL_regkind[OP(n)] == NOTHING) {
2545             DEBUG_PEEP("skip:",n,depth);
2546             NEXT_OFF(scan) += NEXT_OFF(n);
2547             next = n + NODE_STEP_REGNODE;
2548 #ifdef DEBUGGING
2549             if (stringok)
2550                 stop = n;
2551 #endif
2552             n = regnext(n);
2553         }
2554         else if (stringok) {
2555             const unsigned int oldl = STR_LEN(scan);
2556             regnode * const nnext = regnext(n);
2557             
2558             DEBUG_PEEP("merg",n,depth);
2559             
2560             merged++;
2561             if (oldl + STR_LEN(n) > U8_MAX)
2562                 break;
2563             NEXT_OFF(scan) += NEXT_OFF(n);
2564             STR_LEN(scan) += STR_LEN(n);
2565             next = n + NODE_SZ_STR(n);
2566             /* Now we can overwrite *n : */
2567             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
2568 #ifdef DEBUGGING
2569             stop = next - 1;
2570 #endif
2571             n = nnext;
2572             if (stopnow) break;
2573         }
2574
2575 #ifdef EXPERIMENTAL_INPLACESCAN
2576         if (flags && !NEXT_OFF(n)) {
2577             DEBUG_PEEP("atch", val, depth);
2578             if (reg_off_by_arg[OP(n)]) {
2579                 ARG_SET(n, val - n);
2580             }
2581             else {
2582                 NEXT_OFF(n) = val - n;
2583             }
2584             stopnow = 1;
2585         }
2586 #endif
2587     }
2588 #define GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS   0x0390
2589 #define IOTA_D_T        GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS
2590 #define GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS     0x03B0
2591 #define UPSILON_D_T     GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS
2592
2593     if (UTF
2594         && ( OP(scan) == EXACTF || OP(scan) == EXACTFU || OP(scan) == EXACTFA)
2595         && ( STR_LEN(scan) >= 6 ) )
2596     {
2597     /*
2598     Two problematic code points in Unicode casefolding of EXACT nodes:
2599     
2600     U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
2601     U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
2602     
2603     which casefold to
2604     
2605     Unicode                      UTF-8
2606     
2607     U+03B9 U+0308 U+0301         0xCE 0xB9 0xCC 0x88 0xCC 0x81
2608     U+03C5 U+0308 U+0301         0xCF 0x85 0xCC 0x88 0xCC 0x81
2609     
2610     This means that in case-insensitive matching (or "loose matching",
2611     as Unicode calls it), an EXACTF of length six (the UTF-8 encoded byte
2612     length of the above casefolded versions) can match a target string
2613     of length two (the byte length of UTF-8 encoded U+0390 or U+03B0).
2614     This would rather mess up the minimum length computation.
2615     
2616     What we'll do is to look for the tail four bytes, and then peek
2617     at the preceding two bytes to see whether we need to decrease
2618     the minimum length by four (six minus two).
2619     
2620     Thanks to the design of UTF-8, there cannot be false matches:
2621     A sequence of valid UTF-8 bytes cannot be a subsequence of
2622     another valid sequence of UTF-8 bytes.
2623     
2624     */
2625          char * const s0 = STRING(scan), *s, *t;
2626          char * const s1 = s0 + STR_LEN(scan) - 1;
2627          char * const s2 = s1 - 4;
2628 #ifdef EBCDIC /* RD tunifold greek 0390 and 03B0 */
2629          const char t0[] = "\xaf\x49\xaf\x42";
2630 #else
2631          const char t0[] = "\xcc\x88\xcc\x81";
2632 #endif
2633          const char * const t1 = t0 + 3;
2634     
2635          for (s = s0 + 2;
2636               s < s2 && (t = ninstr(s, s1, t0, t1));
2637               s = t + 4) {
2638 #ifdef EBCDIC
2639               if (((U8)t[-1] == 0x68 && (U8)t[-2] == 0xB4) ||
2640                   ((U8)t[-1] == 0x46 && (U8)t[-2] == 0xB5))
2641 #else
2642               if (((U8)t[-1] == 0xB9 && (U8)t[-2] == 0xCE) ||
2643                   ((U8)t[-1] == 0x85 && (U8)t[-2] == 0xCF))
2644 #endif
2645                    *min -= 4;
2646          }
2647     }
2648     
2649 #ifdef DEBUGGING
2650     /* Allow dumping */
2651     n = scan + NODE_SZ_STR(scan);
2652     while (n <= stop) {
2653         if (PL_regkind[OP(n)] != NOTHING || OP(n) == NOTHING) {
2654             OP(n) = OPTIMIZED;
2655             NEXT_OFF(n) = 0;
2656         }
2657         n++;
2658     }
2659 #endif
2660     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
2661     return stopnow;
2662 }
2663
2664 /* REx optimizer.  Converts nodes into quicker variants "in place".
2665    Finds fixed substrings.  */
2666
2667 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
2668    to the position after last scanned or to NULL. */
2669
2670 #define INIT_AND_WITHP \
2671     assert(!and_withp); \
2672     Newx(and_withp,1,struct regnode_charclass_class); \
2673     SAVEFREEPV(and_withp)
2674
2675 /* this is a chain of data about sub patterns we are processing that
2676    need to be handled separately/specially in study_chunk. Its so
2677    we can simulate recursion without losing state.  */
2678 struct scan_frame;
2679 typedef struct scan_frame {
2680     regnode *last;  /* last node to process in this frame */
2681     regnode *next;  /* next node to process when last is reached */
2682     struct scan_frame *prev; /*previous frame*/
2683     I32 stop; /* what stopparen do we use */
2684 } scan_frame;
2685
2686
2687 #define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf)
2688
2689 #define CASE_SYNST_FNC(nAmE)                                       \
2690 case nAmE:                                                         \
2691     if (flags & SCF_DO_STCLASS_AND) {                              \
2692             for (value = 0; value < 256; value++)                  \
2693                 if (!is_ ## nAmE ## _cp(value))                       \
2694                     ANYOF_BITMAP_CLEAR(data->start_class, value);  \
2695     }                                                              \
2696     else {                                                         \
2697             for (value = 0; value < 256; value++)                  \
2698                 if (is_ ## nAmE ## _cp(value))                        \
2699                     ANYOF_BITMAP_SET(data->start_class, value);    \
2700     }                                                              \
2701     break;                                                         \
2702 case N ## nAmE:                                                    \
2703     if (flags & SCF_DO_STCLASS_AND) {                              \
2704             for (value = 0; value < 256; value++)                   \
2705                 if (is_ ## nAmE ## _cp(value))                         \
2706                     ANYOF_BITMAP_CLEAR(data->start_class, value);   \
2707     }                                                               \
2708     else {                                                          \
2709             for (value = 0; value < 256; value++)                   \
2710                 if (!is_ ## nAmE ## _cp(value))                        \
2711                     ANYOF_BITMAP_SET(data->start_class, value);     \
2712     }                                                               \
2713     break
2714
2715
2716
2717 STATIC I32
2718 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
2719                         I32 *minlenp, I32 *deltap,
2720                         regnode *last,
2721                         scan_data_t *data,
2722                         I32 stopparen,
2723                         U8* recursed,
2724                         struct regnode_charclass_class *and_withp,
2725                         U32 flags, U32 depth)
2726                         /* scanp: Start here (read-write). */
2727                         /* deltap: Write maxlen-minlen here. */
2728                         /* last: Stop before this one. */
2729                         /* data: string data about the pattern */
2730                         /* stopparen: treat close N as END */
2731                         /* recursed: which subroutines have we recursed into */
2732                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
2733 {
2734     dVAR;
2735     I32 min = 0, pars = 0, code;
2736     regnode *scan = *scanp, *next;
2737     I32 delta = 0;
2738     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
2739     int is_inf_internal = 0;            /* The studied chunk is infinite */
2740     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
2741     scan_data_t data_fake;
2742     SV *re_trie_maxbuff = NULL;
2743     regnode *first_non_open = scan;
2744     I32 stopmin = I32_MAX;
2745     scan_frame *frame = NULL;
2746     GET_RE_DEBUG_FLAGS_DECL;
2747
2748     PERL_ARGS_ASSERT_STUDY_CHUNK;
2749
2750 #ifdef DEBUGGING
2751     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
2752 #endif
2753
2754     if ( depth == 0 ) {
2755         while (first_non_open && OP(first_non_open) == OPEN)
2756             first_non_open=regnext(first_non_open);
2757     }
2758
2759
2760   fake_study_recurse:
2761     while ( scan && OP(scan) != END && scan < last ){
2762         /* Peephole optimizer: */
2763         DEBUG_STUDYDATA("Peep:", data,depth);
2764         DEBUG_PEEP("Peep",scan,depth);
2765         JOIN_EXACT(scan,&min,0);
2766
2767         /* Follow the next-chain of the current node and optimize
2768            away all the NOTHINGs from it.  */
2769         if (OP(scan) != CURLYX) {
2770             const int max = (reg_off_by_arg[OP(scan)]
2771                        ? I32_MAX
2772                        /* I32 may be smaller than U16 on CRAYs! */
2773                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
2774             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
2775             int noff;
2776             regnode *n = scan;
2777         
2778             /* Skip NOTHING and LONGJMP. */
2779             while ((n = regnext(n))
2780                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
2781                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
2782                    && off + noff < max)
2783                 off += noff;
2784             if (reg_off_by_arg[OP(scan)])
2785                 ARG(scan) = off;
2786             else
2787                 NEXT_OFF(scan) = off;
2788         }
2789
2790
2791
2792         /* The principal pseudo-switch.  Cannot be a switch, since we
2793            look into several different things.  */
2794         if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
2795                    || OP(scan) == IFTHEN) {
2796             next = regnext(scan);
2797             code = OP(scan);
2798             /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
2799         
2800             if (OP(next) == code || code == IFTHEN) {
2801                 /* NOTE - There is similar code to this block below for handling
2802                    TRIE nodes on a re-study.  If you change stuff here check there
2803                    too. */
2804                 I32 max1 = 0, min1 = I32_MAX, num = 0;
2805                 struct regnode_charclass_class accum;
2806                 regnode * const startbranch=scan;
2807                 
2808                 if (flags & SCF_DO_SUBSTR)
2809                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
2810                 if (flags & SCF_DO_STCLASS)
2811                     cl_init_zero(pRExC_state, &accum);
2812
2813                 while (OP(scan) == code) {
2814                     I32 deltanext, minnext, f = 0, fake;
2815                     struct regnode_charclass_class this_class;
2816
2817                     num++;
2818                     data_fake.flags = 0;
2819                     if (data) {
2820                         data_fake.whilem_c = data->whilem_c;
2821                         data_fake.last_closep = data->last_closep;
2822                     }
2823                     else
2824                         data_fake.last_closep = &fake;
2825
2826                     data_fake.pos_delta = delta;
2827                     next = regnext(scan);
2828                     scan = NEXTOPER(scan);
2829                     if (code != BRANCH)
2830                         scan = NEXTOPER(scan);
2831                     if (flags & SCF_DO_STCLASS) {
2832                         cl_init(pRExC_state, &this_class);
2833                         data_fake.start_class = &this_class;
2834                         f = SCF_DO_STCLASS_AND;
2835                     }
2836                     if (flags & SCF_WHILEM_VISITED_POS)
2837                         f |= SCF_WHILEM_VISITED_POS;
2838
2839                     /* we suppose the run is continuous, last=next...*/
2840                     minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
2841                                           next, &data_fake,
2842                                           stopparen, recursed, NULL, f,depth+1);
2843                     if (min1 > minnext)
2844                         min1 = minnext;
2845                     if (max1 < minnext + deltanext)
2846                         max1 = minnext + deltanext;
2847                     if (deltanext == I32_MAX)
2848                         is_inf = is_inf_internal = 1;
2849                     scan = next;
2850                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
2851                         pars++;
2852                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
2853                         if ( stopmin > minnext) 
2854                             stopmin = min + min1;
2855                         flags &= ~SCF_DO_SUBSTR;
2856                         if (data)
2857                             data->flags |= SCF_SEEN_ACCEPT;
2858                     }
2859                     if (data) {
2860                         if (data_fake.flags & SF_HAS_EVAL)
2861                             data->flags |= SF_HAS_EVAL;
2862                         data->whilem_c = data_fake.whilem_c;
2863                     }
2864                     if (flags & SCF_DO_STCLASS)
2865                         cl_or(pRExC_state, &accum, &this_class);
2866                 }
2867                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
2868                     min1 = 0;
2869                 if (flags & SCF_DO_SUBSTR) {
2870                     data->pos_min += min1;
2871                     data->pos_delta += max1 - min1;
2872                     if (max1 != min1 || is_inf)
2873                         data->longest = &(data->longest_float);
2874                 }
2875                 min += min1;
2876                 delta += max1 - min1;
2877                 if (flags & SCF_DO_STCLASS_OR) {
2878                     cl_or(pRExC_state, data->start_class, &accum);
2879                     if (min1) {
2880                         cl_and(data->start_class, and_withp);
2881                         flags &= ~SCF_DO_STCLASS;
2882                     }
2883                 }
2884                 else if (flags & SCF_DO_STCLASS_AND) {
2885                     if (min1) {
2886                         cl_and(data->start_class, &accum);
2887                         flags &= ~SCF_DO_STCLASS;
2888                     }
2889                     else {
2890                         /* Switch to OR mode: cache the old value of
2891                          * data->start_class */
2892                         INIT_AND_WITHP;
2893                         StructCopy(data->start_class, and_withp,
2894                                    struct regnode_charclass_class);
2895                         flags &= ~SCF_DO_STCLASS_AND;
2896                         StructCopy(&accum, data->start_class,
2897                                    struct regnode_charclass_class);
2898                         flags |= SCF_DO_STCLASS_OR;
2899                         data->start_class->flags |= ANYOF_EOS;
2900                     }
2901                 }
2902
2903                 if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) == BRANCH ) {
2904                 /* demq.
2905
2906                    Assuming this was/is a branch we are dealing with: 'scan' now
2907                    points at the item that follows the branch sequence, whatever
2908                    it is. We now start at the beginning of the sequence and look
2909                    for subsequences of
2910
2911                    BRANCH->EXACT=>x1
2912                    BRANCH->EXACT=>x2
2913                    tail
2914
2915                    which would be constructed from a pattern like /A|LIST|OF|WORDS/
2916
2917                    If we can find such a subsequence we need to turn the first
2918                    element into a trie and then add the subsequent branch exact
2919                    strings to the trie.
2920
2921                    We have two cases
2922
2923                      1. patterns where the whole set of branches can be converted. 
2924
2925                      2. patterns where only a subset can be converted.
2926
2927                    In case 1 we can replace the whole set with a single regop
2928                    for the trie. In case 2 we need to keep the start and end
2929                    branches so
2930
2931                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
2932                      becomes BRANCH TRIE; BRANCH X;
2933
2934                   There is an additional case, that being where there is a 
2935                   common prefix, which gets split out into an EXACT like node
2936                   preceding the TRIE node.
2937
2938                   If x(1..n)==tail then we can do a simple trie, if not we make
2939                   a "jump" trie, such that when we match the appropriate word
2940                   we "jump" to the appropriate tail node. Essentially we turn
2941                   a nested if into a case structure of sorts.
2942
2943                 */
2944                 
2945                     int made=0;
2946                     if (!re_trie_maxbuff) {
2947                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2948                         if (!SvIOK(re_trie_maxbuff))
2949                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2950                     }
2951                     if ( SvIV(re_trie_maxbuff)>=0  ) {
2952                         regnode *cur;
2953                         regnode *first = (regnode *)NULL;
2954                         regnode *last = (regnode *)NULL;
2955                         regnode *tail = scan;
2956                         U8 optype = 0;
2957                         U32 count=0;
2958
2959 #ifdef DEBUGGING
2960                         SV * const mysv = sv_newmortal();       /* for dumping */
2961 #endif
2962                         /* var tail is used because there may be a TAIL
2963                            regop in the way. Ie, the exacts will point to the
2964                            thing following the TAIL, but the last branch will
2965                            point at the TAIL. So we advance tail. If we
2966                            have nested (?:) we may have to move through several
2967                            tails.
2968                          */
2969
2970                         while ( OP( tail ) == TAIL ) {
2971                             /* this is the TAIL generated by (?:) */
2972                             tail = regnext( tail );
2973                         }
2974
2975                         
2976                         DEBUG_OPTIMISE_r({
2977                             regprop(RExC_rx, mysv, tail );
2978                             PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
2979                                 (int)depth * 2 + 2, "", 
2980                                 "Looking for TRIE'able sequences. Tail node is: ", 
2981                                 SvPV_nolen_const( mysv )
2982                             );
2983                         });
2984                         
2985                         /*
2986
2987                            step through the branches, cur represents each
2988                            branch, noper is the first thing to be matched
2989                            as part of that branch and noper_next is the
2990                            regnext() of that node. if noper is an EXACT
2991                            and noper_next is the same as scan (our current
2992                            position in the regex) then the EXACT branch is
2993                            a possible optimization target. Once we have
2994                            two or more consecutive such branches we can
2995                            create a trie of the EXACT's contents and stich
2996                            it in place. If the sequence represents all of
2997                            the branches we eliminate the whole thing and
2998                            replace it with a single TRIE. If it is a
2999                            subsequence then we need to stitch it in. This
3000                            means the first branch has to remain, and needs
3001                            to be repointed at the item on the branch chain
3002                            following the last branch optimized. This could
3003                            be either a BRANCH, in which case the
3004                            subsequence is internal, or it could be the
3005                            item following the branch sequence in which
3006                            case the subsequence is at the end.
3007
3008                         */
3009
3010                         /* dont use tail as the end marker for this traverse */
3011                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
3012                             regnode * const noper = NEXTOPER( cur );
3013 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
3014                             regnode * const noper_next = regnext( noper );
3015 #endif
3016
3017                             DEBUG_OPTIMISE_r({
3018                                 regprop(RExC_rx, mysv, cur);
3019                                 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
3020                                    (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
3021
3022                                 regprop(RExC_rx, mysv, noper);
3023                                 PerlIO_printf( Perl_debug_log, " -> %s",
3024                                     SvPV_nolen_const(mysv));
3025
3026                                 if ( noper_next ) {
3027                                   regprop(RExC_rx, mysv, noper_next );
3028                                   PerlIO_printf( Perl_debug_log,"\t=> %s\t",
3029                                     SvPV_nolen_const(mysv));
3030                                 }
3031                                 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d)\n",
3032                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur) );
3033                             });
3034                             if ( (((first && optype!=NOTHING) ? OP( noper ) == optype
3035                                          : PL_regkind[ OP( noper ) ] == EXACT )
3036                                   || OP(noper) == NOTHING )
3037 #ifdef NOJUMPTRIE
3038                                   && noper_next == tail
3039 #endif
3040                                   && count < U16_MAX)
3041                             {
3042                                 count++;
3043                                 if ( !first || optype == NOTHING ) {
3044                                     if (!first) first = cur;
3045                                     optype = OP( noper );
3046                                 } else {
3047                                     last = cur;
3048                                 }
3049                             } else {
3050 /* 
3051     Currently we do not believe that the trie logic can
3052     handle case insensitive matching properly when the
3053     pattern is not unicode (thus forcing unicode semantics).
3054
3055     If/when this is fixed the following define can be swapped
3056     in below to fully enable trie logic.
3057
3058     XXX It may work if not UTF and/or /a (AT_LEAST_UNI_SEMANTICS) but perhaps
3059     not /aa
3060
3061 #define TRIE_TYPE_IS_SAFE 1
3062
3063 */
3064 #define TRIE_TYPE_IS_SAFE ((UTF && UNI_SEMANTICS) || optype==EXACT)
3065
3066                                 if ( last && TRIE_TYPE_IS_SAFE ) {
3067                                     make_trie( pRExC_state, 
3068                                             startbranch, first, cur, tail, count, 
3069                                             optype, depth+1 );
3070                                 }
3071                                 if ( PL_regkind[ OP( noper ) ] == EXACT
3072 #ifdef NOJUMPTRIE
3073                                      && noper_next == tail
3074 #endif
3075                                 ){
3076                                     count = 1;
3077                                     first = cur;
3078                                     optype = OP( noper );
3079                                 } else {
3080                                     count = 0;
3081                                     first = NULL;
3082                                     optype = 0;
3083                                 }
3084                                 last = NULL;
3085                             }
3086                         }
3087                         DEBUG_OPTIMISE_r({
3088                             regprop(RExC_rx, mysv, cur);
3089                             PerlIO_printf( Perl_debug_log,
3090                               "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
3091                               "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3092
3093                         });
3094                         
3095                         if ( last && TRIE_TYPE_IS_SAFE ) {
3096                             made= make_trie( pRExC_state, startbranch, first, scan, tail, count, optype, depth+1 );
3097 #ifdef TRIE_STUDY_OPT   
3098                             if ( ((made == MADE_EXACT_TRIE && 
3099                                  startbranch == first) 
3100                                  || ( first_non_open == first )) && 
3101                                  depth==0 ) {
3102                                 flags |= SCF_TRIE_RESTUDY;
3103                                 if ( startbranch == first 
3104                                      && scan == tail ) 
3105                                 {
3106                                     RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
3107                                 }
3108                             }
3109 #endif
3110                         }
3111                     }
3112                     
3113                 } /* do trie */
3114                 
3115             }
3116             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
3117                 scan = NEXTOPER(NEXTOPER(scan));
3118             } else                      /* single branch is optimized. */
3119                 scan = NEXTOPER(scan);
3120             continue;
3121         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
3122             scan_frame *newframe = NULL;
3123             I32 paren;
3124             regnode *start;
3125             regnode *end;
3126
3127             if (OP(scan) != SUSPEND) {
3128             /* set the pointer */
3129                 if (OP(scan) == GOSUB) {
3130                     paren = ARG(scan);
3131                     RExC_recurse[ARG2L(scan)] = scan;
3132                     start = RExC_open_parens[paren-1];
3133                     end   = RExC_close_parens[paren-1];
3134                 } else {
3135                     paren = 0;
3136                     start = RExC_rxi->program + 1;
3137                     end   = RExC_opend;
3138                 }
3139                 if (!recursed) {
3140                     Newxz(recursed, (((RExC_npar)>>3) +1), U8);
3141                     SAVEFREEPV(recursed);
3142                 }
3143                 if (!PAREN_TEST(recursed,paren+1)) {
3144                     PAREN_SET(recursed,paren+1);
3145                     Newx(newframe,1,scan_frame);
3146                 } else {
3147                     if (flags & SCF_DO_SUBSTR) {
3148                         SCAN_COMMIT(pRExC_state,data,minlenp);
3149                         data->longest = &(data->longest_float);
3150                     }
3151                     is_inf = is_inf_internal = 1;
3152                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3153                         cl_anything(pRExC_state, data->start_class);
3154                     flags &= ~SCF_DO_STCLASS;
3155                 }
3156             } else {
3157                 Newx(newframe,1,scan_frame);
3158                 paren = stopparen;
3159                 start = scan+2;
3160                 end = regnext(scan);
3161             }
3162             if (newframe) {
3163                 assert(start);
3164                 assert(end);
3165                 SAVEFREEPV(newframe);
3166                 newframe->next = regnext(scan);
3167                 newframe->last = last;
3168                 newframe->stop = stopparen;
3169                 newframe->prev = frame;
3170
3171                 frame = newframe;
3172                 scan =  start;
3173                 stopparen = paren;
3174                 last = end;
3175
3176                 continue;
3177             }
3178         }
3179         else if (OP(scan) == EXACT) {
3180             I32 l = STR_LEN(scan);
3181             UV uc;
3182             if (UTF) {
3183                 const U8 * const s = (U8*)STRING(scan);
3184                 l = utf8_length(s, s + l);
3185                 uc = utf8_to_uvchr(s, NULL);
3186             } else {
3187                 uc = *((U8*)STRING(scan));
3188             }
3189             min += l;
3190             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
3191                 /* The code below prefers earlier match for fixed
3192                    offset, later match for variable offset.  */
3193                 if (data->last_end == -1) { /* Update the start info. */
3194                     data->last_start_min = data->pos_min;
3195                     data->last_start_max = is_inf
3196                         ? I32_MAX : data->pos_min + data->pos_delta;
3197                 }
3198                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
3199                 if (UTF)
3200                     SvUTF8_on(data->last_found);
3201                 {
3202                     SV * const sv = data->last_found;
3203                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3204                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
3205                     if (mg && mg->mg_len >= 0)
3206                         mg->mg_len += utf8_length((U8*)STRING(scan),
3207                                                   (U8*)STRING(scan)+STR_LEN(scan));
3208                 }
3209                 data->last_end = data->pos_min + l;
3210                 data->pos_min += l; /* As in the first entry. */
3211                 data->flags &= ~SF_BEFORE_EOL;
3212             }
3213             if (flags & SCF_DO_STCLASS_AND) {
3214                 /* Check whether it is compatible with what we know already! */
3215                 int compat = 1;
3216
3217
3218                 /* If compatible, we or it in below.  It is compatible if is
3219                  * in the bitmp and either 1) its bit or its fold is set, or 2)
3220                  * it's for a locale.  Even if there isn't unicode semantics
3221                  * here, at runtime there may be because of matching against a
3222                  * utf8 string, so accept a possible false positive for
3223                  * latin1-range folds */
3224                 if (uc >= 0x100 ||
3225                     (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3226                     && !ANYOF_BITMAP_TEST(data->start_class, uc)
3227                     && (!(data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD)
3228                         || !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3229                     )
3230                 {
3231                     compat = 0;
3232                 }
3233                 ANYOF_CLASS_ZERO(data->start_class);
3234                 ANYOF_BITMAP_ZERO(data->start_class);
3235                 if (compat)
3236                     ANYOF_BITMAP_SET(data->start_class, uc);
3237                 else if (uc >= 0x100) {
3238                     int i;
3239
3240                     /* Some Unicode code points fold to the Latin1 range; as
3241                      * XXX temporary code, instead of figuring out if this is
3242                      * one, just assume it is and set all the start class bits
3243                      * that could be some such above 255 code point's fold
3244                      * which will generate fals positives.  As the code
3245                      * elsewhere that does compute the fold settles down, it
3246                      * can be extracted out and re-used here */
3247                     for (i = 0; i < 256; i++){
3248                         if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3249                             ANYOF_BITMAP_SET(data->start_class, i);
3250                         }
3251                     }
3252                 }
3253                 data->start_class->flags &= ~ANYOF_EOS;
3254                 if (uc < 0x100)
3255                   data->start_class->flags &= ~ANYOF_UNICODE_ALL;
3256             }
3257             else if (flags & SCF_DO_STCLASS_OR) {
3258                 /* false positive possible if the class is case-folded */
3259                 if (uc < 0x100)
3260                     ANYOF_BITMAP_SET(data->start_class, uc);
3261                 else
3262                     data->start_class->flags |= ANYOF_UNICODE_ALL;
3263                 data->start_class->flags &= ~ANYOF_EOS;
3264                 cl_and(data->start_class, and_withp);
3265             }
3266             flags &= ~SCF_DO_STCLASS;
3267         }
3268         else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
3269             I32 l = STR_LEN(scan);
3270             UV uc = *((U8*)STRING(scan));
3271
3272             /* Search for fixed substrings supports EXACT only. */
3273             if (flags & SCF_DO_SUBSTR) {
3274                 assert(data);
3275                 SCAN_COMMIT(pRExC_state, data, minlenp);
3276             }
3277             if (UTF) {
3278                 const U8 * const s = (U8 *)STRING(scan);
3279                 l = utf8_length(s, s + l);
3280                 uc = utf8_to_uvchr(s, NULL);
3281             }
3282             min += l;
3283             if (flags & SCF_DO_SUBSTR)
3284                 data->pos_min += l;
3285             if (flags & SCF_DO_STCLASS_AND) {
3286                 /* Check whether it is compatible with what we know already! */
3287                 int compat = 1;
3288                 if (uc >= 0x100 ||
3289                  (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3290                   && !ANYOF_BITMAP_TEST(data->start_class, uc)
3291                   && !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3292                 {
3293                     compat = 0;
3294                 }
3295                 ANYOF_CLASS_ZERO(data->start_class);
3296                 ANYOF_BITMAP_ZERO(data->start_class);
3297                 if (compat) {
3298                     ANYOF_BITMAP_SET(data->start_class, uc);
3299                     data->start_class->flags &= ~ANYOF_EOS;
3300                     data->start_class->flags |= ANYOF_LOC_NONBITMAP_FOLD;
3301                     if (OP(scan) == EXACTFL) {
3302                         /* XXX This set is probably no longer necessary, and
3303                          * probably wrong as LOCALE now is on in the initial
3304                          * state */
3305                         data->start_class->flags |= ANYOF_LOCALE;
3306                     }
3307                     else {
3308
3309                         /* Also set the other member of the fold pair.  In case
3310                          * that unicode semantics is called for at runtime, use
3311                          * the full latin1 fold.  (Can't do this for locale,
3312                          * because not known until runtime */
3313                         ANYOF_BITMAP_SET(data->start_class, PL_fold_latin1[uc]);
3314                     }
3315                 }
3316                 else if (uc >= 0x100) {
3317                     int i;
3318                     for (i = 0; i < 256; i++){
3319                         if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3320                             ANYOF_BITMAP_SET(data->start_class, i);
3321                         }
3322                     }
3323                 }
3324             }
3325             else if (flags & SCF_DO_STCLASS_OR) {
3326                 if (data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD) {
3327                     /* false positive possible if the class is case-folded.
3328                        Assume that the locale settings are the same... */
3329                     if (uc < 0x100) {
3330                         ANYOF_BITMAP_SET(data->start_class, uc);
3331                         if (OP(scan) != EXACTFL) {
3332
3333                             /* And set the other member of the fold pair, but
3334                              * can't do that in locale because not known until
3335                              * run-time */
3336                             ANYOF_BITMAP_SET(data->start_class,
3337                                              PL_fold_latin1[uc]);
3338                         }
3339                     }
3340                     data->start_class->flags &= ~ANYOF_EOS;
3341                 }
3342                 cl_and(data->start_class, and_withp);
3343             }
3344             flags &= ~SCF_DO_STCLASS;
3345         }
3346         else if (REGNODE_VARIES(OP(scan))) {
3347             I32 mincount, maxcount, minnext, deltanext, fl = 0;
3348             I32 f = flags, pos_before = 0;
3349             regnode * const oscan = scan;
3350             struct regnode_charclass_class this_class;
3351             struct regnode_charclass_class *oclass = NULL;
3352             I32 next_is_eval = 0;
3353
3354             switch (PL_regkind[OP(scan)]) {
3355             case WHILEM:                /* End of (?:...)* . */
3356                 scan = NEXTOPER(scan);
3357                 goto finish;
3358             case PLUS:
3359                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
3360                     next = NEXTOPER(scan);
3361                     if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
3362                         mincount = 1;
3363                         maxcount = REG_INFTY;
3364                         next = regnext(scan);
3365                         scan = NEXTOPER(scan);
3366                         goto do_curly;
3367                     }
3368                 }
3369                 if (flags & SCF_DO_SUBSTR)
3370                     data->pos_min++;
3371                 min++;
3372                 /* Fall through. */
3373             case STAR:
3374                 if (flags & SCF_DO_STCLASS) {
3375                     mincount = 0;
3376                     maxcount = REG_INFTY;
3377                     next = regnext(scan);
3378                     scan = NEXTOPER(scan);
3379                     goto do_curly;
3380                 }
3381                 is_inf = is_inf_internal = 1;
3382                 scan = regnext(scan);
3383                 if (flags & SCF_DO_SUBSTR) {
3384                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
3385                     data->longest = &(data->longest_float);
3386                 }
3387                 goto optimize_curly_tail;
3388             case CURLY:
3389                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
3390                     && (scan->flags == stopparen))
3391                 {
3392                     mincount = 1;
3393                     maxcount = 1;
3394                 } else {
3395                     mincount = ARG1(scan);
3396                     maxcount = ARG2(scan);
3397                 }
3398                 next = regnext(scan);
3399                 if (OP(scan) == CURLYX) {
3400                     I32 lp = (data ? *(data->last_closep) : 0);
3401                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
3402                 }
3403                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3404                 next_is_eval = (OP(scan) == EVAL);
3405               do_curly:
3406                 if (flags & SCF_DO_SUBSTR) {
3407                     if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
3408                     pos_before = data->pos_min;
3409                 }
3410                 if (data) {
3411                     fl = data->flags;
3412                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
3413                     if (is_inf)
3414                         data->flags |= SF_IS_INF;
3415                 }
3416                 if (flags & SCF_DO_STCLASS) {
3417                     cl_init(pRExC_state, &this_class);
3418                     oclass = data->start_class;
3419                     data->start_class = &this_class;
3420                     f |= SCF_DO_STCLASS_AND;
3421                     f &= ~SCF_DO_STCLASS_OR;
3422                 }
3423                 /* Exclude from super-linear cache processing any {n,m}
3424                    regops for which the combination of input pos and regex
3425                    pos is not enough information to determine if a match
3426                    will be possible.
3427
3428                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
3429                    regex pos at the \s*, the prospects for a match depend not
3430                    only on the input position but also on how many (bar\s*)
3431                    repeats into the {4,8} we are. */
3432                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
3433                     f &= ~SCF_WHILEM_VISITED_POS;
3434
3435                 /* This will finish on WHILEM, setting scan, or on NULL: */
3436                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, 
3437                                       last, data, stopparen, recursed, NULL,
3438                                       (mincount == 0
3439                                         ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
3440
3441                 if (flags & SCF_DO_STCLASS)
3442                     data->start_class = oclass;
3443                 if (mincount == 0 || minnext == 0) {
3444                     if (flags & SCF_DO_STCLASS_OR) {
3445                         cl_or(pRExC_state, data->start_class, &this_class);
3446                     }
3447                     else if (flags & SCF_DO_STCLASS_AND) {
3448                         /* Switch to OR mode: cache the old value of
3449                          * data->start_class */
3450                         INIT_AND_WITHP;
3451                         StructCopy(data->start_class, and_withp,
3452                                    struct regnode_charclass_class);
3453                         flags &= ~SCF_DO_STCLASS_AND;
3454                         StructCopy(&this_class, data->start_class,
3455                                    struct regnode_charclass_class);
3456                         flags |= SCF_DO_STCLASS_OR;
3457                         data->start_class->flags |= ANYOF_EOS;
3458                     }
3459                 } else {                /* Non-zero len */
3460                     if (flags & SCF_DO_STCLASS_OR) {
3461                         cl_or(pRExC_state, data->start_class, &this_class);
3462                         cl_and(data->start_class, and_withp);
3463                     }
3464                     else if (flags & SCF_DO_STCLASS_AND)
3465                         cl_and(data->start_class, &this_class);
3466                     flags &= ~SCF_DO_STCLASS;
3467                 }
3468                 if (!scan)              /* It was not CURLYX, but CURLY. */
3469                     scan = next;
3470                 if ( /* ? quantifier ok, except for (?{ ... }) */
3471                     (next_is_eval || !(mincount == 0 && maxcount == 1))
3472                     && (minnext == 0) && (deltanext == 0)
3473                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
3474                     && maxcount <= REG_INFTY/3) /* Complement check for big count */
3475                 {
3476                     ckWARNreg(RExC_parse,
3477                               "Quantifier unexpected on zero-length expression");
3478                 }
3479
3480                 min += minnext * mincount;
3481                 is_inf_internal |= ((maxcount == REG_INFTY
3482                                      && (minnext + deltanext) > 0)
3483                                     || deltanext == I32_MAX);
3484                 is_inf |= is_inf_internal;
3485                 delta += (minnext + deltanext) * maxcount - minnext * mincount;
3486
3487                 /* Try powerful optimization CURLYX => CURLYN. */
3488                 if (  OP(oscan) == CURLYX && data
3489                       && data->flags & SF_IN_PAR
3490                       && !(data->flags & SF_HAS_EVAL)
3491                       && !deltanext && minnext == 1 ) {
3492                     /* Try to optimize to CURLYN.  */
3493                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
3494                     regnode * const nxt1 = nxt;
3495 #ifdef DEBUGGING
3496                     regnode *nxt2;
3497 #endif
3498
3499                     /* Skip open. */
3500                     nxt = regnext(nxt);
3501                     if (!REGNODE_SIMPLE(OP(nxt))
3502                         && !(PL_regkind[OP(nxt)] == EXACT
3503                              && STR_LEN(nxt) == 1))
3504                         goto nogo;
3505 #ifdef DEBUGGING
3506                     nxt2 = nxt;
3507 #endif
3508                     nxt = regnext(nxt);
3509                     if (OP(nxt) != CLOSE)
3510                         goto nogo;
3511                     if (RExC_open_parens) {
3512                         RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3513                         RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
3514                     }
3515                     /* Now we know that nxt2 is the only contents: */
3516                     oscan->flags = (U8)ARG(nxt);
3517                     OP(oscan) = CURLYN;
3518                     OP(nxt1) = NOTHING; /* was OPEN. */
3519
3520 #ifdef DEBUGGING
3521                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3522                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
3523                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
3524                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
3525                     OP(nxt + 1) = OPTIMIZED; /* was count. */
3526                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
3527 #endif
3528                 }
3529               nogo:
3530
3531                 /* Try optimization CURLYX => CURLYM. */
3532                 if (  OP(oscan) == CURLYX && data
3533                       && !(data->flags & SF_HAS_PAR)
3534                       && !(data->flags & SF_HAS_EVAL)
3535                       && !deltanext     /* atom is fixed width */
3536                       && minnext != 0   /* CURLYM can't handle zero width */
3537                 ) {
3538                     /* XXXX How to optimize if data == 0? */
3539                     /* Optimize to a simpler form.  */
3540                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
3541                     regnode *nxt2;
3542
3543                     OP(oscan) = CURLYM;
3544                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
3545                             && (OP(nxt2) != WHILEM))
3546                         nxt = nxt2;
3547                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
3548                     /* Need to optimize away parenths. */
3549                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
3550                         /* Set the parenth number.  */
3551                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
3552
3553                         oscan->flags = (U8)ARG(nxt);
3554                         if (RExC_open_parens) {
3555                             RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3556                             RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
3557                         }
3558                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
3559                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
3560
3561 #ifdef DEBUGGING
3562                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3563                         OP(nxt + 1) = OPTIMIZED; /* was count. */
3564                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
3565                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
3566 #endif
3567 #if 0
3568                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
3569                             regnode *nnxt = regnext(nxt1);
3570                             if (nnxt == nxt) {
3571                                 if (reg_off_by_arg[OP(nxt1)])
3572                                     ARG_SET(nxt1, nxt2 - nxt1);
3573                                 else if (nxt2 - nxt1 < U16_MAX)
3574                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
3575                                 else
3576                                     OP(nxt) = NOTHING;  /* Cannot beautify */
3577                             }
3578                             nxt1 = nnxt;
3579                         }
3580 #endif
3581                         /* Optimize again: */
3582                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
3583                                     NULL, stopparen, recursed, NULL, 0,depth+1);
3584                     }
3585                     else
3586                         oscan->flags = 0;
3587                 }
3588                 else if ((OP(oscan) == CURLYX)
3589                          && (flags & SCF_WHILEM_VISITED_POS)
3590                          /* See the comment on a similar expression above.
3591                             However, this time it's not a subexpression
3592                             we care about, but the expression itself. */
3593                          && (maxcount == REG_INFTY)
3594                          && data && ++data->whilem_c < 16) {
3595                     /* This stays as CURLYX, we can put the count/of pair. */
3596                     /* Find WHILEM (as in regexec.c) */
3597                     regnode *nxt = oscan + NEXT_OFF(oscan);
3598
3599                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
3600                         nxt += ARG(nxt);
3601                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
3602                         | (RExC_whilem_seen << 4)); /* On WHILEM */
3603                 }
3604                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
3605                     pars++;
3606                 if (flags & SCF_DO_SUBSTR) {
3607                     SV *last_str = NULL;
3608                     int counted = mincount != 0;
3609
3610                     if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
3611 #if defined(SPARC64_GCC_WORKAROUND)
3612                         I32 b = 0;
3613                         STRLEN l = 0;
3614                         const char *s = NULL;
3615                         I32 old = 0;
3616
3617                         if (pos_before >= data->last_start_min)
3618                             b = pos_before;
3619                         else
3620                             b = data->last_start_min;
3621
3622                         l = 0;
3623                         s = SvPV_const(data->last_found, l);
3624                         old = b - data->last_start_min;
3625
3626 #else
3627                         I32 b = pos_before >= data->last_start_min
3628                             ? pos_before : data->last_start_min;
3629                         STRLEN l;
3630                         const char * const s = SvPV_const(data->last_found, l);
3631                         I32 old = b - data->last_start_min;
3632 #endif
3633
3634                         if (UTF)
3635                             old = utf8_hop((U8*)s, old) - (U8*)s;
3636                         l -= old;
3637                         /* Get the added string: */
3638                         last_str = newSVpvn_utf8(s  + old, l, UTF);
3639                         if (deltanext == 0 && pos_before == b) {
3640                             /* What was added is a constant string */
3641                             if (mincount > 1) {
3642                                 SvGROW(last_str, (mincount * l) + 1);
3643                                 repeatcpy(SvPVX(last_str) + l,
3644                                           SvPVX_const(last_str), l, mincount - 1);
3645                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
3646                                 /* Add additional parts. */
3647                                 SvCUR_set(data->last_found,
3648                                           SvCUR(data->last_found) - l);
3649                                 sv_catsv(data->last_found, last_str);
3650                                 {
3651                                     SV * sv = data->last_found;
3652                                     MAGIC *mg =
3653                                         SvUTF8(sv) && SvMAGICAL(sv) ?
3654                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
3655                                     if (mg && mg->mg_len >= 0)
3656                                         mg->mg_len += CHR_SVLEN(last_str) - l;
3657                                 }
3658                                 data->last_end += l * (mincount - 1);
3659                             }
3660                         } else {
3661                             /* start offset must point into the last copy */
3662                             data->last_start_min += minnext * (mincount - 1);
3663                             data->last_start_max += is_inf ? I32_MAX
3664                                 : (maxcount - 1) * (minnext + data->pos_delta);
3665                         }
3666                     }
3667                     /* It is counted once already... */
3668                     data->pos_min += minnext * (mincount - counted);
3669                     data->pos_delta += - counted * deltanext +
3670                         (minnext + deltanext) * maxcount - minnext * mincount;
3671                     if (mincount != maxcount) {
3672                          /* Cannot extend fixed substrings found inside
3673                             the group.  */
3674                         SCAN_COMMIT(pRExC_state,data,minlenp);
3675                         if (mincount && last_str) {
3676                             SV * const sv = data->last_found;
3677                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3678                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
3679
3680                             if (mg)
3681                                 mg->mg_len = -1;
3682                             sv_setsv(sv, last_str);
3683                             data->last_end = data->pos_min;
3684                             data->last_start_min =
3685                                 data->pos_min - CHR_SVLEN(last_str);
3686                             data->last_start_max = is_inf
3687                                 ? I32_MAX
3688                                 : data->pos_min + data->pos_delta
3689                                 - CHR_SVLEN(last_str);
3690                         }
3691                         data->longest = &(data->longest_float);
3692                     }
3693                     SvREFCNT_dec(last_str);
3694                 }
3695                 if (data && (fl & SF_HAS_EVAL))
3696                     data->flags |= SF_HAS_EVAL;
3697               optimize_curly_tail:
3698                 if (OP(oscan) != CURLYX) {
3699                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
3700                            && NEXT_OFF(next))
3701                         NEXT_OFF(oscan) += NEXT_OFF(next);
3702                 }
3703                 continue;
3704             default:                    /* REF, ANYOFV, and CLUMP only? */
3705                 if (flags & SCF_DO_SUBSTR) {
3706                     SCAN_COMMIT(pRExC_state,data,minlenp);      /* Cannot expect anything... */
3707                     data->longest = &(data->longest_float);
3708                 }
3709                 is_inf = is_inf_internal = 1;
3710                 if (flags & SCF_DO_STCLASS_OR)
3711                     cl_anything(pRExC_state, data->start_class);
3712                 flags &= ~SCF_DO_STCLASS;
3713                 break;
3714             }
3715         }
3716         else if (OP(scan) == LNBREAK) {
3717             if (flags & SCF_DO_STCLASS) {
3718                 int value = 0;
3719                 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
3720                 if (flags & SCF_DO_STCLASS_AND) {
3721                     for (value = 0; value < 256; value++)
3722                         if (!is_VERTWS_cp(value))
3723                             ANYOF_BITMAP_CLEAR(data->start_class, value);
3724                 }
3725                 else {
3726                     for (value = 0; value < 256; value++)
3727                         if (is_VERTWS_cp(value))
3728                             ANYOF_BITMAP_SET(data->start_class, value);
3729                 }
3730                 if (flags & SCF_DO_STCLASS_OR)
3731                     cl_and(data->start_class, and_withp);
3732                 flags &= ~SCF_DO_STCLASS;
3733             }
3734             min += 1;
3735             delta += 1;
3736             if (flags & SCF_DO_SUBSTR) {
3737                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
3738                 data->pos_min += 1;
3739                 data->pos_delta += 1;
3740                 data->longest = &(data->longest_float);
3741             }
3742         }
3743         else if (OP(scan) == FOLDCHAR) {
3744             int d = ARG(scan) == LATIN_SMALL_LETTER_SHARP_S ? 1 : 2;
3745             flags &= ~SCF_DO_STCLASS;
3746             min += 1;
3747             delta += d;
3748             if (flags & SCF_DO_SUBSTR) {
3749                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
3750                 data->pos_min += 1;
3751                 data->pos_delta += d;
3752                 data->longest = &(data->longest_float);
3753             }
3754         }
3755         else if (REGNODE_SIMPLE(OP(scan))) {
3756             int value = 0;
3757
3758             if (flags & SCF_DO_SUBSTR) {
3759                 SCAN_COMMIT(pRExC_state,data,minlenp);
3760                 data->pos_min++;
3761             }
3762             min++;
3763             if (flags & SCF_DO_STCLASS) {
3764                 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
3765
3766                 /* Some of the logic below assumes that switching
3767                    locale on will only add false positives. */
3768                 switch (PL_regkind[OP(scan)]) {
3769                 case SANY:
3770                 default:
3771                   do_default:
3772                     /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
3773                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3774                         cl_anything(pRExC_state, data->start_class);
3775                     break;
3776                 case REG_ANY:
3777                     if (OP(scan) == SANY)
3778                         goto do_default;
3779                     if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
3780                         value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
3781                                  || ANYOF_CLASS_TEST_ANY_SET(data->start_class));
3782                         cl_anything(pRExC_state, data->start_class);
3783                     }
3784                     if (flags & SCF_DO_STCLASS_AND || !value)
3785                         ANYOF_BITMAP_CLEAR(data->start_class,'\n');
3786                     break;
3787                 case ANYOF:
3788                     if (flags & SCF_DO_STCLASS_AND)
3789                         cl_and(data->start_class,
3790                                (struct regnode_charclass_class*)scan);
3791                     else
3792                         cl_or(pRExC_state, data->start_class,
3793                               (struct regnode_charclass_class*)scan);
3794                     break;
3795                 case ALNUM:
3796                     if (flags & SCF_DO_STCLASS_AND) {
3797                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3798                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
3799                             if (OP(scan) == ALNUMU) {
3800                                 for (value = 0; value < 256; value++) {
3801                                     if (!isWORDCHAR_L1(value)) {
3802                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3803                                     }
3804                                 }
3805                             } else {
3806                                 for (value = 0; value < 256; value++) {
3807                                     if (!isALNUM(value)) {
3808                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3809                                     }
3810                                 }
3811                             }
3812                         }
3813                     }
3814                     else {
3815                         if (data->start_class->flags & ANYOF_LOCALE)
3816                             ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
3817
3818                         /* Even if under locale, set the bits for non-locale
3819                          * in case it isn't a true locale-node.  This will
3820                          * create false positives if it truly is locale */
3821                         if (OP(scan) == ALNUMU) {
3822                             for (value = 0; value < 256; value++) {
3823                                 if (isWORDCHAR_L1(value)) {
3824                                     ANYOF_BITMAP_SET(data->start_class, value);
3825                                 }
3826                             }
3827                         } else {
3828                             for (value = 0; value < 256; value++) {
3829                                 if (isALNUM(value)) {
3830                                     ANYOF_BITMAP_SET(data->start_class, value);
3831                                 }
3832                             }
3833                         }
3834                     }
3835                     break;
3836                 case NALNUM:
3837                     if (flags & SCF_DO_STCLASS_AND) {
3838                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3839                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
3840                             if (OP(scan) == NALNUMU) {
3841                                 for (value = 0; value < 256; value++) {
3842                                     if (isWORDCHAR_L1(value)) {
3843                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3844                                     }
3845                                 }
3846                             } else {
3847                                 for (value = 0; value < 256; value++) {
3848                                     if (isALNUM(value)) {
3849                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3850                                     }
3851                                 }
3852                             }
3853                         }
3854                     }
3855                     else {
3856                         if (data->start_class->flags & ANYOF_LOCALE)
3857                             ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
3858
3859                         /* Even if under locale, set the bits for non-locale in
3860                          * case it isn't a true locale-node.  This will create
3861                          * false positives if it truly is locale */
3862                         if (OP(scan) == NALNUMU) {
3863                             for (value = 0; value < 256; value++) {
3864                                 if (! isWORDCHAR_L1(value)) {
3865                                     ANYOF_BITMAP_SET(data->start_class, value);
3866                                 }
3867                             }
3868                         } else {
3869                             for (value = 0; value < 256; value++) {
3870                                 if (! isALNUM(value)) {
3871                                     ANYOF_BITMAP_SET(data->start_class, value);
3872                                 }
3873                             }
3874                         }
3875                     }
3876                     break;
3877                 case SPACE:
3878                     if (flags & SCF_DO_STCLASS_AND) {
3879                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3880                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
3881                             if (OP(scan) == SPACEU) {
3882                                 for (value = 0; value < 256; value++) {
3883                                     if (!isSPACE_L1(value)) {
3884                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3885                                     }
3886                                 }
3887                             } else {
3888                                 for (value = 0; value < 256; value++) {
3889                                     if (!isSPACE(value)) {
3890                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3891                                     }
3892                                 }
3893                             }
3894                         }
3895                     }
3896                     else {
3897                         if (data->start_class->flags & ANYOF_LOCALE) {
3898                             ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
3899                         }
3900                         if (OP(scan) == SPACEU) {
3901                             for (value = 0; value < 256; value++) {
3902                                 if (isSPACE_L1(value)) {
3903                                     ANYOF_BITMAP_SET(data->start_class, value);
3904                                 }
3905                             }
3906                         } else {
3907                             for (value = 0; value < 256; value++) {
3908                                 if (isSPACE(value)) {
3909                                     ANYOF_BITMAP_SET(data->start_class, value);
3910                                 }
3911                             }
3912                         }
3913                     }
3914                     break;
3915                 case NSPACE:
3916                     if (flags & SCF_DO_STCLASS_AND) {
3917                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3918                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
3919                             if (OP(scan) == NSPACEU) {
3920                                 for (value = 0; value < 256; value++) {
3921                                     if (isSPACE_L1(value)) {
3922                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3923                                     }
3924                                 }
3925                             } else {
3926                                 for (value = 0; value < 256; value++) {
3927                                     if (isSPACE(value)) {
3928                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3929                                     }
3930                                 }
3931                             }
3932                         }
3933                     }
3934                     else {
3935                         if (data->start_class->flags & ANYOF_LOCALE)
3936                             ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
3937                         if (OP(scan) == NSPACEU) {
3938                             for (value = 0; value < 256; value++) {
3939                                 if (!isSPACE_L1(value)) {
3940                                     ANYOF_BITMAP_SET(data->start_class, value);
3941                                 }
3942                             }
3943                         }
3944                         else {
3945                             for (value = 0; value < 256; value++) {
3946                                 if (!isSPACE(value)) {
3947                                     ANYOF_BITMAP_SET(data->start_class, value);
3948                                 }
3949                             }
3950                         }
3951                     }
3952                     break;
3953                 case DIGIT:
3954                     if (flags & SCF_DO_STCLASS_AND) {
3955                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3956                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
3957                             for (value = 0; value < 256; value++)
3958                                 if (!isDIGIT(value))
3959                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
3960                         }
3961                     }
3962                     else {
3963                         if (data->start_class->flags & ANYOF_LOCALE)
3964                             ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
3965                         for (value = 0; value < 256; value++)
3966                             if (isDIGIT(value))
3967                                 ANYOF_BITMAP_SET(data->start_class, value);
3968                     }
3969                     break;
3970                 case NDIGIT:
3971                     if (flags & SCF_DO_STCLASS_AND) {
3972                         if (!(data->start_class->flags & ANYOF_LOCALE))
3973                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
3974                         for (value = 0; value < 256; value++)
3975                             if (isDIGIT(value))
3976                                 ANYOF_BITMAP_CLEAR(data->start_class, value);
3977                     }
3978                     else {
3979                         if (data->start_class->flags & ANYOF_LOCALE)
3980                             ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
3981                         for (value = 0; value < 256; value++)
3982                             if (!isDIGIT(value))
3983                                 ANYOF_BITMAP_SET(data->start_class, value);
3984                     }
3985                     break;
3986                 CASE_SYNST_FNC(VERTWS);
3987                 CASE_SYNST_FNC(HORIZWS);
3988                 
3989                 }
3990                 if (flags & SCF_DO_STCLASS_OR)
3991                     cl_and(data->start_class, and_withp);
3992                 flags &= ~SCF_DO_STCLASS;
3993             }
3994         }
3995         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
3996             data->flags |= (OP(scan) == MEOL
3997                             ? SF_BEFORE_MEOL
3998                             : SF_BEFORE_SEOL);
3999         }
4000         else if (  PL_regkind[OP(scan)] == BRANCHJ
4001                  /* Lookbehind, or need to calculate parens/evals/stclass: */
4002                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
4003                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
4004             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY 
4005                 || OP(scan) == UNLESSM )
4006             {
4007                 /* Negative Lookahead/lookbehind
4008                    In this case we can't do fixed string optimisation.
4009                 */
4010
4011                 I32 deltanext, minnext, fake = 0;
4012                 regnode *nscan;
4013                 struct regnode_charclass_class intrnl;
4014                 int f = 0;
4015
4016                 data_fake.flags = 0;
4017                 if (data) {
4018                     data_fake.whilem_c = data->whilem_c;
4019                     data_fake.last_closep = data->last_closep;
4020                 }
4021                 else
4022                     data_fake.last_closep = &fake;
4023                 data_fake.pos_delta = delta;
4024                 if ( flags & SCF_DO_STCLASS && !scan->flags
4025                      && OP(scan) == IFMATCH ) { /* Lookahead */
4026                     cl_init(pRExC_state, &intrnl);
4027                     data_fake.start_class = &intrnl;
4028                     f |= SCF_DO_STCLASS_AND;
4029                 }
4030                 if (flags & SCF_WHILEM_VISITED_POS)
4031                     f |= SCF_WHILEM_VISITED_POS;
4032                 next = regnext(scan);
4033                 nscan = NEXTOPER(NEXTOPER(scan));
4034                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext, 
4035                     last, &data_fake, stopparen, recursed, NULL, f, depth+1);
4036                 if (scan->flags) {
4037                     if (deltanext) {
4038                         FAIL("Variable length lookbehind not implemented");
4039                     }
4040                     else if (minnext > (I32)U8_MAX) {
4041                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4042                     }
4043                     scan->flags = (U8)minnext;
4044                 }
4045                 if (data) {
4046                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4047                         pars++;
4048                     if (data_fake.flags & SF_HAS_EVAL)
4049                         data->flags |= SF_HAS_EVAL;
4050                     data->whilem_c = data_fake.whilem_c;
4051                 }
4052                 if (f & SCF_DO_STCLASS_AND) {
4053                     if (flags & SCF_DO_STCLASS_OR) {
4054                         /* OR before, AND after: ideally we would recurse with
4055                          * data_fake to get the AND applied by study of the
4056                          * remainder of the pattern, and then derecurse;
4057                          * *** HACK *** for now just treat as "no information".
4058                          * See [perl #56690].
4059                          */
4060                         cl_init(pRExC_state, data->start_class);
4061                     }  else {
4062                         /* AND before and after: combine and continue */
4063                         const int was = (data->start_class->flags & ANYOF_EOS);
4064
4065                         cl_and(data->start_class, &intrnl);
4066                         if (was)
4067                             data->start_class->flags |= ANYOF_EOS;
4068                     }
4069                 }
4070             }
4071 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
4072             else {
4073                 /* Positive Lookahead/lookbehind
4074                    In this case we can do fixed string optimisation,
4075                    but we must be careful about it. Note in the case of
4076                    lookbehind the positions will be offset by the minimum
4077                    length of the pattern, something we won't know about
4078                    until after the recurse.
4079                 */
4080                 I32 deltanext, fake = 0;
4081                 regnode *nscan;
4082                 struct regnode_charclass_class intrnl;
4083                 int f = 0;
4084                 /* We use SAVEFREEPV so that when the full compile 
4085                     is finished perl will clean up the allocated 
4086                     minlens when it's all done. This way we don't
4087                     have to worry about freeing them when we know
4088                     they wont be used, which would be a pain.
4089                  */
4090                 I32 *minnextp;
4091                 Newx( minnextp, 1, I32 );
4092                 SAVEFREEPV(minnextp);
4093
4094                 if (data) {
4095                     StructCopy(data, &data_fake, scan_data_t);
4096                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
4097                         f |= SCF_DO_SUBSTR;
4098                         if (scan->flags) 
4099                             SCAN_COMMIT(pRExC_state, &data_fake,minlenp);
4100                         data_fake.last_found=newSVsv(data->last_found);
4101                     }
4102                 }
4103                 else
4104                     data_fake.last_closep = &fake;
4105                 data_fake.flags = 0;
4106                 data_fake.pos_delta = delta;
4107                 if (is_inf)
4108                     data_fake.flags |= SF_IS_INF;
4109                 if ( flags & SCF_DO_STCLASS && !scan->flags
4110                      && OP(scan) == IFMATCH ) { /* Lookahead */
4111                     cl_init(pRExC_state, &intrnl);
4112                     data_fake.start_class = &intrnl;
4113                     f |= SCF_DO_STCLASS_AND;
4114                 }
4115                 if (flags & SCF_WHILEM_VISITED_POS)
4116                     f |= SCF_WHILEM_VISITED_POS;
4117                 next = regnext(scan);
4118                 nscan = NEXTOPER(NEXTOPER(scan));
4119
4120                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext, 
4121                     last, &data_fake, stopparen, recursed, NULL, f,depth+1);
4122                 if (scan->flags) {
4123                     if (deltanext) {
4124                         FAIL("Variable length lookbehind not implemented");
4125                     }
4126                     else if (*minnextp > (I32)U8_MAX) {
4127                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4128                     }
4129                     scan->flags = (U8)*minnextp;
4130                 }
4131
4132                 *minnextp += min;
4133
4134                 if (f & SCF_DO_STCLASS_AND) {
4135                     const int was = (data->start_class->flags & ANYOF_EOS);
4136
4137                     cl_and(data->start_class, &intrnl);
4138                     if (was)
4139                         data->start_class->flags |= ANYOF_EOS;
4140                 }
4141                 if (data) {
4142                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4143                         pars++;
4144                     if (data_fake.flags & SF_HAS_EVAL)
4145                         data->flags |= SF_HAS_EVAL;
4146                     data->whilem_c = data_fake.whilem_c;
4147                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
4148                         if (RExC_rx->minlen<*minnextp)
4149                             RExC_rx->minlen=*minnextp;
4150                         SCAN_COMMIT(pRExC_state, &data_fake, minnextp);
4151                         SvREFCNT_dec(data_fake.last_found);
4152                         
4153                         if ( data_fake.minlen_fixed != minlenp ) 
4154                         {
4155                             data->offset_fixed= data_fake.offset_fixed;
4156                             data->minlen_fixed= data_fake.minlen_fixed;
4157                             data->lookbehind_fixed+= scan->flags;
4158                         }
4159                         if ( data_fake.minlen_float != minlenp )
4160                         {
4161                             data->minlen_float= data_fake.minlen_float;
4162                             data->offset_float_min=data_fake.offset_float_min;
4163                             data->offset_float_max=data_fake.offset_float_max;
4164                             data->lookbehind_float+= scan->flags;
4165                         }
4166                     }
4167                 }
4168
4169
4170             }
4171 #endif
4172         }
4173         else if (OP(scan) == OPEN) {
4174             if (stopparen != (I32)ARG(scan))
4175                 pars++;
4176         }
4177         else if (OP(scan) == CLOSE) {
4178             if (stopparen == (I32)ARG(scan)) {
4179                 break;
4180             }
4181             if ((I32)ARG(scan) == is_par) {
4182                 next = regnext(scan);
4183
4184                 if ( next && (OP(next) != WHILEM) && next < last)
4185                     is_par = 0;         /* Disable optimization */
4186             }
4187             if (data)
4188                 *(data->last_closep) = ARG(scan);
4189         }
4190         else if (OP(scan) == EVAL) {
4191                 if (data)
4192                     data->flags |= SF_HAS_EVAL;
4193         }
4194         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
4195             if (flags & SCF_DO_SUBSTR) {
4196                 SCAN_COMMIT(pRExC_state,data,minlenp);
4197                 flags &= ~SCF_DO_SUBSTR;
4198             }
4199             if (data && OP(scan)==ACCEPT) {
4200                 data->flags |= SCF_SEEN_ACCEPT;
4201                 if (stopmin > min)
4202                     stopmin = min;
4203             }
4204         }
4205         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
4206         {
4207                 if (flags & SCF_DO_SUBSTR) {
4208                     SCAN_COMMIT(pRExC_state,data,minlenp);
4209                     data->longest = &(data->longest_float);
4210                 }
4211                 is_inf = is_inf_internal = 1;
4212                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4213                     cl_anything(pRExC_state, data->start_class);
4214                 flags &= ~SCF_DO_STCLASS;
4215         }
4216         else if (OP(scan) == GPOS) {
4217             if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) &&
4218                 !(delta || is_inf || (data && data->pos_delta))) 
4219             {
4220                 if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR))
4221                     RExC_rx->extflags |= RXf_ANCH_GPOS;
4222                 if (RExC_rx->gofs < (U32)min)
4223                     RExC_rx->gofs = min;
4224             } else {
4225                 RExC_rx->extflags |= RXf_GPOS_FLOAT;
4226                 RExC_rx->gofs = 0;
4227             }       
4228         }
4229 #ifdef TRIE_STUDY_OPT
4230 #ifdef FULL_TRIE_STUDY
4231         else if (PL_regkind[OP(scan)] == TRIE) {
4232             /* NOTE - There is similar code to this block above for handling
4233                BRANCH nodes on the initial study.  If you change stuff here
4234                check there too. */
4235             regnode *trie_node= scan;
4236             regnode *tail= regnext(scan);
4237             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4238             I32 max1 = 0, min1 = I32_MAX;
4239             struct regnode_charclass_class accum;
4240
4241             if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
4242                 SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
4243             if (flags & SCF_DO_STCLASS)
4244                 cl_init_zero(pRExC_state, &accum);
4245                 
4246             if (!trie->jump) {
4247                 min1= trie->minlen;
4248                 max1= trie->maxlen;
4249             } else {
4250                 const regnode *nextbranch= NULL;
4251                 U32 word;
4252                 
4253                 for ( word=1 ; word <= trie->wordcount ; word++) 
4254                 {
4255                     I32 deltanext=0, minnext=0, f = 0, fake;
4256                     struct regnode_charclass_class this_class;
4257                     
4258                     data_fake.flags = 0;
4259                     if (data) {
4260                         data_fake.whilem_c = data->whilem_c;
4261                         data_fake.last_closep = data->last_closep;
4262                     }
4263                     else
4264                         data_fake.last_closep = &fake;
4265                     data_fake.pos_delta = delta;
4266                     if (flags & SCF_DO_STCLASS) {
4267                         cl_init(pRExC_state, &this_class);
4268                         data_fake.start_class = &this_class;
4269                         f = SCF_DO_STCLASS_AND;
4270                     }
4271                     if (flags & SCF_WHILEM_VISITED_POS)
4272                         f |= SCF_WHILEM_VISITED_POS;
4273     
4274                     if (trie->jump[word]) {
4275                         if (!nextbranch)
4276                             nextbranch = trie_node + trie->jump[0];
4277                         scan= trie_node + trie->jump[word];
4278                         /* We go from the jump point to the branch that follows
4279                            it. Note this means we need the vestigal unused branches
4280                            even though they arent otherwise used.
4281                          */
4282                         minnext = study_chunk(pRExC_state, &scan, minlenp, 
4283                             &deltanext, (regnode *)nextbranch, &data_fake, 
4284                             stopparen, recursed, NULL, f,depth+1);
4285                     }
4286                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
4287                         nextbranch= regnext((regnode*)nextbranch);
4288                     
4289                     if (min1 > (I32)(minnext + trie->minlen))
4290                         min1 = minnext + trie->minlen;
4291                     if (max1 < (I32)(minnext + deltanext + trie->maxlen))
4292                         max1 = minnext + deltanext + trie->maxlen;
4293                     if (deltanext == I32_MAX)
4294                         is_inf = is_inf_internal = 1;
4295                     
4296                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4297                         pars++;
4298                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4299                         if ( stopmin > min + min1) 
4300                             stopmin = min + min1;
4301                         flags &= ~SCF_DO_SUBSTR;
4302                         if (data)
4303                             data->flags |= SCF_SEEN_ACCEPT;
4304                     }
4305                     if (data) {
4306                         if (data_fake.flags & SF_HAS_EVAL)
4307                             data->flags |= SF_HAS_EVAL;
4308                         data->whilem_c = data_fake.whilem_c;
4309                     }
4310                     if (flags & SCF_DO_STCLASS)
4311                         cl_or(pRExC_state, &accum, &this_class);
4312                 }
4313             }
4314             if (flags & SCF_DO_SUBSTR) {
4315                 data->pos_min += min1;
4316                 data->pos_delta += max1 - min1;
4317                 if (max1 != min1 || is_inf)
4318                     data->longest = &(data->longest_float);
4319             }
4320             min += min1;
4321             delta += max1 - min1;
4322             if (flags & SCF_DO_STCLASS_OR) {
4323                 cl_or(pRExC_state, data->start_class, &accum);
4324                 if (min1) {
4325                     cl_and(data->start_class, and_withp);
4326                     flags &= ~SCF_DO_STCLASS;
4327                 }
4328             }
4329             else if (flags & SCF_DO_STCLASS_AND) {
4330                 if (min1) {
4331                     cl_and(data->start_class, &accum);
4332                     flags &= ~SCF_DO_STCLASS;
4333                 }
4334                 else {
4335                     /* Switch to OR mode: cache the old value of
4336                      * data->start_class */
4337                     INIT_AND_WITHP;
4338                     StructCopy(data->start_class, and_withp,
4339                                struct regnode_charclass_class);
4340                     flags &= ~SCF_DO_STCLASS_AND;
4341                     StructCopy(&accum, data->start_class,
4342                                struct regnode_charclass_class);
4343                     flags |= SCF_DO_STCLASS_OR;
4344                     data->start_class->flags |= ANYOF_EOS;
4345                 }
4346             }
4347             scan= tail;
4348             continue;
4349         }
4350 #else
4351         else if (PL_regkind[OP(scan)] == TRIE) {
4352             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4353             U8*bang=NULL;
4354             
4355             min += trie->minlen;
4356             delta += (trie->maxlen - trie->minlen);
4357             flags &= ~SCF_DO_STCLASS; /* xxx */
4358             if (flags & SCF_DO_SUBSTR) {
4359                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
4360                 data->pos_min += trie->minlen;
4361                 data->pos_delta += (trie->maxlen - trie->minlen);
4362                 if (trie->maxlen != trie->minlen)
4363                     data->longest = &(data->longest_float);
4364             }
4365             if (trie->jump) /* no more substrings -- for now /grr*/
4366                 flags &= ~SCF_DO_SUBSTR; 
4367         }
4368 #endif /* old or new */
4369 #endif /* TRIE_STUDY_OPT */     
4370
4371         /* Else: zero-length, ignore. */
4372         scan = regnext(scan);
4373     }
4374     if (frame) {
4375         last = frame->last;
4376         scan = frame->next;
4377         stopparen = frame->stop;
4378         frame = frame->prev;
4379         goto fake_study_recurse;
4380     }
4381
4382   finish:
4383     assert(!frame);
4384     DEBUG_STUDYDATA("pre-fin:",data,depth);
4385
4386     *scanp = scan;
4387     *deltap = is_inf_internal ? I32_MAX : delta;
4388     if (flags & SCF_DO_SUBSTR && is_inf)
4389         data->pos_delta = I32_MAX - data->pos_min;
4390     if (is_par > (I32)U8_MAX)
4391         is_par = 0;
4392     if (is_par && pars==1 && data) {
4393         data->flags |= SF_IN_PAR;
4394         data->flags &= ~SF_HAS_PAR;
4395     }
4396     else if (pars && data) {
4397         data->flags |= SF_HAS_PAR;
4398         data->flags &= ~SF_IN_PAR;
4399     }
4400     if (flags & SCF_DO_STCLASS_OR)
4401         cl_and(data->start_class, and_withp);
4402     if (flags & SCF_TRIE_RESTUDY)
4403         data->flags |=  SCF_TRIE_RESTUDY;
4404     
4405     DEBUG_STUDYDATA("post-fin:",data,depth);
4406     
4407     return min < stopmin ? min : stopmin;
4408 }
4409
4410 STATIC U32
4411 S_add_data(RExC_state_t *pRExC_state, U32 n, const char *s)
4412 {
4413     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
4414
4415     PERL_ARGS_ASSERT_ADD_DATA;
4416
4417     Renewc(RExC_rxi->data,
4418            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
4419            char, struct reg_data);
4420     if(count)
4421         Renew(RExC_rxi->data->what, count + n, U8);
4422     else
4423         Newx(RExC_rxi->data->what, n, U8);
4424     RExC_rxi->data->count = count + n;
4425     Copy(s, RExC_rxi->data->what + count, n, U8);
4426     return count;
4427 }
4428
4429 /*XXX: todo make this not included in a non debugging perl */
4430 #ifndef PERL_IN_XSUB_RE
4431 void
4432 Perl_reginitcolors(pTHX)
4433 {
4434     dVAR;
4435     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
4436     if (s) {
4437         char *t = savepv(s);
4438         int i = 0;
4439         PL_colors[0] = t;
4440         while (++i < 6) {
4441             t = strchr(t, '\t');
4442             if (t) {
4443                 *t = '\0';
4444                 PL_colors[i] = ++t;
4445             }
4446             else
4447                 PL_colors[i] = t = (char *)"";
4448         }
4449     } else {
4450         int i = 0;
4451         while (i < 6)
4452             PL_colors[i++] = (char *)"";
4453     }
4454     PL_colorset = 1;
4455 }
4456 #endif
4457
4458
4459 #ifdef TRIE_STUDY_OPT
4460 #define CHECK_RESTUDY_GOTO                                  \
4461         if (                                                \
4462               (data.flags & SCF_TRIE_RESTUDY)               \
4463               && ! restudied++                              \
4464         )     goto reStudy
4465 #else
4466 #define CHECK_RESTUDY_GOTO
4467 #endif        
4468
4469 /*
4470  - pregcomp - compile a regular expression into internal code
4471  *
4472  * We can't allocate space until we know how big the compiled form will be,
4473  * but we can't compile it (and thus know how big it is) until we've got a
4474  * place to put the code.  So we cheat:  we compile it twice, once with code
4475  * generation turned off and size counting turned on, and once "for real".
4476  * This also means that we don't allocate space until we are sure that the
4477  * thing really will compile successfully, and we never have to move the
4478  * code and thus invalidate pointers into it.  (Note that it has to be in
4479  * one piece because free() must be able to free it all.) [NB: not true in perl]
4480  *
4481  * Beware that the optimization-preparation code in here knows about some
4482  * of the structure of the compiled regexp.  [I'll say.]
4483  */
4484
4485
4486
4487 #ifndef PERL_IN_XSUB_RE
4488 #define RE_ENGINE_PTR &PL_core_reg_engine
4489 #else
4490 extern const struct regexp_engine my_reg_engine;
4491 #define RE_ENGINE_PTR &my_reg_engine
4492 #endif
4493
4494 #ifndef PERL_IN_XSUB_RE 
4495 REGEXP *
4496 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
4497 {
4498     dVAR;
4499     HV * const table = GvHV(PL_hintgv);
4500
4501     PERL_ARGS_ASSERT_PREGCOMP;
4502
4503     /* Dispatch a request to compile a regexp to correct 
4504        regexp engine. */
4505     if (table) {
4506         SV **ptr= hv_fetchs(table, "regcomp", FALSE);
4507         GET_RE_DEBUG_FLAGS_DECL;
4508         if (ptr && SvIOK(*ptr) && SvIV(*ptr)) {
4509             const regexp_engine *eng=INT2PTR(regexp_engine*,SvIV(*ptr));
4510             DEBUG_COMPILE_r({
4511                 PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
4512                     SvIV(*ptr));
4513             });            
4514             return CALLREGCOMP_ENG(eng, pattern, flags);
4515         } 
4516     }
4517     return Perl_re_compile(aTHX_ pattern, flags);
4518 }
4519 #endif
4520
4521 REGEXP *
4522 Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags)
4523 {
4524     dVAR;
4525     REGEXP *rx;
4526     struct regexp *r;
4527     register regexp_internal *ri;
4528     STRLEN plen;
4529     char  *exp;
4530     char* xend;
4531     regnode *scan;
4532     I32 flags;
4533     I32 minlen = 0;
4534     U32 pm_flags;
4535
4536     /* these are all flags - maybe they should be turned
4537      * into a single int with different bit masks */
4538     I32 sawlookahead = 0;
4539     I32 sawplus = 0;
4540     I32 sawopen = 0;
4541     bool used_setjump = FALSE;
4542     regex_charset initial_charset = get_regex_charset(orig_pm_flags);
4543
4544     U8 jump_ret = 0;
4545     dJMPENV;
4546     scan_data_t data;
4547     RExC_state_t RExC_state;
4548     RExC_state_t * const pRExC_state = &RExC_state;
4549 #ifdef TRIE_STUDY_OPT    
4550     int restudied;
4551     RExC_state_t copyRExC_state;
4552 #endif    
4553     GET_RE_DEBUG_FLAGS_DECL;
4554
4555     PERL_ARGS_ASSERT_RE_COMPILE;
4556
4557     DEBUG_r(if (!PL_colorset) reginitcolors());
4558
4559     RExC_utf8 = RExC_orig_utf8 = SvUTF8(pattern);
4560     RExC_uni_semantics = 0;
4561     RExC_contains_locale = 0;
4562
4563     /****************** LONG JUMP TARGET HERE***********************/
4564     /* Longjmp back to here if have to switch in midstream to utf8 */
4565     if (! RExC_orig_utf8) {
4566         JMPENV_PUSH(jump_ret);
4567         used_setjump = TRUE;
4568     }
4569
4570     if (jump_ret == 0) {    /* First time through */
4571         exp = SvPV(pattern, plen);
4572         xend = exp + plen;
4573         /* ignore the utf8ness if the pattern is 0 length */
4574         if (plen == 0) {
4575             RExC_utf8 = RExC_orig_utf8 = 0;
4576         }
4577
4578         DEBUG_COMPILE_r({
4579             SV *dsv= sv_newmortal();
4580             RE_PV_QUOTED_DECL(s, RExC_utf8,
4581                 dsv, exp, plen, 60);
4582             PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
4583                            PL_colors[4],PL_colors[5],s);
4584         });
4585     }
4586     else {  /* longjumped back */
4587         STRLEN len = plen;
4588
4589         /* If the cause for the longjmp was other than changing to utf8, pop
4590          * our own setjmp, and longjmp to the correct handler */
4591         if (jump_ret != UTF8_LONGJMP) {
4592             JMPENV_POP;
4593             JMPENV_JUMP(jump_ret);
4594         }
4595
4596         GET_RE_DEBUG_FLAGS;
4597
4598         /* It's possible to write a regexp in ascii that represents Unicode
4599         codepoints outside of the byte range, such as via \x{100}. If we
4600         detect such a sequence we have to convert the entire pattern to utf8
4601         and then recompile, as our sizing calculation will have been based
4602         on 1 byte == 1 character, but we will need to use utf8 to encode
4603         at least some part of the pattern, and therefore must convert the whole
4604         thing.
4605         -- dmq */
4606         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
4607             "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
4608         exp = (char*)Perl_bytes_to_utf8(aTHX_ (U8*)SvPV(pattern, plen), &len);
4609         xend = exp + len;
4610         RExC_orig_utf8 = RExC_utf8 = 1;
4611         SAVEFREEPV(exp);
4612     }
4613
4614 #ifdef TRIE_STUDY_OPT
4615     restudied = 0;
4616 #endif
4617
4618     pm_flags = orig_pm_flags;
4619
4620     if (initial_charset == REGEX_LOCALE_CHARSET) {
4621         RExC_contains_locale = 1;
4622     }
4623     else if (RExC_utf8 && initial_charset == REGEX_DEPENDS_CHARSET) {
4624
4625         /* Set to use unicode semantics if the pattern is in utf8 and has the
4626          * 'depends' charset specified, as it means unicode when utf8  */
4627         set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
4628     }
4629
4630     RExC_precomp = exp;
4631     RExC_flags = pm_flags;
4632     RExC_sawback = 0;
4633
4634     RExC_seen = 0;
4635     RExC_in_lookbehind = 0;
4636     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
4637     RExC_seen_evals = 0;
4638     RExC_extralen = 0;
4639     RExC_override_recoding = 0;
4640
4641     /* First pass: determine size, legality. */
4642     RExC_parse = exp;
4643     RExC_start = exp;
4644     RExC_end = xend;
4645     RExC_naughty = 0;
4646     RExC_npar = 1;
4647     RExC_nestroot = 0;
4648     RExC_size = 0L;
4649     RExC_emit = &PL_regdummy;
4650     RExC_whilem_seen = 0;
4651     RExC_open_parens = NULL;
4652     RExC_close_parens = NULL;
4653     RExC_opend = NULL;
4654     RExC_paren_names = NULL;
4655 #ifdef DEBUGGING
4656     RExC_paren_name_list = NULL;
4657 #endif
4658     RExC_recurse = NULL;
4659     RExC_recurse_count = 0;
4660
4661 #if 0 /* REGC() is (currently) a NOP at the first pass.
4662        * Clever compilers notice this and complain. --jhi */
4663     REGC((U8)REG_MAGIC, (char*)RExC_emit);
4664 #endif
4665     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n"));
4666     if (reg(pRExC_state, 0, &flags,1) == NULL) {
4667         RExC_precomp = NULL;
4668         return(NULL);
4669     }
4670
4671     /* Here, finished first pass.  Get rid of any added setjmp */
4672     if (used_setjump) {
4673         JMPENV_POP;
4674     }
4675
4676     DEBUG_PARSE_r({
4677         PerlIO_printf(Perl_debug_log, 
4678             "Required size %"IVdf" nodes\n"
4679             "Starting second pass (creation)\n", 
4680             (IV)RExC_size);
4681         RExC_lastnum=0; 
4682         RExC_lastparse=NULL; 
4683     });
4684
4685     /* The first pass could have found things that force Unicode semantics */
4686     if ((RExC_utf8 || RExC_uni_semantics)
4687          && get_regex_charset(pm_flags) == REGEX_DEPENDS_CHARSET)
4688     {
4689         set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
4690     }
4691
4692     /* Small enough for pointer-storage convention?
4693        If extralen==0, this means that we will not need long jumps. */
4694     if (RExC_size >= 0x10000L && RExC_extralen)
4695         RExC_size += RExC_extralen;
4696     else
4697         RExC_extralen = 0;
4698     if (RExC_whilem_seen > 15)
4699         RExC_whilem_seen = 15;
4700
4701     /* Allocate space and zero-initialize. Note, the two step process 
4702        of zeroing when in debug mode, thus anything assigned has to 
4703        happen after that */
4704     rx = (REGEXP*) newSV_type(SVt_REGEXP);
4705     r = (struct regexp*)SvANY(rx);
4706     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
4707          char, regexp_internal);
4708     if ( r == NULL || ri == NULL )
4709         FAIL("Regexp out of space");
4710 #ifdef DEBUGGING
4711     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
4712     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char);
4713 #else 
4714     /* bulk initialize base fields with 0. */
4715     Zero(ri, sizeof(regexp_internal), char);        
4716 #endif
4717
4718     /* non-zero initialization begins here */
4719     RXi_SET( r, ri );
4720     r->engine= RE_ENGINE_PTR;
4721     r->extflags = pm_flags;
4722     {
4723         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
4724         bool has_charset = (get_regex_charset(r->extflags) != REGEX_DEPENDS_CHARSET);
4725
4726         /* The caret is output if there are any defaults: if not all the STD
4727          * flags are set, or if no character set specifier is needed */
4728         bool has_default =
4729                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
4730                     || ! has_charset);
4731         bool has_runon = ((RExC_seen & REG_SEEN_RUN_ON_COMMENT)==REG_SEEN_RUN_ON_COMMENT);
4732         U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD)
4733                             >> RXf_PMf_STD_PMMOD_SHIFT);
4734         const char *fptr = STD_PAT_MODS;        /*"msix"*/
4735         char *p;
4736         /* Allocate for the worst case, which is all the std flags are turned
4737          * on.  If more precision is desired, we could do a population count of
4738          * the flags set.  This could be done with a small lookup table, or by
4739          * shifting, masking and adding, or even, when available, assembly
4740          * language for a machine-language population count.
4741          * We never output a minus, as all those are defaults, so are
4742          * covered by the caret */
4743         const STRLEN wraplen = plen + has_p + has_runon
4744             + has_default       /* If needs a caret */
4745
4746                 /* If needs a character set specifier */
4747             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
4748             + (sizeof(STD_PAT_MODS) - 1)
4749             + (sizeof("(?:)") - 1);
4750
4751         p = sv_grow(MUTABLE_SV(rx), wraplen + 1); /* +1 for the ending NUL */
4752         SvPOK_on(rx);
4753         SvFLAGS(rx) |= SvUTF8(pattern);
4754         *p++='('; *p++='?';
4755
4756         /* If a default, cover it using the caret */
4757         if (has_default) {
4758             *p++= DEFAULT_PAT_MOD;
4759         }
4760         if (has_charset) {
4761             STRLEN len;
4762             const char* const name = get_regex_charset_name(r->extflags, &len);
4763             Copy(name, p, len, char);
4764             p += len;
4765         }
4766         if (has_p)
4767             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
4768         {
4769             char ch;
4770             while((ch = *fptr++)) {
4771                 if(reganch & 1)
4772                     *p++ = ch;
4773                 reganch >>= 1;
4774             }
4775         }
4776
4777         *p++ = ':';
4778         Copy(RExC_precomp, p, plen, char);
4779         assert ((RX_WRAPPED(rx) - p) < 16);
4780         r->pre_prefix = p - RX_WRAPPED(rx);
4781         p += plen;
4782         if (has_runon)
4783             *p++ = '\n';
4784         *p++ = ')';
4785         *p = 0;
4786         SvCUR_set(rx, p - SvPVX_const(rx));
4787     }
4788
4789     r->intflags = 0;
4790     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
4791     
4792     if (RExC_seen & REG_SEEN_RECURSE) {
4793         Newxz(RExC_open_parens, RExC_npar,regnode *);
4794         SAVEFREEPV(RExC_open_parens);
4795         Newxz(RExC_close_parens,RExC_npar,regnode *);
4796         SAVEFREEPV(RExC_close_parens);
4797     }
4798
4799     /* Useful during FAIL. */
4800 #ifdef RE_TRACK_PATTERN_OFFSETS
4801     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
4802     DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
4803                           "%s %"UVuf" bytes for offset annotations.\n",
4804                           ri->u.offsets ? "Got" : "Couldn't get",
4805                           (UV)((2*RExC_size+1) * sizeof(U32))));
4806 #endif
4807     SetProgLen(ri,RExC_size);
4808     RExC_rx_sv = rx;
4809     RExC_rx = r;
4810     RExC_rxi = ri;
4811     REH_CALL_COMP_BEGIN_HOOK(pRExC_state->rx);
4812
4813     /* Second pass: emit code. */
4814     RExC_flags = pm_flags;      /* don't let top level (?i) bleed */
4815     RExC_parse = exp;
4816     RExC_end = xend;
4817     RExC_naughty = 0;
4818     RExC_npar = 1;
4819     RExC_emit_start = ri->program;
4820     RExC_emit = ri->program;
4821     RExC_emit_bound = ri->program + RExC_size + 1;
4822
4823     /* Store the count of eval-groups for security checks: */
4824     RExC_rx->seen_evals = RExC_seen_evals;
4825     REGC((U8)REG_MAGIC, (char*) RExC_emit++);
4826     if (reg(pRExC_state, 0, &flags,1) == NULL) {
4827         ReREFCNT_dec(rx);   
4828         return(NULL);
4829     }
4830     /* XXXX To minimize changes to RE engine we always allocate
4831        3-units-long substrs field. */
4832     Newx(r->substrs, 1, struct reg_substr_data);
4833     if (RExC_recurse_count) {
4834         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
4835         SAVEFREEPV(RExC_recurse);
4836     }
4837
4838 reStudy:
4839     r->minlen = minlen = sawlookahead = sawplus = sawopen = 0;
4840     Zero(r->substrs, 1, struct reg_substr_data);
4841
4842 #ifdef TRIE_STUDY_OPT
4843     if (!restudied) {
4844         StructCopy(&zero_scan_data, &data, scan_data_t);
4845         copyRExC_state = RExC_state;
4846     } else {
4847         U32 seen=RExC_seen;
4848         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
4849         
4850         RExC_state = copyRExC_state;
4851         if (seen & REG_TOP_LEVEL_BRANCHES) 
4852             RExC_seen |= REG_TOP_LEVEL_BRANCHES;
4853         else
4854             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES;
4855         if (data.last_found) {
4856             SvREFCNT_dec(data.longest_fixed);
4857             SvREFCNT_dec(data.longest_float);
4858             SvREFCNT_dec(data.last_found);
4859         }
4860         StructCopy(&zero_scan_data, &data, scan_data_t);
4861     }
4862 #else
4863     StructCopy(&zero_scan_data, &data, scan_data_t);
4864 #endif    
4865
4866     /* Dig out information for optimizations. */
4867     r->extflags = RExC_flags; /* was pm_op */
4868     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
4869  
4870     if (UTF)
4871         SvUTF8_on(rx);  /* Unicode in it? */
4872     ri->regstclass = NULL;
4873     if (RExC_naughty >= 10)     /* Probably an expensive pattern. */
4874         r->intflags |= PREGf_NAUGHTY;
4875     scan = ri->program + 1;             /* First BRANCH. */
4876
4877     /* testing for BRANCH here tells us whether there is "must appear"
4878        data in the pattern. If there is then we can use it for optimisations */
4879     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /*  Only one top-level choice. */
4880         I32 fake;
4881         STRLEN longest_float_length, longest_fixed_length;
4882         struct regnode_charclass_class ch_class; /* pointed to by data */
4883         int stclass_flag;
4884         I32 last_close = 0; /* pointed to by data */
4885         regnode *first= scan;
4886         regnode *first_next= regnext(first);
4887         /*
4888          * Skip introductions and multiplicators >= 1
4889          * so that we can extract the 'meat' of the pattern that must 
4890          * match in the large if() sequence following.
4891          * NOTE that EXACT is NOT covered here, as it is normally
4892          * picked up by the optimiser separately. 
4893          *
4894          * This is unfortunate as the optimiser isnt handling lookahead
4895          * properly currently.
4896          *
4897          */
4898         while ((OP(first) == OPEN && (sawopen = 1)) ||
4899                /* An OR of *one* alternative - should not happen now. */
4900             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
4901             /* for now we can't handle lookbehind IFMATCH*/
4902             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
4903             (OP(first) == PLUS) ||
4904             (OP(first) == MINMOD) ||
4905                /* An {n,m} with n>0 */
4906             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
4907             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
4908         {
4909                 /* 
4910                  * the only op that could be a regnode is PLUS, all the rest
4911                  * will be regnode_1 or regnode_2.
4912                  *
4913                  */
4914                 if (OP(first) == PLUS)
4915                     sawplus = 1;
4916                 else
4917                     first += regarglen[OP(first)];
4918                 
4919                 first = NEXTOPER(first);
4920                 first_next= regnext(first);
4921         }
4922
4923         /* Starting-point info. */
4924       again:
4925         DEBUG_PEEP("first:",first,0);
4926         /* Ignore EXACT as we deal with it later. */
4927         if (PL_regkind[OP(first)] == EXACT) {
4928             if (OP(first) == EXACT)
4929                 NOOP;   /* Empty, get anchored substr later. */
4930             else
4931                 ri->regstclass = first;
4932         }
4933 #ifdef TRIE_STCLASS     
4934         else if (PL_regkind[OP(first)] == TRIE &&
4935                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0) 
4936         {
4937             regnode *trie_op;
4938             /* this can happen only on restudy */
4939             if ( OP(first) == TRIE ) {
4940                 struct regnode_1 *trieop = (struct regnode_1 *)
4941                     PerlMemShared_calloc(1, sizeof(struct regnode_1));
4942                 StructCopy(first,trieop,struct regnode_1);
4943                 trie_op=(regnode *)trieop;
4944             } else {
4945                 struct regnode_charclass *trieop = (struct regnode_charclass *)
4946                     PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
4947                 StructCopy(first,trieop,struct regnode_charclass);
4948                 trie_op=(regnode *)trieop;
4949             }
4950             OP(trie_op)+=2;
4951             make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
4952             ri->regstclass = trie_op;
4953         }
4954 #endif  
4955         else if (REGNODE_SIMPLE(OP(first)))
4956             ri->regstclass = first;
4957         else if (PL_regkind[OP(first)] == BOUND ||
4958                  PL_regkind[OP(first)] == NBOUND)
4959             ri->regstclass = first;
4960         else if (PL_regkind[OP(first)] == BOL) {
4961             r->extflags |= (OP(first) == MBOL
4962                            ? RXf_ANCH_MBOL
4963                            : (OP(first) == SBOL
4964                               ? RXf_ANCH_SBOL
4965                               : RXf_ANCH_BOL));
4966             first = NEXTOPER(first);
4967             goto again;
4968         }
4969         else if (OP(first) == GPOS) {
4970             r->extflags |= RXf_ANCH_GPOS;
4971             first = NEXTOPER(first);
4972             goto again;
4973         }
4974         else if ((!sawopen || !RExC_sawback) &&
4975             (OP(first) == STAR &&
4976             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
4977             !(r->extflags & RXf_ANCH) && !(RExC_seen & REG_SEEN_EVAL))
4978         {
4979             /* turn .* into ^.* with an implied $*=1 */
4980             const int type =
4981                 (OP(NEXTOPER(first)) == REG_ANY)
4982                     ? RXf_ANCH_MBOL
4983                     : RXf_ANCH_SBOL;
4984             r->extflags |= type;
4985             r->intflags |= PREGf_IMPLICIT;
4986             first = NEXTOPER(first);
4987             goto again;
4988         }
4989         if (sawplus && !sawlookahead && (!sawopen || !RExC_sawback)
4990             && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
4991             /* x+ must match at the 1st pos of run of x's */
4992             r->intflags |= PREGf_SKIP;
4993
4994         /* Scan is after the zeroth branch, first is atomic matcher. */
4995 #ifdef TRIE_STUDY_OPT
4996         DEBUG_PARSE_r(
4997             if (!restudied)
4998                 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
4999                               (IV)(first - scan + 1))
5000         );
5001 #else
5002         DEBUG_PARSE_r(
5003             PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
5004                 (IV)(first - scan + 1))
5005         );
5006 #endif
5007
5008
5009         /*
5010         * If there's something expensive in the r.e., find the
5011         * longest literal string that must appear and make it the
5012         * regmust.  Resolve ties in favor of later strings, since
5013         * the regstart check works with the beginning of the r.e.
5014         * and avoiding duplication strengthens checking.  Not a
5015         * strong reason, but sufficient in the absence of others.
5016         * [Now we resolve ties in favor of the earlier string if
5017         * it happens that c_offset_min has been invalidated, since the
5018         * earlier string may buy us something the later one won't.]
5019         */
5020         
5021         data.longest_fixed = newSVpvs("");
5022         data.longest_float = newSVpvs("");
5023         data.last_found = newSVpvs("");
5024         data.longest = &(data.longest_fixed);
5025         first = scan;
5026         if (!ri->regstclass) {
5027             cl_init(pRExC_state, &ch_class);
5028             data.start_class = &ch_class;
5029             stclass_flag = SCF_DO_STCLASS_AND;
5030         } else                          /* XXXX Check for BOUND? */
5031             stclass_flag = 0;
5032         data.last_closep = &last_close;
5033         
5034         minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */
5035             &data, -1, NULL, NULL,
5036             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
5037
5038         
5039         CHECK_RESTUDY_GOTO;
5040
5041
5042         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
5043              && data.last_start_min == 0 && data.last_end > 0
5044              && !RExC_seen_zerolen
5045              && !(RExC_seen & REG_SEEN_VERBARG)
5046              && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
5047             r->extflags |= RXf_CHECK_ALL;
5048         scan_commit(pRExC_state, &data,&minlen,0);
5049         SvREFCNT_dec(data.last_found);
5050
5051         /* Note that code very similar to this but for anchored string 
5052            follows immediately below, changes may need to be made to both. 
5053            Be careful. 
5054          */
5055         longest_float_length = CHR_SVLEN(data.longest_float);
5056         if (longest_float_length
5057             || (data.flags & SF_FL_BEFORE_EOL
5058                 && (!(data.flags & SF_FL_BEFORE_MEOL)
5059                     || (RExC_flags & RXf_PMf_MULTILINE)))) 
5060         {
5061             I32 t,ml;
5062
5063             if (SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
5064                 && data.offset_fixed == data.offset_float_min
5065                 && SvCUR(data.longest_fixed) == SvCUR(data.longest_float))
5066                     goto remove_float;          /* As in (a)+. */
5067
5068             /* copy the information about the longest float from the reg_scan_data
5069                over to the program. */
5070             if (SvUTF8(data.longest_float)) {
5071                 r->float_utf8 = data.longest_float;
5072                 r->float_substr = NULL;
5073             } else {
5074                 r->float_substr = data.longest_float;
5075                 r->float_utf8 = NULL;
5076             }
5077             /* float_end_shift is how many chars that must be matched that 
5078                follow this item. We calculate it ahead of time as once the
5079                lookbehind offset is added in we lose the ability to correctly
5080                calculate it.*/
5081             ml = data.minlen_float ? *(data.minlen_float) 
5082                                    : (I32)longest_float_length;
5083             r->float_end_shift = ml - data.offset_float_min
5084                 - longest_float_length + (SvTAIL(data.longest_float) != 0)
5085                 + data.lookbehind_float;
5086             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
5087             r->float_max_offset = data.offset_float_max;
5088             if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
5089                 r->float_max_offset -= data.lookbehind_float;
5090             
5091             t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
5092                        && (!(data.flags & SF_FL_BEFORE_MEOL)
5093                            || (RExC_flags & RXf_PMf_MULTILINE)));
5094             fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0);
5095         }
5096         else {
5097           remove_float:
5098             r->float_substr = r->float_utf8 = NULL;
5099             SvREFCNT_dec(data.longest_float);
5100             longest_float_length = 0;
5101         }
5102
5103         /* Note that code very similar to this but for floating string 
5104            is immediately above, changes may need to be made to both. 
5105            Be careful. 
5106          */
5107         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
5108         if (longest_fixed_length
5109             || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
5110                 && (!(data.flags & SF_FIX_BEFORE_MEOL)
5111                     || (RExC_flags & RXf_PMf_MULTILINE)))) 
5112         {
5113             I32 t,ml;
5114
5115             /* copy the information about the longest fixed 
5116                from the reg_scan_data over to the program. */
5117             if (SvUTF8(data.longest_fixed)) {
5118                 r->anchored_utf8 = data.longest_fixed;
5119                 r->anchored_substr = NULL;
5120             } else {
5121                 r->anchored_substr = data.longest_fixed;
5122                 r->anchored_utf8 = NULL;
5123             }
5124             /* fixed_end_shift is how many chars that must be matched that 
5125                follow this item. We calculate it ahead of time as once the
5126                lookbehind offset is added in we lose the ability to correctly
5127                calculate it.*/
5128             ml = data.minlen_fixed ? *(data.minlen_fixed) 
5129                                    : (I32)longest_fixed_length;
5130             r->anchored_end_shift = ml - data.offset_fixed
5131                 - longest_fixed_length + (SvTAIL(data.longest_fixed) != 0)
5132                 + data.lookbehind_fixed;
5133             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
5134
5135             t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
5136                  && (!(data.flags & SF_FIX_BEFORE_MEOL)
5137                      || (RExC_flags & RXf_PMf_MULTILINE)));
5138             fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0);
5139         }
5140         else {
5141             r->anchored_substr = r->anchored_utf8 = NULL;
5142             SvREFCNT_dec(data.longest_fixed);
5143             longest_fixed_length = 0;
5144         }
5145         if (ri->regstclass
5146             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
5147             ri->regstclass = NULL;
5148
5149         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
5150             && stclass_flag
5151             && !(data.start_class->flags & ANYOF_EOS)
5152             && !cl_is_anything(data.start_class))
5153         {
5154             const U32 n = add_data(pRExC_state, 1, "f");
5155             data.start_class->flags |= ANYOF_IS_SYNTHETIC;
5156
5157             Newx(RExC_rxi->data->data[n], 1,
5158                 struct regnode_charclass_class);
5159             StructCopy(data.start_class,
5160                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
5161                        struct regnode_charclass_class);
5162             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5163             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5164             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
5165                       regprop(r, sv, (regnode*)data.start_class);
5166                       PerlIO_printf(Perl_debug_log,
5167                                     "synthetic stclass \"%s\".\n",
5168                                     SvPVX_const(sv));});
5169         }
5170
5171         /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
5172         if (longest_fixed_length > longest_float_length) {
5173             r->check_end_shift = r->anchored_end_shift;
5174             r->check_substr = r->anchored_substr;
5175             r->check_utf8 = r->anchored_utf8;
5176             r->check_offset_min = r->check_offset_max = r->anchored_offset;
5177             if (r->extflags & RXf_ANCH_SINGLE)
5178                 r->extflags |= RXf_NOSCAN;
5179         }
5180         else {
5181             r->check_end_shift = r->float_end_shift;
5182             r->check_substr = r->float_substr;
5183             r->check_utf8 = r->float_utf8;
5184             r->check_offset_min = r->float_min_offset;
5185             r->check_offset_max = r->float_max_offset;
5186         }
5187         /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
5188            This should be changed ASAP!  */
5189         if ((r->check_substr || r->check_utf8) && !(r->extflags & RXf_ANCH_GPOS)) {
5190             r->extflags |= RXf_USE_INTUIT;
5191             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
5192                 r->extflags |= RXf_INTUIT_TAIL;
5193         }
5194         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
5195         if ( (STRLEN)minlen < longest_float_length )
5196             minlen= longest_float_length;
5197         if ( (STRLEN)minlen < longest_fixed_length )
5198             minlen= longest_fixed_length;     
5199         */
5200     }
5201     else {
5202         /* Several toplevels. Best we can is to set minlen. */
5203         I32 fake;
5204         struct regnode_charclass_class ch_class;
5205         I32 last_close = 0;
5206         
5207         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
5208
5209         scan = ri->program + 1;
5210         cl_init(pRExC_state, &ch_class);
5211         data.start_class = &ch_class;
5212         data.last_closep = &last_close;
5213
5214         
5215         minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
5216             &data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
5217         
5218         CHECK_RESTUDY_GOTO;
5219
5220         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
5221                 = r->float_substr = r->float_utf8 = NULL;
5222
5223         if (!(data.start_class->flags & ANYOF_EOS)
5224             && !cl_is_anything(data.start_class))
5225         {
5226             const U32 n = add_data(pRExC_state, 1, "f");
5227             data.start_class->flags |= ANYOF_IS_SYNTHETIC;
5228
5229             Newx(RExC_rxi->data->data[n], 1,
5230                 struct regnode_charclass_class);
5231             StructCopy(data.start_class,
5232                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
5233                        struct regnode_charclass_class);
5234             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5235             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5236             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
5237                       regprop(r, sv, (regnode*)data.start_class);
5238                       PerlIO_printf(Perl_debug_log,
5239                                     "synthetic stclass \"%s\".\n",
5240                                     SvPVX_const(sv));});
5241         }
5242     }
5243
5244     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
5245        the "real" pattern. */
5246     DEBUG_OPTIMISE_r({
5247         PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n",
5248                       (IV)minlen, (IV)r->minlen);
5249     });
5250     r->minlenret = minlen;
5251     if (r->minlen < minlen) 
5252         r->minlen = minlen;
5253     
5254     if (RExC_seen & REG_SEEN_GPOS)
5255         r->extflags |= RXf_GPOS_SEEN;
5256     if (RExC_seen & REG_SEEN_LOOKBEHIND)
5257         r->extflags |= RXf_LOOKBEHIND_SEEN;
5258     if (RExC_seen & REG_SEEN_EVAL)
5259         r->extflags |= RXf_EVAL_SEEN;
5260     if (RExC_seen & REG_SEEN_CANY)
5261         r->extflags |= RXf_CANY_SEEN;
5262     if (RExC_seen & REG_SEEN_VERBARG)
5263         r->intflags |= PREGf_VERBARG_SEEN;
5264     if (RExC_seen & REG_SEEN_CUTGROUP)
5265         r->intflags |= PREGf_CUTGROUP_SEEN;
5266     if (RExC_paren_names)
5267         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
5268     else
5269         RXp_PAREN_NAMES(r) = NULL;
5270
5271 #ifdef STUPID_PATTERN_CHECKS            
5272     if (RX_PRELEN(rx) == 0)
5273         r->extflags |= RXf_NULL;
5274     if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5275         /* XXX: this should happen BEFORE we compile */
5276         r->extflags |= (RXf_SKIPWHITE|RXf_WHITE); 
5277     else if (RX_PRELEN(rx) == 3 && memEQ("\\s+", RX_PRECOMP(rx), 3))
5278         r->extflags |= RXf_WHITE;
5279     else if (RX_PRELEN(rx) == 1 && RXp_PRECOMP(rx)[0] == '^')
5280         r->extflags |= RXf_START_ONLY;
5281 #else
5282     if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5283             /* XXX: this should happen BEFORE we compile */
5284             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE); 
5285     else {
5286         regnode *first = ri->program + 1;
5287         U8 fop = OP(first);
5288
5289         if (PL_regkind[fop] == NOTHING && OP(NEXTOPER(first)) == END)
5290             r->extflags |= RXf_NULL;
5291         else if (PL_regkind[fop] == BOL && OP(NEXTOPER(first)) == END)
5292             r->extflags |= RXf_START_ONLY;
5293         else if (fop == PLUS && OP(NEXTOPER(first)) == SPACE
5294                              && OP(regnext(first)) == END)
5295             r->extflags |= RXf_WHITE;    
5296     }
5297 #endif
5298 #ifdef DEBUGGING
5299     if (RExC_paren_names) {
5300         ri->name_list_idx = add_data( pRExC_state, 1, "a" );
5301         ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list);
5302     } else
5303 #endif
5304         ri->name_list_idx = 0;
5305
5306     if (RExC_recurse_count) {
5307         for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
5308             const regnode *scan = RExC_recurse[RExC_recurse_count-1];
5309             ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
5310         }
5311     }
5312     Newxz(r->offs, RExC_npar, regexp_paren_pair);
5313     /* assume we don't need to swap parens around before we match */
5314
5315     DEBUG_DUMP_r({
5316         PerlIO_printf(Perl_debug_log,"Final program:\n");
5317         regdump(r);
5318     });
5319 #ifdef RE_TRACK_PATTERN_OFFSETS
5320     DEBUG_OFFSETS_r(if (ri->u.offsets) {
5321         const U32 len = ri->u.offsets[0];
5322         U32 i;
5323         GET_RE_DEBUG_FLAGS_DECL;
5324         PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
5325         for (i = 1; i <= len; i++) {
5326             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
5327                 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
5328                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
5329             }
5330         PerlIO_printf(Perl_debug_log, "\n");
5331     });
5332 #endif
5333     return rx;
5334 }
5335
5336 #undef RE_ENGINE_PTR
5337
5338
5339 SV*
5340 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
5341                     const U32 flags)
5342 {
5343     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
5344
5345     PERL_UNUSED_ARG(value);
5346
5347     if (flags & RXapif_FETCH) {
5348         return reg_named_buff_fetch(rx, key, flags);
5349     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
5350         Perl_croak_no_modify(aTHX);
5351         return NULL;
5352     } else if (flags & RXapif_EXISTS) {
5353         return reg_named_buff_exists(rx, key, flags)
5354             ? &PL_sv_yes
5355             : &PL_sv_no;
5356     } else if (flags & RXapif_REGNAMES) {
5357         return reg_named_buff_all(rx, flags);
5358     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
5359         return reg_named_buff_scalar(rx, flags);
5360     } else {
5361         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
5362         return NULL;
5363     }
5364 }
5365
5366 SV*
5367 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
5368                          const U32 flags)
5369 {
5370     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
5371     PERL_UNUSED_ARG(lastkey);
5372
5373     if (flags & RXapif_FIRSTKEY)
5374         return reg_named_buff_firstkey(rx, flags);
5375     else if (flags & RXapif_NEXTKEY)
5376         return reg_named_buff_nextkey(rx, flags);
5377     else {
5378         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter", (int)flags);
5379         return NULL;
5380     }
5381 }
5382
5383 SV*
5384 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
5385                           const U32 flags)
5386 {
5387     AV *retarray = NULL;
5388     SV *ret;
5389     struct regexp *const rx = (struct regexp *)SvANY(r);
5390
5391     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
5392
5393     if (flags & RXapif_ALL)
5394         retarray=newAV();
5395
5396     if (rx && RXp_PAREN_NAMES(rx)) {
5397         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
5398         if (he_str) {
5399             IV i;
5400             SV* sv_dat=HeVAL(he_str);
5401             I32 *nums=(I32*)SvPVX(sv_dat);
5402             for ( i=0; i<SvIVX(sv_dat); i++ ) {
5403                 if ((I32)(rx->nparens) >= nums[i]
5404                     && rx->offs[nums[i]].start != -1
5405                     && rx->offs[nums[i]].end != -1)
5406                 {
5407                     ret = newSVpvs("");
5408                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
5409                     if (!retarray)
5410                         return ret;
5411                 } else {
5412                     ret = newSVsv(&PL_sv_undef);
5413                 }
5414                 if (retarray)
5415                     av_push(retarray, ret);
5416             }
5417             if (retarray)
5418                 return newRV_noinc(MUTABLE_SV(retarray));
5419         }
5420     }
5421     return NULL;
5422 }
5423
5424 bool
5425 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
5426                            const U32 flags)
5427 {
5428     struct regexp *const rx = (struct regexp *)SvANY(r);
5429
5430     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
5431
5432     if (rx && RXp_PAREN_NAMES(rx)) {
5433         if (flags & RXapif_ALL) {
5434             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
5435         } else {
5436             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
5437             if (sv) {
5438                 SvREFCNT_dec(sv);
5439                 return TRUE;
5440             } else {
5441                 return FALSE;
5442             }
5443         }
5444     } else {
5445         return FALSE;
5446     }
5447 }
5448
5449 SV*
5450 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
5451 {
5452     struct regexp *const rx = (struct regexp *)SvANY(r);
5453
5454     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
5455
5456     if ( rx && RXp_PAREN_NAMES(rx) ) {
5457         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
5458
5459         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
5460     } else {
5461         return FALSE;
5462     }
5463 }
5464
5465 SV*
5466 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
5467 {
5468     struct regexp *const rx = (struct regexp *)SvANY(r);
5469     GET_RE_DEBUG_FLAGS_DECL;
5470
5471     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
5472
5473     if (rx && RXp_PAREN_NAMES(rx)) {
5474         HV *hv = RXp_PAREN_NAMES(rx);
5475         HE *temphe;
5476         while ( (temphe = hv_iternext_flags(hv,0)) ) {
5477             IV i;
5478             IV parno = 0;
5479             SV* sv_dat = HeVAL(temphe);
5480             I32 *nums = (I32*)SvPVX(sv_dat);
5481             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5482                 if ((I32)(rx->lastparen) >= nums[i] &&
5483                     rx->offs[nums[i]].start != -1 &&
5484                     rx->offs[nums[i]].end != -1)
5485                 {
5486                     parno = nums[i];
5487                     break;
5488                 }
5489             }
5490             if (parno || flags & RXapif_ALL) {
5491                 return newSVhek(HeKEY_hek(temphe));
5492             }
5493         }
5494     }
5495     return NULL;
5496 }
5497
5498 SV*
5499 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
5500 {
5501     SV *ret;
5502     AV *av;
5503     I32 length;
5504     struct regexp *const rx = (struct regexp *)SvANY(r);
5505
5506     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
5507
5508     if (rx && RXp_PAREN_NAMES(rx)) {
5509         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
5510             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
5511         } else if (flags & RXapif_ONE) {
5512             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
5513             av = MUTABLE_AV(SvRV(ret));
5514             length = av_len(av);
5515             SvREFCNT_dec(ret);
5516             return newSViv(length + 1);
5517         } else {
5518             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", (int)flags);
5519             return NULL;
5520         }
5521     }
5522     return &PL_sv_undef;
5523 }
5524
5525 SV*
5526 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
5527 {
5528     struct regexp *const rx = (struct regexp *)SvANY(r);
5529     AV *av = newAV();
5530
5531     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
5532
5533     if (rx && RXp_PAREN_NAMES(rx)) {
5534         HV *hv= RXp_PAREN_NAMES(rx);
5535         HE *temphe;
5536         (void)hv_iterinit(hv);
5537         while ( (temphe = hv_iternext_flags(hv,0)) ) {
5538             IV i;
5539             IV parno = 0;
5540             SV* sv_dat = HeVAL(temphe);
5541             I32 *nums = (I32*)SvPVX(sv_dat);
5542             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5543                 if ((I32)(rx->lastparen) >= nums[i] &&
5544                     rx->offs[nums[i]].start != -1 &&
5545                     rx->offs[nums[i]].end != -1)
5546                 {
5547                     parno = nums[i];
5548                     break;
5549                 }
5550             }
5551             if (parno || flags & RXapif_ALL) {
5552                 av_push(av, newSVhek(HeKEY_hek(temphe)));
5553             }
5554         }
5555     }
5556
5557     return newRV_noinc(MUTABLE_SV(av));
5558 }
5559
5560 void
5561 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
5562                              SV * const sv)
5563 {
5564     struct regexp *const rx = (struct regexp *)SvANY(r);
5565     char *s = NULL;
5566     I32 i = 0;
5567     I32 s1, t1;
5568
5569     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
5570         
5571     if (!rx->subbeg) {
5572         sv_setsv(sv,&PL_sv_undef);
5573         return;
5574     } 
5575     else               
5576     if (paren == RX_BUFF_IDX_PREMATCH && rx->offs[0].start != -1) {
5577         /* $` */
5578         i = rx->offs[0].start;
5579         s = rx->subbeg;
5580     }
5581     else 
5582     if (paren == RX_BUFF_IDX_POSTMATCH && rx->offs[0].end != -1) {
5583         /* $' */
5584         s = rx->subbeg + rx->offs[0].end;
5585         i = rx->sublen - rx->offs[0].end;
5586     } 
5587     else
5588     if ( 0 <= paren && paren <= (I32)rx->nparens &&
5589         (s1 = rx->offs[paren].start) != -1 &&
5590         (t1 = rx->offs[paren].end) != -1)
5591     {
5592         /* $& $1 ... */
5593         i = t1 - s1;
5594         s = rx->subbeg + s1;
5595     } else {
5596         sv_setsv(sv,&PL_sv_undef);
5597         return;
5598     }          
5599     assert(rx->sublen >= (s - rx->subbeg) + i );
5600     if (i >= 0) {
5601         const int oldtainted = PL_tainted;
5602         TAINT_NOT;
5603         sv_setpvn(sv, s, i);
5604         PL_tainted = oldtainted;
5605         if ( (rx->extflags & RXf_CANY_SEEN)
5606             ? (RXp_MATCH_UTF8(rx)
5607                         && (!i || is_utf8_string((U8*)s, i)))
5608             : (RXp_MATCH_UTF8(rx)) )
5609         {
5610             SvUTF8_on(sv);
5611         }
5612         else
5613             SvUTF8_off(sv);
5614         if (PL_tainting) {
5615             if (RXp_MATCH_TAINTED(rx)) {
5616                 if (SvTYPE(sv) >= SVt_PVMG) {
5617                     MAGIC* const mg = SvMAGIC(sv);
5618                     MAGIC* mgt;
5619                     PL_tainted = 1;
5620                     SvMAGIC_set(sv, mg->mg_moremagic);
5621                     SvTAINT(sv);
5622                     if ((mgt = SvMAGIC(sv))) {
5623                         mg->mg_moremagic = mgt;
5624                         SvMAGIC_set(sv, mg);
5625                     }
5626                 } else {
5627                     PL_tainted = 1;
5628                     SvTAINT(sv);
5629                 }
5630             } else 
5631                 SvTAINTED_off(sv);
5632         }
5633     } else {
5634         sv_setsv(sv,&PL_sv_undef);
5635         return;
5636     }
5637 }
5638
5639 void
5640 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
5641                                                          SV const * const value)
5642 {
5643     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
5644
5645     PERL_UNUSED_ARG(rx);
5646     PERL_UNUSED_ARG(paren);
5647     PERL_UNUSED_ARG(value);
5648
5649     if (!PL_localizing)
5650         Perl_croak_no_modify(aTHX);
5651 }
5652
5653 I32
5654 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
5655                               const I32 paren)
5656 {
5657     struct regexp *const rx = (struct regexp *)SvANY(r);
5658     I32 i;
5659     I32 s1, t1;
5660
5661     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
5662
5663     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
5664         switch (paren) {
5665       /* $` / ${^PREMATCH} */
5666       case RX_BUFF_IDX_PREMATCH:
5667         if (rx->offs[0].start != -1) {
5668                         i = rx->offs[0].start;
5669                         if (i > 0) {
5670                                 s1 = 0;
5671                                 t1 = i;
5672                                 goto getlen;
5673                         }
5674             }
5675         return 0;
5676       /* $' / ${^POSTMATCH} */
5677       case RX_BUFF_IDX_POSTMATCH:
5678             if (rx->offs[0].end != -1) {
5679                         i = rx->sublen - rx->offs[0].end;
5680                         if (i > 0) {
5681                                 s1 = rx->offs[0].end;
5682                                 t1 = rx->sublen;
5683                                 goto getlen;
5684                         }
5685             }
5686         return 0;
5687       /* $& / ${^MATCH}, $1, $2, ... */
5688       default:
5689             if (paren <= (I32)rx->nparens &&
5690             (s1 = rx->offs[paren].start) != -1 &&
5691             (t1 = rx->offs[paren].end) != -1)
5692             {
5693             i = t1 - s1;
5694             goto getlen;
5695         } else {
5696             if (ckWARN(WARN_UNINITIALIZED))
5697                 report_uninit((const SV *)sv);
5698             return 0;
5699         }
5700     }
5701   getlen:
5702     if (i > 0 && RXp_MATCH_UTF8(rx)) {
5703         const char * const s = rx->subbeg + s1;
5704         const U8 *ep;
5705         STRLEN el;
5706
5707         i = t1 - s1;
5708         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
5709                         i = el;
5710     }
5711     return i;
5712 }
5713
5714 SV*
5715 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
5716 {
5717     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
5718         PERL_UNUSED_ARG(rx);
5719         if (0)
5720             return NULL;
5721         else
5722             return newSVpvs("Regexp");
5723 }
5724
5725 /* Scans the name of a named buffer from the pattern.
5726  * If flags is REG_RSN_RETURN_NULL returns null.
5727  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
5728  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
5729  * to the parsed name as looked up in the RExC_paren_names hash.
5730  * If there is an error throws a vFAIL().. type exception.
5731  */
5732
5733 #define REG_RSN_RETURN_NULL    0
5734 #define REG_RSN_RETURN_NAME    1
5735 #define REG_RSN_RETURN_DATA    2
5736
5737 STATIC SV*
5738 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
5739 {
5740     char *name_start = RExC_parse;
5741
5742     PERL_ARGS_ASSERT_REG_SCAN_NAME;
5743
5744     if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
5745          /* skip IDFIRST by using do...while */
5746         if (UTF)
5747             do {
5748                 RExC_parse += UTF8SKIP(RExC_parse);
5749             } while (isALNUM_utf8((U8*)RExC_parse));
5750         else
5751             do {
5752                 RExC_parse++;
5753             } while (isALNUM(*RExC_parse));
5754     }
5755
5756     if ( flags ) {
5757         SV* sv_name
5758             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
5759                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
5760         if ( flags == REG_RSN_RETURN_NAME)
5761             return sv_name;
5762         else if (flags==REG_RSN_RETURN_DATA) {
5763             HE *he_str = NULL;
5764             SV *sv_dat = NULL;
5765             if ( ! sv_name )      /* should not happen*/
5766                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
5767             if (RExC_paren_names)
5768                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
5769             if ( he_str )
5770                 sv_dat = HeVAL(he_str);
5771             if ( ! sv_dat )
5772                 vFAIL("Reference to nonexistent named group");
5773             return sv_dat;
5774         }
5775         else {
5776             Perl_croak(aTHX_ "panic: bad flag in reg_scan_name");
5777         }
5778         /* NOT REACHED */
5779     }
5780     return NULL;
5781 }
5782
5783 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
5784     int rem=(int)(RExC_end - RExC_parse);                       \
5785     int cut;                                                    \
5786     int num;                                                    \
5787     int iscut=0;                                                \
5788     if (rem>10) {                                               \
5789         rem=10;                                                 \
5790         iscut=1;                                                \
5791     }                                                           \
5792     cut=10-rem;                                                 \
5793     if (RExC_lastparse!=RExC_parse)                             \
5794         PerlIO_printf(Perl_debug_log," >%.*s%-*s",              \
5795             rem, RExC_parse,                                    \
5796             cut + 4,                                            \
5797             iscut ? "..." : "<"                                 \
5798         );                                                      \
5799     else                                                        \
5800         PerlIO_printf(Perl_debug_log,"%16s","");                \
5801                                                                 \
5802     if (SIZE_ONLY)                                              \
5803        num = RExC_size + 1;                                     \
5804     else                                                        \
5805        num=REG_NODE_NUM(RExC_emit);                             \
5806     if (RExC_lastnum!=num)                                      \
5807        PerlIO_printf(Perl_debug_log,"|%4d",num);                \
5808     else                                                        \
5809        PerlIO_printf(Perl_debug_log,"|%4s","");                 \
5810     PerlIO_printf(Perl_debug_log,"|%*s%-4s",                    \
5811         (int)((depth*2)), "",                                   \
5812         (funcname)                                              \
5813     );                                                          \
5814     RExC_lastnum=num;                                           \
5815     RExC_lastparse=RExC_parse;                                  \
5816 })
5817
5818
5819
5820 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
5821     DEBUG_PARSE_MSG((funcname));                            \
5822     PerlIO_printf(Perl_debug_log,"%4s","\n");               \
5823 })
5824 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({           \
5825     DEBUG_PARSE_MSG((funcname));                            \
5826     PerlIO_printf(Perl_debug_log,fmt "\n",args);               \
5827 })
5828
5829 /* This section of code defines the inversion list object and its methods.  The
5830  * interfaces are highly subject to change, so as much as possible is static to
5831  * this file.  An inversion list is here implemented as a malloc'd C array with
5832  * some added info.  More will be coming when functionality is added later.
5833  *
5834  * Some of the methods should always be private to the implementation, and some
5835  * should eventually be made public */
5836
5837 #define INVLIST_INITIAL_LEN 10
5838 #define INVLIST_ARRAY_KEY "array"
5839 #define INVLIST_MAX_KEY "max"
5840 #define INVLIST_LEN_KEY "len"
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     SV** list_ptr = hv_fetchs(invlist, INVLIST_ARRAY_KEY, FALSE);
5850
5851     PERL_ARGS_ASSERT_INVLIST_ARRAY;
5852
5853     if (list_ptr == NULL) {
5854         Perl_croak(aTHX_ "panic: inversion list without a '%s' element",
5855                                                             INVLIST_ARRAY_KEY);
5856     }
5857
5858     return INT2PTR(UV *, SvUV(*list_ptr));
5859 }
5860
5861 PERL_STATIC_INLINE void
5862 S_invlist_set_array(pTHX_ HV* const invlist, const UV* const array)
5863 {
5864     PERL_ARGS_ASSERT_INVLIST_SET_ARRAY;
5865
5866     /* Sets the array stored in the inversion list to the memory beginning with
5867      * the parameter */
5868
5869     if (hv_stores(invlist, INVLIST_ARRAY_KEY, newSVuv(PTR2UV(array))) == NULL) {
5870         Perl_croak(aTHX_ "panic: can't store '%s' entry in inversion list",
5871                                                             INVLIST_ARRAY_KEY);
5872     }
5873 }
5874
5875 PERL_STATIC_INLINE UV
5876 S_invlist_len(pTHX_ HV* const invlist)
5877 {
5878     /* Returns the current number of elements in the inversion list's array */
5879
5880     SV** len_ptr = hv_fetchs(invlist, INVLIST_LEN_KEY, FALSE);
5881
5882     PERL_ARGS_ASSERT_INVLIST_LEN;
5883
5884     if (len_ptr == NULL) {
5885         Perl_croak(aTHX_ "panic: inversion list without a '%s' element",
5886                                                             INVLIST_LEN_KEY);
5887     }
5888
5889     return SvUV(*len_ptr);
5890 }
5891
5892 PERL_STATIC_INLINE UV
5893 S_invlist_max(pTHX_ HV* const invlist)
5894 {
5895     /* Returns the maximum number of elements storable in the inversion list's
5896      * array, without having to realloc() */
5897
5898     SV** max_ptr = hv_fetchs(invlist, INVLIST_MAX_KEY, FALSE);
5899
5900     PERL_ARGS_ASSERT_INVLIST_MAX;
5901
5902     if (max_ptr == NULL) {
5903         Perl_croak(aTHX_ "panic: inversion list without a '%s' element",
5904                                                             INVLIST_MAX_KEY);
5905     }
5906
5907     return SvUV(*max_ptr);
5908 }
5909
5910 PERL_STATIC_INLINE void
5911 S_invlist_set_len(pTHX_ HV* const invlist, const UV len)
5912 {
5913     /* Sets the current number of elements stored in the inversion list */
5914
5915     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
5916
5917     if (len != 0 && len > invlist_max(invlist)) {
5918         Perl_croak(aTHX_ "panic: Can't make '%s=%"UVuf"' more than %s=%"UVuf" in inversion list", INVLIST_LEN_KEY, len, INVLIST_MAX_KEY, invlist_max(invlist));
5919     }
5920
5921     if (hv_stores(invlist, INVLIST_LEN_KEY, newSVuv(len)) == NULL) {
5922         Perl_croak(aTHX_ "panic: can't store '%s' entry in inversion list",
5923                                                             INVLIST_LEN_KEY);
5924     }
5925 }
5926
5927 PERL_STATIC_INLINE void
5928 S_invlist_set_max(pTHX_ HV* const invlist, const UV max)
5929 {
5930
5931     /* Sets the maximum number of elements storable in the inversion list
5932      * without having to realloc() */
5933
5934     PERL_ARGS_ASSERT_INVLIST_SET_MAX;
5935
5936     if (max < invlist_len(invlist)) {
5937         Perl_croak(aTHX_ "panic: Can't make '%s=%"UVuf"' less than %s=%"UVuf" in inversion list", INVLIST_MAX_KEY, invlist_len(invlist), INVLIST_LEN_KEY, invlist_max(invlist));
5938     }
5939
5940     if (hv_stores(invlist, INVLIST_MAX_KEY, newSVuv(max)) == NULL) {
5941         Perl_croak(aTHX_ "panic: can't store '%s' entry in inversion list",
5942                                                             INVLIST_LEN_KEY);
5943     }
5944 }
5945
5946 #ifndef PERL_IN_XSUB_RE
5947 HV*
5948 Perl__new_invlist(pTHX_ IV initial_size)
5949 {
5950
5951     /* Return a pointer to a newly constructed inversion list, with enough
5952      * space to store 'initial_size' elements.  If that number is negative, a
5953      * system default is used instead */
5954
5955     HV* invlist = newHV();
5956     UV* list;
5957
5958     if (initial_size < 0) {
5959         initial_size = INVLIST_INITIAL_LEN;
5960     }
5961
5962     /* Allocate the initial space */
5963     Newx(list, initial_size, UV);
5964     invlist_set_array(invlist, list);
5965
5966     /* set_len has to come before set_max, as the latter inspects the len */
5967     invlist_set_len(invlist, 0);
5968     invlist_set_max(invlist, initial_size);
5969
5970     return invlist;
5971 }
5972 #endif
5973
5974 PERL_STATIC_INLINE void
5975 S_invlist_destroy(pTHX_ HV* const invlist)
5976 {
5977    /* Inversion list destructor */
5978
5979     SV** list_ptr = hv_fetchs(invlist, INVLIST_ARRAY_KEY, FALSE);
5980
5981     PERL_ARGS_ASSERT_INVLIST_DESTROY;
5982
5983     if (list_ptr != NULL) {
5984         UV *list = INT2PTR(UV *, SvUV(*list_ptr)); /* PERL_POISON needs lvalue */
5985         Safefree(list);
5986     }
5987 }
5988
5989 STATIC void
5990 S_invlist_extend(pTHX_ HV* const invlist, const UV new_max)
5991 {
5992     /* Change the maximum size of an inversion list (up or down) */
5993
5994     UV* orig_array;
5995     UV* array;
5996     const UV old_max = invlist_max(invlist);
5997
5998     PERL_ARGS_ASSERT_INVLIST_EXTEND;
5999
6000     if (old_max == new_max) {   /* If a no-op */
6001         return;
6002     }
6003
6004     array = orig_array = invlist_array(invlist);
6005     Renew(array, new_max, UV);
6006
6007     /* If the size change moved the list in memory, set the new one */
6008     if (array != orig_array) {
6009         invlist_set_array(invlist, array);
6010     }
6011
6012     invlist_set_max(invlist, new_max);
6013
6014 }
6015
6016 PERL_STATIC_INLINE void
6017 S_invlist_trim(pTHX_ HV* const invlist)
6018 {
6019     PERL_ARGS_ASSERT_INVLIST_TRIM;
6020
6021     /* Change the length of the inversion list to how many entries it currently
6022      * has */
6023
6024     invlist_extend(invlist, invlist_len(invlist));
6025 }
6026
6027 /* An element is in an inversion list iff its index is even numbered: 0, 2, 4,
6028  * etc */
6029
6030 #define ELEMENT_IN_INVLIST_SET(i) (! ((i) & 1))
6031
6032 #ifndef PERL_IN_XSUB_RE
6033 void
6034 Perl__append_range_to_invlist(pTHX_ HV* const invlist, const UV start, const UV end)
6035 {
6036    /* Subject to change or removal.  Append the range from 'start' to 'end' at
6037     * the end of the inversion list.  The range must be above any existing
6038     * ones. */
6039
6040     UV* array = invlist_array(invlist);
6041     UV max = invlist_max(invlist);
6042     UV len = invlist_len(invlist);
6043
6044     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
6045
6046     if (len > 0) {
6047
6048         /* Here, the existing list is non-empty. The current max entry in the
6049          * list is generally the first value not in the set, except when the
6050          * set extends to the end of permissible values, in which case it is
6051          * the first entry in that final set, and so this call is an attempt to
6052          * append out-of-order */
6053
6054         UV final_element = len - 1;
6055         if (array[final_element] > start
6056             || ELEMENT_IN_INVLIST_SET(final_element))
6057         {
6058             Perl_croak(aTHX_ "panic: attempting to append to an inversion list, but wasn't at the end of the list");
6059         }
6060
6061         /* Here, it is a legal append.  If the new range begins with the first
6062          * value not in the set, it is extending the set, so the new first
6063          * value not in the set is one greater than the newly extended range.
6064          * */
6065         if (array[final_element] == start) {
6066             if (end != UV_MAX) {
6067                 array[final_element] = end + 1;
6068             }
6069             else {
6070                 /* But if the end is the maximum representable on the machine,
6071                  * just let the range that this would extend have no end */
6072                 invlist_set_len(invlist, len - 1);
6073             }
6074             return;
6075         }
6076     }
6077
6078     /* Here the new range doesn't extend any existing set.  Add it */
6079
6080     len += 2;   /* Includes an element each for the start and end of range */
6081
6082     /* If overflows the existing space, extend, which may cause the array to be
6083      * moved */
6084     if (max < len) {
6085         invlist_extend(invlist, len);
6086         array = invlist_array(invlist);
6087     }
6088
6089     invlist_set_len(invlist, len);
6090
6091     /* The next item on the list starts the range, the one after that is
6092      * one past the new range.  */
6093     array[len - 2] = start;
6094     if (end != UV_MAX) {
6095         array[len - 1] = end + 1;
6096     }
6097     else {
6098         /* But if the end is the maximum representable on the machine, just let
6099          * the range have no end */
6100         invlist_set_len(invlist, len - 1);
6101     }
6102 }
6103 #endif
6104
6105 STATIC HV*
6106 S_invlist_union(pTHX_ HV* const a, HV* const b)
6107 {
6108     /* Return a new inversion list which is the union of two inversion lists.
6109      * The basis for this comes from "Unicode Demystified" Chapter 13 by
6110      * Richard Gillam, published by Addison-Wesley, and explained at some
6111      * length there.  The preface says to incorporate its examples into your
6112      * code at your own risk.
6113      *
6114      * The algorithm is like a merge sort.
6115      *
6116      * XXX A potential performance improvement is to keep track as we go along
6117      * if only one of the inputs contributes to the result, meaning the other
6118      * is a subset of that one.  In that case, we can skip the final copy and
6119      * return the larger of the input lists */
6120
6121     UV* array_a = invlist_array(a);   /* a's array */
6122     UV* array_b = invlist_array(b);
6123     UV len_a = invlist_len(a);  /* length of a's array */
6124     UV len_b = invlist_len(b);
6125
6126     HV* u;                      /* the resulting union */
6127     UV* array_u;
6128     UV len_u;
6129
6130     UV i_a = 0;             /* current index into a's array */
6131     UV i_b = 0;
6132     UV i_u = 0;
6133
6134     /* running count, as explained in the algorithm source book; items are
6135      * stopped accumulating and are output when the count changes to/from 0.
6136      * The count is incremented when we start a range that's in the set, and
6137      * decremented when we start a range that's not in the set.  So its range
6138      * is 0 to 2.  Only when the count is zero is something not in the set.
6139      */
6140     UV count = 0;
6141
6142     PERL_ARGS_ASSERT_INVLIST_UNION;
6143
6144     /* Size the union for the worst case: that the sets are completely
6145      * disjoint */
6146     u = _new_invlist(len_a + len_b);
6147     array_u = invlist_array(u);
6148
6149     /* Go through each list item by item, stopping when exhausted one of
6150      * them */
6151     while (i_a < len_a && i_b < len_b) {
6152         UV cp;      /* The element to potentially add to the union's array */
6153         bool cp_in_set;   /* is it in the the input list's set or not */
6154
6155         /* We need to take one or the other of the two inputs for the union.
6156          * Since we are merging two sorted lists, we take the smaller of the
6157          * next items.  In case of a tie, we take the one that is in its set
6158          * first.  If we took one not in the set first, it would decrement the
6159          * count, possibly to 0 which would cause it to be output as ending the
6160          * range, and the next time through we would take the same number, and
6161          * output it again as beginning the next range.  By doing it the
6162          * opposite way, there is no possibility that the count will be
6163          * momentarily decremented to 0, and thus the two adjoining ranges will
6164          * be seamlessly merged.  (In a tie and both are in the set or both not
6165          * in the set, it doesn't matter which we take first.) */
6166         if (array_a[i_a] < array_b[i_b]
6167             || (array_a[i_a] == array_b[i_b] && ELEMENT_IN_INVLIST_SET(i_a)))
6168         {
6169             cp_in_set = ELEMENT_IN_INVLIST_SET(i_a);
6170             cp= array_a[i_a++];
6171         }
6172         else {
6173             cp_in_set = ELEMENT_IN_INVLIST_SET(i_b);
6174             cp= array_b[i_b++];
6175         }
6176
6177         /* Here, have chosen which of the two inputs to look at.  Only output
6178          * if the running count changes to/from 0, which marks the
6179          * beginning/end of a range in that's in the set */
6180         if (cp_in_set) {
6181             if (count == 0) {
6182                 array_u[i_u++] = cp;
6183             }
6184             count++;
6185         }
6186         else {
6187             count--;
6188             if (count == 0) {
6189                 array_u[i_u++] = cp;
6190             }
6191         }
6192     }
6193
6194     /* Here, we are finished going through at least one of the lists, which
6195      * means there is something remaining in at most one.  We check if the list
6196      * that hasn't been exhausted is positioned such that we are in the middle
6197      * of a range in its set or not.  (We are in the set if the next item in
6198      * the array marks the beginning of something not in the set)   If in the
6199      * set, we decrement 'count'; if 0, there is potentially more to output.
6200      * There are four cases:
6201      *  1) Both weren't in their sets, count is 0, and remains 0.  What's left
6202      *     in the union is entirely from the non-exhausted set.
6203      *  2) Both were in their sets, count is 2.  Nothing further should
6204      *     be output, as everything that remains will be in the exhausted
6205      *     list's set, hence in the union; decrementing to 1 but not 0 insures
6206      *     that
6207      *  3) the exhausted was in its set, non-exhausted isn't, count is 1.
6208      *     Nothing further should be output because the union includes
6209      *     everything from the exhausted set.  Not decrementing insures that.
6210      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1;
6211      *     decrementing to 0 insures that we look at the remainder of the
6212      *     non-exhausted set */
6213     if ((i_a != len_a && ! ELEMENT_IN_INVLIST_SET(i_a))
6214         || (i_b != len_b && ! ELEMENT_IN_INVLIST_SET(i_b)))
6215     {
6216         count--;
6217     }
6218
6219     /* The final length is what we've output so far, plus what else is about to
6220      * be output.  (If 'count' is non-zero, then the input list we exhausted
6221      * has everything remaining up to the machine's limit in its set, and hence
6222      * in the union, so there will be no further output. */
6223     len_u = i_u;
6224     if (count == 0) {
6225         /* At most one of the subexpressions will be non-zero */
6226         len_u += (len_a - i_a) + (len_b - i_b);
6227     }
6228
6229     /* Set result to final length, which can change the pointer to array_u, so
6230      * re-find it */
6231     if (len_u != invlist_len(u)) {
6232         invlist_set_len(u, len_u);
6233         invlist_trim(u);
6234         array_u = invlist_array(u);
6235     }
6236
6237     /* When 'count' is 0, the list that was exhausted (if one was shorter than
6238      * the other) ended with everything above it not in its set.  That means
6239      * that the remaining part of the union is precisely the same as the
6240      * non-exhausted list, so can just copy it unchanged.  (If both list were
6241      * exhausted at the same time, then the operations below will be both 0.)
6242      */
6243     if (count == 0) {
6244         IV copy_count; /* At most one will have a non-zero copy count */
6245         if ((copy_count = len_a - i_a) > 0) {
6246             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
6247         }
6248         else if ((copy_count = len_b - i_b) > 0) {
6249             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
6250         }
6251     }
6252
6253     return u;
6254 }
6255
6256 STATIC HV*
6257 S_invlist_intersection(pTHX_ HV* const a, HV* const b)
6258 {
6259     /* Return the intersection of two inversion lists.  The basis for this
6260      * comes from "Unicode Demystified" Chapter 13 by Richard Gillam, published
6261      * by Addison-Wesley, and explained at some length there.  The preface says
6262      * to incorporate its examples into your code at your own risk.
6263      *
6264      * The algorithm is like a merge sort, and is essentially the same as the
6265      * union above
6266      */
6267
6268     UV* array_a = invlist_array(a);   /* a's array */
6269     UV* array_b = invlist_array(b);
6270     UV len_a = invlist_len(a);  /* length of a's array */
6271     UV len_b = invlist_len(b);
6272
6273     HV* r;                   /* the resulting intersection */
6274     UV* array_r;
6275     UV len_r;
6276
6277     UV i_a = 0;             /* current index into a's array */
6278     UV i_b = 0;
6279     UV i_r = 0;
6280
6281     /* running count, as explained in the algorithm source book; items are
6282      * stopped accumulating and are output when the count changes to/from 2.
6283      * The count is incremented when we start a range that's in the set, and
6284      * decremented when we start a range that's not in the set.  So its range
6285      * is 0 to 2.  Only when the count is 2 is something in the intersection.
6286      */
6287     UV count = 0;
6288
6289     PERL_ARGS_ASSERT_INVLIST_INTERSECTION;
6290
6291     /* Size the intersection for the worst case: that the intersection ends up
6292      * fragmenting everything to be completely disjoint */
6293     r= _new_invlist(len_a + len_b);
6294     array_r = invlist_array(r);
6295
6296     /* Go through each list item by item, stopping when exhausted one of
6297      * them */
6298     while (i_a < len_a && i_b < len_b) {
6299         UV cp;      /* The element to potentially add to the intersection's
6300                        array */
6301         bool cp_in_set; /* Is it in the input list's set or not */
6302
6303         /* We need to take one or the other of the two inputs for the union.
6304          * Since we are merging two sorted lists, we take the smaller of the
6305          * next items.  In case of a tie, we take the one that is not in its
6306          * set first (a difference from the union algorithm).  If we took one
6307          * in the set first, it would increment the count, possibly to 2 which
6308          * would cause it to be output as starting a range in the intersection,
6309          * and the next time through we would take that same number, and output
6310          * it again as ending the set.  By doing it the opposite of this, we
6311          * there is no possibility that the count will be momentarily
6312          * incremented to 2.  (In a tie and both are in the set or both not in
6313          * the set, it doesn't matter which we take first.) */
6314         if (array_a[i_a] < array_b[i_b]
6315             || (array_a[i_a] == array_b[i_b] && ! ELEMENT_IN_INVLIST_SET(i_a)))
6316         {
6317             cp_in_set = ELEMENT_IN_INVLIST_SET(i_a);
6318             cp= array_a[i_a++];
6319         }
6320         else {
6321             cp_in_set = ELEMENT_IN_INVLIST_SET(i_b);
6322             cp= array_b[i_b++];
6323         }
6324
6325         /* Here, have chosen which of the two inputs to look at.  Only output
6326          * if the running count changes to/from 2, which marks the
6327          * beginning/end of a range that's in the intersection */
6328         if (cp_in_set) {
6329             count++;
6330             if (count == 2) {
6331                 array_r[i_r++] = cp;
6332             }
6333         }
6334         else {
6335             if (count == 2) {
6336                 array_r[i_r++] = cp;
6337             }
6338             count--;
6339         }
6340     }
6341
6342     /* Here, we are finished going through at least one of the sets, which
6343      * means there is something remaining in at most one.  See the comments in
6344      * the union code */
6345     if ((i_a != len_a && ! ELEMENT_IN_INVLIST_SET(i_a))
6346         || (i_b != len_b && ! ELEMENT_IN_INVLIST_SET(i_b)))
6347     {
6348         count--;
6349     }
6350
6351     /* The final length is what we've output so far plus what else is in the
6352      * intersection.  Only one of the subexpressions below will be non-zero */
6353     len_r = i_r;
6354     if (count == 2) {
6355         len_r += (len_a - i_a) + (len_b - i_b);
6356     }
6357
6358     /* Set result to final length, which can change the pointer to array_r, so
6359      * re-find it */
6360     if (len_r != invlist_len(r)) {
6361         invlist_set_len(r, len_r);
6362         invlist_trim(r);
6363         array_r = invlist_array(r);
6364     }
6365
6366     /* Finish outputting any remaining */
6367     if (count == 2) { /* Only one of will have a non-zero copy count */
6368         IV copy_count;
6369         if ((copy_count = len_a - i_a) > 0) {
6370             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
6371         }
6372         else if ((copy_count = len_b - i_b) > 0) {
6373             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
6374         }
6375     }
6376
6377     return r;
6378 }
6379
6380 STATIC HV*
6381 S_add_range_to_invlist(pTHX_ HV* invlist, const UV start, const UV end)
6382 {
6383     /* Add the range from 'start' to 'end' inclusive to the inversion list's
6384      * set.  A pointer to the inversion list is returned.  This may actually be
6385      * a new list, in which case the passed in one has been destroyed.  The
6386      * passed in inversion list can be NULL, in which case a new one is created
6387      * with just the one range in it */
6388
6389     HV* range_invlist;
6390     HV* added_invlist;
6391     UV len;
6392
6393     if (invlist == NULL) {
6394         invlist = _new_invlist(2);
6395         len = 0;
6396     }
6397     else {
6398         len = invlist_len(invlist);
6399     }
6400
6401     /* If comes after the final entry, can just append it to the end */
6402     if (len == 0
6403         || start >= invlist_array(invlist)
6404                                     [invlist_len(invlist) - 1])
6405     {
6406         _append_range_to_invlist(invlist, start, end);
6407         return invlist;
6408     }
6409
6410     /* Here, can't just append things, create and return a new inversion list
6411      * which is the union of this range and the existing inversion list */
6412     range_invlist = _new_invlist(2);
6413     _append_range_to_invlist(range_invlist, start, end);
6414
6415     added_invlist = invlist_union(invlist, range_invlist);
6416
6417     /* The passed in list can be freed, as well as our temporary */
6418     invlist_destroy(range_invlist);
6419     if (invlist != added_invlist) {
6420         invlist_destroy(invlist);
6421     }
6422
6423     return added_invlist;
6424 }
6425
6426 PERL_STATIC_INLINE HV*
6427 S_add_cp_to_invlist(pTHX_ HV* invlist, const UV cp) {
6428     return add_range_to_invlist(invlist, cp, cp);
6429 }
6430
6431 /* End of inversion list object */
6432
6433 /*
6434  - reg - regular expression, i.e. main body or parenthesized thing
6435  *
6436  * Caller must absorb opening parenthesis.
6437  *
6438  * Combining parenthesis handling with the base level of regular expression
6439  * is a trifle forced, but the need to tie the tails of the branches to what
6440  * follows makes it hard to avoid.
6441  */
6442 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
6443 #ifdef DEBUGGING
6444 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
6445 #else
6446 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
6447 #endif
6448
6449 STATIC regnode *
6450 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
6451     /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
6452 {
6453     dVAR;
6454     register regnode *ret;              /* Will be the head of the group. */
6455     register regnode *br;
6456     register regnode *lastbr;
6457     register regnode *ender = NULL;
6458     register I32 parno = 0;
6459     I32 flags;
6460     U32 oregflags = RExC_flags;
6461     bool have_branch = 0;
6462     bool is_open = 0;
6463     I32 freeze_paren = 0;
6464     I32 after_freeze = 0;
6465
6466     /* for (?g), (?gc), and (?o) warnings; warning
6467        about (?c) will warn about (?g) -- japhy    */
6468
6469 #define WASTED_O  0x01
6470 #define WASTED_G  0x02
6471 #define WASTED_C  0x04
6472 #define WASTED_GC (0x02|0x04)
6473     I32 wastedflags = 0x00;
6474
6475     char * parse_start = RExC_parse; /* MJD */
6476     char * const oregcomp_parse = RExC_parse;
6477
6478     GET_RE_DEBUG_FLAGS_DECL;
6479
6480     PERL_ARGS_ASSERT_REG;
6481     DEBUG_PARSE("reg ");
6482
6483     *flagp = 0;                         /* Tentatively. */
6484
6485
6486     /* Make an OPEN node, if parenthesized. */
6487     if (paren) {
6488         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
6489             char *start_verb = RExC_parse;
6490             STRLEN verb_len = 0;
6491             char *start_arg = NULL;
6492             unsigned char op = 0;
6493             int argok = 1;
6494             int internal_argval = 0; /* internal_argval is only useful if !argok */
6495             while ( *RExC_parse && *RExC_parse != ')' ) {
6496                 if ( *RExC_parse == ':' ) {
6497                     start_arg = RExC_parse + 1;
6498                     break;
6499                 }
6500                 RExC_parse++;
6501             }
6502             ++start_verb;
6503             verb_len = RExC_parse - start_verb;
6504             if ( start_arg ) {
6505                 RExC_parse++;
6506                 while ( *RExC_parse && *RExC_parse != ')' ) 
6507                     RExC_parse++;
6508                 if ( *RExC_parse != ')' ) 
6509                     vFAIL("Unterminated verb pattern argument");
6510                 if ( RExC_parse == start_arg )
6511                     start_arg = NULL;
6512             } else {
6513                 if ( *RExC_parse != ')' )
6514                     vFAIL("Unterminated verb pattern");
6515             }
6516             
6517             switch ( *start_verb ) {
6518             case 'A':  /* (*ACCEPT) */
6519                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
6520                     op = ACCEPT;
6521                     internal_argval = RExC_nestroot;
6522                 }
6523                 break;
6524             case 'C':  /* (*COMMIT) */
6525                 if ( memEQs(start_verb,verb_len,"COMMIT") )
6526                     op = COMMIT;
6527                 break;
6528             case 'F':  /* (*FAIL) */
6529                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
6530                     op = OPFAIL;
6531                     argok = 0;
6532                 }
6533                 break;
6534             case ':':  /* (*:NAME) */
6535             case 'M':  /* (*MARK:NAME) */
6536                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
6537                     op = MARKPOINT;
6538                     argok = -1;
6539                 }
6540                 break;
6541             case 'P':  /* (*PRUNE) */
6542                 if ( memEQs(start_verb,verb_len,"PRUNE") )
6543                     op = PRUNE;
6544                 break;
6545             case 'S':   /* (*SKIP) */  
6546                 if ( memEQs(start_verb,verb_len,"SKIP") ) 
6547                     op = SKIP;
6548                 break;
6549             case 'T':  /* (*THEN) */
6550                 /* [19:06] <TimToady> :: is then */
6551                 if ( memEQs(start_verb,verb_len,"THEN") ) {
6552                     op = CUTGROUP;
6553                     RExC_seen |= REG_SEEN_CUTGROUP;
6554                 }
6555                 break;
6556             }
6557             if ( ! op ) {
6558                 RExC_parse++;
6559                 vFAIL3("Unknown verb pattern '%.*s'",
6560                     verb_len, start_verb);
6561             }
6562             if ( argok ) {
6563                 if ( start_arg && internal_argval ) {
6564                     vFAIL3("Verb pattern '%.*s' may not have an argument",
6565                         verb_len, start_verb); 
6566                 } else if ( argok < 0 && !start_arg ) {
6567                     vFAIL3("Verb pattern '%.*s' has a mandatory argument",
6568                         verb_len, start_verb);    
6569                 } else {
6570                     ret = reganode(pRExC_state, op, internal_argval);
6571                     if ( ! internal_argval && ! SIZE_ONLY ) {
6572                         if (start_arg) {
6573                             SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
6574                             ARG(ret) = add_data( pRExC_state, 1, "S" );
6575                             RExC_rxi->data->data[ARG(ret)]=(void*)sv;
6576                             ret->flags = 0;
6577                         } else {
6578                             ret->flags = 1; 
6579                         }
6580                     }               
6581                 }
6582                 if (!internal_argval)
6583                     RExC_seen |= REG_SEEN_VERBARG;
6584             } else if ( start_arg ) {
6585                 vFAIL3("Verb pattern '%.*s' may not have an argument",
6586                         verb_len, start_verb);    
6587             } else {
6588                 ret = reg_node(pRExC_state, op);
6589             }
6590             nextchar(pRExC_state);
6591             return ret;
6592         } else 
6593         if (*RExC_parse == '?') { /* (?...) */
6594             bool is_logical = 0;
6595             const char * const seqstart = RExC_parse;
6596             bool has_use_defaults = FALSE;
6597
6598             RExC_parse++;
6599             paren = *RExC_parse++;
6600             ret = NULL;                 /* For look-ahead/behind. */
6601             switch (paren) {
6602
6603             case 'P':   /* (?P...) variants for those used to PCRE/Python */
6604                 paren = *RExC_parse++;
6605                 if ( paren == '<')         /* (?P<...>) named capture */
6606                     goto named_capture;
6607                 else if (paren == '>') {   /* (?P>name) named recursion */
6608                     goto named_recursion;
6609                 }
6610                 else if (paren == '=') {   /* (?P=...)  named backref */
6611                     /* this pretty much dupes the code for \k<NAME> in regatom(), if
6612                        you change this make sure you change that */
6613                     char* name_start = RExC_parse;
6614                     U32 num = 0;
6615                     SV *sv_dat = reg_scan_name(pRExC_state,
6616                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6617                     if (RExC_parse == name_start || *RExC_parse != ')')
6618                         vFAIL2("Sequence %.3s... not terminated",parse_start);
6619
6620                     if (!SIZE_ONLY) {
6621                         num = add_data( pRExC_state, 1, "S" );
6622                         RExC_rxi->data->data[num]=(void*)sv_dat;
6623                         SvREFCNT_inc_simple_void(sv_dat);
6624                     }
6625                     RExC_sawback = 1;
6626                     ret = reganode(pRExC_state,
6627                                    ((! FOLD)
6628                                      ? NREF
6629                                      : (MORE_ASCII_RESTRICTED)
6630                                        ? NREFFA
6631                                        : (AT_LEAST_UNI_SEMANTICS)
6632                                          ? NREFFU
6633                                          : (LOC)
6634                                            ? NREFFL
6635                                            : NREFF),
6636                                     num);
6637                     *flagp |= HASWIDTH;
6638
6639                     Set_Node_Offset(ret, parse_start+1);
6640                     Set_Node_Cur_Length(ret); /* MJD */
6641
6642                     nextchar(pRExC_state);
6643                     return ret;
6644                 }
6645                 RExC_parse++;
6646                 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
6647                 /*NOTREACHED*/
6648             case '<':           /* (?<...) */
6649                 if (*RExC_parse == '!')
6650                     paren = ',';
6651                 else if (*RExC_parse != '=') 
6652               named_capture:
6653                 {               /* (?<...>) */
6654                     char *name_start;
6655                     SV *svname;
6656                     paren= '>';
6657             case '\'':          /* (?'...') */
6658                     name_start= RExC_parse;
6659                     svname = reg_scan_name(pRExC_state,
6660                         SIZE_ONLY ?  /* reverse test from the others */
6661                         REG_RSN_RETURN_NAME : 
6662                         REG_RSN_RETURN_NULL);
6663                     if (RExC_parse == name_start) {
6664                         RExC_parse++;
6665                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
6666                         /*NOTREACHED*/
6667                     }
6668                     if (*RExC_parse != paren)
6669                         vFAIL2("Sequence (?%c... not terminated",
6670                             paren=='>' ? '<' : paren);
6671                     if (SIZE_ONLY) {
6672                         HE *he_str;
6673                         SV *sv_dat = NULL;
6674                         if (!svname) /* shouldn't happen */
6675                             Perl_croak(aTHX_
6676                                 "panic: reg_scan_name returned NULL");
6677                         if (!RExC_paren_names) {
6678                             RExC_paren_names= newHV();
6679                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
6680 #ifdef DEBUGGING
6681                             RExC_paren_name_list= newAV();
6682                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
6683 #endif
6684                         }
6685                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
6686                         if ( he_str )
6687                             sv_dat = HeVAL(he_str);
6688                         if ( ! sv_dat ) {
6689                             /* croak baby croak */
6690                             Perl_croak(aTHX_
6691                                 "panic: paren_name hash element allocation failed");
6692                         } else if ( SvPOK(sv_dat) ) {
6693                             /* (?|...) can mean we have dupes so scan to check
6694                                its already been stored. Maybe a flag indicating
6695                                we are inside such a construct would be useful,
6696                                but the arrays are likely to be quite small, so
6697                                for now we punt -- dmq */
6698                             IV count = SvIV(sv_dat);
6699                             I32 *pv = (I32*)SvPVX(sv_dat);
6700                             IV i;
6701                             for ( i = 0 ; i < count ; i++ ) {
6702                                 if ( pv[i] == RExC_npar ) {
6703                                     count = 0;
6704                                     break;
6705                                 }
6706                             }
6707                             if ( count ) {
6708                                 pv = (I32*)SvGROW(sv_dat, SvCUR(sv_dat) + sizeof(I32)+1);
6709                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
6710                                 pv[count] = RExC_npar;
6711                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
6712                             }
6713                         } else {
6714                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
6715                             sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
6716                             SvIOK_on(sv_dat);
6717                             SvIV_set(sv_dat, 1);
6718                         }
6719 #ifdef DEBUGGING
6720                         if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
6721                             SvREFCNT_dec(svname);
6722 #endif
6723
6724                         /*sv_dump(sv_dat);*/
6725                     }
6726                     nextchar(pRExC_state);
6727                     paren = 1;
6728                     goto capturing_parens;
6729                 }
6730                 RExC_seen |= REG_SEEN_LOOKBEHIND;
6731                 RExC_in_lookbehind++;
6732                 RExC_parse++;
6733             case '=':           /* (?=...) */
6734                 RExC_seen_zerolen++;
6735                 break;
6736             case '!':           /* (?!...) */
6737                 RExC_seen_zerolen++;
6738                 if (*RExC_parse == ')') {
6739                     ret=reg_node(pRExC_state, OPFAIL);
6740                     nextchar(pRExC_state);
6741                     return ret;
6742                 }
6743                 break;
6744             case '|':           /* (?|...) */
6745                 /* branch reset, behave like a (?:...) except that
6746                    buffers in alternations share the same numbers */
6747                 paren = ':'; 
6748                 after_freeze = freeze_paren = RExC_npar;
6749                 break;
6750             case ':':           /* (?:...) */
6751             case '>':           /* (?>...) */
6752                 break;
6753             case '$':           /* (?$...) */
6754             case '@':           /* (?@...) */
6755                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
6756                 break;
6757             case '#':           /* (?#...) */
6758                 while (*RExC_parse && *RExC_parse != ')')
6759                     RExC_parse++;
6760                 if (*RExC_parse != ')')
6761                     FAIL("Sequence (?#... not terminated");
6762                 nextchar(pRExC_state);
6763                 *flagp = TRYAGAIN;
6764                 return NULL;
6765             case '0' :           /* (?0) */
6766             case 'R' :           /* (?R) */
6767                 if (*RExC_parse != ')')
6768                     FAIL("Sequence (?R) not terminated");
6769                 ret = reg_node(pRExC_state, GOSTART);
6770                 *flagp |= POSTPONED;
6771                 nextchar(pRExC_state);
6772                 return ret;
6773                 /*notreached*/
6774             { /* named and numeric backreferences */
6775                 I32 num;
6776             case '&':            /* (?&NAME) */
6777                 parse_start = RExC_parse - 1;
6778               named_recursion:
6779                 {
6780                     SV *sv_dat = reg_scan_name(pRExC_state,
6781                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6782                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
6783                 }
6784                 goto gen_recurse_regop;
6785                 /* NOT REACHED */
6786             case '+':
6787                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
6788                     RExC_parse++;
6789                     vFAIL("Illegal pattern");
6790                 }
6791                 goto parse_recursion;
6792                 /* NOT REACHED*/
6793             case '-': /* (?-1) */
6794                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
6795                     RExC_parse--; /* rewind to let it be handled later */
6796                     goto parse_flags;
6797                 } 
6798                 /*FALLTHROUGH */
6799             case '1': case '2': case '3': case '4': /* (?1) */
6800             case '5': case '6': case '7': case '8': case '9':
6801                 RExC_parse--;
6802               parse_recursion:
6803                 num = atoi(RExC_parse);
6804                 parse_start = RExC_parse - 1; /* MJD */
6805                 if (*RExC_parse == '-')
6806                     RExC_parse++;
6807                 while (isDIGIT(*RExC_parse))
6808                         RExC_parse++;
6809                 if (*RExC_parse!=')') 
6810                     vFAIL("Expecting close bracket");
6811                         
6812               gen_recurse_regop:
6813                 if ( paren == '-' ) {
6814                     /*
6815                     Diagram of capture buffer numbering.
6816                     Top line is the normal capture buffer numbers
6817                     Bottom line is the negative indexing as from
6818                     the X (the (?-2))
6819
6820                     +   1 2    3 4 5 X          6 7
6821                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
6822                     -   5 4    3 2 1 X          x x
6823
6824                     */
6825                     num = RExC_npar + num;
6826                     if (num < 1)  {
6827                         RExC_parse++;
6828                         vFAIL("Reference to nonexistent group");
6829                     }
6830                 } else if ( paren == '+' ) {
6831                     num = RExC_npar + num - 1;
6832                 }
6833
6834                 ret = reganode(pRExC_state, GOSUB, num);
6835                 if (!SIZE_ONLY) {
6836                     if (num > (I32)RExC_rx->nparens) {
6837                         RExC_parse++;
6838                         vFAIL("Reference to nonexistent group");
6839                     }
6840                     ARG2L_SET( ret, RExC_recurse_count++);
6841                     RExC_emit++;
6842                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
6843                         "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
6844                 } else {
6845                     RExC_size++;
6846                 }
6847                 RExC_seen |= REG_SEEN_RECURSE;
6848                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
6849                 Set_Node_Offset(ret, parse_start); /* MJD */
6850
6851                 *flagp |= POSTPONED;
6852                 nextchar(pRExC_state);
6853                 return ret;
6854             } /* named and numeric backreferences */
6855             /* NOT REACHED */
6856
6857             case '?':           /* (??...) */
6858                 is_logical = 1;
6859                 if (*RExC_parse != '{') {
6860                     RExC_parse++;
6861                     vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
6862                     /*NOTREACHED*/
6863                 }
6864                 *flagp |= POSTPONED;
6865                 paren = *RExC_parse++;
6866                 /* FALL THROUGH */
6867             case '{':           /* (?{...}) */
6868             {
6869                 I32 count = 1;
6870                 U32 n = 0;
6871                 char c;
6872                 char *s = RExC_parse;
6873
6874                 RExC_seen_zerolen++;
6875                 RExC_seen |= REG_SEEN_EVAL;
6876                 while (count && (c = *RExC_parse)) {
6877                     if (c == '\\') {
6878                         if (RExC_parse[1])
6879                             RExC_parse++;
6880                     }
6881                     else if (c == '{')
6882                         count++;
6883                     else if (c == '}')
6884                         count--;
6885                     RExC_parse++;
6886                 }
6887                 if (*RExC_parse != ')') {
6888                     RExC_parse = s;             
6889                     vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
6890                 }
6891                 if (!SIZE_ONLY) {
6892                     PAD *pad;
6893                     OP_4tree *sop, *rop;
6894                     SV * const sv = newSVpvn(s, RExC_parse - 1 - s);
6895
6896                     ENTER;
6897                     Perl_save_re_context(aTHX);
6898                     rop = Perl_sv_compile_2op_is_broken(aTHX_ sv, &sop, "re", &pad);
6899                     sop->op_private |= OPpREFCOUNTED;
6900                     /* re_dup will OpREFCNT_inc */
6901                     OpREFCNT_set(sop, 1);
6902                     LEAVE;
6903
6904                     n = add_data(pRExC_state, 3, "nop");
6905                     RExC_rxi->data->data[n] = (void*)rop;
6906                     RExC_rxi->data->data[n+1] = (void*)sop;
6907                     RExC_rxi->data->data[n+2] = (void*)pad;
6908                     SvREFCNT_dec(sv);
6909                 }
6910                 else {                                          /* First pass */
6911                     if (PL_reginterp_cnt < ++RExC_seen_evals
6912                         && IN_PERL_RUNTIME)
6913                         /* No compiled RE interpolated, has runtime
6914                            components ===> unsafe.  */
6915                         FAIL("Eval-group not allowed at runtime, use re 'eval'");
6916                     if (PL_tainting && PL_tainted)
6917                         FAIL("Eval-group in insecure regular expression");
6918 #if PERL_VERSION > 8
6919                     if (IN_PERL_COMPILETIME)
6920                         PL_cv_has_eval = 1;
6921 #endif
6922                 }
6923
6924                 nextchar(pRExC_state);
6925                 if (is_logical) {
6926                     ret = reg_node(pRExC_state, LOGICAL);
6927                     if (!SIZE_ONLY)
6928                         ret->flags = 2;
6929                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
6930                     /* deal with the length of this later - MJD */
6931                     return ret;
6932                 }
6933                 ret = reganode(pRExC_state, EVAL, n);
6934                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
6935                 Set_Node_Offset(ret, parse_start);
6936                 return ret;
6937             }
6938             case '(':           /* (?(?{...})...) and (?(?=...)...) */
6939             {
6940                 int is_define= 0;
6941                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
6942                     if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
6943                         || RExC_parse[1] == '<'
6944                         || RExC_parse[1] == '{') { /* Lookahead or eval. */
6945                         I32 flag;
6946                         
6947                         ret = reg_node(pRExC_state, LOGICAL);
6948                         if (!SIZE_ONLY)
6949                             ret->flags = 1;
6950                         REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
6951                         goto insert_if;
6952                     }
6953                 }
6954                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
6955                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
6956                 {
6957                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
6958                     char *name_start= RExC_parse++;
6959                     U32 num = 0;
6960                     SV *sv_dat=reg_scan_name(pRExC_state,
6961                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6962                     if (RExC_parse == name_start || *RExC_parse != ch)
6963                         vFAIL2("Sequence (?(%c... not terminated",
6964                             (ch == '>' ? '<' : ch));
6965                     RExC_parse++;
6966                     if (!SIZE_ONLY) {
6967                         num = add_data( pRExC_state, 1, "S" );
6968                         RExC_rxi->data->data[num]=(void*)sv_dat;
6969                         SvREFCNT_inc_simple_void(sv_dat);
6970                     }
6971                     ret = reganode(pRExC_state,NGROUPP,num);
6972                     goto insert_if_check_paren;
6973                 }
6974                 else if (RExC_parse[0] == 'D' &&
6975                          RExC_parse[1] == 'E' &&
6976                          RExC_parse[2] == 'F' &&
6977                          RExC_parse[3] == 'I' &&
6978                          RExC_parse[4] == 'N' &&
6979                          RExC_parse[5] == 'E')
6980                 {
6981                     ret = reganode(pRExC_state,DEFINEP,0);
6982                     RExC_parse +=6 ;
6983                     is_define = 1;
6984                     goto insert_if_check_paren;
6985                 }
6986                 else if (RExC_parse[0] == 'R') {
6987                     RExC_parse++;
6988                     parno = 0;
6989                     if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
6990                         parno = atoi(RExC_parse++);
6991                         while (isDIGIT(*RExC_parse))
6992                             RExC_parse++;
6993                     } else if (RExC_parse[0] == '&') {
6994                         SV *sv_dat;
6995                         RExC_parse++;
6996                         sv_dat = reg_scan_name(pRExC_state,
6997                             SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6998                         parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
6999                     }
7000                     ret = reganode(pRExC_state,INSUBP,parno); 
7001                     goto insert_if_check_paren;
7002                 }
7003                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
7004                     /* (?(1)...) */
7005                     char c;
7006                     parno = atoi(RExC_parse++);
7007
7008                     while (isDIGIT(*RExC_parse))
7009                         RExC_parse++;
7010                     ret = reganode(pRExC_state, GROUPP, parno);
7011
7012                  insert_if_check_paren:
7013                     if ((c = *nextchar(pRExC_state)) != ')')
7014                         vFAIL("Switch condition not recognized");
7015                   insert_if:
7016                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
7017                     br = regbranch(pRExC_state, &flags, 1,depth+1);
7018                     if (br == NULL)
7019                         br = reganode(pRExC_state, LONGJMP, 0);
7020                     else
7021                         REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
7022                     c = *nextchar(pRExC_state);
7023                     if (flags&HASWIDTH)
7024                         *flagp |= HASWIDTH;
7025                     if (c == '|') {
7026                         if (is_define) 
7027                             vFAIL("(?(DEFINE)....) does not allow branches");
7028                         lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
7029                         regbranch(pRExC_state, &flags, 1,depth+1);
7030                         REGTAIL(pRExC_state, ret, lastbr);
7031                         if (flags&HASWIDTH)
7032                             *flagp |= HASWIDTH;
7033                         c = *nextchar(pRExC_state);
7034                     }
7035                     else
7036                         lastbr = NULL;
7037                     if (c != ')')
7038                         vFAIL("Switch (?(condition)... contains too many branches");
7039                     ender = reg_node(pRExC_state, TAIL);
7040                     REGTAIL(pRExC_state, br, ender);
7041                     if (lastbr) {
7042                         REGTAIL(pRExC_state, lastbr, ender);
7043                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
7044                     }
7045                     else
7046                         REGTAIL(pRExC_state, ret, ender);
7047                     RExC_size++; /* XXX WHY do we need this?!!
7048                                     For large programs it seems to be required
7049                                     but I can't figure out why. -- dmq*/
7050                     return ret;
7051                 }
7052                 else {
7053                     vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
7054                 }
7055             }
7056             case 0:
7057                 RExC_parse--; /* for vFAIL to print correctly */
7058                 vFAIL("Sequence (? incomplete");
7059                 break;
7060             case DEFAULT_PAT_MOD:   /* Use default flags with the exceptions
7061                                        that follow */
7062                 has_use_defaults = TRUE;
7063                 STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
7064                 set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
7065                                                 ? REGEX_UNICODE_CHARSET
7066                                                 : REGEX_DEPENDS_CHARSET);
7067                 goto parse_flags;
7068             default:
7069                 --RExC_parse;
7070                 parse_flags:      /* (?i) */  
7071             {
7072                 U32 posflags = 0, negflags = 0;
7073                 U32 *flagsp = &posflags;
7074                 char has_charset_modifier = '\0';
7075                 regex_charset cs = (RExC_utf8 || RExC_uni_semantics)
7076                                     ? REGEX_UNICODE_CHARSET
7077                                     : REGEX_DEPENDS_CHARSET;
7078
7079                 while (*RExC_parse) {
7080                     /* && strchr("iogcmsx", *RExC_parse) */
7081                     /* (?g), (?gc) and (?o) are useless here
7082                        and must be globally applied -- japhy */
7083                     switch (*RExC_parse) {
7084                     CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
7085                     case LOCALE_PAT_MOD:
7086                         if (has_charset_modifier) {
7087                             goto excess_modifier;
7088                         }
7089                         else if (flagsp == &negflags) {
7090                             goto neg_modifier;
7091                         }
7092                         cs = REGEX_LOCALE_CHARSET;
7093                         has_charset_modifier = LOCALE_PAT_MOD;
7094                         RExC_contains_locale = 1;
7095                         break;
7096                     case UNICODE_PAT_MOD:
7097                         if (has_charset_modifier) {
7098                             goto excess_modifier;
7099                         }
7100                         else if (flagsp == &negflags) {
7101                             goto neg_modifier;
7102                         }
7103                         cs = REGEX_UNICODE_CHARSET;
7104                         has_charset_modifier = UNICODE_PAT_MOD;
7105                         break;
7106                     case ASCII_RESTRICT_PAT_MOD:
7107                         if (flagsp == &negflags) {
7108                             goto neg_modifier;
7109                         }
7110                         if (has_charset_modifier) {
7111                             if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
7112                                 goto excess_modifier;
7113                             }
7114                             /* Doubled modifier implies more restricted */
7115                             cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
7116                         }
7117                         else {
7118                             cs = REGEX_ASCII_RESTRICTED_CHARSET;
7119                         }
7120                         has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
7121                         break;
7122                     case DEPENDS_PAT_MOD:
7123                         if (has_use_defaults) {
7124                             goto fail_modifiers;
7125                         }
7126                         else if (flagsp == &negflags) {
7127                             goto neg_modifier;
7128                         }
7129                         else if (has_charset_modifier) {
7130                             goto excess_modifier;
7131                         }
7132
7133                         /* The dual charset means unicode semantics if the
7134                          * pattern (or target, not known until runtime) are
7135                          * utf8, or something in the pattern indicates unicode
7136                          * semantics */
7137                         cs = (RExC_utf8 || RExC_uni_semantics)
7138                              ? REGEX_UNICODE_CHARSET
7139                              : REGEX_DEPENDS_CHARSET;
7140                         has_charset_modifier = DEPENDS_PAT_MOD;
7141                         break;
7142                     excess_modifier:
7143                         RExC_parse++;
7144                         if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
7145                             vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
7146                         }
7147                         else if (has_charset_modifier == *(RExC_parse - 1)) {
7148                             vFAIL2("Regexp modifier \"%c\" may not appear twice", *(RExC_parse - 1));
7149                         }
7150                         else {
7151                             vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
7152                         }
7153                         /*NOTREACHED*/
7154                     neg_modifier:
7155                         RExC_parse++;
7156                         vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", *(RExC_parse - 1));
7157                         /*NOTREACHED*/
7158                     case ONCE_PAT_MOD: /* 'o' */
7159                     case GLOBAL_PAT_MOD: /* 'g' */
7160                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
7161                             const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
7162                             if (! (wastedflags & wflagbit) ) {
7163                                 wastedflags |= wflagbit;
7164                                 vWARN5(
7165                                     RExC_parse + 1,
7166                                     "Useless (%s%c) - %suse /%c modifier",
7167                                     flagsp == &negflags ? "?-" : "?",
7168                                     *RExC_parse,
7169                                     flagsp == &negflags ? "don't " : "",
7170                                     *RExC_parse
7171                                 );
7172                             }
7173                         }
7174                         break;
7175                         
7176                     case CONTINUE_PAT_MOD: /* 'c' */
7177                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
7178                             if (! (wastedflags & WASTED_C) ) {
7179                                 wastedflags |= WASTED_GC;
7180                                 vWARN3(
7181                                     RExC_parse + 1,
7182                                     "Useless (%sc) - %suse /gc modifier",
7183                                     flagsp == &negflags ? "?-" : "?",
7184                                     flagsp == &negflags ? "don't " : ""
7185                                 );
7186                             }
7187                         }
7188                         break;
7189                     case KEEPCOPY_PAT_MOD: /* 'p' */
7190                         if (flagsp == &negflags) {
7191                             if (SIZE_ONLY)
7192                                 ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
7193                         } else {
7194                             *flagsp |= RXf_PMf_KEEPCOPY;
7195                         }
7196                         break;
7197                     case '-':
7198                         /* A flag is a default iff it is following a minus, so
7199                          * if there is a minus, it means will be trying to
7200                          * re-specify a default which is an error */
7201                         if (has_use_defaults || flagsp == &negflags) {
7202             fail_modifiers:
7203                             RExC_parse++;
7204                             vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7205                             /*NOTREACHED*/
7206                         }
7207                         flagsp = &negflags;
7208                         wastedflags = 0;  /* reset so (?g-c) warns twice */
7209                         break;
7210                     case ':':
7211                         paren = ':';
7212                         /*FALLTHROUGH*/
7213                     case ')':
7214                         RExC_flags |= posflags;
7215                         RExC_flags &= ~negflags;
7216                         set_regex_charset(&RExC_flags, cs);
7217                         if (paren != ':') {
7218                             oregflags |= posflags;
7219                             oregflags &= ~negflags;
7220                             set_regex_charset(&oregflags, cs);
7221                         }
7222                         nextchar(pRExC_state);
7223                         if (paren != ':') {
7224                             *flagp = TRYAGAIN;
7225                             return NULL;
7226                         } else {
7227                             ret = NULL;
7228                             goto parse_rest;
7229                         }
7230                         /*NOTREACHED*/
7231                     default:
7232                         RExC_parse++;
7233                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7234                         /*NOTREACHED*/
7235                     }                           
7236                     ++RExC_parse;
7237                 }
7238             }} /* one for the default block, one for the switch */
7239         }
7240         else {                  /* (...) */
7241           capturing_parens:
7242             parno = RExC_npar;
7243             RExC_npar++;
7244             
7245             ret = reganode(pRExC_state, OPEN, parno);
7246             if (!SIZE_ONLY ){
7247                 if (!RExC_nestroot) 
7248                     RExC_nestroot = parno;
7249                 if (RExC_seen & REG_SEEN_RECURSE
7250                     && !RExC_open_parens[parno-1])
7251                 {
7252                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
7253                         "Setting open paren #%"IVdf" to %d\n", 
7254                         (IV)parno, REG_NODE_NUM(ret)));
7255                     RExC_open_parens[parno-1]= ret;
7256                 }
7257             }
7258             Set_Node_Length(ret, 1); /* MJD */
7259             Set_Node_Offset(ret, RExC_parse); /* MJD */
7260             is_open = 1;
7261         }
7262     }
7263     else                        /* ! paren */
7264         ret = NULL;
7265    
7266    parse_rest:
7267     /* Pick up the branches, linking them together. */
7268     parse_start = RExC_parse;   /* MJD */
7269     br = regbranch(pRExC_state, &flags, 1,depth+1);
7270
7271     /*     branch_len = (paren != 0); */
7272
7273     if (br == NULL)
7274         return(NULL);
7275     if (*RExC_parse == '|') {
7276         if (!SIZE_ONLY && RExC_extralen) {
7277             reginsert(pRExC_state, BRANCHJ, br, depth+1);
7278         }
7279         else {                  /* MJD */
7280             reginsert(pRExC_state, BRANCH, br, depth+1);
7281             Set_Node_Length(br, paren != 0);
7282             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
7283         }
7284         have_branch = 1;
7285         if (SIZE_ONLY)
7286             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
7287     }
7288     else if (paren == ':') {
7289         *flagp |= flags&SIMPLE;
7290     }
7291     if (is_open) {                              /* Starts with OPEN. */
7292         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
7293     }
7294     else if (paren != '?')              /* Not Conditional */
7295         ret = br;
7296     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
7297     lastbr = br;
7298     while (*RExC_parse == '|') {
7299         if (!SIZE_ONLY && RExC_extralen) {
7300             ender = reganode(pRExC_state, LONGJMP,0);
7301             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
7302         }
7303         if (SIZE_ONLY)
7304             RExC_extralen += 2;         /* Account for LONGJMP. */
7305         nextchar(pRExC_state);
7306         if (freeze_paren) {
7307             if (RExC_npar > after_freeze)
7308                 after_freeze = RExC_npar;
7309             RExC_npar = freeze_paren;       
7310         }
7311         br = regbranch(pRExC_state, &flags, 0, depth+1);
7312
7313         if (br == NULL)
7314             return(NULL);
7315         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
7316         lastbr = br;
7317         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
7318     }
7319
7320     if (have_branch || paren != ':') {
7321         /* Make a closing node, and hook it on the end. */
7322         switch (paren) {
7323         case ':':
7324             ender = reg_node(pRExC_state, TAIL);
7325             break;
7326         case 1:
7327             ender = reganode(pRExC_state, CLOSE, parno);
7328             if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
7329                 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
7330                         "Setting close paren #%"IVdf" to %d\n", 
7331                         (IV)parno, REG_NODE_NUM(ender)));
7332                 RExC_close_parens[parno-1]= ender;
7333                 if (RExC_nestroot == parno) 
7334                     RExC_nestroot = 0;
7335             }       
7336             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
7337             Set_Node_Length(ender,1); /* MJD */
7338             break;
7339         case '<':
7340         case ',':
7341         case '=':
7342         case '!':
7343             *flagp &= ~HASWIDTH;
7344             /* FALL THROUGH */
7345         case '>':
7346             ender = reg_node(pRExC_state, SUCCEED);
7347             break;
7348         case 0:
7349             ender = reg_node(pRExC_state, END);
7350             if (!SIZE_ONLY) {
7351                 assert(!RExC_opend); /* there can only be one! */
7352                 RExC_opend = ender;
7353             }
7354             break;
7355         }
7356         REGTAIL(pRExC_state, lastbr, ender);
7357
7358         if (have_branch && !SIZE_ONLY) {
7359             if (depth==1)
7360                 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
7361
7362             /* Hook the tails of the branches to the closing node. */
7363             for (br = ret; br; br = regnext(br)) {
7364                 const U8 op = PL_regkind[OP(br)];
7365                 if (op == BRANCH) {
7366                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
7367                 }
7368                 else if (op == BRANCHJ) {
7369                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
7370                 }
7371             }
7372         }
7373     }
7374
7375     {
7376         const char *p;
7377         static const char parens[] = "=!<,>";
7378
7379         if (paren && (p = strchr(parens, paren))) {
7380             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
7381             int flag = (p - parens) > 1;
7382
7383             if (paren == '>')
7384                 node = SUSPEND, flag = 0;
7385             reginsert(pRExC_state, node,ret, depth+1);
7386             Set_Node_Cur_Length(ret);
7387             Set_Node_Offset(ret, parse_start + 1);
7388             ret->flags = flag;
7389             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
7390         }
7391     }
7392
7393     /* Check for proper termination. */
7394     if (paren) {
7395         RExC_flags = oregflags;
7396         if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
7397             RExC_parse = oregcomp_parse;
7398             vFAIL("Unmatched (");
7399         }
7400     }
7401     else if (!paren && RExC_parse < RExC_end) {
7402         if (*RExC_parse == ')') {
7403             RExC_parse++;
7404             vFAIL("Unmatched )");
7405         }
7406         else
7407             FAIL("Junk on end of regexp");      /* "Can't happen". */
7408         /* NOTREACHED */
7409     }
7410
7411     if (RExC_in_lookbehind) {
7412         RExC_in_lookbehind--;
7413     }
7414     if (after_freeze > RExC_npar)
7415         RExC_npar = after_freeze;
7416     return(ret);
7417 }
7418
7419 /*
7420  - regbranch - one alternative of an | operator
7421  *
7422  * Implements the concatenation operator.
7423  */
7424 STATIC regnode *
7425 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
7426 {
7427     dVAR;
7428     register regnode *ret;
7429     register regnode *chain = NULL;
7430     register regnode *latest;
7431     I32 flags = 0, c = 0;
7432     GET_RE_DEBUG_FLAGS_DECL;
7433
7434     PERL_ARGS_ASSERT_REGBRANCH;
7435
7436     DEBUG_PARSE("brnc");
7437
7438     if (first)
7439         ret = NULL;
7440     else {
7441         if (!SIZE_ONLY && RExC_extralen)
7442             ret = reganode(pRExC_state, BRANCHJ,0);
7443         else {
7444             ret = reg_node(pRExC_state, BRANCH);
7445             Set_Node_Length(ret, 1);
7446         }
7447     }
7448         
7449     if (!first && SIZE_ONLY)
7450         RExC_extralen += 1;                     /* BRANCHJ */
7451
7452     *flagp = WORST;                     /* Tentatively. */
7453
7454     RExC_parse--;
7455     nextchar(pRExC_state);
7456     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
7457         flags &= ~TRYAGAIN;
7458         latest = regpiece(pRExC_state, &flags,depth+1);
7459         if (latest == NULL) {
7460             if (flags & TRYAGAIN)
7461                 continue;
7462             return(NULL);
7463         }
7464         else if (ret == NULL)
7465             ret = latest;
7466         *flagp |= flags&(HASWIDTH|POSTPONED);
7467         if (chain == NULL)      /* First piece. */
7468             *flagp |= flags&SPSTART;
7469         else {
7470             RExC_naughty++;
7471             REGTAIL(pRExC_state, chain, latest);
7472         }
7473         chain = latest;
7474         c++;
7475     }
7476     if (chain == NULL) {        /* Loop ran zero times. */
7477         chain = reg_node(pRExC_state, NOTHING);
7478         if (ret == NULL)
7479             ret = chain;
7480     }
7481     if (c == 1) {
7482         *flagp |= flags&SIMPLE;
7483     }
7484
7485     return ret;
7486 }
7487
7488 /*
7489  - regpiece - something followed by possible [*+?]
7490  *
7491  * Note that the branching code sequences used for ? and the general cases
7492  * of * and + are somewhat optimized:  they use the same NOTHING node as
7493  * both the endmarker for their branch list and the body of the last branch.
7494  * It might seem that this node could be dispensed with entirely, but the
7495  * endmarker role is not redundant.
7496  */
7497 STATIC regnode *
7498 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
7499 {
7500     dVAR;
7501     register regnode *ret;
7502     register char op;
7503     register char *next;
7504     I32 flags;
7505     const char * const origparse = RExC_parse;
7506     I32 min;
7507     I32 max = REG_INFTY;
7508     char *parse_start;
7509     const char *maxpos = NULL;
7510     GET_RE_DEBUG_FLAGS_DECL;
7511
7512     PERL_ARGS_ASSERT_REGPIECE;
7513
7514     DEBUG_PARSE("piec");
7515
7516     ret = regatom(pRExC_state, &flags,depth+1);
7517     if (ret == NULL) {
7518         if (flags & TRYAGAIN)
7519             *flagp |= TRYAGAIN;
7520         return(NULL);
7521     }
7522
7523     op = *RExC_parse;
7524
7525     if (op == '{' && regcurly(RExC_parse)) {
7526         maxpos = NULL;
7527         parse_start = RExC_parse; /* MJD */
7528         next = RExC_parse + 1;
7529         while (isDIGIT(*next) || *next == ',') {
7530             if (*next == ',') {
7531                 if (maxpos)
7532                     break;
7533                 else
7534                     maxpos = next;
7535             }
7536             next++;
7537         }
7538         if (*next == '}') {             /* got one */
7539             if (!maxpos)
7540                 maxpos = next;
7541             RExC_parse++;
7542             min = atoi(RExC_parse);
7543             if (*maxpos == ',')
7544                 maxpos++;
7545             else
7546                 maxpos = RExC_parse;
7547             max = atoi(maxpos);
7548             if (!max && *maxpos != '0')
7549                 max = REG_INFTY;                /* meaning "infinity" */
7550             else if (max >= REG_INFTY)
7551                 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
7552             RExC_parse = next;
7553             nextchar(pRExC_state);
7554
7555         do_curly:
7556             if ((flags&SIMPLE)) {
7557                 RExC_naughty += 2 + RExC_naughty / 2;
7558                 reginsert(pRExC_state, CURLY, ret, depth+1);
7559                 Set_Node_Offset(ret, parse_start+1); /* MJD */
7560                 Set_Node_Cur_Length(ret);
7561             }
7562             else {
7563                 regnode * const w = reg_node(pRExC_state, WHILEM);
7564
7565                 w->flags = 0;
7566                 REGTAIL(pRExC_state, ret, w);
7567                 if (!SIZE_ONLY && RExC_extralen) {
7568                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
7569                     reginsert(pRExC_state, NOTHING,ret, depth+1);
7570                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
7571                 }
7572                 reginsert(pRExC_state, CURLYX,ret, depth+1);
7573                                 /* MJD hk */
7574                 Set_Node_Offset(ret, parse_start+1);
7575                 Set_Node_Length(ret,
7576                                 op == '{' ? (RExC_parse - parse_start) : 1);
7577
7578                 if (!SIZE_ONLY && RExC_extralen)
7579                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
7580                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
7581                 if (SIZE_ONLY)
7582                     RExC_whilem_seen++, RExC_extralen += 3;
7583                 RExC_naughty += 4 + RExC_naughty;       /* compound interest */
7584             }
7585             ret->flags = 0;
7586
7587             if (min > 0)
7588                 *flagp = WORST;
7589             if (max > 0)
7590                 *flagp |= HASWIDTH;
7591             if (max < min)
7592                 vFAIL("Can't do {n,m} with n > m");
7593             if (!SIZE_ONLY) {
7594                 ARG1_SET(ret, (U16)min);
7595                 ARG2_SET(ret, (U16)max);
7596             }
7597
7598             goto nest_check;
7599         }
7600     }
7601
7602     if (!ISMULT1(op)) {
7603         *flagp = flags;
7604         return(ret);
7605     }
7606
7607 #if 0                           /* Now runtime fix should be reliable. */
7608
7609     /* if this is reinstated, don't forget to put this back into perldiag:
7610
7611             =item Regexp *+ operand could be empty at {#} in regex m/%s/
7612
7613            (F) The part of the regexp subject to either the * or + quantifier
7614            could match an empty string. The {#} shows in the regular
7615            expression about where the problem was discovered.
7616
7617     */
7618
7619     if (!(flags&HASWIDTH) && op != '?')
7620       vFAIL("Regexp *+ operand could be empty");
7621 #endif
7622
7623     parse_start = RExC_parse;
7624     nextchar(pRExC_state);
7625
7626     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
7627
7628     if (op == '*' && (flags&SIMPLE)) {
7629         reginsert(pRExC_state, STAR, ret, depth+1);
7630         ret->flags = 0;
7631         RExC_naughty += 4;
7632     }
7633     else if (op == '*') {
7634         min = 0;
7635         goto do_curly;
7636     }
7637     else if (op == '+' && (flags&SIMPLE)) {
7638         reginsert(pRExC_state, PLUS, ret, depth+1);
7639         ret->flags = 0;
7640         RExC_naughty += 3;
7641     }
7642     else if (op == '+') {
7643         min = 1;
7644         goto do_curly;
7645     }
7646     else if (op == '?') {
7647         min = 0; max = 1;
7648         goto do_curly;
7649     }
7650   nest_check:
7651     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
7652         ckWARN3reg(RExC_parse,
7653                    "%.*s matches null string many times",
7654                    (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
7655                    origparse);
7656     }
7657
7658     if (RExC_parse < RExC_end && *RExC_parse == '?') {
7659         nextchar(pRExC_state);
7660         reginsert(pRExC_state, MINMOD, ret, depth+1);
7661         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
7662     }
7663 #ifndef REG_ALLOW_MINMOD_SUSPEND
7664     else
7665 #endif
7666     if (RExC_parse < RExC_end && *RExC_parse == '+') {
7667         regnode *ender;
7668         nextchar(pRExC_state);
7669         ender = reg_node(pRExC_state, SUCCEED);
7670         REGTAIL(pRExC_state, ret, ender);
7671         reginsert(pRExC_state, SUSPEND, ret, depth+1);
7672         ret->flags = 0;
7673         ender = reg_node(pRExC_state, TAIL);
7674         REGTAIL(pRExC_state, ret, ender);
7675         /*ret= ender;*/
7676     }
7677
7678     if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
7679         RExC_parse++;
7680         vFAIL("Nested quantifiers");
7681     }
7682
7683     return(ret);
7684 }
7685
7686
7687 /* reg_namedseq(pRExC_state,UVp, UV depth)
7688    
7689    This is expected to be called by a parser routine that has 
7690    recognized '\N' and needs to handle the rest. RExC_parse is
7691    expected to point at the first char following the N at the time
7692    of the call.
7693
7694    The \N may be inside (indicated by valuep not being NULL) or outside a
7695    character class.
7696
7697    \N may begin either a named sequence, or if outside a character class, mean
7698    to match a non-newline.  For non single-quoted regexes, the tokenizer has
7699    attempted to decide which, and in the case of a named sequence converted it
7700    into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...},
7701    where c1... are the characters in the sequence.  For single-quoted regexes,
7702    the tokenizer passes the \N sequence through unchanged; this code will not
7703    attempt to determine this nor expand those.  The net effect is that if the
7704    beginning of the passed-in pattern isn't '{U+' or there is no '}', it
7705    signals that this \N occurrence means to match a non-newline.
7706    
7707    Only the \N{U+...} form should occur in a character class, for the same
7708    reason that '.' inside a character class means to just match a period: it
7709    just doesn't make sense.
7710    
7711    If valuep is non-null then it is assumed that we are parsing inside 
7712    of a charclass definition and the first codepoint in the resolved
7713    string is returned via *valuep and the routine will return NULL. 
7714    In this mode if a multichar string is returned from the charnames 
7715    handler, a warning will be issued, and only the first char in the 
7716    sequence will be examined. If the string returned is zero length
7717    then the value of *valuep is undefined and NON-NULL will 
7718    be returned to indicate failure. (This will NOT be a valid pointer 
7719    to a regnode.)
7720    
7721    If valuep is null then it is assumed that we are parsing normal text and a
7722    new EXACT node is inserted into the program containing the resolved string,
7723    and a pointer to the new node is returned.  But if the string is zero length
7724    a NOTHING node is emitted instead.
7725
7726    On success RExC_parse is set to the char following the endbrace.
7727    Parsing failures will generate a fatal error via vFAIL(...)
7728  */
7729 STATIC regnode *
7730 S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep, I32 *flagp, U32 depth)
7731 {
7732     char * endbrace;    /* '}' following the name */
7733     regnode *ret = NULL;
7734     char* p;
7735
7736     GET_RE_DEBUG_FLAGS_DECL;
7737  
7738     PERL_ARGS_ASSERT_REG_NAMEDSEQ;
7739
7740     GET_RE_DEBUG_FLAGS;
7741
7742     /* The [^\n] meaning of \N ignores spaces and comments under the /x
7743      * modifier.  The other meaning does not */
7744     p = (RExC_flags & RXf_PMf_EXTENDED)
7745         ? regwhite( pRExC_state, RExC_parse )
7746         : RExC_parse;
7747    
7748     /* Disambiguate between \N meaning a named character versus \N meaning
7749      * [^\n].  The former is assumed when it can't be the latter. */
7750     if (*p != '{' || regcurly(p)) {
7751         RExC_parse = p;
7752         if (valuep) {
7753             /* no bare \N in a charclass */
7754             vFAIL("\\N in a character class must be a named character: \\N{...}");
7755         }
7756         nextchar(pRExC_state);
7757         ret = reg_node(pRExC_state, REG_ANY);
7758         *flagp |= HASWIDTH|SIMPLE;
7759         RExC_naughty++;
7760         RExC_parse--;
7761         Set_Node_Length(ret, 1); /* MJD */
7762         return ret;
7763     }
7764
7765     /* Here, we have decided it should be a named sequence */
7766
7767     /* The test above made sure that the next real character is a '{', but
7768      * under the /x modifier, it could be separated by space (or a comment and
7769      * \n) and this is not allowed (for consistency with \x{...} and the
7770      * tokenizer handling of \N{NAME}). */
7771     if (*RExC_parse != '{') {
7772         vFAIL("Missing braces on \\N{}");
7773     }
7774
7775     RExC_parse++;       /* Skip past the '{' */
7776
7777     if (! (endbrace = strchr(RExC_parse, '}')) /* no trailing brace */
7778         || ! (endbrace == RExC_parse            /* nothing between the {} */
7779               || (endbrace - RExC_parse >= 2    /* U+ (bad hex is checked below */
7780                   && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg) */
7781     {
7782         if (endbrace) RExC_parse = endbrace;    /* position msg's '<--HERE' */
7783         vFAIL("\\N{NAME} must be resolved by the lexer");
7784     }
7785
7786     if (endbrace == RExC_parse) {   /* empty: \N{} */
7787         if (! valuep) {
7788             RExC_parse = endbrace + 1;  
7789             return reg_node(pRExC_state,NOTHING);
7790         }
7791
7792         if (SIZE_ONLY) {
7793             ckWARNreg(RExC_parse,
7794                     "Ignoring zero length \\N{} in character class"
7795             );
7796             RExC_parse = endbrace + 1;  
7797         }
7798         *valuep = 0;
7799         return (regnode *) &RExC_parse; /* Invalid regnode pointer */
7800     }
7801
7802     REQUIRE_UTF8;       /* named sequences imply Unicode semantics */
7803     RExC_parse += 2;    /* Skip past the 'U+' */
7804
7805     if (valuep) {   /* In a bracketed char class */
7806         /* We only pay attention to the first char of 
7807         multichar strings being returned. I kinda wonder
7808         if this makes sense as it does change the behaviour
7809         from earlier versions, OTOH that behaviour was broken
7810         as well. XXX Solution is to recharacterize as
7811         [rest-of-class]|multi1|multi2... */
7812
7813         STRLEN length_of_hex;
7814         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
7815             | PERL_SCAN_DISALLOW_PREFIX
7816             | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
7817     
7818         char * endchar = RExC_parse + strcspn(RExC_parse, ".}");
7819         if (endchar < endbrace) {
7820             ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
7821         }
7822
7823         length_of_hex = (STRLEN)(endchar - RExC_parse);
7824         *valuep = grok_hex(RExC_parse, &length_of_hex, &flags, NULL);
7825
7826         /* The tokenizer should have guaranteed validity, but it's possible to
7827          * bypass it by using single quoting, so check */
7828         if (length_of_hex == 0
7829             || length_of_hex != (STRLEN)(endchar - RExC_parse) )
7830         {
7831             RExC_parse += length_of_hex;        /* Includes all the valid */
7832             RExC_parse += (RExC_orig_utf8)      /* point to after 1st invalid */
7833                             ? UTF8SKIP(RExC_parse)
7834                             : 1;
7835             /* Guard against malformed utf8 */
7836             if (RExC_parse >= endchar) RExC_parse = endchar;
7837             vFAIL("Invalid hexadecimal number in \\N{U+...}");
7838         }    
7839
7840         RExC_parse = endbrace + 1;
7841         if (endchar == endbrace) return NULL;
7842
7843         ret = (regnode *) &RExC_parse;  /* Invalid regnode pointer */
7844     }
7845     else {      /* Not a char class */
7846
7847         /* What is done here is to convert this to a sub-pattern of the form
7848          * (?:\x{char1}\x{char2}...)
7849          * and then call reg recursively.  That way, it retains its atomicness,
7850          * while not having to worry about special handling that some code
7851          * points may have.  toke.c has converted the original Unicode values
7852          * to native, so that we can just pass on the hex values unchanged.  We
7853          * do have to set a flag to keep recoding from happening in the
7854          * recursion */
7855
7856         SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP);
7857         STRLEN len;
7858         char *endchar;      /* Points to '.' or '}' ending cur char in the input
7859                                stream */
7860         char *orig_end = RExC_end;
7861
7862         while (RExC_parse < endbrace) {
7863
7864             /* Code points are separated by dots.  If none, there is only one
7865              * code point, and is terminated by the brace */
7866             endchar = RExC_parse + strcspn(RExC_parse, ".}");
7867
7868             /* Convert to notation the rest of the code understands */
7869             sv_catpv(substitute_parse, "\\x{");
7870             sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
7871             sv_catpv(substitute_parse, "}");
7872
7873             /* Point to the beginning of the next character in the sequence. */
7874             RExC_parse = endchar + 1;
7875         }
7876         sv_catpv(substitute_parse, ")");
7877
7878         RExC_parse = SvPV(substitute_parse, len);
7879
7880         /* Don't allow empty number */
7881         if (len < 8) {
7882             vFAIL("Invalid hexadecimal number in \\N{U+...}");
7883         }
7884         RExC_end = RExC_parse + len;
7885
7886         /* The values are Unicode, and therefore not subject to recoding */
7887         RExC_override_recoding = 1;
7888
7889         ret = reg(pRExC_state, 1, flagp, depth+1);
7890
7891         RExC_parse = endbrace;
7892         RExC_end = orig_end;
7893         RExC_override_recoding = 0;
7894
7895         nextchar(pRExC_state);
7896     }
7897
7898     return ret;
7899 }
7900
7901
7902 /*
7903  * reg_recode
7904  *
7905  * It returns the code point in utf8 for the value in *encp.
7906  *    value: a code value in the source encoding
7907  *    encp:  a pointer to an Encode object
7908  *
7909  * If the result from Encode is not a single character,
7910  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
7911  */
7912 STATIC UV
7913 S_reg_recode(pTHX_ const char value, SV **encp)
7914 {
7915     STRLEN numlen = 1;
7916     SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP);
7917     const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
7918     const STRLEN newlen = SvCUR(sv);
7919     UV uv = UNICODE_REPLACEMENT;
7920
7921     PERL_ARGS_ASSERT_REG_RECODE;
7922
7923     if (newlen)
7924         uv = SvUTF8(sv)
7925              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
7926              : *(U8*)s;
7927
7928     if (!newlen || numlen != newlen) {
7929         uv = UNICODE_REPLACEMENT;
7930         *encp = NULL;
7931     }
7932     return uv;
7933 }
7934
7935
7936 /*
7937  - regatom - the lowest level
7938
7939    Try to identify anything special at the start of the pattern. If there
7940    is, then handle it as required. This may involve generating a single regop,
7941    such as for an assertion; or it may involve recursing, such as to
7942    handle a () structure.
7943
7944    If the string doesn't start with something special then we gobble up
7945    as much literal text as we can.
7946
7947    Once we have been able to handle whatever type of thing started the
7948    sequence, we return.
7949
7950    Note: we have to be careful with escapes, as they can be both literal
7951    and special, and in the case of \10 and friends can either, depending
7952    on context. Specifically there are two separate switches for handling
7953    escape sequences, with the one for handling literal escapes requiring
7954    a dummy entry for all of the special escapes that are actually handled
7955    by the other.
7956 */
7957
7958 STATIC regnode *
7959 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
7960 {
7961     dVAR;
7962     register regnode *ret = NULL;
7963     I32 flags;
7964     char *parse_start = RExC_parse;
7965     U8 op;
7966     GET_RE_DEBUG_FLAGS_DECL;
7967     DEBUG_PARSE("atom");
7968     *flagp = WORST;             /* Tentatively. */
7969
7970     PERL_ARGS_ASSERT_REGATOM;
7971
7972 tryagain:
7973     switch ((U8)*RExC_parse) {
7974     case '^':
7975         RExC_seen_zerolen++;
7976         nextchar(pRExC_state);
7977         if (RExC_flags & RXf_PMf_MULTILINE)
7978             ret = reg_node(pRExC_state, MBOL);
7979         else if (RExC_flags & RXf_PMf_SINGLELINE)
7980             ret = reg_node(pRExC_state, SBOL);
7981         else
7982             ret = reg_node(pRExC_state, BOL);
7983         Set_Node_Length(ret, 1); /* MJD */
7984         break;
7985     case '$':
7986         nextchar(pRExC_state);
7987         if (*RExC_parse)
7988             RExC_seen_zerolen++;
7989         if (RExC_flags & RXf_PMf_MULTILINE)
7990             ret = reg_node(pRExC_state, MEOL);
7991         else if (RExC_flags & RXf_PMf_SINGLELINE)
7992             ret = reg_node(pRExC_state, SEOL);
7993         else
7994             ret = reg_node(pRExC_state, EOL);
7995         Set_Node_Length(ret, 1); /* MJD */
7996         break;
7997     case '.':
7998         nextchar(pRExC_state);
7999         if (RExC_flags & RXf_PMf_SINGLELINE)
8000             ret = reg_node(pRExC_state, SANY);
8001         else
8002             ret = reg_node(pRExC_state, REG_ANY);
8003         *flagp |= HASWIDTH|SIMPLE;
8004         RExC_naughty++;
8005         Set_Node_Length(ret, 1); /* MJD */
8006         break;
8007     case '[':
8008     {
8009         char * const oregcomp_parse = ++RExC_parse;
8010         ret = regclass(pRExC_state,depth+1);
8011         if (*RExC_parse != ']') {
8012             RExC_parse = oregcomp_parse;
8013             vFAIL("Unmatched [");
8014         }
8015         nextchar(pRExC_state);
8016         *flagp |= HASWIDTH|SIMPLE;
8017         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
8018         break;
8019     }
8020     case '(':
8021         nextchar(pRExC_state);
8022         ret = reg(pRExC_state, 1, &flags,depth+1);
8023         if (ret == NULL) {
8024                 if (flags & TRYAGAIN) {
8025                     if (RExC_parse == RExC_end) {
8026                          /* Make parent create an empty node if needed. */
8027                         *flagp |= TRYAGAIN;
8028                         return(NULL);
8029                     }
8030                     goto tryagain;
8031                 }
8032                 return(NULL);
8033         }
8034         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
8035         break;
8036     case '|':
8037     case ')':
8038         if (flags & TRYAGAIN) {
8039             *flagp |= TRYAGAIN;
8040             return NULL;
8041         }
8042         vFAIL("Internal urp");
8043                                 /* Supposed to be caught earlier. */
8044         break;
8045     case '{':
8046         if (!regcurly(RExC_parse)) {
8047             RExC_parse++;
8048             goto defchar;
8049         }
8050         /* FALL THROUGH */
8051     case '?':
8052     case '+':
8053     case '*':
8054         RExC_parse++;
8055         vFAIL("Quantifier follows nothing");
8056         break;
8057     case '\\':
8058         /* Special Escapes
8059
8060            This switch handles escape sequences that resolve to some kind
8061            of special regop and not to literal text. Escape sequnces that
8062            resolve to literal text are handled below in the switch marked
8063            "Literal Escapes".
8064
8065            Every entry in this switch *must* have a corresponding entry
8066            in the literal escape switch. However, the opposite is not
8067            required, as the default for this switch is to jump to the
8068            literal text handling code.
8069         */
8070         switch ((U8)*++RExC_parse) {
8071         /* Special Escapes */
8072         case 'A':
8073             RExC_seen_zerolen++;
8074             ret = reg_node(pRExC_state, SBOL);
8075             *flagp |= SIMPLE;
8076             goto finish_meta_pat;
8077         case 'G':
8078             ret = reg_node(pRExC_state, GPOS);
8079             RExC_seen |= REG_SEEN_GPOS;
8080             *flagp |= SIMPLE;
8081             goto finish_meta_pat;
8082         case 'K':
8083             RExC_seen_zerolen++;
8084             ret = reg_node(pRExC_state, KEEPS);
8085             *flagp |= SIMPLE;
8086             /* XXX:dmq : disabling in-place substitution seems to
8087              * be necessary here to avoid cases of memory corruption, as
8088              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
8089              */
8090             RExC_seen |= REG_SEEN_LOOKBEHIND;
8091             goto finish_meta_pat;
8092         case 'Z':
8093             ret = reg_node(pRExC_state, SEOL);
8094             *flagp |= SIMPLE;
8095             RExC_seen_zerolen++;                /* Do not optimize RE away */
8096             goto finish_meta_pat;
8097         case 'z':
8098             ret = reg_node(pRExC_state, EOS);
8099             *flagp |= SIMPLE;
8100             RExC_seen_zerolen++;                /* Do not optimize RE away */
8101             goto finish_meta_pat;
8102         case 'C':
8103             ret = reg_node(pRExC_state, CANY);
8104             RExC_seen |= REG_SEEN_CANY;
8105             *flagp |= HASWIDTH|SIMPLE;
8106             goto finish_meta_pat;
8107         case 'X':
8108             ret = reg_node(pRExC_state, CLUMP);
8109             *flagp |= HASWIDTH;
8110             goto finish_meta_pat;
8111         case 'w':
8112             switch (get_regex_charset(RExC_flags)) {
8113                 case REGEX_LOCALE_CHARSET:
8114                     op = ALNUML;
8115                     break;
8116                 case REGEX_UNICODE_CHARSET:
8117                     op = ALNUMU;
8118                     break;
8119                 case REGEX_ASCII_RESTRICTED_CHARSET:
8120                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8121                     op = ALNUMA;
8122                     break;
8123                 case REGEX_DEPENDS_CHARSET:
8124                     op = ALNUM;
8125                     break;
8126                 default:
8127                     goto bad_charset;
8128             }
8129             ret = reg_node(pRExC_state, op);
8130             *flagp |= HASWIDTH|SIMPLE;
8131             goto finish_meta_pat;
8132         case 'W':
8133             switch (get_regex_charset(RExC_flags)) {
8134                 case REGEX_LOCALE_CHARSET:
8135                     op = NALNUML;
8136                     break;
8137                 case REGEX_UNICODE_CHARSET:
8138                     op = NALNUMU;
8139                     break;
8140                 case REGEX_ASCII_RESTRICTED_CHARSET:
8141                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8142                     op = NALNUMA;
8143                     break;
8144                 case REGEX_DEPENDS_CHARSET:
8145                     op = NALNUM;
8146                     break;
8147                 default:
8148                     goto bad_charset;
8149             }
8150             ret = reg_node(pRExC_state, op);
8151             *flagp |= HASWIDTH|SIMPLE;
8152             goto finish_meta_pat;
8153         case 'b':
8154             RExC_seen_zerolen++;
8155             RExC_seen |= REG_SEEN_LOOKBEHIND;
8156             switch (get_regex_charset(RExC_flags)) {
8157                 case REGEX_LOCALE_CHARSET:
8158                     op = BOUNDL;
8159                     break;
8160                 case REGEX_UNICODE_CHARSET:
8161                     op = BOUNDU;
8162                     break;
8163                 case REGEX_ASCII_RESTRICTED_CHARSET:
8164                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8165                     op = BOUNDA;
8166                     break;
8167                 case REGEX_DEPENDS_CHARSET:
8168                     op = BOUND;
8169                     break;
8170                 default:
8171                     goto bad_charset;
8172             }
8173             ret = reg_node(pRExC_state, op);
8174             FLAGS(ret) = get_regex_charset(RExC_flags);
8175             *flagp |= SIMPLE;
8176             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
8177                 ckWARNregdep(RExC_parse, "\"\\b{\" is deprecated; use \"\\b\\{\" instead");
8178             }
8179             goto finish_meta_pat;
8180         case 'B':
8181             RExC_seen_zerolen++;
8182             RExC_seen |= REG_SEEN_LOOKBEHIND;
8183             switch (get_regex_charset(RExC_flags)) {
8184                 case REGEX_LOCALE_CHARSET:
8185                     op = NBOUNDL;
8186                     break;
8187                 case REGEX_UNICODE_CHARSET:
8188                     op = NBOUNDU;
8189                     break;
8190                 case REGEX_ASCII_RESTRICTED_CHARSET:
8191                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8192                     op = NBOUNDA;
8193                     break;
8194                 case REGEX_DEPENDS_CHARSET:
8195                     op = NBOUND;
8196                     break;
8197                 default:
8198                     goto bad_charset;
8199             }
8200             ret = reg_node(pRExC_state, op);
8201             FLAGS(ret) = get_regex_charset(RExC_flags);
8202             *flagp |= SIMPLE;
8203             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
8204                 ckWARNregdep(RExC_parse, "\"\\B{\" is deprecated; use \"\\B\\{\" instead");
8205             }
8206             goto finish_meta_pat;
8207         case 's':
8208             switch (get_regex_charset(RExC_flags)) {
8209                 case REGEX_LOCALE_CHARSET:
8210                     op = SPACEL;
8211                     break;
8212                 case REGEX_UNICODE_CHARSET:
8213                     op = SPACEU;
8214                     break;
8215                 case REGEX_ASCII_RESTRICTED_CHARSET:
8216                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8217                     op = SPACEA;
8218                     break;
8219                 case REGEX_DEPENDS_CHARSET:
8220                     op = SPACE;
8221                     break;
8222                 default:
8223                     goto bad_charset;
8224             }
8225             ret = reg_node(pRExC_state, op);
8226             *flagp |= HASWIDTH|SIMPLE;
8227             goto finish_meta_pat;
8228         case 'S':
8229             switch (get_regex_charset(RExC_flags)) {
8230                 case REGEX_LOCALE_CHARSET:
8231                     op = NSPACEL;
8232                     break;
8233                 case REGEX_UNICODE_CHARSET:
8234                     op = NSPACEU;
8235                     break;
8236                 case REGEX_ASCII_RESTRICTED_CHARSET:
8237                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8238                     op = NSPACEA;
8239                     break;
8240                 case REGEX_DEPENDS_CHARSET:
8241                     op = NSPACE;
8242                     break;
8243                 default:
8244                     goto bad_charset;
8245             }
8246             ret = reg_node(pRExC_state, op);
8247             *flagp |= HASWIDTH|SIMPLE;
8248             goto finish_meta_pat;
8249         case 'd':
8250             switch (get_regex_charset(RExC_flags)) {
8251                 case REGEX_LOCALE_CHARSET:
8252                     op = DIGITL;
8253                     break;
8254                 case REGEX_ASCII_RESTRICTED_CHARSET:
8255                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8256                     op = DIGITA;
8257                     break;
8258                 case REGEX_DEPENDS_CHARSET: /* No difference between these */
8259                 case REGEX_UNICODE_CHARSET:
8260                     op = DIGIT;
8261                     break;
8262                 default:
8263                     goto bad_charset;
8264             }
8265             ret = reg_node(pRExC_state, op);
8266             *flagp |= HASWIDTH|SIMPLE;
8267             goto finish_meta_pat;
8268         case 'D':
8269             switch (get_regex_charset(RExC_flags)) {
8270                 case REGEX_LOCALE_CHARSET:
8271                     op = NDIGITL;
8272                     break;
8273                 case REGEX_ASCII_RESTRICTED_CHARSET:
8274                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8275                     op = NDIGITA;
8276                     break;
8277                 case REGEX_DEPENDS_CHARSET: /* No difference between these */
8278                 case REGEX_UNICODE_CHARSET:
8279                     op = NDIGIT;
8280                     break;
8281                 default:
8282                     goto bad_charset;
8283             }
8284             ret = reg_node(pRExC_state, op);
8285             *flagp |= HASWIDTH|SIMPLE;
8286             goto finish_meta_pat;
8287         case 'R':
8288             ret = reg_node(pRExC_state, LNBREAK);
8289             *flagp |= HASWIDTH|SIMPLE;
8290             goto finish_meta_pat;
8291         case 'h':
8292             ret = reg_node(pRExC_state, HORIZWS);
8293             *flagp |= HASWIDTH|SIMPLE;
8294             goto finish_meta_pat;
8295         case 'H':
8296             ret = reg_node(pRExC_state, NHORIZWS);
8297             *flagp |= HASWIDTH|SIMPLE;
8298             goto finish_meta_pat;
8299         case 'v':
8300             ret = reg_node(pRExC_state, VERTWS);
8301             *flagp |= HASWIDTH|SIMPLE;
8302             goto finish_meta_pat;
8303         case 'V':
8304             ret = reg_node(pRExC_state, NVERTWS);
8305             *flagp |= HASWIDTH|SIMPLE;
8306          finish_meta_pat:           
8307             nextchar(pRExC_state);
8308             Set_Node_Length(ret, 2); /* MJD */
8309             break;          
8310         case 'p':
8311         case 'P':
8312             {   
8313                 char* const oldregxend = RExC_end;
8314 #ifdef DEBUGGING
8315                 char* parse_start = RExC_parse - 2;
8316 #endif
8317
8318                 if (RExC_parse[1] == '{') {
8319                   /* a lovely hack--pretend we saw [\pX] instead */
8320                     RExC_end = strchr(RExC_parse, '}');
8321                     if (!RExC_end) {
8322                         const U8 c = (U8)*RExC_parse;
8323                         RExC_parse += 2;
8324                         RExC_end = oldregxend;
8325                         vFAIL2("Missing right brace on \\%c{}", c);
8326                     }
8327                     RExC_end++;
8328                 }
8329                 else {
8330                     RExC_end = RExC_parse + 2;
8331                     if (RExC_end > oldregxend)
8332                         RExC_end = oldregxend;
8333                 }
8334                 RExC_parse--;
8335
8336                 ret = regclass(pRExC_state,depth+1);
8337
8338                 RExC_end = oldregxend;
8339                 RExC_parse--;
8340
8341                 Set_Node_Offset(ret, parse_start + 2);
8342                 Set_Node_Cur_Length(ret);
8343                 nextchar(pRExC_state);
8344                 *flagp |= HASWIDTH|SIMPLE;
8345             }
8346             break;
8347         case 'N': 
8348             /* Handle \N and \N{NAME} here and not below because it can be
8349             multicharacter. join_exact() will join them up later on. 
8350             Also this makes sure that things like /\N{BLAH}+/ and 
8351             \N{BLAH} being multi char Just Happen. dmq*/
8352             ++RExC_parse;
8353             ret= reg_namedseq(pRExC_state, NULL, flagp, depth);
8354             break;
8355         case 'k':    /* Handle \k<NAME> and \k'NAME' */
8356         parse_named_seq:
8357         {   
8358             char ch= RExC_parse[1];         
8359             if (ch != '<' && ch != '\'' && ch != '{') {
8360                 RExC_parse++;
8361                 vFAIL2("Sequence %.2s... not terminated",parse_start);
8362             } else {
8363                 /* this pretty much dupes the code for (?P=...) in reg(), if
8364                    you change this make sure you change that */
8365                 char* name_start = (RExC_parse += 2);
8366                 U32 num = 0;
8367                 SV *sv_dat = reg_scan_name(pRExC_state,
8368                     SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8369                 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
8370                 if (RExC_parse == name_start || *RExC_parse != ch)
8371                     vFAIL2("Sequence %.3s... not terminated",parse_start);
8372
8373                 if (!SIZE_ONLY) {
8374                     num = add_data( pRExC_state, 1, "S" );
8375                     RExC_rxi->data->data[num]=(void*)sv_dat;
8376                     SvREFCNT_inc_simple_void(sv_dat);
8377                 }
8378
8379                 RExC_sawback = 1;
8380                 ret = reganode(pRExC_state,
8381                                ((! FOLD)
8382                                  ? NREF
8383                                  : (MORE_ASCII_RESTRICTED)
8384                                    ? NREFFA
8385                                    : (AT_LEAST_UNI_SEMANTICS)
8386                                      ? NREFFU
8387                                      : (LOC)
8388                                        ? NREFFL
8389                                        : NREFF),
8390                                 num);
8391                 *flagp |= HASWIDTH;
8392
8393                 /* override incorrect value set in reganode MJD */
8394                 Set_Node_Offset(ret, parse_start+1);
8395                 Set_Node_Cur_Length(ret); /* MJD */
8396                 nextchar(pRExC_state);
8397
8398             }
8399             break;
8400         }
8401         case 'g': 
8402         case '1': case '2': case '3': case '4':
8403         case '5': case '6': case '7': case '8': case '9':
8404             {
8405                 I32 num;
8406                 bool isg = *RExC_parse == 'g';
8407                 bool isrel = 0; 
8408                 bool hasbrace = 0;
8409                 if (isg) {
8410                     RExC_parse++;
8411                     if (*RExC_parse == '{') {
8412                         RExC_parse++;
8413                         hasbrace = 1;
8414                     }
8415                     if (*RExC_parse == '-') {
8416                         RExC_parse++;
8417                         isrel = 1;
8418                     }
8419                     if (hasbrace && !isDIGIT(*RExC_parse)) {
8420                         if (isrel) RExC_parse--;
8421                         RExC_parse -= 2;                            
8422                         goto parse_named_seq;
8423                 }   }
8424                 num = atoi(RExC_parse);
8425                 if (isg && num == 0)
8426                     vFAIL("Reference to invalid group 0");
8427                 if (isrel) {
8428                     num = RExC_npar - num;
8429                     if (num < 1)
8430                         vFAIL("Reference to nonexistent or unclosed group");
8431                 }
8432                 if (!isg && num > 9 && num >= RExC_npar)
8433                     goto defchar;
8434                 else {
8435                     char * const parse_start = RExC_parse - 1; /* MJD */
8436                     while (isDIGIT(*RExC_parse))
8437                         RExC_parse++;
8438                     if (parse_start == RExC_parse - 1) 
8439                         vFAIL("Unterminated \\g... pattern");
8440                     if (hasbrace) {
8441                         if (*RExC_parse != '}') 
8442                             vFAIL("Unterminated \\g{...} pattern");
8443                         RExC_parse++;
8444                     }    
8445                     if (!SIZE_ONLY) {
8446                         if (num > (I32)RExC_rx->nparens)
8447                             vFAIL("Reference to nonexistent group");
8448                     }
8449                     RExC_sawback = 1;
8450                     ret = reganode(pRExC_state,
8451                                    ((! FOLD)
8452                                      ? REF
8453                                      : (MORE_ASCII_RESTRICTED)
8454                                        ? REFFA
8455                                        : (AT_LEAST_UNI_SEMANTICS)
8456                                          ? REFFU
8457                                          : (LOC)
8458                                            ? REFFL
8459                                            : REFF),
8460                                     num);
8461                     *flagp |= HASWIDTH;
8462
8463                     /* override incorrect value set in reganode MJD */
8464                     Set_Node_Offset(ret, parse_start+1);
8465                     Set_Node_Cur_Length(ret); /* MJD */
8466                     RExC_parse--;
8467                     nextchar(pRExC_state);
8468                 }
8469             }
8470             break;
8471         case '\0':
8472             if (RExC_parse >= RExC_end)
8473                 FAIL("Trailing \\");
8474             /* FALL THROUGH */
8475         default:
8476             /* Do not generate "unrecognized" warnings here, we fall
8477                back into the quick-grab loop below */
8478             parse_start--;
8479             goto defchar;
8480         }
8481         break;
8482
8483     case '#':
8484         if (RExC_flags & RXf_PMf_EXTENDED) {
8485             if ( reg_skipcomment( pRExC_state ) )
8486                 goto tryagain;
8487         }
8488         /* FALL THROUGH */
8489
8490     default:
8491
8492             parse_start = RExC_parse - 1;
8493
8494             RExC_parse++;
8495
8496         defchar: {
8497             typedef enum {
8498                 generic_char = 0,
8499                 char_s,
8500                 upsilon_1,
8501                 upsilon_2,
8502                 iota_1,
8503                 iota_2,
8504             } char_state;
8505             char_state latest_char_state = generic_char;
8506             register STRLEN len;
8507             register UV ender;
8508             register char *p;
8509             char *s;
8510             STRLEN foldlen;
8511             U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
8512             regnode * orig_emit;
8513
8514             ender = 0;
8515             orig_emit = RExC_emit; /* Save the original output node position in
8516                                       case we need to output a different node
8517                                       type */
8518             ret = reg_node(pRExC_state,
8519                            (U8) ((! FOLD) ? EXACT
8520                                           : (LOC)
8521                                              ? EXACTFL
8522                                              : (MORE_ASCII_RESTRICTED)
8523                                                ? EXACTFA
8524                                                : (AT_LEAST_UNI_SEMANTICS)
8525                                                  ? EXACTFU
8526                                                  : EXACTF)
8527                     );
8528             s = STRING(ret);
8529             for (len = 0, p = RExC_parse - 1;
8530               len < 127 && p < RExC_end;
8531               len++)
8532             {
8533                 char * const oldp = p;
8534
8535                 if (RExC_flags & RXf_PMf_EXTENDED)
8536                     p = regwhite( pRExC_state, p );
8537                 switch ((U8)*p) {
8538                 case '^':
8539                 case '$':
8540                 case '.':
8541                 case '[':
8542                 case '(':
8543                 case ')':
8544                 case '|':
8545                     goto loopdone;
8546                 case '\\':
8547                     /* Literal Escapes Switch
8548
8549                        This switch is meant to handle escape sequences that
8550                        resolve to a literal character.
8551
8552                        Every escape sequence that represents something
8553                        else, like an assertion or a char class, is handled
8554                        in the switch marked 'Special Escapes' above in this
8555                        routine, but also has an entry here as anything that
8556                        isn't explicitly mentioned here will be treated as
8557                        an unescaped equivalent literal.
8558                     */
8559
8560                     switch ((U8)*++p) {
8561                     /* These are all the special escapes. */
8562                     case 'A':             /* Start assertion */
8563                     case 'b': case 'B':   /* Word-boundary assertion*/
8564                     case 'C':             /* Single char !DANGEROUS! */
8565                     case 'd': case 'D':   /* digit class */
8566                     case 'g': case 'G':   /* generic-backref, pos assertion */
8567                     case 'h': case 'H':   /* HORIZWS */
8568                     case 'k': case 'K':   /* named backref, keep marker */
8569                     case 'N':             /* named char sequence */
8570                     case 'p': case 'P':   /* Unicode property */
8571                               case 'R':   /* LNBREAK */
8572                     case 's': case 'S':   /* space class */
8573                     case 'v': case 'V':   /* VERTWS */
8574                     case 'w': case 'W':   /* word class */
8575                     case 'X':             /* eXtended Unicode "combining character sequence" */
8576                     case 'z': case 'Z':   /* End of line/string assertion */
8577                         --p;
8578                         goto loopdone;
8579
8580                     /* Anything after here is an escape that resolves to a
8581                        literal. (Except digits, which may or may not)
8582                      */
8583                     case 'n':
8584                         ender = '\n';
8585                         p++;
8586                         break;
8587                     case 'r':
8588                         ender = '\r';
8589                         p++;
8590                         break;
8591                     case 't':
8592                         ender = '\t';
8593                         p++;
8594                         break;
8595                     case 'f':
8596                         ender = '\f';
8597                         p++;
8598                         break;
8599                     case 'e':
8600                           ender = ASCII_TO_NATIVE('\033');
8601                         p++;
8602                         break;
8603                     case 'a':
8604                           ender = ASCII_TO_NATIVE('\007');
8605                         p++;
8606                         break;
8607                     case 'o':
8608                         {
8609                             STRLEN brace_len = len;
8610                             UV result;
8611                             const char* error_msg;
8612
8613                             bool valid = grok_bslash_o(p,
8614                                                        &result,
8615                                                        &brace_len,
8616                                                        &error_msg,
8617                                                        1);
8618                             p += brace_len;
8619                             if (! valid) {
8620                                 RExC_parse = p; /* going to die anyway; point
8621                                                    to exact spot of failure */
8622                                 vFAIL(error_msg);
8623                             }
8624                             else
8625                             {
8626                                 ender = result;
8627                             }
8628                             if (PL_encoding && ender < 0x100) {
8629                                 goto recode_encoding;
8630                             }
8631                             if (ender > 0xff) {
8632                                 REQUIRE_UTF8;
8633                             }
8634                             break;
8635                         }
8636                     case 'x':
8637                         if (*++p == '{') {
8638                             char* const e = strchr(p, '}');
8639         
8640                             if (!e) {
8641                                 RExC_parse = p + 1;
8642                                 vFAIL("Missing right brace on \\x{}");
8643                             }
8644                             else {
8645                                 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
8646                                     | PERL_SCAN_DISALLOW_PREFIX;
8647                                 STRLEN numlen = e - p - 1;
8648                                 ender = grok_hex(p + 1, &numlen, &flags, NULL);
8649                                 if (ender > 0xff)
8650                                     REQUIRE_UTF8;
8651                                 p = e + 1;
8652                             }
8653                         }
8654                         else {
8655                             I32 flags = PERL_SCAN_DISALLOW_PREFIX;
8656                             STRLEN numlen = 2;
8657                             ender = grok_hex(p, &numlen, &flags, NULL);
8658                             p += numlen;
8659                         }
8660                         if (PL_encoding && ender < 0x100)
8661                             goto recode_encoding;
8662                         break;
8663                     case 'c':
8664                         p++;
8665                         ender = grok_bslash_c(*p++, UTF, SIZE_ONLY);
8666                         break;
8667                     case '0': case '1': case '2': case '3':case '4':
8668                     case '5': case '6': case '7': case '8':case '9':
8669                         if (*p == '0' ||
8670                             (isDIGIT(p[1]) && atoi(p) >= RExC_npar))
8671                         {
8672                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
8673                             STRLEN numlen = 3;
8674                             ender = grok_oct(p, &numlen, &flags, NULL);
8675                             if (ender > 0xff) {
8676                                 REQUIRE_UTF8;
8677                             }
8678                             p += numlen;
8679                         }
8680                         else {
8681                             --p;
8682                             goto loopdone;
8683                         }
8684                         if (PL_encoding && ender < 0x100)
8685                             goto recode_encoding;
8686                         break;
8687                     recode_encoding:
8688                         if (! RExC_override_recoding) {
8689                             SV* enc = PL_encoding;
8690                             ender = reg_recode((const char)(U8)ender, &enc);
8691                             if (!enc && SIZE_ONLY)
8692                                 ckWARNreg(p, "Invalid escape in the specified encoding");
8693                             REQUIRE_UTF8;
8694                         }
8695                         break;
8696                     case '\0':
8697                         if (p >= RExC_end)
8698                             FAIL("Trailing \\");
8699                         /* FALL THROUGH */
8700                     default:
8701                         if (!SIZE_ONLY&& isALPHA(*p)) {
8702                             /* Include any { following the alpha to emphasize
8703                              * that it could be part of an escape at some point
8704                              * in the future */
8705                             int len = (*(p + 1) == '{') ? 2 : 1;
8706                             ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
8707                         }
8708                         goto normal_default;
8709                     }
8710                     break;
8711                 default:
8712                   normal_default:
8713                     if (UTF8_IS_START(*p) && UTF) {
8714                         STRLEN numlen;
8715                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
8716                                                &numlen, UTF8_ALLOW_DEFAULT);
8717                         p += numlen;
8718                     }
8719                     else
8720                         ender = (U8) *p++;
8721                     break;
8722                 } /* End of switch on the literal */
8723
8724                 /* Certain characters are problematic because their folded
8725                  * length is so different from their original length that it
8726                  * isn't handleable by the optimizer.  They are therefore not
8727                  * placed in an EXACTish node; and are here handled specially.
8728                  * (Even if the optimizer handled LATIN_SMALL_LETTER_SHARP_S,
8729                  * putting it in a special node keeps regexec from having to
8730                  * deal with a non-utf8 multi-char fold */
8731                 if (FOLD
8732                     && (ender > 255 || (! MORE_ASCII_RESTRICTED && ! LOC)))
8733                 {
8734                     /* We look for either side of the fold.  For example \xDF
8735                      * folds to 'ss'.  We look for both the single character
8736                      * \xDF and the sequence 'ss'.  When we find something that
8737                      * could be one of those, we stop and flush whatever we
8738                      * have output so far into the EXACTish node that was being
8739                      * built.  Then restore the input pointer to what it was.
8740                      * regatom will return that EXACT node, and will be called
8741                      * again, positioned so the first character is the one in
8742                      * question, which we return in a different node type.
8743                      * The multi-char folds are a sequence, so the occurrence
8744                      * of the first character in that sequence doesn't
8745                      * necessarily mean that what follows is the rest of the
8746                      * sequence.  We keep track of that with a state machine,
8747                      * with the state being set to the latest character
8748                      * processed before the current one.  Most characters will
8749                      * set the state to 0, but if one occurs that is part of a
8750                      * potential tricky fold sequence, the state is set to that
8751                      * character, and the next loop iteration sees if the state
8752                      * should progress towards the final folded-from character,
8753                      * or if it was a false alarm.  If it turns out to be a
8754                      * false alarm, the character(s) will be output in a new
8755                      * EXACTish node, and join_exact() will later combine them.
8756                      * In the case of the 'ss' sequence, which is more common
8757                      * and more easily checked, some look-ahead is done to
8758                      * save time by ruling-out some false alarms */
8759                     switch (ender) {
8760                         default:
8761                             latest_char_state = generic_char;
8762                             break;
8763                         case 's':
8764                         case 'S':
8765                              if (AT_LEAST_UNI_SEMANTICS) {
8766                                 if (latest_char_state == char_s) {  /* 'ss' */
8767                                     ender = LATIN_SMALL_LETTER_SHARP_S;
8768                                     goto do_tricky;
8769                                 }
8770                                 else if (p < RExC_end) {
8771
8772                                     /* Look-ahead at the next character.  If it
8773                                      * is also an s, we handle as a sharp s
8774                                      * tricky regnode.  */
8775                                     if (*p == 's' || *p == 'S') {
8776
8777                                         /* But first flush anything in the
8778                                          * EXACTish buffer */
8779                                         if (len != 0) {
8780                                             p = oldp;
8781                                             goto loopdone;
8782                                         }
8783                                         p++;    /* Account for swallowing this
8784                                                    's' up */
8785                                         ender = LATIN_SMALL_LETTER_SHARP_S;
8786                                         goto do_tricky;
8787                                     }
8788                                         /* Here, the next character is not a
8789                                          * literal 's', but still could
8790                                          * evaluate to one if part of a \o{},
8791                                          * \x or \OCTAL-DIGIT.  The minimum
8792                                          * length required for that is 4, eg
8793                                          * \x53 or \123 */
8794                                     else if (*p == '\\'
8795                                              && p < RExC_end - 4
8796                                              && (isDIGIT(*(p + 1))
8797                                                  || *(p + 1) == 'x'
8798                                                  || *(p + 1) == 'o' ))
8799                                     {
8800
8801                                         /* Here, it could be an 's', too much
8802                                          * bother to figure it out here.  Flush
8803                                          * the buffer if any; when come back
8804                                          * here, set the state so know that the
8805                                          * previous char was an 's' */
8806                                         if (len != 0) {
8807                                             latest_char_state = generic_char;
8808                                             p = oldp;
8809                                             goto loopdone;
8810                                         }
8811                                         latest_char_state = char_s;
8812                                         break;
8813                                     }
8814                                 }
8815                             }
8816
8817                             /* Here, can't be an 'ss' sequence, or at least not
8818                              * one that could fold to/from the sharp ss */
8819                             latest_char_state = generic_char;
8820                             break;
8821                         case 0x03C5:    /* First char in upsilon series */
8822                             if (p < RExC_end - 4) { /* Need >= 4 bytes left */
8823                                 latest_char_state = upsilon_1;
8824                                 if (len != 0) {
8825                                     p = oldp;
8826                                     goto loopdone;
8827                                 }
8828                             }
8829                             else {
8830                                 latest_char_state = generic_char;
8831                             }
8832                             break;
8833                         case 0x03B9:    /* First char in iota series */
8834                             if (p < RExC_end - 4) {
8835                                 latest_char_state = iota_1;
8836                                 if (len != 0) {
8837                                     p = oldp;
8838                                     goto loopdone;
8839                                 }
8840                             }
8841                             else {
8842                                 latest_char_state = generic_char;
8843                             }
8844                             break;
8845                         case 0x0308:
8846                             if (latest_char_state == upsilon_1) {
8847                                 latest_char_state = upsilon_2;
8848                             }
8849                             else if (latest_char_state == iota_1) {
8850                                 latest_char_state = iota_2;
8851                             }
8852                             else {
8853                                 latest_char_state = generic_char;
8854                             }
8855                             break;
8856                         case 0x301:
8857                             if (latest_char_state == upsilon_2) {
8858                                 ender = GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS;
8859                                 goto do_tricky;
8860                             }
8861                             else if (latest_char_state == iota_2) {
8862                                 ender = GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS;
8863                                 goto do_tricky;
8864                             }
8865                             latest_char_state = generic_char;
8866                             break;
8867
8868                         /* These are the tricky fold characters.  Flush any
8869                          * buffer first. */
8870                         case GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS:
8871                         case GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS:
8872                         case LATIN_SMALL_LETTER_SHARP_S:
8873                         case LATIN_CAPITAL_LETTER_SHARP_S:
8874                         case 0x1FD3:
8875                         case 0x1FE3:
8876                             if (len != 0) {
8877                                 p = oldp;
8878                                 goto loopdone;
8879                             }
8880                             /* FALL THROUGH */
8881                         do_tricky: {
8882                             char* const oldregxend = RExC_end;
8883                             U8 tmpbuf[UTF8_MAXBYTES+1];
8884
8885                             /* Here, we know we need to generate a special
8886                              * regnode, and 'ender' contains the tricky
8887                              * character.  What's done is to pretend it's in a
8888                              * [bracketed] class, and let the code that deals
8889                              * with those handle it, as that code has all the
8890                              * intelligence necessary.  First save the current
8891                              * parse state, get rid of the already allocated
8892                              * but empty EXACT node that the ANYOFV node will
8893                              * replace, and point the parse to a buffer which
8894                              * we fill with the character we want the regclass
8895                              * code to think is being parsed */
8896                             RExC_emit = orig_emit;
8897                             RExC_parse = (char *) tmpbuf;
8898                             if (UTF) {
8899                                 U8 *d = uvchr_to_utf8(tmpbuf, ender);
8900                                 *d = '\0';
8901                                 RExC_end = (char *) d;
8902                             }
8903                             else {  /* ender above 255 already excluded */
8904                                 tmpbuf[0] = (U8) ender;
8905                                 tmpbuf[1] = '\0';
8906                                 RExC_end = RExC_parse + 1;
8907                             }
8908
8909                             ret = regclass(pRExC_state,depth+1);
8910
8911                             /* Here, have parsed the buffer.  Reset the parse to
8912                              * the actual input, and return */
8913                             RExC_end = oldregxend;
8914                             RExC_parse = p - 1;
8915
8916                             Set_Node_Offset(ret, RExC_parse);
8917                             Set_Node_Cur_Length(ret);
8918                             nextchar(pRExC_state);
8919                             *flagp |= HASWIDTH|SIMPLE;
8920                             return ret;
8921                         }
8922                     }
8923                 }
8924
8925                 if ( RExC_flags & RXf_PMf_EXTENDED)
8926                     p = regwhite( pRExC_state, p );
8927                 if (UTF && FOLD) {
8928                     /* Prime the casefolded buffer.  Locale rules, which apply
8929                      * only to code points < 256, aren't known until execution,
8930                      * so for them, just output the original character using
8931                      * utf8 */
8932                     if (LOC && ender < 256) {
8933                         if (UNI_IS_INVARIANT(ender)) {
8934                             *tmpbuf = (U8) ender;
8935                             foldlen = 1;
8936                         } else {
8937                             *tmpbuf = UTF8_TWO_BYTE_HI(ender);
8938                             *(tmpbuf + 1) = UTF8_TWO_BYTE_LO(ender);
8939                             foldlen = 2;
8940                         }
8941                     }
8942                     else if (isASCII(ender)) {  /* Note: Here can't also be LOC
8943                                                  */
8944                         ender = toLOWER(ender);
8945                         *tmpbuf = (U8) ender;
8946                         foldlen = 1;
8947                     }
8948                     else if (! MORE_ASCII_RESTRICTED && ! LOC) {
8949
8950                         /* Locale and /aa require more selectivity about the
8951                          * fold, so are handled below.  Otherwise, here, just
8952                          * use the fold */
8953                         ender = toFOLD_uni(ender, tmpbuf, &foldlen);
8954                     }
8955                     else {
8956                         /* Under locale rules or /aa we are not to mix,
8957                          * respectively, ords < 256 or ASCII with non-.  So
8958                          * reject folds that mix them, using only the
8959                          * non-folded code point.  So do the fold to a
8960                          * temporary, and inspect each character in it. */
8961                         U8 trialbuf[UTF8_MAXBYTES_CASE+1];
8962                         U8* s = trialbuf;
8963                         UV tmpender = toFOLD_uni(ender, trialbuf, &foldlen);
8964                         U8* e = s + foldlen;
8965                         bool fold_ok = TRUE;
8966
8967                         while (s < e) {
8968                             if (isASCII(*s)
8969                                 || (LOC && (UTF8_IS_INVARIANT(*s)
8970                                            || UTF8_IS_DOWNGRADEABLE_START(*s))))
8971                             {
8972                                 fold_ok = FALSE;
8973                                 break;
8974                             }
8975                             s += UTF8SKIP(s);
8976                         }
8977                         if (fold_ok) {
8978                             Copy(trialbuf, tmpbuf, foldlen, U8);
8979                             ender = tmpender;
8980                         }
8981                         else {
8982                             uvuni_to_utf8(tmpbuf, ender);
8983                             foldlen = UNISKIP(ender);
8984                         }
8985                     }
8986                 }
8987                 if (p < RExC_end && ISMULT2(p)) { /* Back off on ?+*. */
8988                     if (len)
8989                         p = oldp;
8990                     else if (UTF) {
8991                          if (FOLD) {
8992                               /* Emit all the Unicode characters. */
8993                               STRLEN numlen;
8994                               for (foldbuf = tmpbuf;
8995                                    foldlen;
8996                                    foldlen -= numlen) {
8997                                    ender = utf8_to_uvchr(foldbuf, &numlen);
8998                                    if (numlen > 0) {
8999                                         const STRLEN unilen = reguni(pRExC_state, ender, s);
9000                                         s       += unilen;
9001                                         len     += unilen;
9002                                         /* In EBCDIC the numlen
9003                                          * and unilen can differ. */
9004                                         foldbuf += numlen;
9005                                         if (numlen >= foldlen)
9006                                              break;
9007                                    }
9008                                    else
9009                                         break; /* "Can't happen." */
9010                               }
9011                          }
9012                          else {
9013                               const STRLEN unilen = reguni(pRExC_state, ender, s);
9014                               if (unilen > 0) {
9015                                    s   += unilen;
9016                                    len += unilen;
9017                               }
9018                          }
9019                     }
9020                     else {
9021                         len++;
9022                         REGC((char)ender, s++);
9023                     }
9024                     break;
9025                 }
9026                 if (UTF) {
9027                      if (FOLD) {
9028                           /* Emit all the Unicode characters. */
9029                           STRLEN numlen;
9030                           for (foldbuf = tmpbuf;
9031                                foldlen;
9032                                foldlen -= numlen) {
9033                                ender = utf8_to_uvchr(foldbuf, &numlen);
9034                                if (numlen > 0) {
9035                                     const STRLEN unilen = reguni(pRExC_state, ender, s);
9036                                     len     += unilen;
9037                                     s       += unilen;
9038                                     /* In EBCDIC the numlen
9039                                      * and unilen can differ. */
9040                                     foldbuf += numlen;
9041                                     if (numlen >= foldlen)
9042                                          break;
9043                                }
9044                                else
9045                                     break;
9046                           }
9047                      }
9048                      else {
9049                           const STRLEN unilen = reguni(pRExC_state, ender, s);
9050                           if (unilen > 0) {
9051                                s   += unilen;
9052                                len += unilen;
9053                           }
9054                      }
9055                      len--;
9056                 }
9057                 else {
9058                     REGC((char)ender, s++);
9059                 }
9060             }
9061         loopdone:   /* Jumped to when encounters something that shouldn't be in
9062                        the node */
9063             RExC_parse = p - 1;
9064             Set_Node_Cur_Length(ret); /* MJD */
9065             nextchar(pRExC_state);
9066             {
9067                 /* len is STRLEN which is unsigned, need to copy to signed */
9068                 IV iv = len;
9069                 if (iv < 0)
9070                     vFAIL("Internal disaster");
9071             }
9072             if (len > 0)
9073                 *flagp |= HASWIDTH;
9074             if (len == 1 && UNI_IS_INVARIANT(ender))
9075                 *flagp |= SIMPLE;
9076                 
9077             if (SIZE_ONLY)
9078                 RExC_size += STR_SZ(len);
9079             else {
9080                 STR_LEN(ret) = len;
9081                 RExC_emit += STR_SZ(len);
9082             }
9083         }
9084         break;
9085     }
9086
9087     return(ret);
9088
9089 /* Jumped to when an unrecognized character set is encountered */
9090 bad_charset:
9091     Perl_croak(aTHX_ "panic: Unknown regex character set encoding: %u", get_regex_charset(RExC_flags));
9092     return(NULL);
9093 }
9094
9095 STATIC char *
9096 S_regwhite( RExC_state_t *pRExC_state, char *p )
9097 {
9098     const char *e = RExC_end;
9099
9100     PERL_ARGS_ASSERT_REGWHITE;
9101
9102     while (p < e) {
9103         if (isSPACE(*p))
9104             ++p;
9105         else if (*p == '#') {
9106             bool ended = 0;
9107             do {
9108                 if (*p++ == '\n') {
9109                     ended = 1;
9110                     break;
9111                 }
9112             } while (p < e);
9113             if (!ended)
9114                 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
9115         }
9116         else
9117             break;
9118     }
9119     return p;
9120 }
9121
9122 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
9123    Character classes ([:foo:]) can also be negated ([:^foo:]).
9124    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
9125    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
9126    but trigger failures because they are currently unimplemented. */
9127
9128 #define POSIXCC_DONE(c)   ((c) == ':')
9129 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
9130 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
9131
9132 STATIC I32
9133 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
9134 {
9135     dVAR;
9136     I32 namedclass = OOB_NAMEDCLASS;
9137
9138     PERL_ARGS_ASSERT_REGPPOSIXCC;
9139
9140     if (value == '[' && RExC_parse + 1 < RExC_end &&
9141         /* I smell either [: or [= or [. -- POSIX has been here, right? */
9142         POSIXCC(UCHARAT(RExC_parse))) {
9143         const char c = UCHARAT(RExC_parse);
9144         char* const s = RExC_parse++;
9145         
9146         while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
9147             RExC_parse++;
9148         if (RExC_parse == RExC_end)
9149             /* Grandfather lone [:, [=, [. */
9150             RExC_parse = s;
9151         else {
9152             const char* const t = RExC_parse++; /* skip over the c */
9153             assert(*t == c);
9154
9155             if (UCHARAT(RExC_parse) == ']') {
9156                 const char *posixcc = s + 1;
9157                 RExC_parse++; /* skip over the ending ] */
9158
9159                 if (*s == ':') {
9160                     const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
9161                     const I32 skip = t - posixcc;
9162
9163                     /* Initially switch on the length of the name.  */
9164                     switch (skip) {
9165                     case 4:
9166                         if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
9167                             namedclass = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
9168                         break;
9169                     case 5:
9170                         /* Names all of length 5.  */
9171                         /* alnum alpha ascii blank cntrl digit graph lower
9172                            print punct space upper  */
9173                         /* Offset 4 gives the best switch position.  */
9174                         switch (posixcc[4]) {
9175                         case 'a':
9176                             if (memEQ(posixcc, "alph", 4)) /* alpha */
9177                                 namedclass = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
9178                             break;
9179                         case 'e':
9180                             if (memEQ(posixcc, "spac", 4)) /* space */
9181                                 namedclass = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
9182                             break;
9183                         case 'h':
9184                             if (memEQ(posixcc, "grap", 4)) /* graph */
9185                                 namedclass = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
9186                             break;
9187                         case 'i':
9188                             if (memEQ(posixcc, "asci", 4)) /* ascii */
9189                                 namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII;
9190                             break;
9191                         case 'k':
9192                             if (memEQ(posixcc, "blan", 4)) /* blank */
9193                                 namedclass = complement ? ANYOF_NBLANK : ANYOF_BLANK;
9194                             break;
9195                         case 'l':
9196                             if (memEQ(posixcc, "cntr", 4)) /* cntrl */
9197                                 namedclass = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
9198                             break;
9199                         case 'm':
9200                             if (memEQ(posixcc, "alnu", 4)) /* alnum */
9201                                 namedclass = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
9202                             break;
9203                         case 'r':
9204                             if (memEQ(posixcc, "lowe", 4)) /* lower */
9205                                 namedclass = complement ? ANYOF_NLOWER : ANYOF_LOWER;
9206                             else if (memEQ(posixcc, "uppe", 4)) /* upper */
9207                                 namedclass = complement ? ANYOF_NUPPER : ANYOF_UPPER;
9208                             break;
9209                         case 't':
9210                             if (memEQ(posixcc, "digi", 4)) /* digit */
9211                                 namedclass = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
9212                             else if (memEQ(posixcc, "prin", 4)) /* print */
9213                                 namedclass = complement ? ANYOF_NPRINT : ANYOF_PRINT;
9214                             else if (memEQ(posixcc, "punc", 4)) /* punct */
9215                                 namedclass = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
9216                             break;
9217                         }
9218                         break;
9219                     case 6:
9220                         if (memEQ(posixcc, "xdigit", 6))
9221                             namedclass = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
9222                         break;
9223                     }
9224
9225                     if (namedclass == OOB_NAMEDCLASS)
9226                         Simple_vFAIL3("POSIX class [:%.*s:] unknown",
9227                                       t - s - 1, s + 1);
9228                     assert (posixcc[skip] == ':');
9229                     assert (posixcc[skip+1] == ']');
9230                 } else if (!SIZE_ONLY) {
9231                     /* [[=foo=]] and [[.foo.]] are still future. */
9232
9233                     /* adjust RExC_parse so the warning shows after
9234                        the class closes */
9235                     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
9236                         RExC_parse++;
9237                     Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
9238                 }
9239             } else {
9240                 /* Maternal grandfather:
9241                  * "[:" ending in ":" but not in ":]" */
9242                 RExC_parse = s;
9243             }
9244         }
9245     }
9246
9247     return namedclass;
9248 }
9249
9250 STATIC void
9251 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
9252 {
9253     dVAR;
9254
9255     PERL_ARGS_ASSERT_CHECKPOSIXCC;
9256
9257     if (POSIXCC(UCHARAT(RExC_parse))) {
9258         const char *s = RExC_parse;
9259         const char  c = *s++;
9260
9261         while (isALNUM(*s))
9262             s++;
9263         if (*s && c == *s && s[1] == ']') {
9264             ckWARN3reg(s+2,
9265                        "POSIX syntax [%c %c] belongs inside character classes",
9266                        c, c);
9267
9268             /* [[=foo=]] and [[.foo.]] are still future. */
9269             if (POSIXCC_NOTYET(c)) {
9270                 /* adjust RExC_parse so the error shows after
9271                    the class closes */
9272                 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
9273                     NOOP;
9274                 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
9275             }
9276         }
9277     }
9278 }
9279
9280 /* No locale test, and always Unicode semantics */
9281 #define _C_C_T_NOLOC_(NAME,TEST,WORD)                                          \
9282 ANYOF_##NAME:                                                                  \
9283         for (value = 0; value < 256; value++)                                  \
9284             if (TEST)                                                          \
9285             stored += set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);  \
9286     yesno = '+';                                                               \
9287     what = WORD;                                                               \
9288     break;                                                                     \
9289 case ANYOF_N##NAME:                                                            \
9290         for (value = 0; value < 256; value++)                                  \
9291             if (!TEST)                                                         \
9292             stored += set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);  \
9293     yesno = '!';                                                               \
9294     what = WORD;                                                               \
9295     break
9296
9297 /* Like the above, but there are differences if we are in uni-8-bit or not, so
9298  * there are two tests passed in, to use depending on that. There aren't any
9299  * cases where the label is different from the name, so no need for that
9300  * parameter */
9301 #define _C_C_T_(NAME, TEST_8, TEST_7, WORD)                                    \
9302 ANYOF_##NAME:                                                                  \
9303     if (LOC) ANYOF_CLASS_SET(ret, ANYOF_##NAME);                               \
9304     else if (UNI_SEMANTICS) {                                                  \
9305         for (value = 0; value < 256; value++) {                                \
9306             if (TEST_8(value)) stored +=                                       \
9307                       set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);  \
9308         }                                                                      \
9309     }                                                                          \
9310     else {                                                                     \
9311         for (value = 0; value < 128; value++) {                                \
9312             if (TEST_7(UNI_TO_NATIVE(value))) stored +=                        \
9313                 set_regclass_bit(pRExC_state, ret,                     \
9314                                    (U8) UNI_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate);                 \
9315         }                                                                      \
9316     }                                                                          \
9317     yesno = '+';                                                               \
9318     what = WORD;                                                               \
9319     break;                                                                     \
9320 case ANYOF_N##NAME:                                                            \
9321     if (LOC) ANYOF_CLASS_SET(ret, ANYOF_N##NAME);                              \
9322     else if (UNI_SEMANTICS) {                                                  \
9323         for (value = 0; value < 256; value++) {                                \
9324             if (! TEST_8(value)) stored +=                                     \
9325                     set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);    \
9326         }                                                                      \
9327     }                                                                          \
9328     else {                                                                     \
9329         for (value = 0; value < 128; value++) {                                \
9330             if (! TEST_7(UNI_TO_NATIVE(value))) stored += set_regclass_bit(  \
9331                         pRExC_state, ret, (U8) UNI_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate);    \
9332         }                                                                      \
9333         if (AT_LEAST_ASCII_RESTRICTED) {                                       \
9334             for (value = 128; value < 256; value++) {                          \
9335              stored += set_regclass_bit(                                     \
9336                            pRExC_state, ret, (U8) UNI_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate); \
9337             }                                                                  \
9338             ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;                             \
9339         }                                                                      \
9340         else {                                                                 \
9341             /* For a non-ut8 target string with DEPENDS semantics, all above   \
9342              * ASCII Latin1 code points match the complement of any of the     \
9343              * classes.  But in utf8, they have their Unicode semantics, so    \
9344              * can't just set them in the bitmap, or else regexec.c will think \
9345              * they matched when they shouldn't. */                            \
9346             ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL;                     \
9347         }                                                                      \
9348     }                                                                          \
9349     yesno = '!';                                                               \
9350     what = WORD;                                                               \
9351     break
9352
9353 STATIC U8
9354 S_set_regclass_bit_fold(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, HV** invlist_ptr, AV** alternate_ptr)
9355 {
9356
9357     /* Handle the setting of folds in the bitmap for non-locale ANYOF nodes.
9358      * Locale folding is done at run-time, so this function should not be
9359      * called for nodes that are for locales.
9360      *
9361      * This function sets the bit corresponding to the fold of the input
9362      * 'value', if not already set.  The fold of 'f' is 'F', and the fold of
9363      * 'F' is 'f'.
9364      *
9365      * It also knows about the characters that are in the bitmap that have
9366      * folds that are matchable only outside it, and sets the appropriate lists
9367      * and flags.
9368      *
9369      * It returns the number of bits that actually changed from 0 to 1 */
9370
9371     U8 stored = 0;
9372     U8 fold;
9373
9374     PERL_ARGS_ASSERT_SET_REGCLASS_BIT_FOLD;
9375
9376     fold = (AT_LEAST_UNI_SEMANTICS) ? PL_fold_latin1[value]
9377                                     : PL_fold[value];
9378
9379     /* It assumes the bit for 'value' has already been set */
9380     if (fold != value && ! ANYOF_BITMAP_TEST(node, fold)) {
9381         ANYOF_BITMAP_SET(node, fold);
9382         stored++;
9383     }
9384     if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value) && (! isASCII(value) || ! MORE_ASCII_RESTRICTED)) {
9385         /* Certain Latin1 characters have matches outside the bitmap.  To get
9386          * here, 'value' is one of those characters.   None of these matches is
9387          * valid for ASCII characters under /aa, which have been excluded by
9388          * the 'if' above.  The matches fall into three categories:
9389          * 1) They are singly folded-to or -from an above 255 character, as
9390          *    LATIN SMALL LETTER Y WITH DIAERESIS and LATIN CAPITAL LETTER Y
9391          *    WITH DIAERESIS;
9392          * 2) They are part of a multi-char fold with another character in the
9393          *    bitmap, only LATIN SMALL LETTER SHARP S => "ss" fits that bill;
9394          * 3) They are part of a multi-char fold with a character not in the
9395          *    bitmap, such as various ligatures.
9396          * We aren't dealing fully with multi-char folds, except we do deal
9397          * with the pattern containing a character that has a multi-char fold
9398          * (not so much the inverse).
9399          * For types 1) and 3), the matches only happen when the target string
9400          * is utf8; that's not true for 2), and we set a flag for it.
9401          *
9402          * The code below adds to the passed in inversion list the single fold
9403          * closures for 'value'.  The values are hard-coded here so that an
9404          * innocent-looking character class, like /[ks]/i won't have to go out
9405          * to disk to find the possible matches.  XXX It would be better to
9406          * generate these via regen, in case a new version of the Unicode
9407          * standard adds new mappings, though that is not really likely. */
9408         switch (value) {
9409             case 'k':
9410             case 'K':
9411                 /* KELVIN SIGN */
9412                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212A);
9413                 break;
9414             case 's':
9415             case 'S':
9416                 /* LATIN SMALL LETTER LONG S */
9417                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x017F);
9418                 break;
9419             case MICRO_SIGN:
9420                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9421                                                  GREEK_SMALL_LETTER_MU);
9422                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9423                                                  GREEK_CAPITAL_LETTER_MU);
9424                 break;
9425             case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
9426             case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
9427                 /* ANGSTROM SIGN */
9428                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212B);
9429                 if (DEPENDS_SEMANTICS) {    /* See DEPENDS comment below */
9430                     *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9431                                                      PL_fold_latin1[value]);
9432                 }
9433                 break;
9434             case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
9435                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9436                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
9437                 break;
9438             case LATIN_SMALL_LETTER_SHARP_S:
9439                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9440                                         LATIN_CAPITAL_LETTER_SHARP_S);
9441
9442                 /* Under /a, /d, and /u, this can match the two chars "ss" */
9443                 if (! MORE_ASCII_RESTRICTED) {
9444                     add_alternate(alternate_ptr, (U8 *) "ss", 2);
9445
9446                     /* And under /u or /a, it can match even if the target is
9447                      * not utf8 */
9448                     if (AT_LEAST_UNI_SEMANTICS) {
9449                         ANYOF_FLAGS(node) |= ANYOF_NONBITMAP_NON_UTF8;
9450                     }
9451                 }
9452                 break;
9453             case 'F': case 'f':
9454             case 'I': case 'i':
9455             case 'L': case 'l':
9456             case 'T': case 't':
9457             case 'A': case 'a':
9458             case 'H': case 'h':
9459             case 'J': case 'j':
9460             case 'N': case 'n':
9461             case 'W': case 'w':
9462             case 'Y': case 'y':
9463                 /* These all are targets of multi-character folds from code
9464                  * points that require UTF8 to express, so they can't match
9465                  * unless the target string is in UTF-8, so no action here is
9466                  * necessary, as regexec.c properly handles the general case
9467                  * for UTF-8 matching */
9468                 break;
9469             default:
9470                 /* Use deprecated warning to increase the chances of this
9471                  * being output */
9472                 ckWARN2regdep(RExC_parse, "Perl folding rules are not up-to-date for 0x%x; please use the perlbug utility to report;", value);
9473                 break;
9474         }
9475     }
9476     else if (DEPENDS_SEMANTICS
9477             && ! isASCII(value)
9478             && PL_fold_latin1[value] != value)
9479     {
9480            /* Under DEPENDS rules, non-ASCII Latin1 characters match their
9481             * folds only when the target string is in UTF-8.  We add the fold
9482             * here to the list of things to match outside the bitmap, which
9483             * won't be looked at unless it is UTF8 (or else if something else
9484             * says to look even if not utf8, but those things better not happen
9485             * under DEPENDS semantics. */
9486         *invlist_ptr = add_cp_to_invlist(*invlist_ptr, PL_fold_latin1[value]);
9487     }
9488
9489     return stored;
9490 }
9491
9492
9493 PERL_STATIC_INLINE U8
9494 S_set_regclass_bit(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, HV** invlist_ptr, AV** alternate_ptr)
9495 {
9496     /* This inline function sets a bit in the bitmap if not already set, and if
9497      * appropriate, its fold, returning the number of bits that actually
9498      * changed from 0 to 1 */
9499
9500     U8 stored;
9501
9502     PERL_ARGS_ASSERT_SET_REGCLASS_BIT;
9503
9504     if (ANYOF_BITMAP_TEST(node, value)) {   /* Already set */
9505         return 0;
9506     }
9507
9508     ANYOF_BITMAP_SET(node, value);
9509     stored = 1;
9510
9511     if (FOLD && ! LOC) {        /* Locale folds aren't known until runtime */
9512         stored += set_regclass_bit_fold(pRExC_state, node, value, invlist_ptr, alternate_ptr);
9513     }
9514
9515     return stored;
9516 }
9517
9518 STATIC void
9519 S_add_alternate(pTHX_ AV** alternate_ptr, U8* string, STRLEN len)
9520 {
9521     /* Adds input 'string' with length 'len' to the ANYOF node's unicode
9522      * alternate list, pointed to by 'alternate_ptr'.  This is an array of
9523      * the multi-character folds of characters in the node */
9524     SV *sv;
9525
9526     PERL_ARGS_ASSERT_ADD_ALTERNATE;
9527
9528     if (! *alternate_ptr) {
9529         *alternate_ptr = newAV();
9530     }
9531     sv = newSVpvn_utf8((char*)string, len, TRUE);
9532     av_push(*alternate_ptr, sv);
9533     return;
9534 }
9535
9536 /*
9537    parse a class specification and produce either an ANYOF node that
9538    matches the pattern or perhaps will be optimized into an EXACTish node
9539    instead. The node contains a bit map for the first 256 characters, with the
9540    corresponding bit set if that character is in the list.  For characters
9541    above 255, a range list is used */
9542
9543 STATIC regnode *
9544 S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
9545 {
9546     dVAR;
9547     register UV nextvalue;
9548     register IV prevvalue = OOB_UNICODE;
9549     register IV range = 0;
9550     UV value = 0; /* XXX:dmq: needs to be referenceable (unfortunately) */
9551     register regnode *ret;
9552     STRLEN numlen;
9553     IV namedclass;
9554     char *rangebegin = NULL;
9555     bool need_class = 0;
9556     bool allow_full_fold = TRUE;   /* Assume wants multi-char folding */
9557     SV *listsv = NULL;
9558     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
9559                                       than just initialized.  */
9560     UV n;
9561
9562     /* code points this node matches that can't be stored in the bitmap */
9563     HV* nonbitmap = NULL;
9564
9565     /* The items that are to match that aren't stored in the bitmap, but are a
9566      * result of things that are stored there.  This is the fold closure of
9567      * such a character, either because it has DEPENDS semantics and shouldn't
9568      * be matched unless the target string is utf8, or is a code point that is
9569      * too large for the bit map, as for example, the fold of the MICRO SIGN is
9570      * above 255.  This all is solely for performance reasons.  By having this
9571      * code know the outside-the-bitmap folds that the bitmapped characters are
9572      * involved with, we don't have to go out to disk to find the list of
9573      * matches, unless the character class includes code points that aren't
9574      * storable in the bit map.  That means that a character class with an 's'
9575      * in it, for example, doesn't need to go out to disk to find everything
9576      * that matches.  A 2nd list is used so that the 'nonbitmap' list is kept
9577      * empty unless there is something whose fold we don't know about, and will
9578      * have to go out to the disk to find. */
9579     HV* l1_fold_invlist = NULL;
9580
9581     /* List of multi-character folds that are matched by this node */
9582     AV* unicode_alternate  = NULL;
9583 #ifdef EBCDIC
9584     UV literal_endpoint = 0;
9585 #endif
9586     UV stored = 0;  /* how many chars stored in the bitmap */
9587
9588     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
9589         case we need to change the emitted regop to an EXACT. */
9590     const char * orig_parse = RExC_parse;
9591     GET_RE_DEBUG_FLAGS_DECL;
9592
9593     PERL_ARGS_ASSERT_REGCLASS;
9594 #ifndef DEBUGGING
9595     PERL_UNUSED_ARG(depth);
9596 #endif
9597
9598     DEBUG_PARSE("clas");
9599
9600     /* Assume we are going to generate an ANYOF node. */
9601     ret = reganode(pRExC_state, ANYOF, 0);
9602
9603
9604     if (!SIZE_ONLY) {
9605         ANYOF_FLAGS(ret) = 0;
9606     }
9607
9608     if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
9609         RExC_naughty++;
9610         RExC_parse++;
9611         if (!SIZE_ONLY)
9612             ANYOF_FLAGS(ret) |= ANYOF_INVERT;
9613
9614         /* We have decided to not allow multi-char folds in inverted character
9615          * classes, due to the confusion that can happen, even with classes
9616          * that are designed for a non-Unicode world:  You have the peculiar
9617          * case that:
9618             "s s" =~ /^[^\xDF]+$/i => Y
9619             "ss"  =~ /^[^\xDF]+$/i => N
9620          *
9621          * See [perl #89750] */
9622         allow_full_fold = FALSE;
9623     }
9624
9625     if (SIZE_ONLY) {
9626         RExC_size += ANYOF_SKIP;
9627         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
9628     }
9629     else {
9630         RExC_emit += ANYOF_SKIP;
9631         if (LOC) {
9632             ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
9633         }
9634         ANYOF_BITMAP_ZERO(ret);
9635         listsv = newSVpvs("# comment\n");
9636         initial_listsv_len = SvCUR(listsv);
9637     }
9638
9639     nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
9640
9641     if (!SIZE_ONLY && POSIXCC(nextvalue))
9642         checkposixcc(pRExC_state);
9643
9644     /* allow 1st char to be ] (allowing it to be - is dealt with later) */
9645     if (UCHARAT(RExC_parse) == ']')
9646         goto charclassloop;
9647
9648 parseit:
9649     while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
9650
9651     charclassloop:
9652
9653         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
9654
9655         if (!range)
9656             rangebegin = RExC_parse;
9657         if (UTF) {
9658             value = utf8n_to_uvchr((U8*)RExC_parse,
9659                                    RExC_end - RExC_parse,
9660                                    &numlen, UTF8_ALLOW_DEFAULT);
9661             RExC_parse += numlen;
9662         }
9663         else
9664             value = UCHARAT(RExC_parse++);
9665
9666         nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
9667         if (value == '[' && POSIXCC(nextvalue))
9668             namedclass = regpposixcc(pRExC_state, value);
9669         else if (value == '\\') {
9670             if (UTF) {
9671                 value = utf8n_to_uvchr((U8*)RExC_parse,
9672                                    RExC_end - RExC_parse,
9673                                    &numlen, UTF8_ALLOW_DEFAULT);
9674                 RExC_parse += numlen;
9675             }
9676             else
9677                 value = UCHARAT(RExC_parse++);
9678             /* Some compilers cannot handle switching on 64-bit integer
9679              * values, therefore value cannot be an UV.  Yes, this will
9680              * be a problem later if we want switch on Unicode.
9681              * A similar issue a little bit later when switching on
9682              * namedclass. --jhi */
9683             switch ((I32)value) {
9684             case 'w':   namedclass = ANYOF_ALNUM;       break;
9685             case 'W':   namedclass = ANYOF_NALNUM;      break;
9686             case 's':   namedclass = ANYOF_SPACE;       break;
9687             case 'S':   namedclass = ANYOF_NSPACE;      break;
9688             case 'd':   namedclass = ANYOF_DIGIT;       break;
9689             case 'D':   namedclass = ANYOF_NDIGIT;      break;
9690             case 'v':   namedclass = ANYOF_VERTWS;      break;
9691             case 'V':   namedclass = ANYOF_NVERTWS;     break;
9692             case 'h':   namedclass = ANYOF_HORIZWS;     break;
9693             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
9694             case 'N':  /* Handle \N{NAME} in class */
9695                 {
9696                     /* We only pay attention to the first char of 
9697                     multichar strings being returned. I kinda wonder
9698                     if this makes sense as it does change the behaviour
9699                     from earlier versions, OTOH that behaviour was broken
9700                     as well. */
9701                     UV v; /* value is register so we cant & it /grrr */
9702                     if (reg_namedseq(pRExC_state, &v, NULL, depth)) {
9703                         goto parseit;
9704                     }
9705                     value= v; 
9706                 }
9707                 break;
9708             case 'p':
9709             case 'P':
9710                 {
9711                 char *e;
9712                 if (RExC_parse >= RExC_end)
9713                     vFAIL2("Empty \\%c{}", (U8)value);
9714                 if (*RExC_parse == '{') {
9715                     const U8 c = (U8)value;
9716                     e = strchr(RExC_parse++, '}');
9717                     if (!e)
9718                         vFAIL2("Missing right brace on \\%c{}", c);
9719                     while (isSPACE(UCHARAT(RExC_parse)))
9720                         RExC_parse++;
9721                     if (e == RExC_parse)
9722                         vFAIL2("Empty \\%c{}", c);
9723                     n = e - RExC_parse;
9724                     while (isSPACE(UCHARAT(RExC_parse + n - 1)))
9725                         n--;
9726                 }
9727                 else {
9728                     e = RExC_parse;
9729                     n = 1;
9730                 }
9731                 if (!SIZE_ONLY) {
9732                     if (UCHARAT(RExC_parse) == '^') {
9733                          RExC_parse++;
9734                          n--;
9735                          value = value == 'p' ? 'P' : 'p'; /* toggle */
9736                          while (isSPACE(UCHARAT(RExC_parse))) {
9737                               RExC_parse++;
9738                               n--;
9739                          }
9740                     }
9741
9742                     /* Add the property name to the list.  If /i matching, give
9743                      * a different name which consists of the normal name
9744                      * sandwiched between two underscores and '_i'.  The design
9745                      * is discussed in the commit message for this. */
9746                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s%.*s%s\n",
9747                                         (value=='p' ? '+' : '!'),
9748                                         (FOLD) ? "__" : "",
9749                                         (int)n,
9750                                         RExC_parse,
9751                                         (FOLD) ? "_i" : ""
9752                                     );
9753                 }
9754                 RExC_parse = e + 1;
9755
9756                 /* The \p could match something in the Latin1 range, hence
9757                  * something that isn't utf8 */
9758                 ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
9759                 namedclass = ANYOF_MAX;  /* no official name, but it's named */
9760
9761                 /* \p means they want Unicode semantics */
9762                 RExC_uni_semantics = 1;
9763                 }
9764                 break;
9765             case 'n':   value = '\n';                   break;
9766             case 'r':   value = '\r';                   break;
9767             case 't':   value = '\t';                   break;
9768             case 'f':   value = '\f';                   break;
9769             case 'b':   value = '\b';                   break;
9770             case 'e':   value = ASCII_TO_NATIVE('\033');break;
9771             case 'a':   value = ASCII_TO_NATIVE('\007');break;
9772             case 'o':
9773                 RExC_parse--;   /* function expects to be pointed at the 'o' */
9774                 {
9775                     const char* error_msg;
9776                     bool valid = grok_bslash_o(RExC_parse,
9777                                                &value,
9778                                                &numlen,
9779                                                &error_msg,
9780                                                SIZE_ONLY);
9781                     RExC_parse += numlen;
9782                     if (! valid) {
9783                         vFAIL(error_msg);
9784                     }
9785                 }
9786                 if (PL_encoding && value < 0x100) {
9787                     goto recode_encoding;
9788                 }
9789                 break;
9790             case 'x':
9791                 if (*RExC_parse == '{') {
9792                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
9793                         | PERL_SCAN_DISALLOW_PREFIX;
9794                     char * const e = strchr(RExC_parse++, '}');
9795                     if (!e)
9796                         vFAIL("Missing right brace on \\x{}");
9797
9798                     numlen = e - RExC_parse;
9799                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
9800                     RExC_parse = e + 1;
9801                 }
9802                 else {
9803                     I32 flags = PERL_SCAN_DISALLOW_PREFIX;
9804                     numlen = 2;
9805                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
9806                     RExC_parse += numlen;
9807                 }
9808                 if (PL_encoding && value < 0x100)
9809                     goto recode_encoding;
9810                 break;
9811             case 'c':
9812                 value = grok_bslash_c(*RExC_parse++, UTF, SIZE_ONLY);
9813                 break;
9814             case '0': case '1': case '2': case '3': case '4':
9815             case '5': case '6': case '7':
9816                 {
9817                     /* Take 1-3 octal digits */
9818                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
9819                     numlen = 3;
9820                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
9821                     RExC_parse += numlen;
9822                     if (PL_encoding && value < 0x100)
9823                         goto recode_encoding;
9824                     break;
9825                 }
9826             recode_encoding:
9827                 if (! RExC_override_recoding) {
9828                     SV* enc = PL_encoding;
9829                     value = reg_recode((const char)(U8)value, &enc);
9830                     if (!enc && SIZE_ONLY)
9831                         ckWARNreg(RExC_parse,
9832                                   "Invalid escape in the specified encoding");
9833                     break;
9834                 }
9835             default:
9836                 /* Allow \_ to not give an error */
9837                 if (!SIZE_ONLY && isALNUM(value) && value != '_') {
9838                     ckWARN2reg(RExC_parse,
9839                                "Unrecognized escape \\%c in character class passed through",
9840                                (int)value);
9841                 }
9842                 break;
9843             }
9844         } /* end of \blah */
9845 #ifdef EBCDIC
9846         else
9847             literal_endpoint++;
9848 #endif
9849
9850         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
9851
9852             /* What matches in a locale is not known until runtime, so need to
9853              * (one time per class) allocate extra space to pass to regexec.
9854              * The space will contain a bit for each named class that is to be
9855              * matched against.  This isn't needed for \p{} and pseudo-classes,
9856              * as they are not affected by locale, and hence are dealt with
9857              * separately */
9858             if (LOC && namedclass < ANYOF_MAX && ! need_class) {
9859                 need_class = 1;
9860                 if (SIZE_ONLY) {
9861                     RExC_size += ANYOF_CLASS_SKIP - ANYOF_SKIP;
9862                 }
9863                 else {
9864                     RExC_emit += ANYOF_CLASS_SKIP - ANYOF_SKIP;
9865                     ANYOF_CLASS_ZERO(ret);
9866                 }
9867                 ANYOF_FLAGS(ret) |= ANYOF_CLASS;
9868             }
9869
9870             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
9871              * literal, as is the character that began the false range, i.e.
9872              * the 'a' in the examples */
9873             if (range) {
9874                 if (!SIZE_ONLY) {
9875                     const int w =
9876                         RExC_parse >= rangebegin ?
9877                         RExC_parse - rangebegin : 0;
9878                     ckWARN4reg(RExC_parse,
9879                                "False [] range \"%*.*s\"",
9880                                w, w, rangebegin);
9881
9882                     stored +=
9883                          set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
9884                     if (prevvalue < 256) {
9885                         stored +=
9886                          set_regclass_bit(pRExC_state, ret, (U8) prevvalue, &l1_fold_invlist, &unicode_alternate);
9887                     }
9888                     else {
9889                         nonbitmap = add_cp_to_invlist(nonbitmap, prevvalue);
9890                     }
9891                 }
9892
9893                 range = 0; /* this was not a true range */
9894             }
9895
9896
9897     
9898             if (!SIZE_ONLY) {
9899                 const char *what = NULL;
9900                 char yesno = 0;
9901
9902                 /* Possible truncation here but in some 64-bit environments
9903                  * the compiler gets heartburn about switch on 64-bit values.
9904                  * A similar issue a little earlier when switching on value.
9905                  * --jhi */
9906                 switch ((I32)namedclass) {
9907                 
9908                 case _C_C_T_(ALNUMC, isALNUMC_L1, isALNUMC, "XPosixAlnum");
9909                 case _C_C_T_(ALPHA, isALPHA_L1, isALPHA, "XPosixAlpha");
9910                 case _C_C_T_(BLANK, isBLANK_L1, isBLANK, "XPosixBlank");
9911                 case _C_C_T_(CNTRL, isCNTRL_L1, isCNTRL, "XPosixCntrl");
9912                 case _C_C_T_(GRAPH, isGRAPH_L1, isGRAPH, "XPosixGraph");
9913                 case _C_C_T_(LOWER, isLOWER_L1, isLOWER, "XPosixLower");
9914                 case _C_C_T_(PRINT, isPRINT_L1, isPRINT, "XPosixPrint");
9915                 case _C_C_T_(PSXSPC, isPSXSPC_L1, isPSXSPC, "XPosixSpace");
9916                 case _C_C_T_(PUNCT, isPUNCT_L1, isPUNCT, "XPosixPunct");
9917                 case _C_C_T_(UPPER, isUPPER_L1, isUPPER, "XPosixUpper");
9918                 /* \s, \w match all unicode if utf8. */
9919                 case _C_C_T_(SPACE, isSPACE_L1, isSPACE, "SpacePerl");
9920                 case _C_C_T_(ALNUM, isWORDCHAR_L1, isALNUM, "Word");
9921                 case _C_C_T_(XDIGIT, isXDIGIT_L1, isXDIGIT, "XPosixXDigit");
9922                 case _C_C_T_NOLOC_(VERTWS, is_VERTWS_latin1(&value), "VertSpace");
9923                 case _C_C_T_NOLOC_(HORIZWS, is_HORIZWS_latin1(&value), "HorizSpace");
9924                 case ANYOF_ASCII:
9925                     if (LOC)
9926                         ANYOF_CLASS_SET(ret, ANYOF_ASCII);
9927                     else {
9928                         for (value = 0; value < 128; value++)
9929                             stored +=
9930                               set_regclass_bit(pRExC_state, ret, (U8) ASCII_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate);
9931                     }
9932                     yesno = '+';
9933                     what = NULL;        /* Doesn't match outside ascii, so
9934                                            don't want to add +utf8:: */
9935                     break;
9936                 case ANYOF_NASCII:
9937                     if (LOC)
9938                         ANYOF_CLASS_SET(ret, ANYOF_NASCII);
9939                     else {
9940                         for (value = 128; value < 256; value++)
9941                             stored +=
9942                               set_regclass_bit(pRExC_state, ret, (U8) ASCII_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate);
9943                     }
9944                     ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
9945                     yesno = '!';
9946                     what = "ASCII";
9947                     break;              
9948                 case ANYOF_DIGIT:
9949                     if (LOC)
9950                         ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
9951                     else {
9952                         /* consecutive digits assumed */
9953                         for (value = '0'; value <= '9'; value++)
9954                             stored +=
9955                               set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);
9956                     }
9957                     yesno = '+';
9958                     what = "Digit";
9959                     break;
9960                 case ANYOF_NDIGIT:
9961                     if (LOC)
9962                         ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
9963                     else {
9964                         /* consecutive digits assumed */
9965                         for (value = 0; value < '0'; value++)
9966                             stored +=
9967                               set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);
9968                         for (value = '9' + 1; value < 256; value++)
9969                             stored +=
9970                               set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);
9971                     }
9972                     yesno = '!';
9973                     what = "Digit";
9974                     if (AT_LEAST_ASCII_RESTRICTED ) {
9975                         ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
9976                     }
9977                     break;              
9978                 case ANYOF_MAX:
9979                     /* this is to handle \p and \P */
9980                     break;
9981                 default:
9982                     vFAIL("Invalid [::] class");
9983                     break;
9984                 }
9985                 if (what && ! (AT_LEAST_ASCII_RESTRICTED)) {
9986                     /* Strings such as "+utf8::isWord\n" */
9987                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::Is%s\n", yesno, what);
9988                 }
9989
9990                 continue;
9991             }
9992         } /* end of namedclass \blah */
9993
9994         if (range) {
9995             if (prevvalue > (IV)value) /* b-a */ {
9996                 const int w = RExC_parse - rangebegin;
9997                 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
9998                 range = 0; /* not a valid range */
9999             }
10000         }
10001         else {
10002             prevvalue = value; /* save the beginning of the range */
10003             if (RExC_parse+1 < RExC_end
10004                 && *RExC_parse == '-'
10005                 && RExC_parse[1] != ']')
10006             {
10007                 RExC_parse++;
10008
10009                 /* a bad range like \w-, [:word:]- ? */
10010                 if (namedclass > OOB_NAMEDCLASS) {
10011                     if (ckWARN(WARN_REGEXP)) {
10012                         const int w =
10013                             RExC_parse >= rangebegin ?
10014                             RExC_parse - rangebegin : 0;
10015                         vWARN4(RExC_parse,
10016                                "False [] range \"%*.*s\"",
10017                                w, w, rangebegin);
10018                     }
10019                     if (!SIZE_ONLY)
10020                         stored +=
10021                             set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
10022                 } else
10023                     range = 1;  /* yeah, it's a range! */
10024                 continue;       /* but do it the next time */
10025             }
10026         }
10027
10028         /* non-Latin1 code point implies unicode semantics.  Must be set in
10029          * pass1 so is there for the whole of pass 2 */
10030         if (value > 255) {
10031             RExC_uni_semantics = 1;
10032         }
10033
10034         /* now is the next time */
10035         if (!SIZE_ONLY) {
10036             if (prevvalue < 256) {
10037                 const IV ceilvalue = value < 256 ? value : 255;
10038                 IV i;
10039 #ifdef EBCDIC
10040                 /* In EBCDIC [\x89-\x91] should include
10041                  * the \x8e but [i-j] should not. */
10042                 if (literal_endpoint == 2 &&
10043                     ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
10044                      (isUPPER(prevvalue) && isUPPER(ceilvalue))))
10045                 {
10046                     if (isLOWER(prevvalue)) {
10047                         for (i = prevvalue; i <= ceilvalue; i++)
10048                             if (isLOWER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
10049                                 stored +=
10050                                   set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
10051                             }
10052                     } else {
10053                         for (i = prevvalue; i <= ceilvalue; i++)
10054                             if (isUPPER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
10055                                 stored +=
10056                                   set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
10057                             }
10058                     }
10059                 }
10060                 else
10061 #endif
10062                       for (i = prevvalue; i <= ceilvalue; i++) {
10063                         stored += set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
10064                       }
10065           }
10066           if (value > 255) {
10067             const UV prevnatvalue  = NATIVE_TO_UNI(prevvalue);
10068             const UV natvalue      = NATIVE_TO_UNI(value);
10069             nonbitmap = add_range_to_invlist(nonbitmap, prevnatvalue, natvalue);
10070         }
10071 #ifdef EBCDIC
10072             literal_endpoint = 0;
10073 #endif
10074         }
10075
10076         range = 0; /* this range (if it was one) is done now */
10077     }
10078
10079
10080
10081     if (SIZE_ONLY)
10082         return ret;
10083     /****** !SIZE_ONLY AFTER HERE *********/
10084
10085     /* If folding and there are code points above 255, we calculate all
10086      * characters that could fold to or from the ones already on the list */
10087     if (FOLD && nonbitmap) {
10088         UV i;
10089
10090         HV* fold_intersection;
10091         UV* fold_list;
10092
10093         /* This is a list of all the characters that participate in folds
10094             * (except marks, etc in multi-char folds */
10095         if (! PL_utf8_foldable) {
10096             SV* swash = swash_init("utf8", "Cased", &PL_sv_undef, 1, 0);
10097             PL_utf8_foldable = _swash_to_invlist(swash);
10098         }
10099
10100         /* This is a hash that for a particular fold gives all characters
10101             * that are involved in it */
10102         if (! PL_utf8_foldclosures) {
10103
10104             /* If we were unable to find any folds, then we likely won't be
10105              * able to find the closures.  So just create an empty list.
10106              * Folding will effectively be restricted to the non-Unicode rules
10107              * hard-coded into Perl.  (This case happens legitimately during
10108              * compilation of Perl itself before the Unicode tables are
10109              * generated) */
10110             if (invlist_len(PL_utf8_foldable) == 0) {
10111                 PL_utf8_foldclosures = _new_invlist(0);
10112             } else {
10113                 /* If the folds haven't been read in, call a fold function
10114                     * to force that */
10115                 if (! PL_utf8_tofold) {
10116                     U8 dummy[UTF8_MAXBYTES+1];
10117                     STRLEN dummy_len;
10118                     to_utf8_fold((U8*) "A", dummy, &dummy_len);
10119                 }
10120                 PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
10121             }
10122         }
10123
10124         /* Only the characters in this class that participate in folds need
10125             * be checked.  Get the intersection of this class and all the
10126             * possible characters that are foldable.  This can quickly narrow
10127             * down a large class */
10128         fold_intersection = invlist_intersection(PL_utf8_foldable, nonbitmap);
10129
10130         /* Now look at the foldable characters in this class individually */
10131         fold_list = invlist_array(fold_intersection);
10132         for (i = 0; i < invlist_len(fold_intersection); i++) {
10133             UV j;
10134
10135             /* The next entry is the beginning of the range that is in the
10136              * class */
10137             UV start = fold_list[i++];
10138
10139
10140             /* The next entry is the beginning of the next range, which
10141                 * isn't in the class, so the end of the current range is one
10142                 * less than that */
10143             UV end = fold_list[i] - 1;
10144
10145             /* Look at every character in the range */
10146             for (j = start; j <= end; j++) {
10147
10148                 /* Get its fold */
10149                 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
10150                 STRLEN foldlen;
10151                 const UV f =
10152                     _to_uni_fold_flags(j, foldbuf, &foldlen, allow_full_fold);
10153
10154                 if (foldlen > (STRLEN)UNISKIP(f)) {
10155
10156                     /* Any multicharacter foldings (disallowed in
10157                         * lookbehind patterns) require the following
10158                         * transform: [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst) where
10159                         * E folds into "pq" and F folds into "rst", all other
10160                         * characters fold to single characters.  We save away
10161                         * these multicharacter foldings, to be later saved as
10162                         * part of the additional "s" data. */
10163                     if (! RExC_in_lookbehind) {
10164                         U8* loc = foldbuf;
10165                         U8* e = foldbuf + foldlen;
10166
10167                         /* If any of the folded characters of this are in
10168                             * the Latin1 range, tell the regex engine that
10169                             * this can match a non-utf8 target string.  The
10170                             * only multi-byte fold whose source is in the
10171                             * Latin1 range (U+00DF) applies only when the
10172                             * target string is utf8, or under unicode rules */
10173                         if (j > 255 || AT_LEAST_UNI_SEMANTICS) {
10174                             while (loc < e) {
10175
10176                                 /* Can't mix ascii with non- under /aa */
10177                                 if (MORE_ASCII_RESTRICTED
10178                                     && (isASCII(*loc) != isASCII(j)))
10179                                 {
10180                                     goto end_multi_fold;
10181                                 }
10182                                 if (UTF8_IS_INVARIANT(*loc)
10183                                     || UTF8_IS_DOWNGRADEABLE_START(*loc))
10184                                 {
10185                                     /* Can't mix above and below 256 under
10186                                         * LOC */
10187                                     if (LOC) {
10188                                         goto end_multi_fold;
10189                                     }
10190                                     ANYOF_FLAGS(ret)
10191                                             |= ANYOF_NONBITMAP_NON_UTF8;
10192                                     break;
10193                                 }
10194                                 loc += UTF8SKIP(loc);
10195                             }
10196                         }
10197
10198                         add_alternate(&unicode_alternate, foldbuf, foldlen);
10199                     end_multi_fold: ;
10200                     }
10201
10202                     /* This is special-cased, as it is the only letter which
10203                      * has both a multi-fold and single-fold in Latin1.  All
10204                      * the other chars that have single and multi-folds are
10205                      * always in utf8, and the utf8 folding algorithm catches
10206                      * them */
10207                     if (! LOC && j == LATIN_CAPITAL_LETTER_SHARP_S) {
10208                         stored += set_regclass_bit(pRExC_state,
10209                                         ret,
10210                                         LATIN_SMALL_LETTER_SHARP_S,
10211                                         &l1_fold_invlist, &unicode_alternate);
10212                     }
10213                 }
10214                 else {
10215                     /* Single character fold.  Add everything in its fold
10216                         * closure to the list that this node should match */
10217                     SV** listp;
10218
10219                     /* The fold closures data structure is a hash with the
10220                         * keys being every character that is folded to, like
10221                         * 'k', and the values each an array of everything that
10222                         * folds to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ] */
10223                     if ((listp = hv_fetch(PL_utf8_foldclosures,
10224                                     (char *) foldbuf, foldlen, FALSE)))
10225                     {
10226                         AV* list = (AV*) *listp;
10227                         IV k;
10228                         for (k = 0; k <= av_len(list); k++) {
10229                             SV** c_p = av_fetch(list, k, FALSE);
10230                             UV c;
10231                             if (c_p == NULL) {
10232                                 Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
10233                             }
10234                             c = SvUV(*c_p);
10235
10236                             /* /aa doesn't allow folds between ASCII and
10237                                 * non-; /l doesn't allow them between above
10238                                 * and below 256 */
10239                             if ((MORE_ASCII_RESTRICTED
10240                                  && (isASCII(c) != isASCII(j)))
10241                                     || (LOC && ((c < 256) != (j < 256))))
10242                             {
10243                                 continue;
10244                             }
10245
10246                             if (c < 256 && AT_LEAST_UNI_SEMANTICS) {
10247                                 stored += set_regclass_bit(pRExC_state,
10248                                         ret,
10249                                         (U8) c,
10250                                         &l1_fold_invlist, &unicode_alternate);
10251                             }
10252                                 /* It may be that the code point is already
10253                                     * in this range or already in the bitmap,
10254                                     * in which case we need do nothing */
10255                             else if ((c < start || c > end)
10256                                         && (c > 255
10257                                             || ! ANYOF_BITMAP_TEST(ret, c)))
10258                             {
10259                                 nonbitmap = add_cp_to_invlist(nonbitmap, c);
10260                             }
10261                         }
10262                     }
10263                 }
10264             }
10265         }
10266         invlist_destroy(fold_intersection);
10267     }
10268
10269     /* Combine the two lists into one. */
10270     if (l1_fold_invlist) {
10271         if (nonbitmap) {
10272             nonbitmap = invlist_union(nonbitmap, l1_fold_invlist);
10273         }
10274         else {
10275             nonbitmap = l1_fold_invlist;
10276         }
10277     }
10278
10279     /* Here, we have calculated what code points should be in the character
10280      * class.   Now we can see about various optimizations.  Fold calculation
10281      * needs to take place before inversion.  Otherwise /[^k]/i would invert to
10282      * include K, which under /i would match k. */
10283
10284     /* Optimize inverted simple patterns (e.g. [^a-z]).  Note that we haven't
10285      * set the FOLD flag yet, so this this does optimize those.  It doesn't
10286      * optimize locale.  Doing so perhaps could be done as long as there is
10287      * nothing like \w in it; some thought also would have to be given to the
10288      * interaction with above 0x100 chars */
10289     if (! LOC
10290         && (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT
10291         && ! unicode_alternate
10292         && ! nonbitmap
10293         && SvCUR(listsv) == initial_listsv_len)
10294     {
10295         for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
10296             ANYOF_BITMAP(ret)[value] ^= 0xFF;
10297         stored = 256 - stored;
10298
10299         /* The inversion means that everything above 255 is matched; and at the
10300          * same time we clear the invert flag */
10301         ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL;
10302     }
10303
10304     /* Folding in the bitmap is taken care of above, but not for locale (for
10305      * which we have to wait to see what folding is in effect at runtime), and
10306      * for things not in the bitmap.  Set run-time fold flag for these */
10307     if (FOLD && (LOC || nonbitmap || unicode_alternate)) {
10308         ANYOF_FLAGS(ret) |= ANYOF_LOC_NONBITMAP_FOLD;
10309     }
10310
10311     /* A single character class can be "optimized" into an EXACTish node.
10312      * Note that since we don't currently count how many characters there are
10313      * outside the bitmap, we are XXX missing optimization possibilities for
10314      * them.  This optimization can't happen unless this is a truly single
10315      * character class, which means that it can't be an inversion into a
10316      * many-character class, and there must be no possibility of there being
10317      * things outside the bitmap.  'stored' (only) for locales doesn't include
10318      * \w, etc, so have to make a special test that they aren't present
10319      *
10320      * Similarly A 2-character class of the very special form like [bB] can be
10321      * optimized into an EXACTFish node, but only for non-locales, and for
10322      * characters which only have the two folds; so things like 'fF' and 'Ii'
10323      * wouldn't work because they are part of the fold of 'LATIN SMALL LIGATURE
10324      * FI'. */
10325     if (! nonbitmap
10326         && ! unicode_alternate
10327         && SvCUR(listsv) == initial_listsv_len
10328         && ! (ANYOF_FLAGS(ret) & (ANYOF_INVERT|ANYOF_UNICODE_ALL))
10329         && (((stored == 1 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
10330                               || (! ANYOF_CLASS_TEST_ANY_SET(ret)))))
10331             || (stored == 2 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
10332                                  && (! _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value))
10333                                  /* If the latest code point has a fold whose
10334                                   * bit is set, it must be the only other one */
10335                                 && ((prevvalue = PL_fold_latin1[value]) != (IV)value)
10336                                  && ANYOF_BITMAP_TEST(ret, prevvalue)))))
10337     {
10338         /* Note that the information needed to decide to do this optimization
10339          * is not currently available until the 2nd pass, and that the actually
10340          * used EXACTish node takes less space than the calculated ANYOF node,
10341          * and hence the amount of space calculated in the first pass is larger
10342          * than actually used, so this optimization doesn't gain us any space.
10343          * But an EXACT node is faster than an ANYOF node, and can be combined
10344          * with any adjacent EXACT nodes later by the optimizer for further
10345          * gains.  The speed of executing an EXACTF is similar to an ANYOF
10346          * node, so the optimization advantage comes from the ability to join
10347          * it to adjacent EXACT nodes */
10348
10349         const char * cur_parse= RExC_parse;
10350         U8 op;
10351         RExC_emit = (regnode *)orig_emit;
10352         RExC_parse = (char *)orig_parse;
10353
10354         if (stored == 1) {
10355
10356             /* A locale node with one point can be folded; all the other cases
10357              * with folding will have two points, since we calculate them above
10358              */
10359             if (ANYOF_FLAGS(ret) & ANYOF_LOC_NONBITMAP_FOLD) {
10360                  op = EXACTFL;
10361             }
10362             else {
10363                 op = EXACT;
10364             }
10365         }   /* else 2 chars in the bit map: the folds of each other */
10366         else if (AT_LEAST_UNI_SEMANTICS || !isASCII(value)) {
10367
10368             /* To join adjacent nodes, they must be the exact EXACTish type.
10369              * Try to use the most likely type, by using EXACTFU if the regex
10370              * calls for them, or is required because the character is
10371              * non-ASCII */
10372             op = EXACTFU;
10373         }
10374         else {    /* Otherwise, more likely to be EXACTF type */
10375             op = EXACTF;
10376         }
10377
10378         ret = reg_node(pRExC_state, op);
10379         RExC_parse = (char *)cur_parse;
10380         if (UTF && ! NATIVE_IS_INVARIANT(value)) {
10381             *STRING(ret)= UTF8_EIGHT_BIT_HI((U8) value);
10382             *(STRING(ret) + 1)= UTF8_EIGHT_BIT_LO((U8) value);
10383             STR_LEN(ret)= 2;
10384             RExC_emit += STR_SZ(2);
10385         }
10386         else {
10387             *STRING(ret)= (char)value;
10388             STR_LEN(ret)= 1;
10389             RExC_emit += STR_SZ(1);
10390         }
10391         SvREFCNT_dec(listsv);
10392         return ret;
10393     }
10394
10395     if (nonbitmap) {
10396         UV* nonbitmap_array = invlist_array(nonbitmap);
10397         UV nonbitmap_len = invlist_len(nonbitmap);
10398         UV i;
10399
10400         /*  Here have the full list of items to match that aren't in the
10401          *  bitmap.  Convert to the structure that the rest of the code is
10402          *  expecting.   XXX That rest of the code should convert to this
10403          *  structure */
10404         for (i = 0; i < nonbitmap_len; i++) {
10405
10406             /* The next entry is the beginning of the range that is in the
10407              * class */
10408             UV start = nonbitmap_array[i++];
10409             UV end;
10410
10411             /* The next entry is the beginning of the next range, which isn't
10412              * in the class, so the end of the current range is one less than
10413              * that.  But if there is no next range, it means that the range
10414              * begun by 'start' extends to infinity, which for this platform
10415              * ends at UV_MAX */
10416             if (i == nonbitmap_len) {
10417                 end = UV_MAX;
10418             }
10419             else {
10420                 end = nonbitmap_array[i] - 1;
10421             }
10422
10423             if (start == end) {
10424                 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", start);
10425             }
10426             else {
10427                 /* The \t sets the whole range */
10428                 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
10429                         /* XXX EBCDIC */
10430                                    start, end);
10431             }
10432         }
10433         invlist_destroy(nonbitmap);
10434     }
10435
10436     if (SvCUR(listsv) == initial_listsv_len && ! unicode_alternate) {
10437         ARG_SET(ret, ANYOF_NONBITMAP_EMPTY);
10438         SvREFCNT_dec(listsv);
10439         SvREFCNT_dec(unicode_alternate);
10440     }
10441     else {
10442
10443         AV * const av = newAV();
10444         SV *rv;
10445         /* The 0th element stores the character class description
10446          * in its textual form: used later (regexec.c:Perl_regclass_swash())
10447          * to initialize the appropriate swash (which gets stored in
10448          * the 1st element), and also useful for dumping the regnode.
10449          * The 2nd element stores the multicharacter foldings,
10450          * used later (regexec.c:S_reginclass()). */
10451         av_store(av, 0, listsv);
10452         av_store(av, 1, NULL);
10453
10454         /* Store any computed multi-char folds only if we are allowing
10455          * them */
10456         if (allow_full_fold) {
10457             av_store(av, 2, MUTABLE_SV(unicode_alternate));
10458             if (unicode_alternate) { /* This node is variable length */
10459                 OP(ret) = ANYOFV;
10460             }
10461         }
10462         else {
10463             av_store(av, 2, NULL);
10464         }
10465         rv = newRV_noinc(MUTABLE_SV(av));
10466         n = add_data(pRExC_state, 1, "s");
10467         RExC_rxi->data->data[n] = (void*)rv;
10468         ARG_SET(ret, n);
10469     }
10470     return ret;
10471 }
10472 #undef _C_C_T_
10473
10474
10475 /* reg_skipcomment()
10476
10477    Absorbs an /x style # comments from the input stream.
10478    Returns true if there is more text remaining in the stream.
10479    Will set the REG_SEEN_RUN_ON_COMMENT flag if the comment
10480    terminates the pattern without including a newline.
10481
10482    Note its the callers responsibility to ensure that we are
10483    actually in /x mode
10484
10485 */
10486
10487 STATIC bool
10488 S_reg_skipcomment(pTHX_ RExC_state_t *pRExC_state)
10489 {
10490     bool ended = 0;
10491
10492     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
10493
10494     while (RExC_parse < RExC_end)
10495         if (*RExC_parse++ == '\n') {
10496             ended = 1;
10497             break;
10498         }
10499     if (!ended) {
10500         /* we ran off the end of the pattern without ending
10501            the comment, so we have to add an \n when wrapping */
10502         RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
10503         return 0;
10504     } else
10505         return 1;
10506 }
10507
10508 /* nextchar()
10509
10510    Advances the parse position, and optionally absorbs
10511    "whitespace" from the inputstream.
10512
10513    Without /x "whitespace" means (?#...) style comments only,
10514    with /x this means (?#...) and # comments and whitespace proper.
10515
10516    Returns the RExC_parse point from BEFORE the scan occurs.
10517
10518    This is the /x friendly way of saying RExC_parse++.
10519 */
10520
10521 STATIC char*
10522 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
10523 {
10524     char* const retval = RExC_parse++;
10525
10526     PERL_ARGS_ASSERT_NEXTCHAR;
10527
10528     for (;;) {
10529         if (*RExC_parse == '(' && RExC_parse[1] == '?' &&
10530                 RExC_parse[2] == '#') {
10531             while (*RExC_parse != ')') {
10532                 if (RExC_parse == RExC_end)
10533                     FAIL("Sequence (?#... not terminated");
10534                 RExC_parse++;
10535             }
10536             RExC_parse++;
10537             continue;
10538         }
10539         if (RExC_flags & RXf_PMf_EXTENDED) {
10540             if (isSPACE(*RExC_parse)) {
10541                 RExC_parse++;
10542                 continue;
10543             }
10544             else if (*RExC_parse == '#') {
10545                 if ( reg_skipcomment( pRExC_state ) )
10546                     continue;
10547             }
10548         }
10549         return retval;
10550     }
10551 }
10552
10553 /*
10554 - reg_node - emit a node
10555 */
10556 STATIC regnode *                        /* Location. */
10557 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
10558 {
10559     dVAR;
10560     register regnode *ptr;
10561     regnode * const ret = RExC_emit;
10562     GET_RE_DEBUG_FLAGS_DECL;
10563
10564     PERL_ARGS_ASSERT_REG_NODE;
10565
10566     if (SIZE_ONLY) {
10567         SIZE_ALIGN(RExC_size);
10568         RExC_size += 1;
10569         return(ret);
10570     }
10571     if (RExC_emit >= RExC_emit_bound)
10572         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d", op);
10573
10574     NODE_ALIGN_FILL(ret);
10575     ptr = ret;
10576     FILL_ADVANCE_NODE(ptr, op);
10577     REH_CALL_REGCOMP_HOOK(pRExC_state->rx, (ptr) - 1);
10578 #ifdef RE_TRACK_PATTERN_OFFSETS
10579     if (RExC_offsets) {         /* MJD */
10580         MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n", 
10581               "reg_node", __LINE__, 
10582               PL_reg_name[op],
10583               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] 
10584                 ? "Overwriting end of array!\n" : "OK",
10585               (UV)(RExC_emit - RExC_emit_start),
10586               (UV)(RExC_parse - RExC_start),
10587               (UV)RExC_offsets[0])); 
10588         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
10589     }
10590 #endif
10591     RExC_emit = ptr;
10592     return(ret);
10593 }
10594
10595 /*
10596 - reganode - emit a node with an argument
10597 */
10598 STATIC regnode *                        /* Location. */
10599 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
10600 {
10601     dVAR;
10602     register regnode *ptr;
10603     regnode * const ret = RExC_emit;
10604     GET_RE_DEBUG_FLAGS_DECL;
10605
10606     PERL_ARGS_ASSERT_REGANODE;
10607
10608     if (SIZE_ONLY) {
10609         SIZE_ALIGN(RExC_size);
10610         RExC_size += 2;
10611         /* 
10612            We can't do this:
10613            
10614            assert(2==regarglen[op]+1); 
10615         
10616            Anything larger than this has to allocate the extra amount.
10617            If we changed this to be:
10618            
10619            RExC_size += (1 + regarglen[op]);
10620            
10621            then it wouldn't matter. Its not clear what side effect
10622            might come from that so its not done so far.
10623            -- dmq
10624         */
10625         return(ret);
10626     }
10627     if (RExC_emit >= RExC_emit_bound)
10628         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d", op);
10629
10630     NODE_ALIGN_FILL(ret);
10631     ptr = ret;
10632     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
10633     REH_CALL_REGCOMP_HOOK(pRExC_state->rx, (ptr) - 2);
10634 #ifdef RE_TRACK_PATTERN_OFFSETS
10635     if (RExC_offsets) {         /* MJD */
10636         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
10637               "reganode",
10638               __LINE__,
10639               PL_reg_name[op],
10640               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? 
10641               "Overwriting end of array!\n" : "OK",
10642               (UV)(RExC_emit - RExC_emit_start),
10643               (UV)(RExC_parse - RExC_start),
10644               (UV)RExC_offsets[0])); 
10645         Set_Cur_Node_Offset;
10646     }
10647 #endif            
10648     RExC_emit = ptr;
10649     return(ret);
10650 }
10651
10652 /*
10653 - reguni - emit (if appropriate) a Unicode character
10654 */
10655 STATIC STRLEN
10656 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
10657 {
10658     dVAR;
10659
10660     PERL_ARGS_ASSERT_REGUNI;
10661
10662     return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
10663 }
10664
10665 /*
10666 - reginsert - insert an operator in front of already-emitted operand
10667 *
10668 * Means relocating the operand.
10669 */
10670 STATIC void
10671 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
10672 {
10673     dVAR;
10674     register regnode *src;
10675     register regnode *dst;
10676     register regnode *place;
10677     const int offset = regarglen[(U8)op];
10678     const int size = NODE_STEP_REGNODE + offset;
10679     GET_RE_DEBUG_FLAGS_DECL;
10680
10681     PERL_ARGS_ASSERT_REGINSERT;
10682     PERL_UNUSED_ARG(depth);
10683 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
10684     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
10685     if (SIZE_ONLY) {
10686         RExC_size += size;
10687         return;
10688     }
10689
10690     src = RExC_emit;
10691     RExC_emit += size;
10692     dst = RExC_emit;
10693     if (RExC_open_parens) {
10694         int paren;
10695         /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
10696         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
10697             if ( RExC_open_parens[paren] >= opnd ) {
10698                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
10699                 RExC_open_parens[paren] += size;
10700             } else {
10701                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
10702             }
10703             if ( RExC_close_parens[paren] >= opnd ) {
10704                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
10705                 RExC_close_parens[paren] += size;
10706             } else {
10707                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
10708             }
10709         }
10710     }
10711
10712     while (src > opnd) {
10713         StructCopy(--src, --dst, regnode);
10714 #ifdef RE_TRACK_PATTERN_OFFSETS
10715         if (RExC_offsets) {     /* MJD 20010112 */
10716             MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
10717                   "reg_insert",
10718                   __LINE__,
10719                   PL_reg_name[op],
10720                   (UV)(dst - RExC_emit_start) > RExC_offsets[0] 
10721                     ? "Overwriting end of array!\n" : "OK",
10722                   (UV)(src - RExC_emit_start),
10723                   (UV)(dst - RExC_emit_start),
10724                   (UV)RExC_offsets[0])); 
10725             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
10726             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
10727         }
10728 #endif
10729     }
10730     
10731
10732     place = opnd;               /* Op node, where operand used to be. */
10733 #ifdef RE_TRACK_PATTERN_OFFSETS
10734     if (RExC_offsets) {         /* MJD */
10735         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
10736               "reginsert",
10737               __LINE__,
10738               PL_reg_name[op],
10739               (UV)(place - RExC_emit_start) > RExC_offsets[0] 
10740               ? "Overwriting end of array!\n" : "OK",
10741               (UV)(place - RExC_emit_start),
10742               (UV)(RExC_parse - RExC_start),
10743               (UV)RExC_offsets[0]));
10744         Set_Node_Offset(place, RExC_parse);
10745         Set_Node_Length(place, 1);
10746     }
10747 #endif    
10748     src = NEXTOPER(place);
10749     FILL_ADVANCE_NODE(place, op);
10750     REH_CALL_REGCOMP_HOOK(pRExC_state->rx, (place) - 1);
10751     Zero(src, offset, regnode);
10752 }
10753
10754 /*
10755 - regtail - set the next-pointer at the end of a node chain of p to val.
10756 - SEE ALSO: regtail_study
10757 */
10758 /* TODO: All three parms should be const */
10759 STATIC void
10760 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
10761 {
10762     dVAR;
10763     register regnode *scan;
10764     GET_RE_DEBUG_FLAGS_DECL;
10765
10766     PERL_ARGS_ASSERT_REGTAIL;
10767 #ifndef DEBUGGING
10768     PERL_UNUSED_ARG(depth);
10769 #endif
10770
10771     if (SIZE_ONLY)
10772         return;
10773
10774     /* Find last node. */
10775     scan = p;
10776     for (;;) {
10777         regnode * const temp = regnext(scan);
10778         DEBUG_PARSE_r({
10779             SV * const mysv=sv_newmortal();
10780             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
10781             regprop(RExC_rx, mysv, scan);
10782             PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
10783                 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
10784                     (temp == NULL ? "->" : ""),
10785                     (temp == NULL ? PL_reg_name[OP(val)] : "")
10786             );
10787         });
10788         if (temp == NULL)
10789             break;
10790         scan = temp;
10791     }
10792
10793     if (reg_off_by_arg[OP(scan)]) {
10794         ARG_SET(scan, val - scan);
10795     }
10796     else {
10797         NEXT_OFF(scan) = val - scan;
10798     }
10799 }
10800
10801 #ifdef DEBUGGING
10802 /*
10803 - regtail_study - set the next-pointer at the end of a node chain of p to val.
10804 - Look for optimizable sequences at the same time.
10805 - currently only looks for EXACT chains.
10806
10807 This is experimental code. The idea is to use this routine to perform 
10808 in place optimizations on branches and groups as they are constructed,
10809 with the long term intention of removing optimization from study_chunk so
10810 that it is purely analytical.
10811
10812 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
10813 to control which is which.
10814
10815 */
10816 /* TODO: All four parms should be const */
10817
10818 STATIC U8
10819 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
10820 {
10821     dVAR;
10822     register regnode *scan;
10823     U8 exact = PSEUDO;
10824 #ifdef EXPERIMENTAL_INPLACESCAN
10825     I32 min = 0;
10826 #endif
10827     GET_RE_DEBUG_FLAGS_DECL;
10828
10829     PERL_ARGS_ASSERT_REGTAIL_STUDY;
10830
10831
10832     if (SIZE_ONLY)
10833         return exact;
10834
10835     /* Find last node. */
10836
10837     scan = p;
10838     for (;;) {
10839         regnode * const temp = regnext(scan);
10840 #ifdef EXPERIMENTAL_INPLACESCAN
10841         if (PL_regkind[OP(scan)] == EXACT)
10842             if (join_exact(pRExC_state,scan,&min,1,val,depth+1))
10843                 return EXACT;
10844 #endif
10845         if ( exact ) {
10846             switch (OP(scan)) {
10847                 case EXACT:
10848                 case EXACTF:
10849                 case EXACTFA:
10850                 case EXACTFU:
10851                 case EXACTFL:
10852                         if( exact == PSEUDO )
10853                             exact= OP(scan);
10854                         else if ( exact != OP(scan) )
10855                             exact= 0;
10856                 case NOTHING:
10857                     break;
10858                 default:
10859                     exact= 0;
10860             }
10861         }
10862         DEBUG_PARSE_r({
10863             SV * const mysv=sv_newmortal();
10864             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
10865             regprop(RExC_rx, mysv, scan);
10866             PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
10867                 SvPV_nolen_const(mysv),
10868                 REG_NODE_NUM(scan),
10869                 PL_reg_name[exact]);
10870         });
10871         if (temp == NULL)
10872             break;
10873         scan = temp;
10874     }
10875     DEBUG_PARSE_r({
10876         SV * const mysv_val=sv_newmortal();
10877         DEBUG_PARSE_MSG("");
10878         regprop(RExC_rx, mysv_val, val);
10879         PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
10880                       SvPV_nolen_const(mysv_val),
10881                       (IV)REG_NODE_NUM(val),
10882                       (IV)(val - scan)
10883         );
10884     });
10885     if (reg_off_by_arg[OP(scan)]) {
10886         ARG_SET(scan, val - scan);
10887     }
10888     else {
10889         NEXT_OFF(scan) = val - scan;
10890     }
10891
10892     return exact;
10893 }
10894 #endif
10895
10896 /*
10897  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
10898  */
10899 #ifdef DEBUGGING
10900 static void 
10901 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
10902 {
10903     int bit;
10904     int set=0;
10905     regex_charset cs;
10906
10907     for (bit=0; bit<32; bit++) {
10908         if (flags & (1<<bit)) {
10909             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
10910                 continue;
10911             }
10912             if (!set++ && lead) 
10913                 PerlIO_printf(Perl_debug_log, "%s",lead);
10914             PerlIO_printf(Perl_debug_log, "%s ",PL_reg_extflags_name[bit]);
10915         }               
10916     }      
10917     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
10918             if (!set++ && lead) {
10919                 PerlIO_printf(Perl_debug_log, "%s",lead);
10920             }
10921             switch (cs) {
10922                 case REGEX_UNICODE_CHARSET:
10923                     PerlIO_printf(Perl_debug_log, "UNICODE");
10924                     break;
10925                 case REGEX_LOCALE_CHARSET:
10926                     PerlIO_printf(Perl_debug_log, "LOCALE");
10927                     break;
10928                 case REGEX_ASCII_RESTRICTED_CHARSET:
10929                     PerlIO_printf(Perl_debug_log, "ASCII-RESTRICTED");
10930                     break;
10931                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
10932                     PerlIO_printf(Perl_debug_log, "ASCII-MORE_RESTRICTED");
10933                     break;
10934                 default:
10935                     PerlIO_printf(Perl_debug_log, "UNKNOWN CHARACTER SET");
10936                     break;
10937             }
10938     }
10939     if (lead)  {
10940         if (set) 
10941             PerlIO_printf(Perl_debug_log, "\n");
10942         else 
10943             PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
10944     }            
10945 }   
10946 #endif
10947
10948 void
10949 Perl_regdump(pTHX_ const regexp *r)
10950 {
10951 #ifdef DEBUGGING
10952     dVAR;
10953     SV * const sv = sv_newmortal();
10954     SV *dsv= sv_newmortal();
10955     RXi_GET_DECL(r,ri);
10956     GET_RE_DEBUG_FLAGS_DECL;
10957
10958     PERL_ARGS_ASSERT_REGDUMP;
10959
10960     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
10961
10962     /* Header fields of interest. */
10963     if (r->anchored_substr) {
10964         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr), 
10965             RE_SV_DUMPLEN(r->anchored_substr), 30);
10966         PerlIO_printf(Perl_debug_log,
10967                       "anchored %s%s at %"IVdf" ",
10968                       s, RE_SV_TAIL(r->anchored_substr),
10969                       (IV)r->anchored_offset);
10970     } else if (r->anchored_utf8) {
10971         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8), 
10972             RE_SV_DUMPLEN(r->anchored_utf8), 30);
10973         PerlIO_printf(Perl_debug_log,
10974                       "anchored utf8 %s%s at %"IVdf" ",
10975                       s, RE_SV_TAIL(r->anchored_utf8),
10976                       (IV)r->anchored_offset);
10977     }                 
10978     if (r->float_substr) {
10979         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr), 
10980             RE_SV_DUMPLEN(r->float_substr), 30);
10981         PerlIO_printf(Perl_debug_log,
10982                       "floating %s%s at %"IVdf"..%"UVuf" ",
10983                       s, RE_SV_TAIL(r->float_substr),
10984                       (IV)r->float_min_offset, (UV)r->float_max_offset);
10985     } else if (r->float_utf8) {
10986         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8), 
10987             RE_SV_DUMPLEN(r->float_utf8), 30);
10988         PerlIO_printf(Perl_debug_log,
10989                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
10990                       s, RE_SV_TAIL(r->float_utf8),
10991                       (IV)r->float_min_offset, (UV)r->float_max_offset);
10992     }
10993     if (r->check_substr || r->check_utf8)
10994         PerlIO_printf(Perl_debug_log,
10995                       (const char *)
10996                       (r->check_substr == r->float_substr
10997                        && r->check_utf8 == r->float_utf8
10998                        ? "(checking floating" : "(checking anchored"));
10999     if (r->extflags & RXf_NOSCAN)
11000         PerlIO_printf(Perl_debug_log, " noscan");
11001     if (r->extflags & RXf_CHECK_ALL)
11002         PerlIO_printf(Perl_debug_log, " isall");
11003     if (r->check_substr || r->check_utf8)
11004         PerlIO_printf(Perl_debug_log, ") ");
11005
11006     if (ri->regstclass) {
11007         regprop(r, sv, ri->regstclass);
11008         PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
11009     }
11010     if (r->extflags & RXf_ANCH) {
11011         PerlIO_printf(Perl_debug_log, "anchored");
11012         if (r->extflags & RXf_ANCH_BOL)
11013             PerlIO_printf(Perl_debug_log, "(BOL)");
11014         if (r->extflags & RXf_ANCH_MBOL)
11015             PerlIO_printf(Perl_debug_log, "(MBOL)");
11016         if (r->extflags & RXf_ANCH_SBOL)
11017             PerlIO_printf(Perl_debug_log, "(SBOL)");
11018         if (r->extflags & RXf_ANCH_GPOS)
11019             PerlIO_printf(Perl_debug_log, "(GPOS)");
11020         PerlIO_putc(Perl_debug_log, ' ');
11021     }
11022     if (r->extflags & RXf_GPOS_SEEN)
11023         PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
11024     if (r->intflags & PREGf_SKIP)
11025         PerlIO_printf(Perl_debug_log, "plus ");
11026     if (r->intflags & PREGf_IMPLICIT)
11027         PerlIO_printf(Perl_debug_log, "implicit ");
11028     PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
11029     if (r->extflags & RXf_EVAL_SEEN)
11030         PerlIO_printf(Perl_debug_log, "with eval ");
11031     PerlIO_printf(Perl_debug_log, "\n");
11032     DEBUG_FLAGS_r(regdump_extflags("r->extflags: ",r->extflags));            
11033 #else
11034     PERL_ARGS_ASSERT_REGDUMP;
11035     PERL_UNUSED_CONTEXT;
11036     PERL_UNUSED_ARG(r);
11037 #endif  /* DEBUGGING */
11038 }
11039
11040 /*
11041 - regprop - printable representation of opcode
11042 */
11043 #define EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags) \
11044 STMT_START { \
11045         if (do_sep) {                           \
11046             Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]); \
11047             if (flags & ANYOF_INVERT)           \
11048                 /*make sure the invert info is in each */ \
11049                 sv_catpvs(sv, "^");             \
11050             do_sep = 0;                         \
11051         }                                       \
11052 } STMT_END
11053
11054 void
11055 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
11056 {
11057 #ifdef DEBUGGING
11058     dVAR;
11059     register int k;
11060     RXi_GET_DECL(prog,progi);
11061     GET_RE_DEBUG_FLAGS_DECL;
11062     
11063     PERL_ARGS_ASSERT_REGPROP;
11064
11065     sv_setpvs(sv, "");
11066
11067     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
11068         /* It would be nice to FAIL() here, but this may be called from
11069            regexec.c, and it would be hard to supply pRExC_state. */
11070         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
11071     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
11072
11073     k = PL_regkind[OP(o)];
11074
11075     if (k == EXACT) {
11076         sv_catpvs(sv, " ");
11077         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT) 
11078          * is a crude hack but it may be the best for now since 
11079          * we have no flag "this EXACTish node was UTF-8" 
11080          * --jhi */
11081         pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
11082                   PERL_PV_ESCAPE_UNI_DETECT |
11083                   PERL_PV_ESCAPE_NONASCII   |
11084                   PERL_PV_PRETTY_ELLIPSES   |
11085                   PERL_PV_PRETTY_LTGT       |
11086                   PERL_PV_PRETTY_NOCLEAR
11087                   );
11088     } else if (k == TRIE) {
11089         /* print the details of the trie in dumpuntil instead, as
11090          * progi->data isn't available here */
11091         const char op = OP(o);
11092         const U32 n = ARG(o);
11093         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
11094                (reg_ac_data *)progi->data->data[n] :
11095                NULL;
11096         const reg_trie_data * const trie
11097             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
11098         
11099         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
11100         DEBUG_TRIE_COMPILE_r(
11101             Perl_sv_catpvf(aTHX_ sv,
11102                 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
11103                 (UV)trie->startstate,
11104                 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
11105                 (UV)trie->wordcount,
11106                 (UV)trie->minlen,
11107                 (UV)trie->maxlen,
11108                 (UV)TRIE_CHARCOUNT(trie),
11109                 (UV)trie->uniquecharcount
11110             )
11111         );
11112         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
11113             int i;
11114             int rangestart = -1;
11115             U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
11116             sv_catpvs(sv, "[");
11117             for (i = 0; i <= 256; i++) {
11118                 if (i < 256 && BITMAP_TEST(bitmap,i)) {
11119                     if (rangestart == -1)
11120                         rangestart = i;
11121                 } else if (rangestart != -1) {
11122                     if (i <= rangestart + 3)
11123                         for (; rangestart < i; rangestart++)
11124                             put_byte(sv, rangestart);
11125                     else {
11126                         put_byte(sv, rangestart);
11127                         sv_catpvs(sv, "-");
11128                         put_byte(sv, i - 1);
11129                     }
11130                     rangestart = -1;
11131                 }
11132             }
11133             sv_catpvs(sv, "]");
11134         } 
11135          
11136     } else if (k == CURLY) {
11137         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
11138             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
11139         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
11140     }
11141     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
11142         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
11143     else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
11144         Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
11145         if ( RXp_PAREN_NAMES(prog) ) {
11146             if ( k != REF || (OP(o) < NREF)) {
11147                 AV *list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
11148                 SV **name= av_fetch(list, ARG(o), 0 );
11149                 if (name)
11150                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
11151             }       
11152             else {
11153                 AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]);
11154                 SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]);
11155                 I32 *nums=(I32*)SvPVX(sv_dat);
11156                 SV **name= av_fetch(list, nums[0], 0 );
11157                 I32 n;
11158                 if (name) {
11159                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
11160                         Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
11161                                     (n ? "," : ""), (IV)nums[n]);
11162                     }
11163                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
11164                 }
11165             }
11166         }            
11167     } else if (k == GOSUB) 
11168         Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
11169     else if (k == VERB) {
11170         if (!o->flags) 
11171             Perl_sv_catpvf(aTHX_ sv, ":%"SVf, 
11172                            SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
11173     } else if (k == LOGICAL)
11174         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);     /* 2: embedded, otherwise 1 */
11175     else if (k == FOLDCHAR)
11176         Perl_sv_catpvf(aTHX_ sv, "[0x%"UVXf"]", PTR2UV(ARG(o)) );
11177     else if (k == ANYOF) {
11178         int i, rangestart = -1;
11179         const U8 flags = ANYOF_FLAGS(o);
11180         int do_sep = 0;
11181
11182         /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
11183         static const char * const anyofs[] = {
11184             "\\w",
11185             "\\W",
11186             "\\s",
11187             "\\S",
11188             "\\d",
11189             "\\D",
11190             "[:alnum:]",
11191             "[:^alnum:]",
11192             "[:alpha:]",
11193             "[:^alpha:]",
11194             "[:ascii:]",
11195             "[:^ascii:]",
11196             "[:cntrl:]",
11197             "[:^cntrl:]",
11198             "[:graph:]",
11199             "[:^graph:]",
11200             "[:lower:]",
11201             "[:^lower:]",
11202             "[:print:]",
11203             "[:^print:]",
11204             "[:punct:]",
11205             "[:^punct:]",
11206             "[:upper:]",
11207             "[:^upper:]",
11208             "[:xdigit:]",
11209             "[:^xdigit:]",
11210             "[:space:]",
11211             "[:^space:]",
11212             "[:blank:]",
11213             "[:^blank:]"
11214         };
11215
11216         if (flags & ANYOF_LOCALE)
11217             sv_catpvs(sv, "{loc}");
11218         if (flags & ANYOF_LOC_NONBITMAP_FOLD)
11219             sv_catpvs(sv, "{i}");
11220         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
11221         if (flags & ANYOF_INVERT)
11222             sv_catpvs(sv, "^");
11223         
11224         /* output what the standard cp 0-255 bitmap matches */
11225         for (i = 0; i <= 256; i++) {
11226             if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
11227                 if (rangestart == -1)
11228                     rangestart = i;
11229             } else if (rangestart != -1) {
11230                 if (i <= rangestart + 3)
11231                     for (; rangestart < i; rangestart++)
11232                         put_byte(sv, rangestart);
11233                 else {
11234                     put_byte(sv, rangestart);
11235                     sv_catpvs(sv, "-");
11236                     put_byte(sv, i - 1);
11237                 }
11238                 do_sep = 1;
11239                 rangestart = -1;
11240             }
11241         }
11242         
11243         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
11244         /* output any special charclass tests (used entirely under use locale) */
11245         if (ANYOF_CLASS_TEST_ANY_SET(o))
11246             for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
11247                 if (ANYOF_CLASS_TEST(o,i)) {
11248                     sv_catpv(sv, anyofs[i]);
11249                     do_sep = 1;
11250                 }
11251         
11252         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
11253         
11254         if (flags & ANYOF_NON_UTF8_LATIN1_ALL) {
11255             sv_catpvs(sv, "{non-utf8-latin1-all}");
11256         }
11257
11258         /* output information about the unicode matching */
11259         if (flags & ANYOF_UNICODE_ALL)
11260             sv_catpvs(sv, "{unicode_all}");
11261         else if (ANYOF_NONBITMAP(o))
11262             sv_catpvs(sv, "{unicode}");
11263         if (flags & ANYOF_NONBITMAP_NON_UTF8)
11264             sv_catpvs(sv, "{outside bitmap}");
11265
11266         if (ANYOF_NONBITMAP(o)) {
11267             SV *lv;
11268             SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
11269         
11270             if (lv) {
11271                 if (sw) {
11272                     U8 s[UTF8_MAXBYTES_CASE+1];
11273
11274                     for (i = 0; i <= 256; i++) { /* just the first 256 */
11275                         uvchr_to_utf8(s, i);
11276                         
11277                         if (i < 256 && swash_fetch(sw, s, TRUE)) {
11278                             if (rangestart == -1)
11279                                 rangestart = i;
11280                         } else if (rangestart != -1) {
11281                             if (i <= rangestart + 3)
11282                                 for (; rangestart < i; rangestart++) {
11283                                     const U8 * const e = uvchr_to_utf8(s,rangestart);
11284                                     U8 *p;
11285                                     for(p = s; p < e; p++)
11286                                         put_byte(sv, *p);
11287                                 }
11288                             else {
11289                                 const U8 *e = uvchr_to_utf8(s,rangestart);
11290                                 U8 *p;
11291                                 for (p = s; p < e; p++)
11292                                     put_byte(sv, *p);
11293                                 sv_catpvs(sv, "-");
11294                                 e = uvchr_to_utf8(s, i-1);
11295                                 for (p = s; p < e; p++)
11296                                     put_byte(sv, *p);
11297                                 }
11298                                 rangestart = -1;
11299                             }
11300                         }
11301                         
11302                     sv_catpvs(sv, "..."); /* et cetera */
11303                 }
11304
11305                 {
11306                     char *s = savesvpv(lv);
11307                     char * const origs = s;
11308                 
11309                     while (*s && *s != '\n')
11310                         s++;
11311                 
11312                     if (*s == '\n') {
11313                         const char * const t = ++s;
11314                         
11315                         while (*s) {
11316                             if (*s == '\n')
11317                                 *s = ' ';
11318                             s++;
11319                         }
11320                         if (s[-1] == ' ')
11321                             s[-1] = 0;
11322                         
11323                         sv_catpv(sv, t);
11324                     }
11325                 
11326                     Safefree(origs);
11327                 }
11328             }
11329         }
11330
11331         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
11332     }
11333     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
11334         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
11335 #else
11336     PERL_UNUSED_CONTEXT;
11337     PERL_UNUSED_ARG(sv);
11338     PERL_UNUSED_ARG(o);
11339     PERL_UNUSED_ARG(prog);
11340 #endif  /* DEBUGGING */
11341 }
11342
11343 SV *
11344 Perl_re_intuit_string(pTHX_ REGEXP * const r)
11345 {                               /* Assume that RE_INTUIT is set */
11346     dVAR;
11347     struct regexp *const prog = (struct regexp *)SvANY(r);
11348     GET_RE_DEBUG_FLAGS_DECL;
11349
11350     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
11351     PERL_UNUSED_CONTEXT;
11352
11353     DEBUG_COMPILE_r(
11354         {
11355             const char * const s = SvPV_nolen_const(prog->check_substr
11356                       ? prog->check_substr : prog->check_utf8);
11357
11358             if (!PL_colorset) reginitcolors();
11359             PerlIO_printf(Perl_debug_log,
11360                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
11361                       PL_colors[4],
11362                       prog->check_substr ? "" : "utf8 ",
11363                       PL_colors[5],PL_colors[0],
11364                       s,
11365                       PL_colors[1],
11366                       (strlen(s) > 60 ? "..." : ""));
11367         } );
11368
11369     return prog->check_substr ? prog->check_substr : prog->check_utf8;
11370 }
11371
11372 /* 
11373    pregfree() 
11374    
11375    handles refcounting and freeing the perl core regexp structure. When 
11376    it is necessary to actually free the structure the first thing it 
11377    does is call the 'free' method of the regexp_engine associated to
11378    the regexp, allowing the handling of the void *pprivate; member 
11379    first. (This routine is not overridable by extensions, which is why 
11380    the extensions free is called first.)
11381    
11382    See regdupe and regdupe_internal if you change anything here. 
11383 */
11384 #ifndef PERL_IN_XSUB_RE
11385 void
11386 Perl_pregfree(pTHX_ REGEXP *r)
11387 {
11388     SvREFCNT_dec(r);
11389 }
11390
11391 void
11392 Perl_pregfree2(pTHX_ REGEXP *rx)
11393 {
11394     dVAR;
11395     struct regexp *const r = (struct regexp *)SvANY(rx);
11396     GET_RE_DEBUG_FLAGS_DECL;
11397
11398     PERL_ARGS_ASSERT_PREGFREE2;
11399
11400     if (r->mother_re) {
11401         ReREFCNT_dec(r->mother_re);
11402     } else {
11403         CALLREGFREE_PVT(rx); /* free the private data */
11404         SvREFCNT_dec(RXp_PAREN_NAMES(r));
11405     }        
11406     if (r->substrs) {
11407         SvREFCNT_dec(r->anchored_substr);
11408         SvREFCNT_dec(r->anchored_utf8);
11409         SvREFCNT_dec(r->float_substr);
11410         SvREFCNT_dec(r->float_utf8);
11411         Safefree(r->substrs);
11412     }
11413     RX_MATCH_COPY_FREE(rx);
11414 #ifdef PERL_OLD_COPY_ON_WRITE
11415     SvREFCNT_dec(r->saved_copy);
11416 #endif
11417     Safefree(r->offs);
11418 }
11419
11420 /*  reg_temp_copy()
11421     
11422     This is a hacky workaround to the structural issue of match results
11423     being stored in the regexp structure which is in turn stored in
11424     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
11425     could be PL_curpm in multiple contexts, and could require multiple
11426     result sets being associated with the pattern simultaneously, such
11427     as when doing a recursive match with (??{$qr})
11428     
11429     The solution is to make a lightweight copy of the regexp structure 
11430     when a qr// is returned from the code executed by (??{$qr}) this
11431     lightweight copy doesn't actually own any of its data except for
11432     the starp/end and the actual regexp structure itself. 
11433     
11434 */    
11435     
11436     
11437 REGEXP *
11438 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
11439 {
11440     struct regexp *ret;
11441     struct regexp *const r = (struct regexp *)SvANY(rx);
11442     register const I32 npar = r->nparens+1;
11443
11444     PERL_ARGS_ASSERT_REG_TEMP_COPY;
11445
11446     if (!ret_x)
11447         ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
11448     ret = (struct regexp *)SvANY(ret_x);
11449     
11450     (void)ReREFCNT_inc(rx);
11451     /* We can take advantage of the existing "copied buffer" mechanism in SVs
11452        by pointing directly at the buffer, but flagging that the allocated
11453        space in the copy is zero. As we've just done a struct copy, it's now
11454        a case of zero-ing that, rather than copying the current length.  */
11455     SvPV_set(ret_x, RX_WRAPPED(rx));
11456     SvFLAGS(ret_x) |= SvFLAGS(rx) & (SVf_POK|SVp_POK|SVf_UTF8);
11457     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
11458            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
11459     SvLEN_set(ret_x, 0);
11460     SvSTASH_set(ret_x, NULL);
11461     SvMAGIC_set(ret_x, NULL);
11462     Newx(ret->offs, npar, regexp_paren_pair);
11463     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
11464     if (r->substrs) {
11465         Newx(ret->substrs, 1, struct reg_substr_data);
11466         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
11467
11468         SvREFCNT_inc_void(ret->anchored_substr);
11469         SvREFCNT_inc_void(ret->anchored_utf8);
11470         SvREFCNT_inc_void(ret->float_substr);
11471         SvREFCNT_inc_void(ret->float_utf8);
11472
11473         /* check_substr and check_utf8, if non-NULL, point to either their
11474            anchored or float namesakes, and don't hold a second reference.  */
11475     }
11476     RX_MATCH_COPIED_off(ret_x);
11477 #ifdef PERL_OLD_COPY_ON_WRITE
11478     ret->saved_copy = NULL;
11479 #endif
11480     ret->mother_re = rx;
11481     
11482     return ret_x;
11483 }
11484 #endif
11485
11486 /* regfree_internal() 
11487
11488    Free the private data in a regexp. This is overloadable by 
11489    extensions. Perl takes care of the regexp structure in pregfree(), 
11490    this covers the *pprivate pointer which technically perl doesn't 
11491    know about, however of course we have to handle the 
11492    regexp_internal structure when no extension is in use. 
11493    
11494    Note this is called before freeing anything in the regexp 
11495    structure. 
11496  */
11497  
11498 void
11499 Perl_regfree_internal(pTHX_ REGEXP * const rx)
11500 {
11501     dVAR;
11502     struct regexp *const r = (struct regexp *)SvANY(rx);
11503     RXi_GET_DECL(r,ri);
11504     GET_RE_DEBUG_FLAGS_DECL;
11505
11506     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
11507
11508     DEBUG_COMPILE_r({
11509         if (!PL_colorset)
11510             reginitcolors();
11511         {
11512             SV *dsv= sv_newmortal();
11513             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
11514                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
11515             PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n", 
11516                 PL_colors[4],PL_colors[5],s);
11517         }
11518     });
11519 #ifdef RE_TRACK_PATTERN_OFFSETS
11520     if (ri->u.offsets)
11521         Safefree(ri->u.offsets);             /* 20010421 MJD */
11522 #endif
11523     if (ri->data) {
11524         int n = ri->data->count;
11525         PAD* new_comppad = NULL;
11526         PAD* old_comppad;
11527         PADOFFSET refcnt;
11528
11529         while (--n >= 0) {
11530           /* If you add a ->what type here, update the comment in regcomp.h */
11531             switch (ri->data->what[n]) {
11532             case 'a':
11533             case 's':
11534             case 'S':
11535             case 'u':
11536                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
11537                 break;
11538             case 'f':
11539                 Safefree(ri->data->data[n]);
11540                 break;
11541             case 'p':
11542                 new_comppad = MUTABLE_AV(ri->data->data[n]);
11543                 break;
11544             case 'o':
11545                 if (new_comppad == NULL)
11546                     Perl_croak(aTHX_ "panic: pregfree comppad");
11547                 PAD_SAVE_LOCAL(old_comppad,
11548                     /* Watch out for global destruction's random ordering. */
11549                     (SvTYPE(new_comppad) == SVt_PVAV) ? new_comppad : NULL
11550                 );
11551                 OP_REFCNT_LOCK;
11552                 refcnt = OpREFCNT_dec((OP_4tree*)ri->data->data[n]);
11553                 OP_REFCNT_UNLOCK;
11554                 if (!refcnt)
11555                     op_free((OP_4tree*)ri->data->data[n]);
11556
11557                 PAD_RESTORE_LOCAL(old_comppad);
11558                 SvREFCNT_dec(MUTABLE_SV(new_comppad));
11559                 new_comppad = NULL;
11560                 break;
11561             case 'n':
11562                 break;
11563             case 'T':           
11564                 { /* Aho Corasick add-on structure for a trie node.
11565                      Used in stclass optimization only */
11566                     U32 refcount;
11567                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
11568                     OP_REFCNT_LOCK;
11569                     refcount = --aho->refcount;
11570                     OP_REFCNT_UNLOCK;
11571                     if ( !refcount ) {
11572                         PerlMemShared_free(aho->states);
11573                         PerlMemShared_free(aho->fail);
11574                          /* do this last!!!! */
11575                         PerlMemShared_free(ri->data->data[n]);
11576                         PerlMemShared_free(ri->regstclass);
11577                     }
11578                 }
11579                 break;
11580             case 't':
11581                 {
11582                     /* trie structure. */
11583                     U32 refcount;
11584                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
11585                     OP_REFCNT_LOCK;
11586                     refcount = --trie->refcount;
11587                     OP_REFCNT_UNLOCK;
11588                     if ( !refcount ) {
11589                         PerlMemShared_free(trie->charmap);
11590                         PerlMemShared_free(trie->states);
11591                         PerlMemShared_free(trie->trans);
11592                         if (trie->bitmap)
11593                             PerlMemShared_free(trie->bitmap);
11594                         if (trie->jump)
11595                             PerlMemShared_free(trie->jump);
11596                         PerlMemShared_free(trie->wordinfo);
11597                         /* do this last!!!! */
11598                         PerlMemShared_free(ri->data->data[n]);
11599                     }
11600                 }
11601                 break;
11602             default:
11603                 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
11604             }
11605         }
11606         Safefree(ri->data->what);
11607         Safefree(ri->data);
11608     }
11609
11610     Safefree(ri);
11611 }
11612
11613 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
11614 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
11615 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
11616
11617 /* 
11618    re_dup - duplicate a regexp. 
11619    
11620    This routine is expected to clone a given regexp structure. It is only
11621    compiled under USE_ITHREADS.
11622
11623    After all of the core data stored in struct regexp is duplicated
11624    the regexp_engine.dupe method is used to copy any private data
11625    stored in the *pprivate pointer. This allows extensions to handle
11626    any duplication it needs to do.
11627
11628    See pregfree() and regfree_internal() if you change anything here. 
11629 */
11630 #if defined(USE_ITHREADS)
11631 #ifndef PERL_IN_XSUB_RE
11632 void
11633 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
11634 {
11635     dVAR;
11636     I32 npar;
11637     const struct regexp *r = (const struct regexp *)SvANY(sstr);
11638     struct regexp *ret = (struct regexp *)SvANY(dstr);
11639     
11640     PERL_ARGS_ASSERT_RE_DUP_GUTS;
11641
11642     npar = r->nparens+1;
11643     Newx(ret->offs, npar, regexp_paren_pair);
11644     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
11645     if(ret->swap) {
11646         /* no need to copy these */
11647         Newx(ret->swap, npar, regexp_paren_pair);
11648     }
11649
11650     if (ret->substrs) {
11651         /* Do it this way to avoid reading from *r after the StructCopy().
11652            That way, if any of the sv_dup_inc()s dislodge *r from the L1
11653            cache, it doesn't matter.  */
11654         const bool anchored = r->check_substr
11655             ? r->check_substr == r->anchored_substr
11656             : r->check_utf8 == r->anchored_utf8;
11657         Newx(ret->substrs, 1, struct reg_substr_data);
11658         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
11659
11660         ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
11661         ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
11662         ret->float_substr = sv_dup_inc(ret->float_substr, param);
11663         ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
11664
11665         /* check_substr and check_utf8, if non-NULL, point to either their
11666            anchored or float namesakes, and don't hold a second reference.  */
11667
11668         if (ret->check_substr) {
11669             if (anchored) {
11670                 assert(r->check_utf8 == r->anchored_utf8);
11671                 ret->check_substr = ret->anchored_substr;
11672                 ret->check_utf8 = ret->anchored_utf8;
11673             } else {
11674                 assert(r->check_substr == r->float_substr);
11675                 assert(r->check_utf8 == r->float_utf8);
11676                 ret->check_substr = ret->float_substr;
11677                 ret->check_utf8 = ret->float_utf8;
11678             }
11679         } else if (ret->check_utf8) {
11680             if (anchored) {
11681                 ret->check_utf8 = ret->anchored_utf8;
11682             } else {
11683                 ret->check_utf8 = ret->float_utf8;
11684             }
11685         }
11686     }
11687
11688     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
11689
11690     if (ret->pprivate)
11691         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
11692
11693     if (RX_MATCH_COPIED(dstr))
11694         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
11695     else
11696         ret->subbeg = NULL;
11697 #ifdef PERL_OLD_COPY_ON_WRITE
11698     ret->saved_copy = NULL;
11699 #endif
11700
11701     if (ret->mother_re) {
11702         if (SvPVX_const(dstr) == SvPVX_const(ret->mother_re)) {
11703             /* Our storage points directly to our mother regexp, but that's
11704                1: a buffer in a different thread
11705                2: something we no longer hold a reference on
11706                so we need to copy it locally.  */
11707             /* Note we need to sue SvCUR() on our mother_re, because it, in
11708                turn, may well be pointing to its own mother_re.  */
11709             SvPV_set(dstr, SAVEPVN(SvPVX_const(ret->mother_re),
11710                                    SvCUR(ret->mother_re)+1));
11711             SvLEN_set(dstr, SvCUR(ret->mother_re)+1);
11712         }
11713         ret->mother_re      = NULL;
11714     }
11715     ret->gofs = 0;
11716 }
11717 #endif /* PERL_IN_XSUB_RE */
11718
11719 /*
11720    regdupe_internal()
11721    
11722    This is the internal complement to regdupe() which is used to copy
11723    the structure pointed to by the *pprivate pointer in the regexp.
11724    This is the core version of the extension overridable cloning hook.
11725    The regexp structure being duplicated will be copied by perl prior
11726    to this and will be provided as the regexp *r argument, however 
11727    with the /old/ structures pprivate pointer value. Thus this routine
11728    may override any copying normally done by perl.
11729    
11730    It returns a pointer to the new regexp_internal structure.
11731 */
11732
11733 void *
11734 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
11735 {
11736     dVAR;
11737     struct regexp *const r = (struct regexp *)SvANY(rx);
11738     regexp_internal *reti;
11739     int len, npar;
11740     RXi_GET_DECL(r,ri);
11741
11742     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
11743     
11744     npar = r->nparens+1;
11745     len = ProgLen(ri);
11746     
11747     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), char, regexp_internal);
11748     Copy(ri->program, reti->program, len+1, regnode);
11749     
11750
11751     reti->regstclass = NULL;
11752
11753     if (ri->data) {
11754         struct reg_data *d;
11755         const int count = ri->data->count;
11756         int i;
11757
11758         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
11759                 char, struct reg_data);
11760         Newx(d->what, count, U8);
11761
11762         d->count = count;
11763         for (i = 0; i < count; i++) {
11764             d->what[i] = ri->data->what[i];
11765             switch (d->what[i]) {
11766                 /* legal options are one of: sSfpontTua
11767                    see also regcomp.h and pregfree() */
11768             case 'a': /* actually an AV, but the dup function is identical.  */
11769             case 's':
11770             case 'S':
11771             case 'p': /* actually an AV, but the dup function is identical.  */
11772             case 'u': /* actually an HV, but the dup function is identical.  */
11773                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
11774                 break;
11775             case 'f':
11776                 /* This is cheating. */
11777                 Newx(d->data[i], 1, struct regnode_charclass_class);
11778                 StructCopy(ri->data->data[i], d->data[i],
11779                             struct regnode_charclass_class);
11780                 reti->regstclass = (regnode*)d->data[i];
11781                 break;
11782             case 'o':
11783                 /* Compiled op trees are readonly and in shared memory,
11784                    and can thus be shared without duplication. */
11785                 OP_REFCNT_LOCK;
11786                 d->data[i] = (void*)OpREFCNT_inc((OP*)ri->data->data[i]);
11787                 OP_REFCNT_UNLOCK;
11788                 break;
11789             case 'T':
11790                 /* Trie stclasses are readonly and can thus be shared
11791                  * without duplication. We free the stclass in pregfree
11792                  * when the corresponding reg_ac_data struct is freed.
11793                  */
11794                 reti->regstclass= ri->regstclass;
11795                 /* Fall through */
11796             case 't':
11797                 OP_REFCNT_LOCK;
11798                 ((reg_trie_data*)ri->data->data[i])->refcount++;
11799                 OP_REFCNT_UNLOCK;
11800                 /* Fall through */
11801             case 'n':
11802                 d->data[i] = ri->data->data[i];
11803                 break;
11804             default:
11805                 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
11806             }
11807         }
11808
11809         reti->data = d;
11810     }
11811     else
11812         reti->data = NULL;
11813
11814     reti->name_list_idx = ri->name_list_idx;
11815
11816 #ifdef RE_TRACK_PATTERN_OFFSETS
11817     if (ri->u.offsets) {
11818         Newx(reti->u.offsets, 2*len+1, U32);
11819         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
11820     }
11821 #else
11822     SetProgLen(reti,len);
11823 #endif
11824
11825     return (void*)reti;
11826 }
11827
11828 #endif    /* USE_ITHREADS */
11829
11830 #ifndef PERL_IN_XSUB_RE
11831
11832 /*
11833  - regnext - dig the "next" pointer out of a node
11834  */
11835 regnode *
11836 Perl_regnext(pTHX_ register regnode *p)
11837 {
11838     dVAR;
11839     register I32 offset;
11840
11841     if (!p)
11842         return(NULL);
11843
11844     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
11845         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(p), (int)REGNODE_MAX);
11846     }
11847
11848     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
11849     if (offset == 0)
11850         return(NULL);
11851
11852     return(p+offset);
11853 }
11854 #endif
11855
11856 STATIC void     
11857 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
11858 {
11859     va_list args;
11860     STRLEN l1 = strlen(pat1);
11861     STRLEN l2 = strlen(pat2);
11862     char buf[512];
11863     SV *msv;
11864     const char *message;
11865
11866     PERL_ARGS_ASSERT_RE_CROAK2;
11867
11868     if (l1 > 510)
11869         l1 = 510;
11870     if (l1 + l2 > 510)
11871         l2 = 510 - l1;
11872     Copy(pat1, buf, l1 , char);
11873     Copy(pat2, buf + l1, l2 , char);
11874     buf[l1 + l2] = '\n';
11875     buf[l1 + l2 + 1] = '\0';
11876 #ifdef I_STDARG
11877     /* ANSI variant takes additional second argument */
11878     va_start(args, pat2);
11879 #else
11880     va_start(args);
11881 #endif
11882     msv = vmess(buf, &args);
11883     va_end(args);
11884     message = SvPV_const(msv,l1);
11885     if (l1 > 512)
11886         l1 = 512;
11887     Copy(message, buf, l1 , char);
11888     buf[l1-1] = '\0';                   /* Overwrite \n */
11889     Perl_croak(aTHX_ "%s", buf);
11890 }
11891
11892 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
11893
11894 #ifndef PERL_IN_XSUB_RE
11895 void
11896 Perl_save_re_context(pTHX)
11897 {
11898     dVAR;
11899
11900     struct re_save_state *state;
11901
11902     SAVEVPTR(PL_curcop);
11903     SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
11904
11905     state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
11906     PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
11907     SSPUSHUV(SAVEt_RE_STATE);
11908
11909     Copy(&PL_reg_state, state, 1, struct re_save_state);
11910
11911     PL_reg_start_tmp = 0;
11912     PL_reg_start_tmpl = 0;
11913     PL_reg_oldsaved = NULL;
11914     PL_reg_oldsavedlen = 0;
11915     PL_reg_maxiter = 0;
11916     PL_reg_leftiter = 0;
11917     PL_reg_poscache = NULL;
11918     PL_reg_poscache_size = 0;
11919 #ifdef PERL_OLD_COPY_ON_WRITE
11920     PL_nrs = NULL;
11921 #endif
11922
11923     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
11924     if (PL_curpm) {
11925         const REGEXP * const rx = PM_GETRE(PL_curpm);
11926         if (rx) {
11927             U32 i;
11928             for (i = 1; i <= RX_NPARENS(rx); i++) {
11929                 char digits[TYPE_CHARS(long)];
11930                 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
11931                 GV *const *const gvp
11932                     = (GV**)hv_fetch(PL_defstash, digits, len, 0);
11933
11934                 if (gvp) {
11935                     GV * const gv = *gvp;
11936                     if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
11937                         save_scalar(gv);
11938                 }
11939             }
11940         }
11941     }
11942 }
11943 #endif
11944
11945 static void
11946 clear_re(pTHX_ void *r)
11947 {
11948     dVAR;
11949     ReREFCNT_dec((REGEXP *)r);
11950 }
11951
11952 #ifdef DEBUGGING
11953
11954 STATIC void
11955 S_put_byte(pTHX_ SV *sv, int c)
11956 {
11957     PERL_ARGS_ASSERT_PUT_BYTE;
11958
11959     /* Our definition of isPRINT() ignores locales, so only bytes that are
11960        not part of UTF-8 are considered printable. I assume that the same
11961        holds for UTF-EBCDIC.
11962        Also, code point 255 is not printable in either (it's E0 in EBCDIC,
11963        which Wikipedia says:
11964
11965        EO, or Eight Ones, is an 8-bit EBCDIC character code represented as all
11966        ones (binary 1111 1111, hexadecimal FF). It is similar, but not
11967        identical, to the ASCII delete (DEL) or rubout control character.
11968        ) So the old condition can be simplified to !isPRINT(c)  */
11969     if (!isPRINT(c)) {
11970         if (c < 256) {
11971             Perl_sv_catpvf(aTHX_ sv, "\\x%02x", c);
11972         }
11973         else {
11974             Perl_sv_catpvf(aTHX_ sv, "\\x{%x}", c);
11975         }
11976     }
11977     else {
11978         const char string = c;
11979         if (c == '-' || c == ']' || c == '\\' || c == '^')
11980             sv_catpvs(sv, "\\");
11981         sv_catpvn(sv, &string, 1);
11982     }
11983 }
11984
11985
11986 #define CLEAR_OPTSTART \
11987     if (optstart) STMT_START { \
11988             DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
11989             optstart=NULL; \
11990     } STMT_END
11991
11992 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
11993
11994 STATIC const regnode *
11995 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
11996             const regnode *last, const regnode *plast, 
11997             SV* sv, I32 indent, U32 depth)
11998 {
11999     dVAR;
12000     register U8 op = PSEUDO;    /* Arbitrary non-END op. */
12001     register const regnode *next;
12002     const regnode *optstart= NULL;
12003     
12004     RXi_GET_DECL(r,ri);
12005     GET_RE_DEBUG_FLAGS_DECL;
12006
12007     PERL_ARGS_ASSERT_DUMPUNTIL;
12008
12009 #ifdef DEBUG_DUMPUNTIL
12010     PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
12011         last ? last-start : 0,plast ? plast-start : 0);
12012 #endif
12013             
12014     if (plast && plast < last) 
12015         last= plast;
12016
12017     while (PL_regkind[op] != END && (!last || node < last)) {
12018         /* While that wasn't END last time... */
12019         NODE_ALIGN(node);
12020         op = OP(node);
12021         if (op == CLOSE || op == WHILEM)
12022             indent--;
12023         next = regnext((regnode *)node);
12024
12025         /* Where, what. */
12026         if (OP(node) == OPTIMIZED) {
12027             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
12028                 optstart = node;
12029             else
12030                 goto after_print;
12031         } else
12032             CLEAR_OPTSTART;
12033         
12034         regprop(r, sv, node);
12035         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
12036                       (int)(2*indent + 1), "", SvPVX_const(sv));
12037         
12038         if (OP(node) != OPTIMIZED) {                  
12039             if (next == NULL)           /* Next ptr. */
12040                 PerlIO_printf(Perl_debug_log, " (0)");
12041             else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
12042                 PerlIO_printf(Perl_debug_log, " (FAIL)");
12043             else 
12044                 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
12045             (void)PerlIO_putc(Perl_debug_log, '\n'); 
12046         }
12047         
12048       after_print:
12049         if (PL_regkind[(U8)op] == BRANCHJ) {
12050             assert(next);
12051             {
12052                 register const regnode *nnode = (OP(next) == LONGJMP
12053                                              ? regnext((regnode *)next)
12054                                              : next);
12055                 if (last && nnode > last)
12056                     nnode = last;
12057                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
12058             }
12059         }
12060         else if (PL_regkind[(U8)op] == BRANCH) {
12061             assert(next);
12062             DUMPUNTIL(NEXTOPER(node), next);
12063         }
12064         else if ( PL_regkind[(U8)op]  == TRIE ) {
12065             const regnode *this_trie = node;
12066             const char op = OP(node);
12067             const U32 n = ARG(node);
12068             const reg_ac_data * const ac = op>=AHOCORASICK ?
12069                (reg_ac_data *)ri->data->data[n] :
12070                NULL;
12071             const reg_trie_data * const trie =
12072                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
12073 #ifdef DEBUGGING
12074             AV *const trie_words = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
12075 #endif
12076             const regnode *nextbranch= NULL;
12077             I32 word_idx;
12078             sv_setpvs(sv, "");
12079             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
12080                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
12081                 
12082                 PerlIO_printf(Perl_debug_log, "%*s%s ",
12083                    (int)(2*(indent+3)), "",
12084                     elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
12085                             PL_colors[0], PL_colors[1],
12086                             (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
12087                             PERL_PV_PRETTY_ELLIPSES    |
12088                             PERL_PV_PRETTY_LTGT
12089                             )
12090                             : "???"
12091                 );
12092                 if (trie->jump) {
12093                     U16 dist= trie->jump[word_idx+1];
12094                     PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
12095                                   (UV)((dist ? this_trie + dist : next) - start));
12096                     if (dist) {
12097                         if (!nextbranch)
12098                             nextbranch= this_trie + trie->jump[0];    
12099                         DUMPUNTIL(this_trie + dist, nextbranch);
12100                     }
12101                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
12102                         nextbranch= regnext((regnode *)nextbranch);
12103                 } else {
12104                     PerlIO_printf(Perl_debug_log, "\n");
12105                 }
12106             }
12107             if (last && next > last)
12108                 node= last;
12109             else
12110                 node= next;
12111         }
12112         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
12113             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
12114                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
12115         }
12116         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
12117             assert(next);
12118             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
12119         }
12120         else if ( op == PLUS || op == STAR) {
12121             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
12122         }
12123         else if (PL_regkind[(U8)op] == ANYOF) {
12124             /* arglen 1 + class block */
12125             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_CLASS)
12126                     ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
12127             node = NEXTOPER(node);
12128         }
12129         else if (PL_regkind[(U8)op] == EXACT) {
12130             /* Literal string, where present. */
12131             node += NODE_SZ_STR(node) - 1;
12132             node = NEXTOPER(node);
12133         }
12134         else {
12135             node = NEXTOPER(node);
12136             node += regarglen[(U8)op];
12137         }
12138         if (op == CURLYX || op == OPEN)
12139             indent++;
12140     }
12141     CLEAR_OPTSTART;
12142 #ifdef DEBUG_DUMPUNTIL    
12143     PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
12144 #endif
12145     return node;
12146 }
12147
12148 #endif  /* DEBUGGING */
12149
12150 /*
12151  * Local variables:
12152  * c-indentation-style: bsd
12153  * c-basic-offset: 4
12154  * indent-tabs-mode: t
12155  * End:
12156  *
12157  * ex: set ts=8 sts=4 sw=4 noet:
12158  */