]> git.vpit.fr Git - perl/modules/re-engine-Hooks.git/blob - src/5015000/regcomp.c
Attach the callbacks to every regexps in a thread-safe way
[perl/modules/re-engine-Hooks.git] / src / 5015000 / regcomp.c
1 /*    regcomp.c
2  */
3
4 /*
5  * 'A fair jaw-cracker dwarf-language must be.'            --Samwise Gamgee
6  *
7  *     [p.285 of _The Lord of the Rings_, II/iii: "The Ring Goes South"]
8  */
9
10 /* This file contains functions for compiling a regular expression.  See
11  * also regexec.c which funnily enough, contains functions for executing
12  * a regular expression.
13  *
14  * This file is also copied at build time to ext/re/re_comp.c, where
15  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
16  * This causes the main functions to be compiled under new names and with
17  * debugging support added, which makes "use re 'debug'" work.
18  */
19
20 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
21  * confused with the original package (see point 3 below).  Thanks, Henry!
22  */
23
24 /* Additional note: this code is very heavily munged from Henry's version
25  * in places.  In some spots I've traded clarity for efficiency, so don't
26  * blame Henry for some of the lack of readability.
27  */
28
29 /* The names of the functions have been changed from regcomp and
30  * regexec to pregcomp and pregexec in order to avoid conflicts
31  * with the POSIX routines of the same names.
32 */
33
34 #ifdef PERL_EXT_RE_BUILD
35 #include "re_top.h"
36 #endif
37
38 /*
39  * pregcomp and pregexec -- regsub and regerror are not used in perl
40  *
41  *      Copyright (c) 1986 by University of Toronto.
42  *      Written by Henry Spencer.  Not derived from licensed software.
43  *
44  *      Permission is granted to anyone to use this software for any
45  *      purpose on any computer system, and to redistribute it freely,
46  *      subject to the following restrictions:
47  *
48  *      1. The author is not responsible for the consequences of use of
49  *              this software, no matter how awful, even if they arise
50  *              from defects in it.
51  *
52  *      2. The origin of this software must not be misrepresented, either
53  *              by explicit claim or by omission.
54  *
55  *      3. Altered versions must be plainly marked as such, and must not
56  *              be misrepresented as being the original software.
57  *
58  *
59  ****    Alterations to Henry's code are...
60  ****
61  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
62  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
63  ****    by Larry Wall and others
64  ****
65  ****    You may distribute under the terms of either the GNU General Public
66  ****    License or the Artistic License, as specified in the README file.
67
68  *
69  * Beware that some of this code is subtly aware of the way operator
70  * precedence is structured in regular expressions.  Serious changes in
71  * regular-expression syntax might require a total rethink.
72  */
73 #include "EXTERN.h"
74 #define PERL_IN_REGCOMP_C
75 #include "perl.h"
76
77 #ifndef PERL_IN_XSUB_RE
78 #include "re_defs.h"
79 #endif
80
81 #define REG_COMP_C
82 #ifdef PERL_IN_XSUB_RE
83 #  include "re_comp.h"
84 #else
85 #  include "regcomp.h"
86 #endif
87
88 #include "dquote_static.c"
89
90 #ifdef op
91 #undef op
92 #endif /* op */
93
94 #ifdef MSDOS
95 #  if defined(BUGGY_MSC6)
96  /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
97 #    pragma optimize("a",off)
98  /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
99 #    pragma optimize("w",on )
100 #  endif /* BUGGY_MSC6 */
101 #endif /* MSDOS */
102
103 #ifndef STATIC
104 #define STATIC  static
105 #endif
106
107 typedef struct RExC_state_t {
108     U32         flags;                  /* are we folding, multilining? */
109     char        *precomp;               /* uncompiled string. */
110     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
111     regexp      *rx;                    /* perl core regexp structure */
112     regexp_internal     *rxi;           /* internal data for regexp object pprivate field */        
113     char        *start;                 /* Start of input for compile */
114     char        *end;                   /* End of input for compile */
115     char        *parse;                 /* Input-scan pointer. */
116     I32         whilem_seen;            /* number of WHILEM in this expr */
117     regnode     *emit_start;            /* Start of emitted-code area */
118     regnode     *emit_bound;            /* First regnode outside of the allocated space */
119     regnode     *emit;                  /* Code-emit pointer; &regdummy = don't = compiling */
120     I32         naughty;                /* How bad is this pattern? */
121     I32         sawback;                /* Did we see \1, ...? */
122     U32         seen;
123     I32         size;                   /* Code size. */
124     I32         npar;                   /* Capture buffer count, (OPEN). */
125     I32         cpar;                   /* Capture buffer count, (CLOSE). */
126     I32         nestroot;               /* root parens we are in - used by accept */
127     I32         extralen;
128     I32         seen_zerolen;
129     I32         seen_evals;
130     regnode     **open_parens;          /* pointers to open parens */
131     regnode     **close_parens;         /* pointers to close parens */
132     regnode     *opend;                 /* END node in program */
133     I32         utf8;           /* whether the pattern is utf8 or not */
134     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
135                                 /* XXX use this for future optimisation of case
136                                  * where pattern must be upgraded to utf8. */
137     I32         uni_semantics;  /* If a d charset modifier should use unicode
138                                    rules, even if the pattern is not in
139                                    utf8 */
140     HV          *paren_names;           /* Paren names */
141     
142     regnode     **recurse;              /* Recurse regops */
143     I32         recurse_count;          /* Number of recurse regops */
144     I32         in_lookbehind;
145     I32         contains_locale;
146     I32         override_recoding;
147 #if ADD_TO_REGEXEC
148     char        *starttry;              /* -Dr: where regtry was called. */
149 #define RExC_starttry   (pRExC_state->starttry)
150 #endif
151 #ifdef DEBUGGING
152     const char  *lastparse;
153     I32         lastnum;
154     AV          *paren_name_list;       /* idx -> name */
155 #define RExC_lastparse  (pRExC_state->lastparse)
156 #define RExC_lastnum    (pRExC_state->lastnum)
157 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
158 #endif
159 } RExC_state_t;
160
161 #define RExC_flags      (pRExC_state->flags)
162 #define RExC_precomp    (pRExC_state->precomp)
163 #define RExC_rx_sv      (pRExC_state->rx_sv)
164 #define RExC_rx         (pRExC_state->rx)
165 #define RExC_rxi        (pRExC_state->rxi)
166 #define RExC_start      (pRExC_state->start)
167 #define RExC_end        (pRExC_state->end)
168 #define RExC_parse      (pRExC_state->parse)
169 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
170 #ifdef RE_TRACK_PATTERN_OFFSETS
171 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the others */
172 #endif
173 #define RExC_emit       (pRExC_state->emit)
174 #define RExC_emit_start (pRExC_state->emit_start)
175 #define RExC_emit_bound (pRExC_state->emit_bound)
176 #define RExC_naughty    (pRExC_state->naughty)
177 #define RExC_sawback    (pRExC_state->sawback)
178 #define RExC_seen       (pRExC_state->seen)
179 #define RExC_size       (pRExC_state->size)
180 #define RExC_npar       (pRExC_state->npar)
181 #define RExC_nestroot   (pRExC_state->nestroot)
182 #define RExC_extralen   (pRExC_state->extralen)
183 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
184 #define RExC_seen_evals (pRExC_state->seen_evals)
185 #define RExC_utf8       (pRExC_state->utf8)
186 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
187 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
188 #define RExC_open_parens        (pRExC_state->open_parens)
189 #define RExC_close_parens       (pRExC_state->close_parens)
190 #define RExC_opend      (pRExC_state->opend)
191 #define RExC_paren_names        (pRExC_state->paren_names)
192 #define RExC_recurse    (pRExC_state->recurse)
193 #define RExC_recurse_count      (pRExC_state->recurse_count)
194 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
195 #define RExC_contains_locale    (pRExC_state->contains_locale)
196 #define RExC_override_recoding  (pRExC_state->override_recoding)
197
198
199 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
200 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
201         ((*s) == '{' && regcurly(s)))
202
203 #ifdef SPSTART
204 #undef SPSTART          /* dratted cpp namespace... */
205 #endif
206 /*
207  * Flags to be passed up and down.
208  */
209 #define WORST           0       /* Worst case. */
210 #define HASWIDTH        0x01    /* Known to match non-null strings. */
211
212 /* Simple enough to be STAR/PLUS operand, in an EXACT node must be a single
213  * character, and if utf8, must be invariant.  Note that this is not the same thing as REGNODE_SIMPLE */
214 #define SIMPLE          0x02
215 #define SPSTART         0x04    /* Starts with * or +. */
216 #define TRYAGAIN        0x08    /* Weeded out a declaration. */
217 #define POSTPONED       0x10    /* (?1),(?&name), (??{...}) or similar */
218
219 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
220
221 /* whether trie related optimizations are enabled */
222 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
223 #define TRIE_STUDY_OPT
224 #define FULL_TRIE_STUDY
225 #define TRIE_STCLASS
226 #endif
227
228
229
230 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
231 #define PBITVAL(paren) (1 << ((paren) & 7))
232 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
233 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
234 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
235
236 /* If not already in utf8, do a longjmp back to the beginning */
237 #define UTF8_LONGJMP 42 /* Choose a value not likely to ever conflict */
238 #define REQUIRE_UTF8    STMT_START {                                       \
239                                      if (! UTF) JMPENV_JUMP(UTF8_LONGJMP); \
240                         } STMT_END
241
242 /* About scan_data_t.
243
244   During optimisation we recurse through the regexp program performing
245   various inplace (keyhole style) optimisations. In addition study_chunk
246   and scan_commit populate this data structure with information about
247   what strings MUST appear in the pattern. We look for the longest 
248   string that must appear at a fixed location, and we look for the
249   longest string that may appear at a floating location. So for instance
250   in the pattern:
251   
252     /FOO[xX]A.*B[xX]BAR/
253     
254   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
255   strings (because they follow a .* construct). study_chunk will identify
256   both FOO and BAR as being the longest fixed and floating strings respectively.
257   
258   The strings can be composites, for instance
259   
260      /(f)(o)(o)/
261      
262   will result in a composite fixed substring 'foo'.
263   
264   For each string some basic information is maintained:
265   
266   - offset or min_offset
267     This is the position the string must appear at, or not before.
268     It also implicitly (when combined with minlenp) tells us how many
269     characters must match before the string we are searching for.
270     Likewise when combined with minlenp and the length of the string it
271     tells us how many characters must appear after the string we have 
272     found.
273   
274   - max_offset
275     Only used for floating strings. This is the rightmost point that
276     the string can appear at. If set to I32 max it indicates that the
277     string can occur infinitely far to the right.
278   
279   - minlenp
280     A pointer to the minimum length of the pattern that the string 
281     was found inside. This is important as in the case of positive 
282     lookahead or positive lookbehind we can have multiple patterns 
283     involved. Consider
284     
285     /(?=FOO).*F/
286     
287     The minimum length of the pattern overall is 3, the minimum length
288     of the lookahead part is 3, but the minimum length of the part that
289     will actually match is 1. So 'FOO's minimum length is 3, but the 
290     minimum length for the F is 1. This is important as the minimum length
291     is used to determine offsets in front of and behind the string being 
292     looked for.  Since strings can be composites this is the length of the
293     pattern at the time it was committed with a scan_commit. Note that
294     the length is calculated by study_chunk, so that the minimum lengths
295     are not known until the full pattern has been compiled, thus the 
296     pointer to the value.
297   
298   - lookbehind
299   
300     In the case of lookbehind the string being searched for can be
301     offset past the start point of the final matching string. 
302     If this value was just blithely removed from the min_offset it would
303     invalidate some of the calculations for how many chars must match
304     before or after (as they are derived from min_offset and minlen and
305     the length of the string being searched for). 
306     When the final pattern is compiled and the data is moved from the
307     scan_data_t structure into the regexp structure the information
308     about lookbehind is factored in, with the information that would 
309     have been lost precalculated in the end_shift field for the 
310     associated string.
311
312   The fields pos_min and pos_delta are used to store the minimum offset
313   and the delta to the maximum offset at the current point in the pattern.    
314
315 */
316
317 typedef struct scan_data_t {
318     /*I32 len_min;      unused */
319     /*I32 len_delta;    unused */
320     I32 pos_min;
321     I32 pos_delta;
322     SV *last_found;
323     I32 last_end;           /* min value, <0 unless valid. */
324     I32 last_start_min;
325     I32 last_start_max;
326     SV **longest;           /* Either &l_fixed, or &l_float. */
327     SV *longest_fixed;      /* longest fixed string found in pattern */
328     I32 offset_fixed;       /* offset where it starts */
329     I32 *minlen_fixed;      /* pointer to the minlen relevant to the string */
330     I32 lookbehind_fixed;   /* is the position of the string modfied by LB */
331     SV *longest_float;      /* longest floating string found in pattern */
332     I32 offset_float_min;   /* earliest point in string it can appear */
333     I32 offset_float_max;   /* latest point in string it can appear */
334     I32 *minlen_float;      /* pointer to the minlen relevant to the string */
335     I32 lookbehind_float;   /* is the position of the string modified by LB */
336     I32 flags;
337     I32 whilem_c;
338     I32 *last_closep;
339     struct regnode_charclass_class *start_class;
340 } scan_data_t;
341
342 /*
343  * Forward declarations for pregcomp()'s friends.
344  */
345
346 static const scan_data_t zero_scan_data =
347   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
348
349 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
350 #define SF_BEFORE_SEOL          0x0001
351 #define SF_BEFORE_MEOL          0x0002
352 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
353 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
354
355 #ifdef NO_UNARY_PLUS
356 #  define SF_FIX_SHIFT_EOL      (0+2)
357 #  define SF_FL_SHIFT_EOL               (0+4)
358 #else
359 #  define SF_FIX_SHIFT_EOL      (+2)
360 #  define SF_FL_SHIFT_EOL               (+4)
361 #endif
362
363 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
364 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
365
366 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
367 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
368 #define SF_IS_INF               0x0040
369 #define SF_HAS_PAR              0x0080
370 #define SF_IN_PAR               0x0100
371 #define SF_HAS_EVAL             0x0200
372 #define SCF_DO_SUBSTR           0x0400
373 #define SCF_DO_STCLASS_AND      0x0800
374 #define SCF_DO_STCLASS_OR       0x1000
375 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
376 #define SCF_WHILEM_VISITED_POS  0x2000
377
378 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
379 #define SCF_SEEN_ACCEPT         0x8000 
380
381 #define UTF cBOOL(RExC_utf8)
382 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
383 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
384 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_DEPENDS_CHARSET)
385 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags) >= REGEX_UNICODE_CHARSET)
386 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_RESTRICTED_CHARSET)
387 #define MORE_ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
388 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags) >= REGEX_ASCII_RESTRICTED_CHARSET)
389
390 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
391
392 #define OOB_UNICODE             12345678
393 #define OOB_NAMEDCLASS          -1
394
395 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
396 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
397
398
399 /* length of regex to show in messages that don't mark a position within */
400 #define RegexLengthToShowInErrorMessages 127
401
402 /*
403  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
404  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
405  * op/pragma/warn/regcomp.
406  */
407 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
408 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
409
410 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
411
412 /*
413  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
414  * arg. Show regex, up to a maximum length. If it's too long, chop and add
415  * "...".
416  */
417 #define _FAIL(code) STMT_START {                                        \
418     const char *ellipses = "";                                          \
419     IV len = RExC_end - RExC_precomp;                                   \
420                                                                         \
421     if (!SIZE_ONLY)                                                     \
422         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);                   \
423     if (len > RegexLengthToShowInErrorMessages) {                       \
424         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
425         len = RegexLengthToShowInErrorMessages - 10;                    \
426         ellipses = "...";                                               \
427     }                                                                   \
428     code;                                                               \
429 } STMT_END
430
431 #define FAIL(msg) _FAIL(                            \
432     Perl_croak(aTHX_ "%s in regex m/%.*s%s/",       \
433             msg, (int)len, RExC_precomp, ellipses))
434
435 #define FAIL2(msg,arg) _FAIL(                       \
436     Perl_croak(aTHX_ msg " in regex m/%.*s%s/",     \
437             arg, (int)len, RExC_precomp, ellipses))
438
439 /*
440  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
441  */
442 #define Simple_vFAIL(m) STMT_START {                                    \
443     const IV offset = RExC_parse - RExC_precomp;                        \
444     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
445             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
446 } STMT_END
447
448 /*
449  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
450  */
451 #define vFAIL(m) STMT_START {                           \
452     if (!SIZE_ONLY)                                     \
453         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);   \
454     Simple_vFAIL(m);                                    \
455 } STMT_END
456
457 /*
458  * Like Simple_vFAIL(), but accepts two arguments.
459  */
460 #define Simple_vFAIL2(m,a1) STMT_START {                        \
461     const IV offset = RExC_parse - RExC_precomp;                        \
462     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1,                   \
463             (int)offset, RExC_precomp, RExC_precomp + offset);  \
464 } STMT_END
465
466 /*
467  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
468  */
469 #define vFAIL2(m,a1) STMT_START {                       \
470     if (!SIZE_ONLY)                                     \
471         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);   \
472     Simple_vFAIL2(m, a1);                               \
473 } STMT_END
474
475
476 /*
477  * Like Simple_vFAIL(), but accepts three arguments.
478  */
479 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
480     const IV offset = RExC_parse - RExC_precomp;                \
481     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2,               \
482             (int)offset, RExC_precomp, RExC_precomp + offset);  \
483 } STMT_END
484
485 /*
486  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
487  */
488 #define vFAIL3(m,a1,a2) STMT_START {                    \
489     if (!SIZE_ONLY)                                     \
490         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);   \
491     Simple_vFAIL3(m, a1, a2);                           \
492 } STMT_END
493
494 /*
495  * Like Simple_vFAIL(), but accepts four arguments.
496  */
497 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
498     const IV offset = RExC_parse - RExC_precomp;                \
499     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3,           \
500             (int)offset, RExC_precomp, RExC_precomp + offset);  \
501 } STMT_END
502
503 #define ckWARNreg(loc,m) STMT_START {                                   \
504     const IV offset = loc - RExC_precomp;                               \
505     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
506             (int)offset, RExC_precomp, RExC_precomp + offset);          \
507 } STMT_END
508
509 #define ckWARNregdep(loc,m) STMT_START {                                \
510     const IV offset = loc - RExC_precomp;                               \
511     Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),     \
512             m REPORT_LOCATION,                                          \
513             (int)offset, RExC_precomp, RExC_precomp + offset);          \
514 } STMT_END
515
516 #define ckWARN2regdep(loc,m, a1) STMT_START {                           \
517     const IV offset = loc - RExC_precomp;                               \
518     Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),     \
519             m REPORT_LOCATION,                                          \
520             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
521 } STMT_END
522
523 #define ckWARN2reg(loc, m, a1) STMT_START {                             \
524     const IV offset = loc - RExC_precomp;                               \
525     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
526             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
527 } STMT_END
528
529 #define vWARN3(loc, m, a1, a2) STMT_START {                             \
530     const IV offset = loc - RExC_precomp;                               \
531     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
532             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
533 } STMT_END
534
535 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                         \
536     const IV offset = loc - RExC_precomp;                               \
537     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
538             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
539 } STMT_END
540
541 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
542     const IV offset = loc - RExC_precomp;                               \
543     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
544             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
545 } STMT_END
546
547 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
548     const IV offset = loc - RExC_precomp;                               \
549     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
550             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
551 } STMT_END
552
553 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
554     const IV offset = loc - RExC_precomp;                               \
555     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
556             a1, a2, a3, a4, (int)offset, RExC_precomp, RExC_precomp + offset); \
557 } STMT_END
558
559
560 /* Allow for side effects in s */
561 #define REGC(c,s) STMT_START {                  \
562     if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
563 } STMT_END
564
565 /* Macros for recording node offsets.   20001227 mjd@plover.com 
566  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
567  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
568  * Element 0 holds the number n.
569  * Position is 1 indexed.
570  */
571 #ifndef RE_TRACK_PATTERN_OFFSETS
572 #define Set_Node_Offset_To_R(node,byte)
573 #define Set_Node_Offset(node,byte)
574 #define Set_Cur_Node_Offset
575 #define Set_Node_Length_To_R(node,len)
576 #define Set_Node_Length(node,len)
577 #define Set_Node_Cur_Length(node)
578 #define Node_Offset(n) 
579 #define Node_Length(n) 
580 #define Set_Node_Offset_Length(node,offset,len)
581 #define ProgLen(ri) ri->u.proglen
582 #define SetProgLen(ri,x) ri->u.proglen = x
583 #else
584 #define ProgLen(ri) ri->u.offsets[0]
585 #define SetProgLen(ri,x) ri->u.offsets[0] = x
586 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
587     if (! SIZE_ONLY) {                                                  \
588         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
589                     __LINE__, (int)(node), (int)(byte)));               \
590         if((node) < 0) {                                                \
591             Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \
592         } else {                                                        \
593             RExC_offsets[2*(node)-1] = (byte);                          \
594         }                                                               \
595     }                                                                   \
596 } STMT_END
597
598 #define Set_Node_Offset(node,byte) \
599     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
600 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
601
602 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
603     if (! SIZE_ONLY) {                                                  \
604         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
605                 __LINE__, (int)(node), (int)(len)));                    \
606         if((node) < 0) {                                                \
607             Perl_croak(aTHX_ "value of node is %d in Length macro", (int)(node)); \
608         } else {                                                        \
609             RExC_offsets[2*(node)] = (len);                             \
610         }                                                               \
611     }                                                                   \
612 } STMT_END
613
614 #define Set_Node_Length(node,len) \
615     Set_Node_Length_To_R((node)-RExC_emit_start, len)
616 #define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
617 #define Set_Node_Cur_Length(node) \
618     Set_Node_Length(node, RExC_parse - parse_start)
619
620 /* Get offsets and lengths */
621 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
622 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
623
624 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
625     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
626     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
627 } STMT_END
628 #endif
629
630 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
631 #define EXPERIMENTAL_INPLACESCAN
632 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
633
634 #define DEBUG_STUDYDATA(str,data,depth)                              \
635 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
636     PerlIO_printf(Perl_debug_log,                                    \
637         "%*s" str "Pos:%"IVdf"/%"IVdf                                \
638         " Flags: 0x%"UVXf" Whilem_c: %"IVdf" Lcp: %"IVdf" %s",       \
639         (int)(depth)*2, "",                                          \
640         (IV)((data)->pos_min),                                       \
641         (IV)((data)->pos_delta),                                     \
642         (UV)((data)->flags),                                         \
643         (IV)((data)->whilem_c),                                      \
644         (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
645         is_inf ? "INF " : ""                                         \
646     );                                                               \
647     if ((data)->last_found)                                          \
648         PerlIO_printf(Perl_debug_log,                                \
649             "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
650             " %sFloat: '%s' @ %"IVdf"/%"IVdf"",                      \
651             SvPVX_const((data)->last_found),                         \
652             (IV)((data)->last_end),                                  \
653             (IV)((data)->last_start_min),                            \
654             (IV)((data)->last_start_max),                            \
655             ((data)->longest &&                                      \
656              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
657             SvPVX_const((data)->longest_fixed),                      \
658             (IV)((data)->offset_fixed),                              \
659             ((data)->longest &&                                      \
660              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
661             SvPVX_const((data)->longest_float),                      \
662             (IV)((data)->offset_float_min),                          \
663             (IV)((data)->offset_float_max)                           \
664         );                                                           \
665     PerlIO_printf(Perl_debug_log,"\n");                              \
666 });
667
668 static void clear_re(pTHX_ void *r);
669
670 /* Mark that we cannot extend a found fixed substring at this point.
671    Update the longest found anchored substring and the longest found
672    floating substrings if needed. */
673
674 STATIC void
675 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp, int is_inf)
676 {
677     const STRLEN l = CHR_SVLEN(data->last_found);
678     const STRLEN old_l = CHR_SVLEN(*data->longest);
679     GET_RE_DEBUG_FLAGS_DECL;
680
681     PERL_ARGS_ASSERT_SCAN_COMMIT;
682
683     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
684         SvSetMagicSV(*data->longest, data->last_found);
685         if (*data->longest == data->longest_fixed) {
686             data->offset_fixed = l ? data->last_start_min : data->pos_min;
687             if (data->flags & SF_BEFORE_EOL)
688                 data->flags
689                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
690             else
691                 data->flags &= ~SF_FIX_BEFORE_EOL;
692             data->minlen_fixed=minlenp; 
693             data->lookbehind_fixed=0;
694         }
695         else { /* *data->longest == data->longest_float */
696             data->offset_float_min = l ? data->last_start_min : data->pos_min;
697             data->offset_float_max = (l
698                                       ? data->last_start_max
699                                       : data->pos_min + data->pos_delta);
700             if (is_inf || (U32)data->offset_float_max > (U32)I32_MAX)
701                 data->offset_float_max = I32_MAX;
702             if (data->flags & SF_BEFORE_EOL)
703                 data->flags
704                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
705             else
706                 data->flags &= ~SF_FL_BEFORE_EOL;
707             data->minlen_float=minlenp;
708             data->lookbehind_float=0;
709         }
710     }
711     SvCUR_set(data->last_found, 0);
712     {
713         SV * const sv = data->last_found;
714         if (SvUTF8(sv) && SvMAGICAL(sv)) {
715             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
716             if (mg)
717                 mg->mg_len = 0;
718         }
719     }
720     data->last_end = -1;
721     data->flags &= ~SF_BEFORE_EOL;
722     DEBUG_STUDYDATA("commit: ",data,0);
723 }
724
725 /* Can match anything (initialization) */
726 STATIC void
727 S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
728 {
729     PERL_ARGS_ASSERT_CL_ANYTHING;
730
731     ANYOF_BITMAP_SETALL(cl);
732     cl->flags = ANYOF_CLASS|ANYOF_EOS|ANYOF_UNICODE_ALL
733                 |ANYOF_LOC_NONBITMAP_FOLD|ANYOF_NON_UTF8_LATIN1_ALL;
734
735     /* If any portion of the regex is to operate under locale rules,
736      * initialization includes it.  The reason this isn't done for all regexes
737      * is that the optimizer was written under the assumption that locale was
738      * all-or-nothing.  Given the complexity and lack of documentation in the
739      * optimizer, and that there are inadequate test cases for locale, so many
740      * parts of it may not work properly, it is safest to avoid locale unless
741      * necessary. */
742     if (RExC_contains_locale) {
743         ANYOF_CLASS_SETALL(cl);     /* /l uses class */
744         cl->flags |= ANYOF_LOCALE;
745     }
746     else {
747         ANYOF_CLASS_ZERO(cl);       /* Only /l uses class now */
748     }
749 }
750
751 /* Can match anything (initialization) */
752 STATIC int
753 S_cl_is_anything(const struct regnode_charclass_class *cl)
754 {
755     int value;
756
757     PERL_ARGS_ASSERT_CL_IS_ANYTHING;
758
759     for (value = 0; value <= ANYOF_MAX; value += 2)
760         if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
761             return 1;
762     if (!(cl->flags & ANYOF_UNICODE_ALL))
763         return 0;
764     if (!ANYOF_BITMAP_TESTALLSET((const void*)cl))
765         return 0;
766     return 1;
767 }
768
769 /* Can match anything (initialization) */
770 STATIC void
771 S_cl_init(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
772 {
773     PERL_ARGS_ASSERT_CL_INIT;
774
775     Zero(cl, 1, struct regnode_charclass_class);
776     cl->type = ANYOF;
777     cl_anything(pRExC_state, cl);
778     ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
779 }
780
781 /* These two functions currently do the exact same thing */
782 #define cl_init_zero            S_cl_init
783
784 /* 'AND' a given class with another one.  Can create false positives.  'cl'
785  * should not be inverted.  'and_with->flags & ANYOF_CLASS' should be 0 if
786  * 'and_with' is a regnode_charclass instead of a regnode_charclass_class. */
787 STATIC void
788 S_cl_and(struct regnode_charclass_class *cl,
789         const struct regnode_charclass_class *and_with)
790 {
791     PERL_ARGS_ASSERT_CL_AND;
792
793     assert(and_with->type == ANYOF);
794
795     /* I (khw) am not sure all these restrictions are necessary XXX */
796     if (!(ANYOF_CLASS_TEST_ANY_SET(and_with))
797         && !(ANYOF_CLASS_TEST_ANY_SET(cl))
798         && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
799         && !(and_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
800         && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) {
801         int i;
802
803         if (and_with->flags & ANYOF_INVERT)
804             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
805                 cl->bitmap[i] &= ~and_with->bitmap[i];
806         else
807             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
808                 cl->bitmap[i] &= and_with->bitmap[i];
809     } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
810
811     if (and_with->flags & ANYOF_INVERT) {
812
813         /* Here, the and'ed node is inverted.  Get the AND of the flags that
814          * aren't affected by the inversion.  Those that are affected are
815          * handled individually below */
816         U8 affected_flags = cl->flags & ~INVERSION_UNAFFECTED_FLAGS;
817         cl->flags &= (and_with->flags & INVERSION_UNAFFECTED_FLAGS);
818         cl->flags |= affected_flags;
819
820         /* We currently don't know how to deal with things that aren't in the
821          * bitmap, but we know that the intersection is no greater than what
822          * is already in cl, so let there be false positives that get sorted
823          * out after the synthetic start class succeeds, and the node is
824          * matched for real. */
825
826         /* The inversion of these two flags indicate that the resulting
827          * intersection doesn't have them */
828         if (and_with->flags & ANYOF_UNICODE_ALL) {
829             cl->flags &= ~ANYOF_UNICODE_ALL;
830         }
831         if (and_with->flags & ANYOF_NON_UTF8_LATIN1_ALL) {
832             cl->flags &= ~ANYOF_NON_UTF8_LATIN1_ALL;
833         }
834     }
835     else {   /* and'd node is not inverted */
836         U8 outside_bitmap_but_not_utf8; /* Temp variable */
837
838         if (! ANYOF_NONBITMAP(and_with)) {
839
840             /* Here 'and_with' doesn't match anything outside the bitmap
841              * (except possibly ANYOF_UNICODE_ALL), which means the
842              * intersection can't either, except for ANYOF_UNICODE_ALL, in
843              * which case we don't know what the intersection is, but it's no
844              * greater than what cl already has, so can just leave it alone,
845              * with possible false positives */
846             if (! (and_with->flags & ANYOF_UNICODE_ALL)) {
847                 ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
848                 cl->flags &= ~ANYOF_NONBITMAP_NON_UTF8;
849             }
850         }
851         else if (! ANYOF_NONBITMAP(cl)) {
852
853             /* Here, 'and_with' does match something outside the bitmap, and cl
854              * doesn't have a list of things to match outside the bitmap.  If
855              * cl can match all code points above 255, the intersection will
856              * be those above-255 code points that 'and_with' matches.  If cl
857              * can't match all Unicode code points, it means that it can't
858              * match anything outside the bitmap (since the 'if' that got us
859              * into this block tested for that), so we leave the bitmap empty.
860              */
861             if (cl->flags & ANYOF_UNICODE_ALL) {
862                 ARG_SET(cl, ARG(and_with));
863
864                 /* and_with's ARG may match things that don't require UTF8.
865                  * And now cl's will too, in spite of this being an 'and'.  See
866                  * the comments below about the kludge */
867                 cl->flags |= and_with->flags & ANYOF_NONBITMAP_NON_UTF8;
868             }
869         }
870         else {
871             /* Here, both 'and_with' and cl match something outside the
872              * bitmap.  Currently we do not do the intersection, so just match
873              * whatever cl had at the beginning.  */
874         }
875
876
877         /* Take the intersection of the two sets of flags.  However, the
878          * ANYOF_NONBITMAP_NON_UTF8 flag is treated as an 'or'.  This is a
879          * kludge around the fact that this flag is not treated like the others
880          * which are initialized in cl_anything().  The way the optimizer works
881          * is that the synthetic start class (SSC) is initialized to match
882          * anything, and then the first time a real node is encountered, its
883          * values are AND'd with the SSC's with the result being the values of
884          * the real node.  However, there are paths through the optimizer where
885          * the AND never gets called, so those initialized bits are set
886          * inappropriately, which is not usually a big deal, as they just cause
887          * false positives in the SSC, which will just mean a probably
888          * imperceptible slow down in execution.  However this bit has a
889          * higher false positive consequence in that it can cause utf8.pm,
890          * utf8_heavy.pl ... to be loaded when not necessary, which is a much
891          * bigger slowdown and also causes significant extra memory to be used.
892          * In order to prevent this, the code now takes a different tack.  The
893          * bit isn't set unless some part of the regular expression needs it,
894          * but once set it won't get cleared.  This means that these extra
895          * modules won't get loaded unless there was some path through the
896          * pattern that would have required them anyway, and  so any false
897          * positives that occur by not ANDing them out when they could be
898          * aren't as severe as they would be if we treated this bit like all
899          * the others */
900         outside_bitmap_but_not_utf8 = (cl->flags | and_with->flags)
901                                       & ANYOF_NONBITMAP_NON_UTF8;
902         cl->flags &= and_with->flags;
903         cl->flags |= outside_bitmap_but_not_utf8;
904     }
905 }
906
907 /* 'OR' a given class with another one.  Can create false positives.  'cl'
908  * should not be inverted.  'or_with->flags & ANYOF_CLASS' should be 0 if
909  * 'or_with' is a regnode_charclass instead of a regnode_charclass_class. */
910 STATIC void
911 S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
912 {
913     PERL_ARGS_ASSERT_CL_OR;
914
915     if (or_with->flags & ANYOF_INVERT) {
916
917         /* Here, the or'd node is to be inverted.  This means we take the
918          * complement of everything not in the bitmap, but currently we don't
919          * know what that is, so give up and match anything */
920         if (ANYOF_NONBITMAP(or_with)) {
921             cl_anything(pRExC_state, cl);
922         }
923         /* We do not use
924          * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
925          *   <= (B1 | !B2) | (CL1 | !CL2)
926          * which is wasteful if CL2 is small, but we ignore CL2:
927          *   (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
928          * XXXX Can we handle case-fold?  Unclear:
929          *   (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
930          *   (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
931          */
932         else if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
933              && !(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
934              && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD) ) {
935             int i;
936
937             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
938                 cl->bitmap[i] |= ~or_with->bitmap[i];
939         } /* XXXX: logic is complicated otherwise */
940         else {
941             cl_anything(pRExC_state, cl);
942         }
943
944         /* And, we can just take the union of the flags that aren't affected
945          * by the inversion */
946         cl->flags |= or_with->flags & INVERSION_UNAFFECTED_FLAGS;
947
948         /* For the remaining flags:
949             ANYOF_UNICODE_ALL and inverted means to not match anything above
950                     255, which means that the union with cl should just be
951                     what cl has in it, so can ignore this flag
952             ANYOF_NON_UTF8_LATIN1_ALL and inverted means if not utf8 and ord
953                     is 127-255 to match them, but then invert that, so the
954                     union with cl should just be what cl has in it, so can
955                     ignore this flag
956          */
957     } else {    /* 'or_with' is not inverted */
958         /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
959         if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
960              && (!(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
961                  || (cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) ) {
962             int i;
963
964             /* OR char bitmap and class bitmap separately */
965             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
966                 cl->bitmap[i] |= or_with->bitmap[i];
967             if (ANYOF_CLASS_TEST_ANY_SET(or_with)) {
968                 for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++)
969                     cl->classflags[i] |= or_with->classflags[i];
970                 cl->flags |= ANYOF_CLASS;
971             }
972         }
973         else { /* XXXX: logic is complicated, leave it along for a moment. */
974             cl_anything(pRExC_state, cl);
975         }
976
977         if (ANYOF_NONBITMAP(or_with)) {
978
979             /* Use the added node's outside-the-bit-map match if there isn't a
980              * conflict.  If there is a conflict (both nodes match something
981              * outside the bitmap, but what they match outside is not the same
982              * pointer, and hence not easily compared until XXX we extend
983              * inversion lists this far), give up and allow the start class to
984              * match everything outside the bitmap.  If that stuff is all above
985              * 255, can just set UNICODE_ALL, otherwise caould be anything. */
986             if (! ANYOF_NONBITMAP(cl)) {
987                 ARG_SET(cl, ARG(or_with));
988             }
989             else if (ARG(cl) != ARG(or_with)) {
990
991                 if ((or_with->flags & ANYOF_NONBITMAP_NON_UTF8)) {
992                     cl_anything(pRExC_state, cl);
993                 }
994                 else {
995                     cl->flags |= ANYOF_UNICODE_ALL;
996                 }
997             }
998         }
999
1000         /* Take the union */
1001         cl->flags |= or_with->flags;
1002     }
1003 }
1004
1005 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1006 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
1007 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1008 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list ? (TRIE_LIST_CUR( idx ) - 1) : 0 )
1009
1010
1011 #ifdef DEBUGGING
1012 /*
1013    dump_trie(trie,widecharmap,revcharmap)
1014    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1015    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1016
1017    These routines dump out a trie in a somewhat readable format.
1018    The _interim_ variants are used for debugging the interim
1019    tables that are used to generate the final compressed
1020    representation which is what dump_trie expects.
1021
1022    Part of the reason for their existence is to provide a form
1023    of documentation as to how the different representations function.
1024
1025 */
1026
1027 /*
1028   Dumps the final compressed table form of the trie to Perl_debug_log.
1029   Used for debugging make_trie().
1030 */
1031
1032 STATIC void
1033 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1034             AV *revcharmap, U32 depth)
1035 {
1036     U32 state;
1037     SV *sv=sv_newmortal();
1038     int colwidth= widecharmap ? 6 : 4;
1039     U16 word;
1040     GET_RE_DEBUG_FLAGS_DECL;
1041
1042     PERL_ARGS_ASSERT_DUMP_TRIE;
1043
1044     PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
1045         (int)depth * 2 + 2,"",
1046         "Match","Base","Ofs" );
1047
1048     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1049         SV ** const tmp = av_fetch( revcharmap, state, 0);
1050         if ( tmp ) {
1051             PerlIO_printf( Perl_debug_log, "%*s", 
1052                 colwidth,
1053                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1054                             PL_colors[0], PL_colors[1],
1055                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1056                             PERL_PV_ESCAPE_FIRSTCHAR 
1057                 ) 
1058             );
1059         }
1060     }
1061     PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
1062         (int)depth * 2 + 2,"");
1063
1064     for( state = 0 ; state < trie->uniquecharcount ; state++ )
1065         PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
1066     PerlIO_printf( Perl_debug_log, "\n");
1067
1068     for( state = 1 ; state < trie->statecount ; state++ ) {
1069         const U32 base = trie->states[ state ].trans.base;
1070
1071         PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state);
1072
1073         if ( trie->states[ state ].wordnum ) {
1074             PerlIO_printf( Perl_debug_log, " W%4X", trie->states[ state ].wordnum );
1075         } else {
1076             PerlIO_printf( Perl_debug_log, "%6s", "" );
1077         }
1078
1079         PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
1080
1081         if ( base ) {
1082             U32 ofs = 0;
1083
1084             while( ( base + ofs  < trie->uniquecharcount ) ||
1085                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
1086                      && trie->trans[ base + ofs - trie->uniquecharcount ].check != state))
1087                     ofs++;
1088
1089             PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
1090
1091             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
1092                 if ( ( base + ofs >= trie->uniquecharcount ) &&
1093                      ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
1094                      trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
1095                 {
1096                    PerlIO_printf( Perl_debug_log, "%*"UVXf,
1097                     colwidth,
1098                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
1099                 } else {
1100                     PerlIO_printf( Perl_debug_log, "%*s",colwidth,"   ." );
1101                 }
1102             }
1103
1104             PerlIO_printf( Perl_debug_log, "]");
1105
1106         }
1107         PerlIO_printf( Perl_debug_log, "\n" );
1108     }
1109     PerlIO_printf(Perl_debug_log, "%*sword_info N:(prev,len)=", (int)depth*2, "");
1110     for (word=1; word <= trie->wordcount; word++) {
1111         PerlIO_printf(Perl_debug_log, " %d:(%d,%d)",
1112             (int)word, (int)(trie->wordinfo[word].prev),
1113             (int)(trie->wordinfo[word].len));
1114     }
1115     PerlIO_printf(Perl_debug_log, "\n" );
1116 }    
1117 /*
1118   Dumps a fully constructed but uncompressed trie in list form.
1119   List tries normally only are used for construction when the number of 
1120   possible chars (trie->uniquecharcount) is very high.
1121   Used for debugging make_trie().
1122 */
1123 STATIC void
1124 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
1125                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
1126                          U32 depth)
1127 {
1128     U32 state;
1129     SV *sv=sv_newmortal();
1130     int colwidth= widecharmap ? 6 : 4;
1131     GET_RE_DEBUG_FLAGS_DECL;
1132
1133     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
1134
1135     /* print out the table precompression.  */
1136     PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
1137         (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
1138         "------:-----+-----------------\n" );
1139     
1140     for( state=1 ; state < next_alloc ; state ++ ) {
1141         U16 charid;
1142     
1143         PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
1144             (int)depth * 2 + 2,"", (UV)state  );
1145         if ( ! trie->states[ state ].wordnum ) {
1146             PerlIO_printf( Perl_debug_log, "%5s| ","");
1147         } else {
1148             PerlIO_printf( Perl_debug_log, "W%4x| ",
1149                 trie->states[ state ].wordnum
1150             );
1151         }
1152         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
1153             SV ** const tmp = av_fetch( revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
1154             if ( tmp ) {
1155                 PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
1156                     colwidth,
1157                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1158                             PL_colors[0], PL_colors[1],
1159                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1160                             PERL_PV_ESCAPE_FIRSTCHAR 
1161                     ) ,
1162                     TRIE_LIST_ITEM(state,charid).forid,
1163                     (UV)TRIE_LIST_ITEM(state,charid).newstate
1164                 );
1165                 if (!(charid % 10)) 
1166                     PerlIO_printf(Perl_debug_log, "\n%*s| ",
1167                         (int)((depth * 2) + 14), "");
1168             }
1169         }
1170         PerlIO_printf( Perl_debug_log, "\n");
1171     }
1172 }    
1173
1174 /*
1175   Dumps a fully constructed but uncompressed trie in table form.
1176   This is the normal DFA style state transition table, with a few 
1177   twists to facilitate compression later. 
1178   Used for debugging make_trie().
1179 */
1180 STATIC void
1181 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
1182                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
1183                           U32 depth)
1184 {
1185     U32 state;
1186     U16 charid;
1187     SV *sv=sv_newmortal();
1188     int colwidth= widecharmap ? 6 : 4;
1189     GET_RE_DEBUG_FLAGS_DECL;
1190
1191     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
1192     
1193     /*
1194        print out the table precompression so that we can do a visual check
1195        that they are identical.
1196      */
1197     
1198     PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
1199
1200     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1201         SV ** const tmp = av_fetch( revcharmap, charid, 0);
1202         if ( tmp ) {
1203             PerlIO_printf( Perl_debug_log, "%*s", 
1204                 colwidth,
1205                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1206                             PL_colors[0], PL_colors[1],
1207                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1208                             PERL_PV_ESCAPE_FIRSTCHAR 
1209                 ) 
1210             );
1211         }
1212     }
1213
1214     PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
1215
1216     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
1217         PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
1218     }
1219
1220     PerlIO_printf( Perl_debug_log, "\n" );
1221
1222     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
1223
1224         PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ", 
1225             (int)depth * 2 + 2,"",
1226             (UV)TRIE_NODENUM( state ) );
1227
1228         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1229             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
1230             if (v)
1231                 PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
1232             else
1233                 PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
1234         }
1235         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1236             PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check );
1237         } else {
1238             PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n", (UV)trie->trans[ state ].check,
1239             trie->states[ TRIE_NODENUM( state ) ].wordnum );
1240         }
1241     }
1242 }
1243
1244 #endif
1245
1246
1247 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
1248   startbranch: the first branch in the whole branch sequence
1249   first      : start branch of sequence of branch-exact nodes.
1250                May be the same as startbranch
1251   last       : Thing following the last branch.
1252                May be the same as tail.
1253   tail       : item following the branch sequence
1254   count      : words in the sequence
1255   flags      : currently the OP() type we will be building one of /EXACT(|F|Fl)/
1256   depth      : indent depth
1257
1258 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
1259
1260 A trie is an N'ary tree where the branches are determined by digital
1261 decomposition of the key. IE, at the root node you look up the 1st character and
1262 follow that branch repeat until you find the end of the branches. Nodes can be
1263 marked as "accepting" meaning they represent a complete word. Eg:
1264
1265   /he|she|his|hers/
1266
1267 would convert into the following structure. Numbers represent states, letters
1268 following numbers represent valid transitions on the letter from that state, if
1269 the number is in square brackets it represents an accepting state, otherwise it
1270 will be in parenthesis.
1271
1272       +-h->+-e->[3]-+-r->(8)-+-s->[9]
1273       |    |
1274       |   (2)
1275       |    |
1276      (1)   +-i->(6)-+-s->[7]
1277       |
1278       +-s->(3)-+-h->(4)-+-e->[5]
1279
1280       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
1281
1282 This shows that when matching against the string 'hers' we will begin at state 1
1283 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
1284 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
1285 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
1286 single traverse. We store a mapping from accepting to state to which word was
1287 matched, and then when we have multiple possibilities we try to complete the
1288 rest of the regex in the order in which they occured in the alternation.
1289
1290 The only prior NFA like behaviour that would be changed by the TRIE support is
1291 the silent ignoring of duplicate alternations which are of the form:
1292
1293  / (DUPE|DUPE) X? (?{ ... }) Y /x
1294
1295 Thus EVAL blocks following a trie may be called a different number of times with
1296 and without the optimisation. With the optimisations dupes will be silently
1297 ignored. This inconsistent behaviour of EVAL type nodes is well established as
1298 the following demonstrates:
1299
1300  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
1301
1302 which prints out 'word' three times, but
1303
1304  'words'=~/(word|word|word)(?{ print $1 })S/
1305
1306 which doesnt print it out at all. This is due to other optimisations kicking in.
1307
1308 Example of what happens on a structural level:
1309
1310 The regexp /(ac|ad|ab)+/ will produce the following debug output:
1311
1312    1: CURLYM[1] {1,32767}(18)
1313    5:   BRANCH(8)
1314    6:     EXACT <ac>(16)
1315    8:   BRANCH(11)
1316    9:     EXACT <ad>(16)
1317   11:   BRANCH(14)
1318   12:     EXACT <ab>(16)
1319   16:   SUCCEED(0)
1320   17:   NOTHING(18)
1321   18: END(0)
1322
1323 This would be optimizable with startbranch=5, first=5, last=16, tail=16
1324 and should turn into:
1325
1326    1: CURLYM[1] {1,32767}(18)
1327    5:   TRIE(16)
1328         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
1329           <ac>
1330           <ad>
1331           <ab>
1332   16:   SUCCEED(0)
1333   17:   NOTHING(18)
1334   18: END(0)
1335
1336 Cases where tail != last would be like /(?foo|bar)baz/:
1337
1338    1: BRANCH(4)
1339    2:   EXACT <foo>(8)
1340    4: BRANCH(7)
1341    5:   EXACT <bar>(8)
1342    7: TAIL(8)
1343    8: EXACT <baz>(10)
1344   10: END(0)
1345
1346 which would be optimizable with startbranch=1, first=1, last=7, tail=8
1347 and would end up looking like:
1348
1349     1: TRIE(8)
1350       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
1351         <foo>
1352         <bar>
1353    7: TAIL(8)
1354    8: EXACT <baz>(10)
1355   10: END(0)
1356
1357     d = uvuni_to_utf8_flags(d, uv, 0);
1358
1359 is the recommended Unicode-aware way of saying
1360
1361     *(d++) = uv;
1362 */
1363
1364 #define TRIE_STORE_REVCHAR                                                 \
1365     STMT_START {                                                           \
1366         if (UTF) {                                                         \
1367             SV *zlopp = newSV(2);                                          \
1368             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
1369             unsigned const char *const kapow = uvuni_to_utf8(flrbbbbb, uvc & 0xFF); \
1370             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
1371             SvPOK_on(zlopp);                                               \
1372             SvUTF8_on(zlopp);                                              \
1373             av_push(revcharmap, zlopp);                                    \
1374         } else {                                                           \
1375             char ooooff = (char)uvc;                                               \
1376             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
1377         }                                                                  \
1378         } STMT_END
1379
1380 #define TRIE_READ_CHAR STMT_START {                                           \
1381     wordlen++;                                                                \
1382     if ( UTF ) {                                                              \
1383         if ( folder ) {                                                       \
1384             if ( foldlen > 0 ) {                                              \
1385                uvc = utf8n_to_uvuni( scan, UTF8_MAXLEN, &len, uniflags );     \
1386                foldlen -= len;                                                \
1387                scan += len;                                                   \
1388                len = 0;                                                       \
1389             } else {                                                          \
1390                 uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
1391                 uvc = to_uni_fold( uvc, foldbuf, &foldlen );                  \
1392                 foldlen -= UNISKIP( uvc );                                    \
1393                 scan = foldbuf + UNISKIP( uvc );                              \
1394             }                                                                 \
1395         } else {                                                              \
1396             uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
1397         }                                                                     \
1398     } else {                                                                  \
1399         uvc = (U32)*uc;                                                       \
1400         len = 1;                                                              \
1401     }                                                                         \
1402 } STMT_END
1403
1404
1405
1406 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
1407     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
1408         U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
1409         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
1410     }                                                           \
1411     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
1412     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
1413     TRIE_LIST_CUR( state )++;                                   \
1414 } STMT_END
1415
1416 #define TRIE_LIST_NEW(state) STMT_START {                       \
1417     Newxz( trie->states[ state ].trans.list,               \
1418         4, reg_trie_trans_le );                                 \
1419      TRIE_LIST_CUR( state ) = 1;                                \
1420      TRIE_LIST_LEN( state ) = 4;                                \
1421 } STMT_END
1422
1423 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
1424     U16 dupe= trie->states[ state ].wordnum;                    \
1425     regnode * const noper_next = regnext( noper );              \
1426                                                                 \
1427     DEBUG_r({                                                   \
1428         /* store the word for dumping */                        \
1429         SV* tmp;                                                \
1430         if (OP(noper) != NOTHING)                               \
1431             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
1432         else                                                    \
1433             tmp = newSVpvn_utf8( "", 0, UTF );                  \
1434         av_push( trie_words, tmp );                             \
1435     });                                                         \
1436                                                                 \
1437     curword++;                                                  \
1438     trie->wordinfo[curword].prev   = 0;                         \
1439     trie->wordinfo[curword].len    = wordlen;                   \
1440     trie->wordinfo[curword].accept = state;                     \
1441                                                                 \
1442     if ( noper_next < tail ) {                                  \
1443         if (!trie->jump)                                        \
1444             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, sizeof(U16) ); \
1445         trie->jump[curword] = (U16)(noper_next - convert);      \
1446         if (!jumper)                                            \
1447             jumper = noper_next;                                \
1448         if (!nextbranch)                                        \
1449             nextbranch= regnext(cur);                           \
1450     }                                                           \
1451                                                                 \
1452     if ( dupe ) {                                               \
1453         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
1454         /* chain, so that when the bits of chain are later    */\
1455         /* linked together, the dups appear in the chain      */\
1456         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
1457         trie->wordinfo[dupe].prev = curword;                    \
1458     } else {                                                    \
1459         /* we haven't inserted this word yet.                */ \
1460         trie->states[ state ].wordnum = curword;                \
1461     }                                                           \
1462 } STMT_END
1463
1464
1465 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
1466      ( ( base + charid >=  ucharcount                                   \
1467          && base + charid < ubound                                      \
1468          && state == trie->trans[ base - ucharcount + charid ].check    \
1469          && trie->trans[ base - ucharcount + charid ].next )            \
1470            ? trie->trans[ base - ucharcount + charid ].next             \
1471            : ( state==1 ? special : 0 )                                 \
1472       )
1473
1474 #define MADE_TRIE       1
1475 #define MADE_JUMP_TRIE  2
1476 #define MADE_EXACT_TRIE 4
1477
1478 STATIC I32
1479 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth)
1480 {
1481     dVAR;
1482     /* first pass, loop through and scan words */
1483     reg_trie_data *trie;
1484     HV *widecharmap = NULL;
1485     AV *revcharmap = newAV();
1486     regnode *cur;
1487     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1488     STRLEN len = 0;
1489     UV uvc = 0;
1490     U16 curword = 0;
1491     U32 next_alloc = 0;
1492     regnode *jumper = NULL;
1493     regnode *nextbranch = NULL;
1494     regnode *convert = NULL;
1495     U32 *prev_states; /* temp array mapping each state to previous one */
1496     /* we just use folder as a flag in utf8 */
1497     const U8 * folder = NULL;
1498
1499 #ifdef DEBUGGING
1500     const U32 data_slot = add_data( pRExC_state, 4, "tuuu" );
1501     AV *trie_words = NULL;
1502     /* along with revcharmap, this only used during construction but both are
1503      * useful during debugging so we store them in the struct when debugging.
1504      */
1505 #else
1506     const U32 data_slot = add_data( pRExC_state, 2, "tu" );
1507     STRLEN trie_charcount=0;
1508 #endif
1509     SV *re_trie_maxbuff;
1510     GET_RE_DEBUG_FLAGS_DECL;
1511
1512     PERL_ARGS_ASSERT_MAKE_TRIE;
1513 #ifndef DEBUGGING
1514     PERL_UNUSED_ARG(depth);
1515 #endif
1516
1517     switch (flags) {
1518         case EXACTFA:
1519         case EXACTFU: folder = PL_fold_latin1; break;
1520         case EXACTF:  folder = PL_fold; break;
1521         case EXACTFL: folder = PL_fold_locale; break;
1522     }
1523
1524     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
1525     trie->refcount = 1;
1526     trie->startstate = 1;
1527     trie->wordcount = word_count;
1528     RExC_rxi->data->data[ data_slot ] = (void*)trie;
1529     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
1530     if (!(UTF && folder))
1531         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
1532     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
1533                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
1534
1535     DEBUG_r({
1536         trie_words = newAV();
1537     });
1538
1539     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
1540     if (!SvIOK(re_trie_maxbuff)) {
1541         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
1542     }
1543     DEBUG_OPTIMISE_r({
1544                 PerlIO_printf( Perl_debug_log,
1545                   "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
1546                   (int)depth * 2 + 2, "", 
1547                   REG_NODE_NUM(startbranch),REG_NODE_NUM(first), 
1548                   REG_NODE_NUM(last), REG_NODE_NUM(tail),
1549                   (int)depth);
1550     });
1551    
1552    /* Find the node we are going to overwrite */
1553     if ( first == startbranch && OP( last ) != BRANCH ) {
1554         /* whole branch chain */
1555         convert = first;
1556     } else {
1557         /* branch sub-chain */
1558         convert = NEXTOPER( first );
1559     }
1560         
1561     /*  -- First loop and Setup --
1562
1563        We first traverse the branches and scan each word to determine if it
1564        contains widechars, and how many unique chars there are, this is
1565        important as we have to build a table with at least as many columns as we
1566        have unique chars.
1567
1568        We use an array of integers to represent the character codes 0..255
1569        (trie->charmap) and we use a an HV* to store Unicode characters. We use the
1570        native representation of the character value as the key and IV's for the
1571        coded index.
1572
1573        *TODO* If we keep track of how many times each character is used we can
1574        remap the columns so that the table compression later on is more
1575        efficient in terms of memory by ensuring the most common value is in the
1576        middle and the least common are on the outside.  IMO this would be better
1577        than a most to least common mapping as theres a decent chance the most
1578        common letter will share a node with the least common, meaning the node
1579        will not be compressible. With a middle is most common approach the worst
1580        case is when we have the least common nodes twice.
1581
1582      */
1583
1584     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1585         regnode * const noper = NEXTOPER( cur );
1586         const U8 *uc = (U8*)STRING( noper );
1587         const U8 * const e  = uc + STR_LEN( noper );
1588         STRLEN foldlen = 0;
1589         U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1590         const U8 *scan = (U8*)NULL;
1591         U32 wordlen      = 0;         /* required init */
1592         STRLEN chars = 0;
1593         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the bitmap?*/
1594
1595         if (OP(noper) == NOTHING) {
1596             trie->minlen= 0;
1597             continue;
1598         }
1599         if ( set_bit ) /* bitmap only alloced when !(UTF&&Folding) */
1600             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
1601                                           regardless of encoding */
1602
1603         for ( ; uc < e ; uc += len ) {
1604             TRIE_CHARCOUNT(trie)++;
1605             TRIE_READ_CHAR;
1606             chars++;
1607             if ( uvc < 256 ) {
1608                 if ( !trie->charmap[ uvc ] ) {
1609                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
1610                     if ( folder )
1611                         trie->charmap[ folder[ uvc ] ] = trie->charmap[ uvc ];
1612                     TRIE_STORE_REVCHAR;
1613                 }
1614                 if ( set_bit ) {
1615                     /* store the codepoint in the bitmap, and its folded
1616                      * equivalent. */
1617                     TRIE_BITMAP_SET(trie,uvc);
1618
1619                     /* store the folded codepoint */
1620                     if ( folder ) TRIE_BITMAP_SET(trie,folder[ uvc ]);
1621
1622                     if ( !UTF ) {
1623                         /* store first byte of utf8 representation of
1624                            variant codepoints */
1625                         if (! UNI_IS_INVARIANT(uvc)) {
1626                             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));
1627                         }
1628                     }
1629                     set_bit = 0; /* We've done our bit :-) */
1630                 }
1631             } else {
1632                 SV** svpp;
1633                 if ( !widecharmap )
1634                     widecharmap = newHV();
1635
1636                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
1637
1638                 if ( !svpp )
1639                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
1640
1641                 if ( !SvTRUE( *svpp ) ) {
1642                     sv_setiv( *svpp, ++trie->uniquecharcount );
1643                     TRIE_STORE_REVCHAR;
1644                 }
1645             }
1646         }
1647         if( cur == first ) {
1648             trie->minlen=chars;
1649             trie->maxlen=chars;
1650         } else if (chars < trie->minlen) {
1651             trie->minlen=chars;
1652         } else if (chars > trie->maxlen) {
1653             trie->maxlen=chars;
1654         }
1655
1656     } /* end first pass */
1657     DEBUG_TRIE_COMPILE_r(
1658         PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
1659                 (int)depth * 2 + 2,"",
1660                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
1661                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
1662                 (int)trie->minlen, (int)trie->maxlen )
1663     );
1664
1665     /*
1666         We now know what we are dealing with in terms of unique chars and
1667         string sizes so we can calculate how much memory a naive
1668         representation using a flat table  will take. If it's over a reasonable
1669         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
1670         conservative but potentially much slower representation using an array
1671         of lists.
1672
1673         At the end we convert both representations into the same compressed
1674         form that will be used in regexec.c for matching with. The latter
1675         is a form that cannot be used to construct with but has memory
1676         properties similar to the list form and access properties similar
1677         to the table form making it both suitable for fast searches and
1678         small enough that its feasable to store for the duration of a program.
1679
1680         See the comment in the code where the compressed table is produced
1681         inplace from the flat tabe representation for an explanation of how
1682         the compression works.
1683
1684     */
1685
1686
1687     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
1688     prev_states[1] = 0;
1689
1690     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1) > SvIV(re_trie_maxbuff) ) {
1691         /*
1692             Second Pass -- Array Of Lists Representation
1693
1694             Each state will be represented by a list of charid:state records
1695             (reg_trie_trans_le) the first such element holds the CUR and LEN
1696             points of the allocated array. (See defines above).
1697
1698             We build the initial structure using the lists, and then convert
1699             it into the compressed table form which allows faster lookups
1700             (but cant be modified once converted).
1701         */
1702
1703         STRLEN transcount = 1;
1704
1705         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
1706             "%*sCompiling trie using list compiler\n",
1707             (int)depth * 2 + 2, ""));
1708         
1709         trie->states = (reg_trie_state *)
1710             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1711                                   sizeof(reg_trie_state) );
1712         TRIE_LIST_NEW(1);
1713         next_alloc = 2;
1714
1715         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1716
1717             regnode * const noper = NEXTOPER( cur );
1718             U8 *uc           = (U8*)STRING( noper );
1719             const U8 * const e = uc + STR_LEN( noper );
1720             U32 state        = 1;         /* required init */
1721             U16 charid       = 0;         /* sanity init */
1722             U8 *scan         = (U8*)NULL; /* sanity init */
1723             STRLEN foldlen   = 0;         /* required init */
1724             U32 wordlen      = 0;         /* required init */
1725             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1726
1727             if (OP(noper) != NOTHING) {
1728                 for ( ; uc < e ; uc += len ) {
1729
1730                     TRIE_READ_CHAR;
1731
1732                     if ( uvc < 256 ) {
1733                         charid = trie->charmap[ uvc ];
1734                     } else {
1735                         SV** const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1736                         if ( !svpp ) {
1737                             charid = 0;
1738                         } else {
1739                             charid=(U16)SvIV( *svpp );
1740                         }
1741                     }
1742                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
1743                     if ( charid ) {
1744
1745                         U16 check;
1746                         U32 newstate = 0;
1747
1748                         charid--;
1749                         if ( !trie->states[ state ].trans.list ) {
1750                             TRIE_LIST_NEW( state );
1751                         }
1752                         for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) {
1753                             if ( TRIE_LIST_ITEM( state, check ).forid == charid ) {
1754                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
1755                                 break;
1756                             }
1757                         }
1758                         if ( ! newstate ) {
1759                             newstate = next_alloc++;
1760                             prev_states[newstate] = state;
1761                             TRIE_LIST_PUSH( state, charid, newstate );
1762                             transcount++;
1763                         }
1764                         state = newstate;
1765                     } else {
1766                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1767                     }
1768                 }
1769             }
1770             TRIE_HANDLE_WORD(state);
1771
1772         } /* end second pass */
1773
1774         /* next alloc is the NEXT state to be allocated */
1775         trie->statecount = next_alloc; 
1776         trie->states = (reg_trie_state *)
1777             PerlMemShared_realloc( trie->states,
1778                                    next_alloc
1779                                    * sizeof(reg_trie_state) );
1780
1781         /* and now dump it out before we compress it */
1782         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
1783                                                          revcharmap, next_alloc,
1784                                                          depth+1)
1785         );
1786
1787         trie->trans = (reg_trie_trans *)
1788             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
1789         {
1790             U32 state;
1791             U32 tp = 0;
1792             U32 zp = 0;
1793
1794
1795             for( state=1 ; state < next_alloc ; state ++ ) {
1796                 U32 base=0;
1797
1798                 /*
1799                 DEBUG_TRIE_COMPILE_MORE_r(
1800                     PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
1801                 );
1802                 */
1803
1804                 if (trie->states[state].trans.list) {
1805                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
1806                     U16 maxid=minid;
1807                     U16 idx;
1808
1809                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1810                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
1811                         if ( forid < minid ) {
1812                             minid=forid;
1813                         } else if ( forid > maxid ) {
1814                             maxid=forid;
1815                         }
1816                     }
1817                     if ( transcount < tp + maxid - minid + 1) {
1818                         transcount *= 2;
1819                         trie->trans = (reg_trie_trans *)
1820                             PerlMemShared_realloc( trie->trans,
1821                                                      transcount
1822                                                      * sizeof(reg_trie_trans) );
1823                         Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans );
1824                     }
1825                     base = trie->uniquecharcount + tp - minid;
1826                     if ( maxid == minid ) {
1827                         U32 set = 0;
1828                         for ( ; zp < tp ; zp++ ) {
1829                             if ( ! trie->trans[ zp ].next ) {
1830                                 base = trie->uniquecharcount + zp - minid;
1831                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1832                                 trie->trans[ zp ].check = state;
1833                                 set = 1;
1834                                 break;
1835                             }
1836                         }
1837                         if ( !set ) {
1838                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1839                             trie->trans[ tp ].check = state;
1840                             tp++;
1841                             zp = tp;
1842                         }
1843                     } else {
1844                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1845                             const U32 tid = base -  trie->uniquecharcount + TRIE_LIST_ITEM( state, idx ).forid;
1846                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state, idx ).newstate;
1847                             trie->trans[ tid ].check = state;
1848                         }
1849                         tp += ( maxid - minid + 1 );
1850                     }
1851                     Safefree(trie->states[ state ].trans.list);
1852                 }
1853                 /*
1854                 DEBUG_TRIE_COMPILE_MORE_r(
1855                     PerlIO_printf( Perl_debug_log, " base: %d\n",base);
1856                 );
1857                 */
1858                 trie->states[ state ].trans.base=base;
1859             }
1860             trie->lasttrans = tp + 1;
1861         }
1862     } else {
1863         /*
1864            Second Pass -- Flat Table Representation.
1865
1866            we dont use the 0 slot of either trans[] or states[] so we add 1 to each.
1867            We know that we will need Charcount+1 trans at most to store the data
1868            (one row per char at worst case) So we preallocate both structures
1869            assuming worst case.
1870
1871            We then construct the trie using only the .next slots of the entry
1872            structs.
1873
1874            We use the .check field of the first entry of the node temporarily to
1875            make compression both faster and easier by keeping track of how many non
1876            zero fields are in the node.
1877
1878            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
1879            transition.
1880
1881            There are two terms at use here: state as a TRIE_NODEIDX() which is a
1882            number representing the first entry of the node, and state as a
1883            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1) and
1884            TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3) if there
1885            are 2 entrys per node. eg:
1886
1887              A B       A B
1888           1. 2 4    1. 3 7
1889           2. 0 3    3. 0 5
1890           3. 0 0    5. 0 0
1891           4. 0 0    7. 0 0
1892
1893            The table is internally in the right hand, idx form. However as we also
1894            have to deal with the states array which is indexed by nodenum we have to
1895            use TRIE_NODENUM() to convert.
1896
1897         */
1898         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
1899             "%*sCompiling trie using table compiler\n",
1900             (int)depth * 2 + 2, ""));
1901
1902         trie->trans = (reg_trie_trans *)
1903             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
1904                                   * trie->uniquecharcount + 1,
1905                                   sizeof(reg_trie_trans) );
1906         trie->states = (reg_trie_state *)
1907             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1908                                   sizeof(reg_trie_state) );
1909         next_alloc = trie->uniquecharcount + 1;
1910
1911
1912         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1913
1914             regnode * const noper   = NEXTOPER( cur );
1915             const U8 *uc     = (U8*)STRING( noper );
1916             const U8 * const e = uc + STR_LEN( noper );
1917
1918             U32 state        = 1;         /* required init */
1919
1920             U16 charid       = 0;         /* sanity init */
1921             U32 accept_state = 0;         /* sanity init */
1922             U8 *scan         = (U8*)NULL; /* sanity init */
1923
1924             STRLEN foldlen   = 0;         /* required init */
1925             U32 wordlen      = 0;         /* required init */
1926             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1927
1928             if ( OP(noper) != NOTHING ) {
1929                 for ( ; uc < e ; uc += len ) {
1930
1931                     TRIE_READ_CHAR;
1932
1933                     if ( uvc < 256 ) {
1934                         charid = trie->charmap[ uvc ];
1935                     } else {
1936                         SV* const * const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1937                         charid = svpp ? (U16)SvIV(*svpp) : 0;
1938                     }
1939                     if ( charid ) {
1940                         charid--;
1941                         if ( !trie->trans[ state + charid ].next ) {
1942                             trie->trans[ state + charid ].next = next_alloc;
1943                             trie->trans[ state ].check++;
1944                             prev_states[TRIE_NODENUM(next_alloc)]
1945                                     = TRIE_NODENUM(state);
1946                             next_alloc += trie->uniquecharcount;
1947                         }
1948                         state = trie->trans[ state + charid ].next;
1949                     } else {
1950                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1951                     }
1952                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
1953                 }
1954             }
1955             accept_state = TRIE_NODENUM( state );
1956             TRIE_HANDLE_WORD(accept_state);
1957
1958         } /* end second pass */
1959
1960         /* and now dump it out before we compress it */
1961         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
1962                                                           revcharmap,
1963                                                           next_alloc, depth+1));
1964
1965         {
1966         /*
1967            * Inplace compress the table.*
1968
1969            For sparse data sets the table constructed by the trie algorithm will
1970            be mostly 0/FAIL transitions or to put it another way mostly empty.
1971            (Note that leaf nodes will not contain any transitions.)
1972
1973            This algorithm compresses the tables by eliminating most such
1974            transitions, at the cost of a modest bit of extra work during lookup:
1975
1976            - Each states[] entry contains a .base field which indicates the
1977            index in the state[] array wheres its transition data is stored.
1978
1979            - If .base is 0 there are no valid transitions from that node.
1980
1981            - If .base is nonzero then charid is added to it to find an entry in
1982            the trans array.
1983
1984            -If trans[states[state].base+charid].check!=state then the
1985            transition is taken to be a 0/Fail transition. Thus if there are fail
1986            transitions at the front of the node then the .base offset will point
1987            somewhere inside the previous nodes data (or maybe even into a node
1988            even earlier), but the .check field determines if the transition is
1989            valid.
1990
1991            XXX - wrong maybe?
1992            The following process inplace converts the table to the compressed
1993            table: We first do not compress the root node 1,and mark all its
1994            .check pointers as 1 and set its .base pointer as 1 as well. This
1995            allows us to do a DFA construction from the compressed table later,
1996            and ensures that any .base pointers we calculate later are greater
1997            than 0.
1998
1999            - We set 'pos' to indicate the first entry of the second node.
2000
2001            - We then iterate over the columns of the node, finding the first and
2002            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
2003            and set the .check pointers accordingly, and advance pos
2004            appropriately and repreat for the next node. Note that when we copy
2005            the next pointers we have to convert them from the original
2006            NODEIDX form to NODENUM form as the former is not valid post
2007            compression.
2008
2009            - If a node has no transitions used we mark its base as 0 and do not
2010            advance the pos pointer.
2011
2012            - If a node only has one transition we use a second pointer into the
2013            structure to fill in allocated fail transitions from other states.
2014            This pointer is independent of the main pointer and scans forward
2015            looking for null transitions that are allocated to a state. When it
2016            finds one it writes the single transition into the "hole".  If the
2017            pointer doesnt find one the single transition is appended as normal.
2018
2019            - Once compressed we can Renew/realloc the structures to release the
2020            excess space.
2021
2022            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
2023            specifically Fig 3.47 and the associated pseudocode.
2024
2025            demq
2026         */
2027         const U32 laststate = TRIE_NODENUM( next_alloc );
2028         U32 state, charid;
2029         U32 pos = 0, zp=0;
2030         trie->statecount = laststate;
2031
2032         for ( state = 1 ; state < laststate ; state++ ) {
2033             U8 flag = 0;
2034             const U32 stateidx = TRIE_NODEIDX( state );
2035             const U32 o_used = trie->trans[ stateidx ].check;
2036             U32 used = trie->trans[ stateidx ].check;
2037             trie->trans[ stateidx ].check = 0;
2038
2039             for ( charid = 0 ; used && charid < trie->uniquecharcount ; charid++ ) {
2040                 if ( flag || trie->trans[ stateidx + charid ].next ) {
2041                     if ( trie->trans[ stateidx + charid ].next ) {
2042                         if (o_used == 1) {
2043                             for ( ; zp < pos ; zp++ ) {
2044                                 if ( ! trie->trans[ zp ].next ) {
2045                                     break;
2046                                 }
2047                             }
2048                             trie->states[ state ].trans.base = zp + trie->uniquecharcount - charid ;
2049                             trie->trans[ zp ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2050                             trie->trans[ zp ].check = state;
2051                             if ( ++zp > pos ) pos = zp;
2052                             break;
2053                         }
2054                         used--;
2055                     }
2056                     if ( !flag ) {
2057                         flag = 1;
2058                         trie->states[ state ].trans.base = pos + trie->uniquecharcount - charid ;
2059                     }
2060                     trie->trans[ pos ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2061                     trie->trans[ pos ].check = state;
2062                     pos++;
2063                 }
2064             }
2065         }
2066         trie->lasttrans = pos + 1;
2067         trie->states = (reg_trie_state *)
2068             PerlMemShared_realloc( trie->states, laststate
2069                                    * sizeof(reg_trie_state) );
2070         DEBUG_TRIE_COMPILE_MORE_r(
2071                 PerlIO_printf( Perl_debug_log,
2072                     "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
2073                     (int)depth * 2 + 2,"",
2074                     (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1 ),
2075                     (IV)next_alloc,
2076                     (IV)pos,
2077                     ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
2078             );
2079
2080         } /* end table compress */
2081     }
2082     DEBUG_TRIE_COMPILE_MORE_r(
2083             PerlIO_printf(Perl_debug_log, "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
2084                 (int)depth * 2 + 2, "",
2085                 (UV)trie->statecount,
2086                 (UV)trie->lasttrans)
2087     );
2088     /* resize the trans array to remove unused space */
2089     trie->trans = (reg_trie_trans *)
2090         PerlMemShared_realloc( trie->trans, trie->lasttrans
2091                                * sizeof(reg_trie_trans) );
2092
2093     {   /* Modify the program and insert the new TRIE node */ 
2094         U8 nodetype =(U8)(flags & 0xFF);
2095         char *str=NULL;
2096         
2097 #ifdef DEBUGGING
2098         regnode *optimize = NULL;
2099 #ifdef RE_TRACK_PATTERN_OFFSETS
2100
2101         U32 mjd_offset = 0;
2102         U32 mjd_nodelen = 0;
2103 #endif /* RE_TRACK_PATTERN_OFFSETS */
2104 #endif /* DEBUGGING */
2105         /*
2106            This means we convert either the first branch or the first Exact,
2107            depending on whether the thing following (in 'last') is a branch
2108            or not and whther first is the startbranch (ie is it a sub part of
2109            the alternation or is it the whole thing.)
2110            Assuming its a sub part we convert the EXACT otherwise we convert
2111            the whole branch sequence, including the first.
2112          */
2113         /* Find the node we are going to overwrite */
2114         if ( first != startbranch || OP( last ) == BRANCH ) {
2115             /* branch sub-chain */
2116             NEXT_OFF( first ) = (U16)(last - first);
2117 #ifdef RE_TRACK_PATTERN_OFFSETS
2118             DEBUG_r({
2119                 mjd_offset= Node_Offset((convert));
2120                 mjd_nodelen= Node_Length((convert));
2121             });
2122 #endif
2123             /* whole branch chain */
2124         }
2125 #ifdef RE_TRACK_PATTERN_OFFSETS
2126         else {
2127             DEBUG_r({
2128                 const  regnode *nop = NEXTOPER( convert );
2129                 mjd_offset= Node_Offset((nop));
2130                 mjd_nodelen= Node_Length((nop));
2131             });
2132         }
2133         DEBUG_OPTIMISE_r(
2134             PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
2135                 (int)depth * 2 + 2, "",
2136                 (UV)mjd_offset, (UV)mjd_nodelen)
2137         );
2138 #endif
2139         /* But first we check to see if there is a common prefix we can 
2140            split out as an EXACT and put in front of the TRIE node.  */
2141         trie->startstate= 1;
2142         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
2143             U32 state;
2144             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
2145                 U32 ofs = 0;
2146                 I32 idx = -1;
2147                 U32 count = 0;
2148                 const U32 base = trie->states[ state ].trans.base;
2149
2150                 if ( trie->states[state].wordnum )
2151                         count = 1;
2152
2153                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2154                     if ( ( base + ofs >= trie->uniquecharcount ) &&
2155                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
2156                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
2157                     {
2158                         if ( ++count > 1 ) {
2159                             SV **tmp = av_fetch( revcharmap, ofs, 0);
2160                             const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
2161                             if ( state == 1 ) break;
2162                             if ( count == 2 ) {
2163                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
2164                                 DEBUG_OPTIMISE_r(
2165                                     PerlIO_printf(Perl_debug_log,
2166                                         "%*sNew Start State=%"UVuf" Class: [",
2167                                         (int)depth * 2 + 2, "",
2168                                         (UV)state));
2169                                 if (idx >= 0) {
2170                                     SV ** const tmp = av_fetch( revcharmap, idx, 0);
2171                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
2172
2173                                     TRIE_BITMAP_SET(trie,*ch);
2174                                     if ( folder )
2175                                         TRIE_BITMAP_SET(trie, folder[ *ch ]);
2176                                     DEBUG_OPTIMISE_r(
2177                                         PerlIO_printf(Perl_debug_log, "%s", (char*)ch)
2178                                     );
2179                                 }
2180                             }
2181                             TRIE_BITMAP_SET(trie,*ch);
2182                             if ( folder )
2183                                 TRIE_BITMAP_SET(trie,folder[ *ch ]);
2184                             DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
2185                         }
2186                         idx = ofs;
2187                     }
2188                 }
2189                 if ( count == 1 ) {
2190                     SV **tmp = av_fetch( revcharmap, idx, 0);
2191                     STRLEN len;
2192                     char *ch = SvPV( *tmp, len );
2193                     DEBUG_OPTIMISE_r({
2194                         SV *sv=sv_newmortal();
2195                         PerlIO_printf( Perl_debug_log,
2196                             "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
2197                             (int)depth * 2 + 2, "",
2198                             (UV)state, (UV)idx, 
2199                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6, 
2200                                 PL_colors[0], PL_colors[1],
2201                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2202                                 PERL_PV_ESCAPE_FIRSTCHAR 
2203                             )
2204                         );
2205                     });
2206                     if ( state==1 ) {
2207                         OP( convert ) = nodetype;
2208                         str=STRING(convert);
2209                         STR_LEN(convert)=0;
2210                     }
2211                     STR_LEN(convert) += len;
2212                     while (len--)
2213                         *str++ = *ch++;
2214                 } else {
2215 #ifdef DEBUGGING            
2216                     if (state>1)
2217                         DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
2218 #endif
2219                     break;
2220                 }
2221             }
2222             trie->prefixlen = (state-1);
2223             if (str) {
2224                 regnode *n = convert+NODE_SZ_STR(convert);
2225                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
2226                 trie->startstate = state;
2227                 trie->minlen -= (state - 1);
2228                 trie->maxlen -= (state - 1);
2229 #ifdef DEBUGGING
2230                /* At least the UNICOS C compiler choked on this
2231                 * being argument to DEBUG_r(), so let's just have
2232                 * it right here. */
2233                if (
2234 #ifdef PERL_EXT_RE_BUILD
2235                    1
2236 #else
2237                    DEBUG_r_TEST
2238 #endif
2239                    ) {
2240                    regnode *fix = convert;
2241                    U32 word = trie->wordcount;
2242                    mjd_nodelen++;
2243                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
2244                    while( ++fix < n ) {
2245                        Set_Node_Offset_Length(fix, 0, 0);
2246                    }
2247                    while (word--) {
2248                        SV ** const tmp = av_fetch( trie_words, word, 0 );
2249                        if (tmp) {
2250                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
2251                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
2252                            else
2253                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
2254                        }
2255                    }
2256                }
2257 #endif
2258                 if (trie->maxlen) {
2259                     convert = n;
2260                 } else {
2261                     NEXT_OFF(convert) = (U16)(tail - convert);
2262                     DEBUG_r(optimize= n);
2263                 }
2264             }
2265         }
2266         if (!jumper) 
2267             jumper = last; 
2268         if ( trie->maxlen ) {
2269             NEXT_OFF( convert ) = (U16)(tail - convert);
2270             ARG_SET( convert, data_slot );
2271             /* Store the offset to the first unabsorbed branch in 
2272                jump[0], which is otherwise unused by the jump logic. 
2273                We use this when dumping a trie and during optimisation. */
2274             if (trie->jump) 
2275                 trie->jump[0] = (U16)(nextbranch - convert);
2276             
2277             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
2278              *   and there is a bitmap
2279              *   and the first "jump target" node we found leaves enough room
2280              * then convert the TRIE node into a TRIEC node, with the bitmap
2281              * embedded inline in the opcode - this is hypothetically faster.
2282              */
2283             if ( !trie->states[trie->startstate].wordnum
2284                  && trie->bitmap
2285                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
2286             {
2287                 OP( convert ) = TRIEC;
2288                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
2289                 PerlMemShared_free(trie->bitmap);
2290                 trie->bitmap= NULL;
2291             } else 
2292                 OP( convert ) = TRIE;
2293
2294             /* store the type in the flags */
2295             convert->flags = nodetype;
2296             DEBUG_r({
2297             optimize = convert 
2298                       + NODE_STEP_REGNODE 
2299                       + regarglen[ OP( convert ) ];
2300             });
2301             /* XXX We really should free up the resource in trie now, 
2302                    as we won't use them - (which resources?) dmq */
2303         }
2304         /* needed for dumping*/
2305         DEBUG_r(if (optimize) {
2306             regnode *opt = convert;
2307
2308             while ( ++opt < optimize) {
2309                 Set_Node_Offset_Length(opt,0,0);
2310             }
2311             /* 
2312                 Try to clean up some of the debris left after the 
2313                 optimisation.
2314              */
2315             while( optimize < jumper ) {
2316                 mjd_nodelen += Node_Length((optimize));
2317                 OP( optimize ) = OPTIMIZED;
2318                 Set_Node_Offset_Length(optimize,0,0);
2319                 optimize++;
2320             }
2321             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
2322         });
2323     } /* end node insert */
2324
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 the trie logic handles case insensitive matching properly only
3052     when the pattern is UTF-8 and the node is EXACTFU (thus forcing unicode
3053     semantics).
3054
3055     If/when this is fixed the following define can be swapped
3056     in below to fully enable trie logic.
3057
3058 #define TRIE_TYPE_IS_SAFE 1
3059
3060 */
3061 #define TRIE_TYPE_IS_SAFE ((UTF && optype == EXACTFU) || optype==EXACT)
3062
3063                                 if ( last && TRIE_TYPE_IS_SAFE ) {
3064                                     make_trie( pRExC_state, 
3065                                             startbranch, first, cur, tail, count, 
3066                                             optype, depth+1 );
3067                                 }
3068                                 if ( PL_regkind[ OP( noper ) ] == EXACT
3069 #ifdef NOJUMPTRIE
3070                                      && noper_next == tail
3071 #endif
3072                                 ){
3073                                     count = 1;
3074                                     first = cur;
3075                                     optype = OP( noper );
3076                                 } else {
3077                                     count = 0;
3078                                     first = NULL;
3079                                     optype = 0;
3080                                 }
3081                                 last = NULL;
3082                             }
3083                         }
3084                         DEBUG_OPTIMISE_r({
3085                             regprop(RExC_rx, mysv, cur);
3086                             PerlIO_printf( Perl_debug_log,
3087                               "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
3088                               "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3089
3090                         });
3091                         
3092                         if ( last && TRIE_TYPE_IS_SAFE ) {
3093                             made= make_trie( pRExC_state, startbranch, first, scan, tail, count, optype, depth+1 );
3094 #ifdef TRIE_STUDY_OPT   
3095                             if ( ((made == MADE_EXACT_TRIE && 
3096                                  startbranch == first) 
3097                                  || ( first_non_open == first )) && 
3098                                  depth==0 ) {
3099                                 flags |= SCF_TRIE_RESTUDY;
3100                                 if ( startbranch == first 
3101                                      && scan == tail ) 
3102                                 {
3103                                     RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
3104                                 }
3105                             }
3106 #endif
3107                         }
3108                     }
3109                     
3110                 } /* do trie */
3111                 
3112             }
3113             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
3114                 scan = NEXTOPER(NEXTOPER(scan));
3115             } else                      /* single branch is optimized. */
3116                 scan = NEXTOPER(scan);
3117             continue;
3118         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
3119             scan_frame *newframe = NULL;
3120             I32 paren;
3121             regnode *start;
3122             regnode *end;
3123
3124             if (OP(scan) != SUSPEND) {
3125             /* set the pointer */
3126                 if (OP(scan) == GOSUB) {
3127                     paren = ARG(scan);
3128                     RExC_recurse[ARG2L(scan)] = scan;
3129                     start = RExC_open_parens[paren-1];
3130                     end   = RExC_close_parens[paren-1];
3131                 } else {
3132                     paren = 0;
3133                     start = RExC_rxi->program + 1;
3134                     end   = RExC_opend;
3135                 }
3136                 if (!recursed) {
3137                     Newxz(recursed, (((RExC_npar)>>3) +1), U8);
3138                     SAVEFREEPV(recursed);
3139                 }
3140                 if (!PAREN_TEST(recursed,paren+1)) {
3141                     PAREN_SET(recursed,paren+1);
3142                     Newx(newframe,1,scan_frame);
3143                 } else {
3144                     if (flags & SCF_DO_SUBSTR) {
3145                         SCAN_COMMIT(pRExC_state,data,minlenp);
3146                         data->longest = &(data->longest_float);
3147                     }
3148                     is_inf = is_inf_internal = 1;
3149                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3150                         cl_anything(pRExC_state, data->start_class);
3151                     flags &= ~SCF_DO_STCLASS;
3152                 }
3153             } else {
3154                 Newx(newframe,1,scan_frame);
3155                 paren = stopparen;
3156                 start = scan+2;
3157                 end = regnext(scan);
3158             }
3159             if (newframe) {
3160                 assert(start);
3161                 assert(end);
3162                 SAVEFREEPV(newframe);
3163                 newframe->next = regnext(scan);
3164                 newframe->last = last;
3165                 newframe->stop = stopparen;
3166                 newframe->prev = frame;
3167
3168                 frame = newframe;
3169                 scan =  start;
3170                 stopparen = paren;
3171                 last = end;
3172
3173                 continue;
3174             }
3175         }
3176         else if (OP(scan) == EXACT) {
3177             I32 l = STR_LEN(scan);
3178             UV uc;
3179             if (UTF) {
3180                 const U8 * const s = (U8*)STRING(scan);
3181                 l = utf8_length(s, s + l);
3182                 uc = utf8_to_uvchr(s, NULL);
3183             } else {
3184                 uc = *((U8*)STRING(scan));
3185             }
3186             min += l;
3187             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
3188                 /* The code below prefers earlier match for fixed
3189                    offset, later match for variable offset.  */
3190                 if (data->last_end == -1) { /* Update the start info. */
3191                     data->last_start_min = data->pos_min;
3192                     data->last_start_max = is_inf
3193                         ? I32_MAX : data->pos_min + data->pos_delta;
3194                 }
3195                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
3196                 if (UTF)
3197                     SvUTF8_on(data->last_found);
3198                 {
3199                     SV * const sv = data->last_found;
3200                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3201                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
3202                     if (mg && mg->mg_len >= 0)
3203                         mg->mg_len += utf8_length((U8*)STRING(scan),
3204                                                   (U8*)STRING(scan)+STR_LEN(scan));
3205                 }
3206                 data->last_end = data->pos_min + l;
3207                 data->pos_min += l; /* As in the first entry. */
3208                 data->flags &= ~SF_BEFORE_EOL;
3209             }
3210             if (flags & SCF_DO_STCLASS_AND) {
3211                 /* Check whether it is compatible with what we know already! */
3212                 int compat = 1;
3213
3214
3215                 /* If compatible, we or it in below.  It is compatible if is
3216                  * in the bitmp and either 1) its bit or its fold is set, or 2)
3217                  * it's for a locale.  Even if there isn't unicode semantics
3218                  * here, at runtime there may be because of matching against a
3219                  * utf8 string, so accept a possible false positive for
3220                  * latin1-range folds */
3221                 if (uc >= 0x100 ||
3222                     (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3223                     && !ANYOF_BITMAP_TEST(data->start_class, uc)
3224                     && (!(data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD)
3225                         || !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3226                     )
3227                 {
3228                     compat = 0;
3229                 }
3230                 ANYOF_CLASS_ZERO(data->start_class);
3231                 ANYOF_BITMAP_ZERO(data->start_class);
3232                 if (compat)
3233                     ANYOF_BITMAP_SET(data->start_class, uc);
3234                 else if (uc >= 0x100) {
3235                     int i;
3236
3237                     /* Some Unicode code points fold to the Latin1 range; as
3238                      * XXX temporary code, instead of figuring out if this is
3239                      * one, just assume it is and set all the start class bits
3240                      * that could be some such above 255 code point's fold
3241                      * which will generate fals positives.  As the code
3242                      * elsewhere that does compute the fold settles down, it
3243                      * can be extracted out and re-used here */
3244                     for (i = 0; i < 256; i++){
3245                         if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3246                             ANYOF_BITMAP_SET(data->start_class, i);
3247                         }
3248                     }
3249                 }
3250                 data->start_class->flags &= ~ANYOF_EOS;
3251                 if (uc < 0x100)
3252                   data->start_class->flags &= ~ANYOF_UNICODE_ALL;
3253             }
3254             else if (flags & SCF_DO_STCLASS_OR) {
3255                 /* false positive possible if the class is case-folded */
3256                 if (uc < 0x100)
3257                     ANYOF_BITMAP_SET(data->start_class, uc);
3258                 else
3259                     data->start_class->flags |= ANYOF_UNICODE_ALL;
3260                 data->start_class->flags &= ~ANYOF_EOS;
3261                 cl_and(data->start_class, and_withp);
3262             }
3263             flags &= ~SCF_DO_STCLASS;
3264         }
3265         else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
3266             I32 l = STR_LEN(scan);
3267             UV uc = *((U8*)STRING(scan));
3268
3269             /* Search for fixed substrings supports EXACT only. */
3270             if (flags & SCF_DO_SUBSTR) {
3271                 assert(data);
3272                 SCAN_COMMIT(pRExC_state, data, minlenp);
3273             }
3274             if (UTF) {
3275                 const U8 * const s = (U8 *)STRING(scan);
3276                 l = utf8_length(s, s + l);
3277                 uc = utf8_to_uvchr(s, NULL);
3278             }
3279             min += l;
3280             if (flags & SCF_DO_SUBSTR)
3281                 data->pos_min += l;
3282             if (flags & SCF_DO_STCLASS_AND) {
3283                 /* Check whether it is compatible with what we know already! */
3284                 int compat = 1;
3285                 if (uc >= 0x100 ||
3286                  (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3287                   && !ANYOF_BITMAP_TEST(data->start_class, uc)
3288                   && !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3289                 {
3290                     compat = 0;
3291                 }
3292                 ANYOF_CLASS_ZERO(data->start_class);
3293                 ANYOF_BITMAP_ZERO(data->start_class);
3294                 if (compat) {
3295                     ANYOF_BITMAP_SET(data->start_class, uc);
3296                     data->start_class->flags &= ~ANYOF_EOS;
3297                     data->start_class->flags |= ANYOF_LOC_NONBITMAP_FOLD;
3298                     if (OP(scan) == EXACTFL) {
3299                         /* XXX This set is probably no longer necessary, and
3300                          * probably wrong as LOCALE now is on in the initial
3301                          * state */
3302                         data->start_class->flags |= ANYOF_LOCALE;
3303                     }
3304                     else {
3305
3306                         /* Also set the other member of the fold pair.  In case
3307                          * that unicode semantics is called for at runtime, use
3308                          * the full latin1 fold.  (Can't do this for locale,
3309                          * because not known until runtime */
3310                         ANYOF_BITMAP_SET(data->start_class, PL_fold_latin1[uc]);
3311                     }
3312                 }
3313                 else if (uc >= 0x100) {
3314                     int i;
3315                     for (i = 0; i < 256; i++){
3316                         if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3317                             ANYOF_BITMAP_SET(data->start_class, i);
3318                         }
3319                     }
3320                 }
3321             }
3322             else if (flags & SCF_DO_STCLASS_OR) {
3323                 if (data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD) {
3324                     /* false positive possible if the class is case-folded.
3325                        Assume that the locale settings are the same... */
3326                     if (uc < 0x100) {
3327                         ANYOF_BITMAP_SET(data->start_class, uc);
3328                         if (OP(scan) != EXACTFL) {
3329
3330                             /* And set the other member of the fold pair, but
3331                              * can't do that in locale because not known until
3332                              * run-time */
3333                             ANYOF_BITMAP_SET(data->start_class,
3334                                              PL_fold_latin1[uc]);
3335                         }
3336                     }
3337                     data->start_class->flags &= ~ANYOF_EOS;
3338                 }
3339                 cl_and(data->start_class, and_withp);
3340             }
3341             flags &= ~SCF_DO_STCLASS;
3342         }
3343         else if (REGNODE_VARIES(OP(scan))) {
3344             I32 mincount, maxcount, minnext, deltanext, fl = 0;
3345             I32 f = flags, pos_before = 0;
3346             regnode * const oscan = scan;
3347             struct regnode_charclass_class this_class;
3348             struct regnode_charclass_class *oclass = NULL;
3349             I32 next_is_eval = 0;
3350
3351             switch (PL_regkind[OP(scan)]) {
3352             case WHILEM:                /* End of (?:...)* . */
3353                 scan = NEXTOPER(scan);
3354                 goto finish;
3355             case PLUS:
3356                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
3357                     next = NEXTOPER(scan);
3358                     if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
3359                         mincount = 1;
3360                         maxcount = REG_INFTY;
3361                         next = regnext(scan);
3362                         scan = NEXTOPER(scan);
3363                         goto do_curly;
3364                     }
3365                 }
3366                 if (flags & SCF_DO_SUBSTR)
3367                     data->pos_min++;
3368                 min++;
3369                 /* Fall through. */
3370             case STAR:
3371                 if (flags & SCF_DO_STCLASS) {
3372                     mincount = 0;
3373                     maxcount = REG_INFTY;
3374                     next = regnext(scan);
3375                     scan = NEXTOPER(scan);
3376                     goto do_curly;
3377                 }
3378                 is_inf = is_inf_internal = 1;
3379                 scan = regnext(scan);
3380                 if (flags & SCF_DO_SUBSTR) {
3381                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
3382                     data->longest = &(data->longest_float);
3383                 }
3384                 goto optimize_curly_tail;
3385             case CURLY:
3386                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
3387                     && (scan->flags == stopparen))
3388                 {
3389                     mincount = 1;
3390                     maxcount = 1;
3391                 } else {
3392                     mincount = ARG1(scan);
3393                     maxcount = ARG2(scan);
3394                 }
3395                 next = regnext(scan);
3396                 if (OP(scan) == CURLYX) {
3397                     I32 lp = (data ? *(data->last_closep) : 0);
3398                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
3399                 }
3400                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3401                 next_is_eval = (OP(scan) == EVAL);
3402               do_curly:
3403                 if (flags & SCF_DO_SUBSTR) {
3404                     if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
3405                     pos_before = data->pos_min;
3406                 }
3407                 if (data) {
3408                     fl = data->flags;
3409                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
3410                     if (is_inf)
3411                         data->flags |= SF_IS_INF;
3412                 }
3413                 if (flags & SCF_DO_STCLASS) {
3414                     cl_init(pRExC_state, &this_class);
3415                     oclass = data->start_class;
3416                     data->start_class = &this_class;
3417                     f |= SCF_DO_STCLASS_AND;
3418                     f &= ~SCF_DO_STCLASS_OR;
3419                 }
3420                 /* Exclude from super-linear cache processing any {n,m}
3421                    regops for which the combination of input pos and regex
3422                    pos is not enough information to determine if a match
3423                    will be possible.
3424
3425                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
3426                    regex pos at the \s*, the prospects for a match depend not
3427                    only on the input position but also on how many (bar\s*)
3428                    repeats into the {4,8} we are. */
3429                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
3430                     f &= ~SCF_WHILEM_VISITED_POS;
3431
3432                 /* This will finish on WHILEM, setting scan, or on NULL: */
3433                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, 
3434                                       last, data, stopparen, recursed, NULL,
3435                                       (mincount == 0
3436                                         ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
3437
3438                 if (flags & SCF_DO_STCLASS)
3439                     data->start_class = oclass;
3440                 if (mincount == 0 || minnext == 0) {
3441                     if (flags & SCF_DO_STCLASS_OR) {
3442                         cl_or(pRExC_state, data->start_class, &this_class);
3443                     }
3444                     else if (flags & SCF_DO_STCLASS_AND) {
3445                         /* Switch to OR mode: cache the old value of
3446                          * data->start_class */
3447                         INIT_AND_WITHP;
3448                         StructCopy(data->start_class, and_withp,
3449                                    struct regnode_charclass_class);
3450                         flags &= ~SCF_DO_STCLASS_AND;
3451                         StructCopy(&this_class, data->start_class,
3452                                    struct regnode_charclass_class);
3453                         flags |= SCF_DO_STCLASS_OR;
3454                         data->start_class->flags |= ANYOF_EOS;
3455                     }
3456                 } else {                /* Non-zero len */
3457                     if (flags & SCF_DO_STCLASS_OR) {
3458                         cl_or(pRExC_state, data->start_class, &this_class);
3459                         cl_and(data->start_class, and_withp);
3460                     }
3461                     else if (flags & SCF_DO_STCLASS_AND)
3462                         cl_and(data->start_class, &this_class);
3463                     flags &= ~SCF_DO_STCLASS;
3464                 }
3465                 if (!scan)              /* It was not CURLYX, but CURLY. */
3466                     scan = next;
3467                 if ( /* ? quantifier ok, except for (?{ ... }) */
3468                     (next_is_eval || !(mincount == 0 && maxcount == 1))
3469                     && (minnext == 0) && (deltanext == 0)
3470                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
3471                     && maxcount <= REG_INFTY/3) /* Complement check for big count */
3472                 {
3473                     ckWARNreg(RExC_parse,
3474                               "Quantifier unexpected on zero-length expression");
3475                 }
3476
3477                 min += minnext * mincount;
3478                 is_inf_internal |= ((maxcount == REG_INFTY
3479                                      && (minnext + deltanext) > 0)
3480                                     || deltanext == I32_MAX);
3481                 is_inf |= is_inf_internal;
3482                 delta += (minnext + deltanext) * maxcount - minnext * mincount;
3483
3484                 /* Try powerful optimization CURLYX => CURLYN. */
3485                 if (  OP(oscan) == CURLYX && data
3486                       && data->flags & SF_IN_PAR
3487                       && !(data->flags & SF_HAS_EVAL)
3488                       && !deltanext && minnext == 1 ) {
3489                     /* Try to optimize to CURLYN.  */
3490                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
3491                     regnode * const nxt1 = nxt;
3492 #ifdef DEBUGGING
3493                     regnode *nxt2;
3494 #endif
3495
3496                     /* Skip open. */
3497                     nxt = regnext(nxt);
3498                     if (!REGNODE_SIMPLE(OP(nxt))
3499                         && !(PL_regkind[OP(nxt)] == EXACT
3500                              && STR_LEN(nxt) == 1))
3501                         goto nogo;
3502 #ifdef DEBUGGING
3503                     nxt2 = nxt;
3504 #endif
3505                     nxt = regnext(nxt);
3506                     if (OP(nxt) != CLOSE)
3507                         goto nogo;
3508                     if (RExC_open_parens) {
3509                         RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3510                         RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
3511                     }
3512                     /* Now we know that nxt2 is the only contents: */
3513                     oscan->flags = (U8)ARG(nxt);
3514                     OP(oscan) = CURLYN;
3515                     OP(nxt1) = NOTHING; /* was OPEN. */
3516
3517 #ifdef DEBUGGING
3518                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3519                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
3520                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
3521                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
3522                     OP(nxt + 1) = OPTIMIZED; /* was count. */
3523                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
3524 #endif
3525                 }
3526               nogo:
3527
3528                 /* Try optimization CURLYX => CURLYM. */
3529                 if (  OP(oscan) == CURLYX && data
3530                       && !(data->flags & SF_HAS_PAR)
3531                       && !(data->flags & SF_HAS_EVAL)
3532                       && !deltanext     /* atom is fixed width */
3533                       && minnext != 0   /* CURLYM can't handle zero width */
3534                 ) {
3535                     /* XXXX How to optimize if data == 0? */
3536                     /* Optimize to a simpler form.  */
3537                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
3538                     regnode *nxt2;
3539
3540                     OP(oscan) = CURLYM;
3541                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
3542                             && (OP(nxt2) != WHILEM))
3543                         nxt = nxt2;
3544                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
3545                     /* Need to optimize away parenths. */
3546                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
3547                         /* Set the parenth number.  */
3548                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
3549
3550                         oscan->flags = (U8)ARG(nxt);
3551                         if (RExC_open_parens) {
3552                             RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3553                             RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
3554                         }
3555                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
3556                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
3557
3558 #ifdef DEBUGGING
3559                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3560                         OP(nxt + 1) = OPTIMIZED; /* was count. */
3561                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
3562                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
3563 #endif
3564 #if 0
3565                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
3566                             regnode *nnxt = regnext(nxt1);
3567                             if (nnxt == nxt) {
3568                                 if (reg_off_by_arg[OP(nxt1)])
3569                                     ARG_SET(nxt1, nxt2 - nxt1);
3570                                 else if (nxt2 - nxt1 < U16_MAX)
3571                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
3572                                 else
3573                                     OP(nxt) = NOTHING;  /* Cannot beautify */
3574                             }
3575                             nxt1 = nnxt;
3576                         }
3577 #endif
3578                         /* Optimize again: */
3579                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
3580                                     NULL, stopparen, recursed, NULL, 0,depth+1);
3581                     }
3582                     else
3583                         oscan->flags = 0;
3584                 }
3585                 else if ((OP(oscan) == CURLYX)
3586                          && (flags & SCF_WHILEM_VISITED_POS)
3587                          /* See the comment on a similar expression above.
3588                             However, this time it's not a subexpression
3589                             we care about, but the expression itself. */
3590                          && (maxcount == REG_INFTY)
3591                          && data && ++data->whilem_c < 16) {
3592                     /* This stays as CURLYX, we can put the count/of pair. */
3593                     /* Find WHILEM (as in regexec.c) */
3594                     regnode *nxt = oscan + NEXT_OFF(oscan);
3595
3596                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
3597                         nxt += ARG(nxt);
3598                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
3599                         | (RExC_whilem_seen << 4)); /* On WHILEM */
3600                 }
3601                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
3602                     pars++;
3603                 if (flags & SCF_DO_SUBSTR) {
3604                     SV *last_str = NULL;
3605                     int counted = mincount != 0;
3606
3607                     if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
3608 #if defined(SPARC64_GCC_WORKAROUND)
3609                         I32 b = 0;
3610                         STRLEN l = 0;
3611                         const char *s = NULL;
3612                         I32 old = 0;
3613
3614                         if (pos_before >= data->last_start_min)
3615                             b = pos_before;
3616                         else
3617                             b = data->last_start_min;
3618
3619                         l = 0;
3620                         s = SvPV_const(data->last_found, l);
3621                         old = b - data->last_start_min;
3622
3623 #else
3624                         I32 b = pos_before >= data->last_start_min
3625                             ? pos_before : data->last_start_min;
3626                         STRLEN l;
3627                         const char * const s = SvPV_const(data->last_found, l);
3628                         I32 old = b - data->last_start_min;
3629 #endif
3630
3631                         if (UTF)
3632                             old = utf8_hop((U8*)s, old) - (U8*)s;
3633                         l -= old;
3634                         /* Get the added string: */
3635                         last_str = newSVpvn_utf8(s  + old, l, UTF);
3636                         if (deltanext == 0 && pos_before == b) {
3637                             /* What was added is a constant string */
3638                             if (mincount > 1) {
3639                                 SvGROW(last_str, (mincount * l) + 1);
3640                                 repeatcpy(SvPVX(last_str) + l,
3641                                           SvPVX_const(last_str), l, mincount - 1);
3642                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
3643                                 /* Add additional parts. */
3644                                 SvCUR_set(data->last_found,
3645                                           SvCUR(data->last_found) - l);
3646                                 sv_catsv(data->last_found, last_str);
3647                                 {
3648                                     SV * sv = data->last_found;
3649                                     MAGIC *mg =
3650                                         SvUTF8(sv) && SvMAGICAL(sv) ?
3651                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
3652                                     if (mg && mg->mg_len >= 0)
3653                                         mg->mg_len += CHR_SVLEN(last_str) - l;
3654                                 }
3655                                 data->last_end += l * (mincount - 1);
3656                             }
3657                         } else {
3658                             /* start offset must point into the last copy */
3659                             data->last_start_min += minnext * (mincount - 1);
3660                             data->last_start_max += is_inf ? I32_MAX
3661                                 : (maxcount - 1) * (minnext + data->pos_delta);
3662                         }
3663                     }
3664                     /* It is counted once already... */
3665                     data->pos_min += minnext * (mincount - counted);
3666                     data->pos_delta += - counted * deltanext +
3667                         (minnext + deltanext) * maxcount - minnext * mincount;
3668                     if (mincount != maxcount) {
3669                          /* Cannot extend fixed substrings found inside
3670                             the group.  */
3671                         SCAN_COMMIT(pRExC_state,data,minlenp);
3672                         if (mincount && last_str) {
3673                             SV * const sv = data->last_found;
3674                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3675                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
3676
3677                             if (mg)
3678                                 mg->mg_len = -1;
3679                             sv_setsv(sv, last_str);
3680                             data->last_end = data->pos_min;
3681                             data->last_start_min =
3682                                 data->pos_min - CHR_SVLEN(last_str);
3683                             data->last_start_max = is_inf
3684                                 ? I32_MAX
3685                                 : data->pos_min + data->pos_delta
3686                                 - CHR_SVLEN(last_str);
3687                         }
3688                         data->longest = &(data->longest_float);
3689                     }
3690                     SvREFCNT_dec(last_str);
3691                 }
3692                 if (data && (fl & SF_HAS_EVAL))
3693                     data->flags |= SF_HAS_EVAL;
3694               optimize_curly_tail:
3695                 if (OP(oscan) != CURLYX) {
3696                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
3697                            && NEXT_OFF(next))
3698                         NEXT_OFF(oscan) += NEXT_OFF(next);
3699                 }
3700                 continue;
3701             default:                    /* REF, ANYOFV, and CLUMP only? */
3702                 if (flags & SCF_DO_SUBSTR) {
3703                     SCAN_COMMIT(pRExC_state,data,minlenp);      /* Cannot expect anything... */
3704                     data->longest = &(data->longest_float);
3705                 }
3706                 is_inf = is_inf_internal = 1;
3707                 if (flags & SCF_DO_STCLASS_OR)
3708                     cl_anything(pRExC_state, data->start_class);
3709                 flags &= ~SCF_DO_STCLASS;
3710                 break;
3711             }
3712         }
3713         else if (OP(scan) == LNBREAK) {
3714             if (flags & SCF_DO_STCLASS) {
3715                 int value = 0;
3716                 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
3717                 if (flags & SCF_DO_STCLASS_AND) {
3718                     for (value = 0; value < 256; value++)
3719                         if (!is_VERTWS_cp(value))
3720                             ANYOF_BITMAP_CLEAR(data->start_class, value);
3721                 }
3722                 else {
3723                     for (value = 0; value < 256; value++)
3724                         if (is_VERTWS_cp(value))
3725                             ANYOF_BITMAP_SET(data->start_class, value);
3726                 }
3727                 if (flags & SCF_DO_STCLASS_OR)
3728                     cl_and(data->start_class, and_withp);
3729                 flags &= ~SCF_DO_STCLASS;
3730             }
3731             min += 1;
3732             delta += 1;
3733             if (flags & SCF_DO_SUBSTR) {
3734                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
3735                 data->pos_min += 1;
3736                 data->pos_delta += 1;
3737                 data->longest = &(data->longest_float);
3738             }
3739         }
3740         else if (OP(scan) == FOLDCHAR) {
3741             int d = ARG(scan) == LATIN_SMALL_LETTER_SHARP_S ? 1 : 2;
3742             flags &= ~SCF_DO_STCLASS;
3743             min += 1;
3744             delta += d;
3745             if (flags & SCF_DO_SUBSTR) {
3746                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
3747                 data->pos_min += 1;
3748                 data->pos_delta += d;
3749                 data->longest = &(data->longest_float);
3750             }
3751         }
3752         else if (REGNODE_SIMPLE(OP(scan))) {
3753             int value = 0;
3754
3755             if (flags & SCF_DO_SUBSTR) {
3756                 SCAN_COMMIT(pRExC_state,data,minlenp);
3757                 data->pos_min++;
3758             }
3759             min++;
3760             if (flags & SCF_DO_STCLASS) {
3761                 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
3762
3763                 /* Some of the logic below assumes that switching
3764                    locale on will only add false positives. */
3765                 switch (PL_regkind[OP(scan)]) {
3766                 case SANY:
3767                 default:
3768                   do_default:
3769                     /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
3770                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3771                         cl_anything(pRExC_state, data->start_class);
3772                     break;
3773                 case REG_ANY:
3774                     if (OP(scan) == SANY)
3775                         goto do_default;
3776                     if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
3777                         value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
3778                                  || ANYOF_CLASS_TEST_ANY_SET(data->start_class));
3779                         cl_anything(pRExC_state, data->start_class);
3780                     }
3781                     if (flags & SCF_DO_STCLASS_AND || !value)
3782                         ANYOF_BITMAP_CLEAR(data->start_class,'\n');
3783                     break;
3784                 case ANYOF:
3785                     if (flags & SCF_DO_STCLASS_AND)
3786                         cl_and(data->start_class,
3787                                (struct regnode_charclass_class*)scan);
3788                     else
3789                         cl_or(pRExC_state, data->start_class,
3790                               (struct regnode_charclass_class*)scan);
3791                     break;
3792                 case ALNUM:
3793                     if (flags & SCF_DO_STCLASS_AND) {
3794                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3795                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
3796                             if (OP(scan) == ALNUMU) {
3797                                 for (value = 0; value < 256; value++) {
3798                                     if (!isWORDCHAR_L1(value)) {
3799                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3800                                     }
3801                                 }
3802                             } else {
3803                                 for (value = 0; value < 256; value++) {
3804                                     if (!isALNUM(value)) {
3805                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3806                                     }
3807                                 }
3808                             }
3809                         }
3810                     }
3811                     else {
3812                         if (data->start_class->flags & ANYOF_LOCALE)
3813                             ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
3814
3815                         /* Even if under locale, set the bits for non-locale
3816                          * in case it isn't a true locale-node.  This will
3817                          * create false positives if it truly is locale */
3818                         if (OP(scan) == ALNUMU) {
3819                             for (value = 0; value < 256; value++) {
3820                                 if (isWORDCHAR_L1(value)) {
3821                                     ANYOF_BITMAP_SET(data->start_class, value);
3822                                 }
3823                             }
3824                         } else {
3825                             for (value = 0; value < 256; value++) {
3826                                 if (isALNUM(value)) {
3827                                     ANYOF_BITMAP_SET(data->start_class, value);
3828                                 }
3829                             }
3830                         }
3831                     }
3832                     break;
3833                 case NALNUM:
3834                     if (flags & SCF_DO_STCLASS_AND) {
3835                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3836                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
3837                             if (OP(scan) == NALNUMU) {
3838                                 for (value = 0; value < 256; value++) {
3839                                     if (isWORDCHAR_L1(value)) {
3840                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3841                                     }
3842                                 }
3843                             } else {
3844                                 for (value = 0; value < 256; value++) {
3845                                     if (isALNUM(value)) {
3846                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3847                                     }
3848                                 }
3849                             }
3850                         }
3851                     }
3852                     else {
3853                         if (data->start_class->flags & ANYOF_LOCALE)
3854                             ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
3855
3856                         /* Even if under locale, set the bits for non-locale in
3857                          * case it isn't a true locale-node.  This will create
3858                          * false positives if it truly is locale */
3859                         if (OP(scan) == NALNUMU) {
3860                             for (value = 0; value < 256; value++) {
3861                                 if (! isWORDCHAR_L1(value)) {
3862                                     ANYOF_BITMAP_SET(data->start_class, value);
3863                                 }
3864                             }
3865                         } else {
3866                             for (value = 0; value < 256; value++) {
3867                                 if (! isALNUM(value)) {
3868                                     ANYOF_BITMAP_SET(data->start_class, value);
3869                                 }
3870                             }
3871                         }
3872                     }
3873                     break;
3874                 case SPACE:
3875                     if (flags & SCF_DO_STCLASS_AND) {
3876                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3877                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
3878                             if (OP(scan) == SPACEU) {
3879                                 for (value = 0; value < 256; value++) {
3880                                     if (!isSPACE_L1(value)) {
3881                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3882                                     }
3883                                 }
3884                             } else {
3885                                 for (value = 0; value < 256; value++) {
3886                                     if (!isSPACE(value)) {
3887                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3888                                     }
3889                                 }
3890                             }
3891                         }
3892                     }
3893                     else {
3894                         if (data->start_class->flags & ANYOF_LOCALE) {
3895                             ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
3896                         }
3897                         if (OP(scan) == SPACEU) {
3898                             for (value = 0; value < 256; value++) {
3899                                 if (isSPACE_L1(value)) {
3900                                     ANYOF_BITMAP_SET(data->start_class, value);
3901                                 }
3902                             }
3903                         } else {
3904                             for (value = 0; value < 256; value++) {
3905                                 if (isSPACE(value)) {
3906                                     ANYOF_BITMAP_SET(data->start_class, value);
3907                                 }
3908                             }
3909                         }
3910                     }
3911                     break;
3912                 case NSPACE:
3913                     if (flags & SCF_DO_STCLASS_AND) {
3914                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3915                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
3916                             if (OP(scan) == NSPACEU) {
3917                                 for (value = 0; value < 256; value++) {
3918                                     if (isSPACE_L1(value)) {
3919                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3920                                     }
3921                                 }
3922                             } else {
3923                                 for (value = 0; value < 256; value++) {
3924                                     if (isSPACE(value)) {
3925                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3926                                     }
3927                                 }
3928                             }
3929                         }
3930                     }
3931                     else {
3932                         if (data->start_class->flags & ANYOF_LOCALE)
3933                             ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
3934                         if (OP(scan) == NSPACEU) {
3935                             for (value = 0; value < 256; value++) {
3936                                 if (!isSPACE_L1(value)) {
3937                                     ANYOF_BITMAP_SET(data->start_class, value);
3938                                 }
3939                             }
3940                         }
3941                         else {
3942                             for (value = 0; value < 256; value++) {
3943                                 if (!isSPACE(value)) {
3944                                     ANYOF_BITMAP_SET(data->start_class, value);
3945                                 }
3946                             }
3947                         }
3948                     }
3949                     break;
3950                 case DIGIT:
3951                     if (flags & SCF_DO_STCLASS_AND) {
3952                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3953                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
3954                             for (value = 0; value < 256; value++)
3955                                 if (!isDIGIT(value))
3956                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
3957                         }
3958                     }
3959                     else {
3960                         if (data->start_class->flags & ANYOF_LOCALE)
3961                             ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
3962                         for (value = 0; value < 256; value++)
3963                             if (isDIGIT(value))
3964                                 ANYOF_BITMAP_SET(data->start_class, value);
3965                     }
3966                     break;
3967                 case NDIGIT:
3968                     if (flags & SCF_DO_STCLASS_AND) {
3969                         if (!(data->start_class->flags & ANYOF_LOCALE))
3970                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
3971                         for (value = 0; value < 256; value++)
3972                             if (isDIGIT(value))
3973                                 ANYOF_BITMAP_CLEAR(data->start_class, value);
3974                     }
3975                     else {
3976                         if (data->start_class->flags & ANYOF_LOCALE)
3977                             ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
3978                         for (value = 0; value < 256; value++)
3979                             if (!isDIGIT(value))
3980                                 ANYOF_BITMAP_SET(data->start_class, value);
3981                     }
3982                     break;
3983                 CASE_SYNST_FNC(VERTWS);
3984                 CASE_SYNST_FNC(HORIZWS);
3985                 
3986                 }
3987                 if (flags & SCF_DO_STCLASS_OR)
3988                     cl_and(data->start_class, and_withp);
3989                 flags &= ~SCF_DO_STCLASS;
3990             }
3991         }
3992         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
3993             data->flags |= (OP(scan) == MEOL
3994                             ? SF_BEFORE_MEOL
3995                             : SF_BEFORE_SEOL);
3996         }
3997         else if (  PL_regkind[OP(scan)] == BRANCHJ
3998                  /* Lookbehind, or need to calculate parens/evals/stclass: */
3999                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
4000                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
4001             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY 
4002                 || OP(scan) == UNLESSM )
4003             {
4004                 /* Negative Lookahead/lookbehind
4005                    In this case we can't do fixed string optimisation.
4006                 */
4007
4008                 I32 deltanext, minnext, fake = 0;
4009                 regnode *nscan;
4010                 struct regnode_charclass_class intrnl;
4011                 int f = 0;
4012
4013                 data_fake.flags = 0;
4014                 if (data) {
4015                     data_fake.whilem_c = data->whilem_c;
4016                     data_fake.last_closep = data->last_closep;
4017                 }
4018                 else
4019                     data_fake.last_closep = &fake;
4020                 data_fake.pos_delta = delta;
4021                 if ( flags & SCF_DO_STCLASS && !scan->flags
4022                      && OP(scan) == IFMATCH ) { /* Lookahead */
4023                     cl_init(pRExC_state, &intrnl);
4024                     data_fake.start_class = &intrnl;
4025                     f |= SCF_DO_STCLASS_AND;
4026                 }
4027                 if (flags & SCF_WHILEM_VISITED_POS)
4028                     f |= SCF_WHILEM_VISITED_POS;
4029                 next = regnext(scan);
4030                 nscan = NEXTOPER(NEXTOPER(scan));
4031                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext, 
4032                     last, &data_fake, stopparen, recursed, NULL, f, depth+1);
4033                 if (scan->flags) {
4034                     if (deltanext) {
4035                         FAIL("Variable length lookbehind not implemented");
4036                     }
4037                     else if (minnext > (I32)U8_MAX) {
4038                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4039                     }
4040                     scan->flags = (U8)minnext;
4041                 }
4042                 if (data) {
4043                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4044                         pars++;
4045                     if (data_fake.flags & SF_HAS_EVAL)
4046                         data->flags |= SF_HAS_EVAL;
4047                     data->whilem_c = data_fake.whilem_c;
4048                 }
4049                 if (f & SCF_DO_STCLASS_AND) {
4050                     if (flags & SCF_DO_STCLASS_OR) {
4051                         /* OR before, AND after: ideally we would recurse with
4052                          * data_fake to get the AND applied by study of the
4053                          * remainder of the pattern, and then derecurse;
4054                          * *** HACK *** for now just treat as "no information".
4055                          * See [perl #56690].
4056                          */
4057                         cl_init(pRExC_state, data->start_class);
4058                     }  else {
4059                         /* AND before and after: combine and continue */
4060                         const int was = (data->start_class->flags & ANYOF_EOS);
4061
4062                         cl_and(data->start_class, &intrnl);
4063                         if (was)
4064                             data->start_class->flags |= ANYOF_EOS;
4065                     }
4066                 }
4067             }
4068 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
4069             else {
4070                 /* Positive Lookahead/lookbehind
4071                    In this case we can do fixed string optimisation,
4072                    but we must be careful about it. Note in the case of
4073                    lookbehind the positions will be offset by the minimum
4074                    length of the pattern, something we won't know about
4075                    until after the recurse.
4076                 */
4077                 I32 deltanext, fake = 0;
4078                 regnode *nscan;
4079                 struct regnode_charclass_class intrnl;
4080                 int f = 0;
4081                 /* We use SAVEFREEPV so that when the full compile 
4082                     is finished perl will clean up the allocated 
4083                     minlens when it's all done. This way we don't
4084                     have to worry about freeing them when we know
4085                     they wont be used, which would be a pain.
4086                  */
4087                 I32 *minnextp;
4088                 Newx( minnextp, 1, I32 );
4089                 SAVEFREEPV(minnextp);
4090
4091                 if (data) {
4092                     StructCopy(data, &data_fake, scan_data_t);
4093                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
4094                         f |= SCF_DO_SUBSTR;
4095                         if (scan->flags) 
4096                             SCAN_COMMIT(pRExC_state, &data_fake,minlenp);
4097                         data_fake.last_found=newSVsv(data->last_found);
4098                     }
4099                 }
4100                 else
4101                     data_fake.last_closep = &fake;
4102                 data_fake.flags = 0;
4103                 data_fake.pos_delta = delta;
4104                 if (is_inf)
4105                     data_fake.flags |= SF_IS_INF;
4106                 if ( flags & SCF_DO_STCLASS && !scan->flags
4107                      && OP(scan) == IFMATCH ) { /* Lookahead */
4108                     cl_init(pRExC_state, &intrnl);
4109                     data_fake.start_class = &intrnl;
4110                     f |= SCF_DO_STCLASS_AND;
4111                 }
4112                 if (flags & SCF_WHILEM_VISITED_POS)
4113                     f |= SCF_WHILEM_VISITED_POS;
4114                 next = regnext(scan);
4115                 nscan = NEXTOPER(NEXTOPER(scan));
4116
4117                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext, 
4118                     last, &data_fake, stopparen, recursed, NULL, f,depth+1);
4119                 if (scan->flags) {
4120                     if (deltanext) {
4121                         FAIL("Variable length lookbehind not implemented");
4122                     }
4123                     else if (*minnextp > (I32)U8_MAX) {
4124                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4125                     }
4126                     scan->flags = (U8)*minnextp;
4127                 }
4128
4129                 *minnextp += min;
4130
4131                 if (f & SCF_DO_STCLASS_AND) {
4132                     const int was = (data->start_class->flags & ANYOF_EOS);
4133
4134                     cl_and(data->start_class, &intrnl);
4135                     if (was)
4136                         data->start_class->flags |= ANYOF_EOS;
4137                 }
4138                 if (data) {
4139                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4140                         pars++;
4141                     if (data_fake.flags & SF_HAS_EVAL)
4142                         data->flags |= SF_HAS_EVAL;
4143                     data->whilem_c = data_fake.whilem_c;
4144                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
4145                         if (RExC_rx->minlen<*minnextp)
4146                             RExC_rx->minlen=*minnextp;
4147                         SCAN_COMMIT(pRExC_state, &data_fake, minnextp);
4148                         SvREFCNT_dec(data_fake.last_found);
4149                         
4150                         if ( data_fake.minlen_fixed != minlenp ) 
4151                         {
4152                             data->offset_fixed= data_fake.offset_fixed;
4153                             data->minlen_fixed= data_fake.minlen_fixed;
4154                             data->lookbehind_fixed+= scan->flags;
4155                         }
4156                         if ( data_fake.minlen_float != minlenp )
4157                         {
4158                             data->minlen_float= data_fake.minlen_float;
4159                             data->offset_float_min=data_fake.offset_float_min;
4160                             data->offset_float_max=data_fake.offset_float_max;
4161                             data->lookbehind_float+= scan->flags;
4162                         }
4163                     }
4164                 }
4165
4166
4167             }
4168 #endif
4169         }
4170         else if (OP(scan) == OPEN) {
4171             if (stopparen != (I32)ARG(scan))
4172                 pars++;
4173         }
4174         else if (OP(scan) == CLOSE) {
4175             if (stopparen == (I32)ARG(scan)) {
4176                 break;
4177             }
4178             if ((I32)ARG(scan) == is_par) {
4179                 next = regnext(scan);
4180
4181                 if ( next && (OP(next) != WHILEM) && next < last)
4182                     is_par = 0;         /* Disable optimization */
4183             }
4184             if (data)
4185                 *(data->last_closep) = ARG(scan);
4186         }
4187         else if (OP(scan) == EVAL) {
4188                 if (data)
4189                     data->flags |= SF_HAS_EVAL;
4190         }
4191         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
4192             if (flags & SCF_DO_SUBSTR) {
4193                 SCAN_COMMIT(pRExC_state,data,minlenp);
4194                 flags &= ~SCF_DO_SUBSTR;
4195             }
4196             if (data && OP(scan)==ACCEPT) {
4197                 data->flags |= SCF_SEEN_ACCEPT;
4198                 if (stopmin > min)
4199                     stopmin = min;
4200             }
4201         }
4202         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
4203         {
4204                 if (flags & SCF_DO_SUBSTR) {
4205                     SCAN_COMMIT(pRExC_state,data,minlenp);
4206                     data->longest = &(data->longest_float);
4207                 }
4208                 is_inf = is_inf_internal = 1;
4209                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4210                     cl_anything(pRExC_state, data->start_class);
4211                 flags &= ~SCF_DO_STCLASS;
4212         }
4213         else if (OP(scan) == GPOS) {
4214             if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) &&
4215                 !(delta || is_inf || (data && data->pos_delta))) 
4216             {
4217                 if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR))
4218                     RExC_rx->extflags |= RXf_ANCH_GPOS;
4219                 if (RExC_rx->gofs < (U32)min)
4220                     RExC_rx->gofs = min;
4221             } else {
4222                 RExC_rx->extflags |= RXf_GPOS_FLOAT;
4223                 RExC_rx->gofs = 0;
4224             }       
4225         }
4226 #ifdef TRIE_STUDY_OPT
4227 #ifdef FULL_TRIE_STUDY
4228         else if (PL_regkind[OP(scan)] == TRIE) {
4229             /* NOTE - There is similar code to this block above for handling
4230                BRANCH nodes on the initial study.  If you change stuff here
4231                check there too. */
4232             regnode *trie_node= scan;
4233             regnode *tail= regnext(scan);
4234             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4235             I32 max1 = 0, min1 = I32_MAX;
4236             struct regnode_charclass_class accum;
4237
4238             if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
4239                 SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
4240             if (flags & SCF_DO_STCLASS)
4241                 cl_init_zero(pRExC_state, &accum);
4242                 
4243             if (!trie->jump) {
4244                 min1= trie->minlen;
4245                 max1= trie->maxlen;
4246             } else {
4247                 const regnode *nextbranch= NULL;
4248                 U32 word;
4249                 
4250                 for ( word=1 ; word <= trie->wordcount ; word++) 
4251                 {
4252                     I32 deltanext=0, minnext=0, f = 0, fake;
4253                     struct regnode_charclass_class this_class;
4254                     
4255                     data_fake.flags = 0;
4256                     if (data) {
4257                         data_fake.whilem_c = data->whilem_c;
4258                         data_fake.last_closep = data->last_closep;
4259                     }
4260                     else
4261                         data_fake.last_closep = &fake;
4262                     data_fake.pos_delta = delta;
4263                     if (flags & SCF_DO_STCLASS) {
4264                         cl_init(pRExC_state, &this_class);
4265                         data_fake.start_class = &this_class;
4266                         f = SCF_DO_STCLASS_AND;
4267                     }
4268                     if (flags & SCF_WHILEM_VISITED_POS)
4269                         f |= SCF_WHILEM_VISITED_POS;
4270     
4271                     if (trie->jump[word]) {
4272                         if (!nextbranch)
4273                             nextbranch = trie_node + trie->jump[0];
4274                         scan= trie_node + trie->jump[word];
4275                         /* We go from the jump point to the branch that follows
4276                            it. Note this means we need the vestigal unused branches
4277                            even though they arent otherwise used.
4278                          */
4279                         minnext = study_chunk(pRExC_state, &scan, minlenp, 
4280                             &deltanext, (regnode *)nextbranch, &data_fake, 
4281                             stopparen, recursed, NULL, f,depth+1);
4282                     }
4283                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
4284                         nextbranch= regnext((regnode*)nextbranch);
4285                     
4286                     if (min1 > (I32)(minnext + trie->minlen))
4287                         min1 = minnext + trie->minlen;
4288                     if (max1 < (I32)(minnext + deltanext + trie->maxlen))
4289                         max1 = minnext + deltanext + trie->maxlen;
4290                     if (deltanext == I32_MAX)
4291                         is_inf = is_inf_internal = 1;
4292                     
4293                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4294                         pars++;
4295                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4296                         if ( stopmin > min + min1) 
4297                             stopmin = min + min1;
4298                         flags &= ~SCF_DO_SUBSTR;
4299                         if (data)
4300                             data->flags |= SCF_SEEN_ACCEPT;
4301                     }
4302                     if (data) {
4303                         if (data_fake.flags & SF_HAS_EVAL)
4304                             data->flags |= SF_HAS_EVAL;
4305                         data->whilem_c = data_fake.whilem_c;
4306                     }
4307                     if (flags & SCF_DO_STCLASS)
4308                         cl_or(pRExC_state, &accum, &this_class);
4309                 }
4310             }
4311             if (flags & SCF_DO_SUBSTR) {
4312                 data->pos_min += min1;
4313                 data->pos_delta += max1 - min1;
4314                 if (max1 != min1 || is_inf)
4315                     data->longest = &(data->longest_float);
4316             }
4317             min += min1;
4318             delta += max1 - min1;
4319             if (flags & SCF_DO_STCLASS_OR) {
4320                 cl_or(pRExC_state, data->start_class, &accum);
4321                 if (min1) {
4322                     cl_and(data->start_class, and_withp);
4323                     flags &= ~SCF_DO_STCLASS;
4324                 }
4325             }
4326             else if (flags & SCF_DO_STCLASS_AND) {
4327                 if (min1) {
4328                     cl_and(data->start_class, &accum);
4329                     flags &= ~SCF_DO_STCLASS;
4330                 }
4331                 else {
4332                     /* Switch to OR mode: cache the old value of
4333                      * data->start_class */
4334                     INIT_AND_WITHP;
4335                     StructCopy(data->start_class, and_withp,
4336                                struct regnode_charclass_class);
4337                     flags &= ~SCF_DO_STCLASS_AND;
4338                     StructCopy(&accum, data->start_class,
4339                                struct regnode_charclass_class);
4340                     flags |= SCF_DO_STCLASS_OR;
4341                     data->start_class->flags |= ANYOF_EOS;
4342                 }
4343             }
4344             scan= tail;
4345             continue;
4346         }
4347 #else
4348         else if (PL_regkind[OP(scan)] == TRIE) {
4349             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4350             U8*bang=NULL;
4351             
4352             min += trie->minlen;
4353             delta += (trie->maxlen - trie->minlen);
4354             flags &= ~SCF_DO_STCLASS; /* xxx */
4355             if (flags & SCF_DO_SUBSTR) {
4356                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
4357                 data->pos_min += trie->minlen;
4358                 data->pos_delta += (trie->maxlen - trie->minlen);
4359                 if (trie->maxlen != trie->minlen)
4360                     data->longest = &(data->longest_float);
4361             }
4362             if (trie->jump) /* no more substrings -- for now /grr*/
4363                 flags &= ~SCF_DO_SUBSTR; 
4364         }
4365 #endif /* old or new */
4366 #endif /* TRIE_STUDY_OPT */     
4367
4368         /* Else: zero-length, ignore. */
4369         scan = regnext(scan);
4370     }
4371     if (frame) {
4372         last = frame->last;
4373         scan = frame->next;
4374         stopparen = frame->stop;
4375         frame = frame->prev;
4376         goto fake_study_recurse;
4377     }
4378
4379   finish:
4380     assert(!frame);
4381     DEBUG_STUDYDATA("pre-fin:",data,depth);
4382
4383     *scanp = scan;
4384     *deltap = is_inf_internal ? I32_MAX : delta;
4385     if (flags & SCF_DO_SUBSTR && is_inf)
4386         data->pos_delta = I32_MAX - data->pos_min;
4387     if (is_par > (I32)U8_MAX)
4388         is_par = 0;
4389     if (is_par && pars==1 && data) {
4390         data->flags |= SF_IN_PAR;
4391         data->flags &= ~SF_HAS_PAR;
4392     }
4393     else if (pars && data) {
4394         data->flags |= SF_HAS_PAR;
4395         data->flags &= ~SF_IN_PAR;
4396     }
4397     if (flags & SCF_DO_STCLASS_OR)
4398         cl_and(data->start_class, and_withp);
4399     if (flags & SCF_TRIE_RESTUDY)
4400         data->flags |=  SCF_TRIE_RESTUDY;
4401     
4402     DEBUG_STUDYDATA("post-fin:",data,depth);
4403     
4404     return min < stopmin ? min : stopmin;
4405 }
4406
4407 STATIC U32
4408 S_add_data(RExC_state_t *pRExC_state, U32 n, const char *s)
4409 {
4410     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
4411
4412     PERL_ARGS_ASSERT_ADD_DATA;
4413
4414     Renewc(RExC_rxi->data,
4415            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
4416            char, struct reg_data);
4417     if(count)
4418         Renew(RExC_rxi->data->what, count + n, U8);
4419     else
4420         Newx(RExC_rxi->data->what, n, U8);
4421     RExC_rxi->data->count = count + n;
4422     Copy(s, RExC_rxi->data->what + count, n, U8);
4423     return count;
4424 }
4425
4426 /*XXX: todo make this not included in a non debugging perl */
4427 #ifndef PERL_IN_XSUB_RE
4428 void
4429 Perl_reginitcolors(pTHX)
4430 {
4431     dVAR;
4432     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
4433     if (s) {
4434         char *t = savepv(s);
4435         int i = 0;
4436         PL_colors[0] = t;
4437         while (++i < 6) {
4438             t = strchr(t, '\t');
4439             if (t) {
4440                 *t = '\0';
4441                 PL_colors[i] = ++t;
4442             }
4443             else
4444                 PL_colors[i] = t = (char *)"";
4445         }
4446     } else {
4447         int i = 0;
4448         while (i < 6)
4449             PL_colors[i++] = (char *)"";
4450     }
4451     PL_colorset = 1;
4452 }
4453 #endif
4454
4455
4456 #ifdef TRIE_STUDY_OPT
4457 #define CHECK_RESTUDY_GOTO                                  \
4458         if (                                                \
4459               (data.flags & SCF_TRIE_RESTUDY)               \
4460               && ! restudied++                              \
4461         )     goto reStudy
4462 #else
4463 #define CHECK_RESTUDY_GOTO
4464 #endif        
4465
4466 /*
4467  - pregcomp - compile a regular expression into internal code
4468  *
4469  * We can't allocate space until we know how big the compiled form will be,
4470  * but we can't compile it (and thus know how big it is) until we've got a
4471  * place to put the code.  So we cheat:  we compile it twice, once with code
4472  * generation turned off and size counting turned on, and once "for real".
4473  * This also means that we don't allocate space until we are sure that the
4474  * thing really will compile successfully, and we never have to move the
4475  * code and thus invalidate pointers into it.  (Note that it has to be in
4476  * one piece because free() must be able to free it all.) [NB: not true in perl]
4477  *
4478  * Beware that the optimization-preparation code in here knows about some
4479  * of the structure of the compiled regexp.  [I'll say.]
4480  */
4481
4482
4483
4484 #ifndef PERL_IN_XSUB_RE
4485 #define RE_ENGINE_PTR &PL_core_reg_engine
4486 #else
4487 extern const struct regexp_engine my_reg_engine;
4488 #define RE_ENGINE_PTR &my_reg_engine
4489 #endif
4490
4491 #ifndef PERL_IN_XSUB_RE 
4492 REGEXP *
4493 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
4494 {
4495     dVAR;
4496     HV * const table = GvHV(PL_hintgv);
4497
4498     PERL_ARGS_ASSERT_PREGCOMP;
4499
4500     /* Dispatch a request to compile a regexp to correct 
4501        regexp engine. */
4502     if (table) {
4503         SV **ptr= hv_fetchs(table, "regcomp", FALSE);
4504         GET_RE_DEBUG_FLAGS_DECL;
4505         if (ptr && SvIOK(*ptr) && SvIV(*ptr)) {
4506             const regexp_engine *eng=INT2PTR(regexp_engine*,SvIV(*ptr));
4507             DEBUG_COMPILE_r({
4508                 PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
4509                     SvIV(*ptr));
4510             });            
4511             return CALLREGCOMP_ENG(eng, pattern, flags);
4512         } 
4513     }
4514     return Perl_re_compile(aTHX_ pattern, flags);
4515 }
4516 #endif
4517
4518 REGEXP *
4519 Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags)
4520 {
4521     dVAR;
4522     REGEXP *rx;
4523     struct regexp *r;
4524     register regexp_internal *ri;
4525     STRLEN plen;
4526     char  *exp;
4527     char* xend;
4528     regnode *scan;
4529     I32 flags;
4530     I32 minlen = 0;
4531     U32 pm_flags;
4532
4533     /* these are all flags - maybe they should be turned
4534      * into a single int with different bit masks */
4535     I32 sawlookahead = 0;
4536     I32 sawplus = 0;
4537     I32 sawopen = 0;
4538     bool used_setjump = FALSE;
4539     regex_charset initial_charset = get_regex_charset(orig_pm_flags);
4540
4541     U8 jump_ret = 0;
4542     dJMPENV;
4543     scan_data_t data;
4544     RExC_state_t RExC_state;
4545     RExC_state_t * const pRExC_state = &RExC_state;
4546 #ifdef TRIE_STUDY_OPT    
4547     int restudied;
4548     RExC_state_t copyRExC_state;
4549 #endif    
4550     GET_RE_DEBUG_FLAGS_DECL;
4551
4552     PERL_ARGS_ASSERT_RE_COMPILE;
4553
4554     DEBUG_r(if (!PL_colorset) reginitcolors());
4555
4556     RExC_utf8 = RExC_orig_utf8 = SvUTF8(pattern);
4557     RExC_uni_semantics = 0;
4558     RExC_contains_locale = 0;
4559
4560     /****************** LONG JUMP TARGET HERE***********************/
4561     /* Longjmp back to here if have to switch in midstream to utf8 */
4562     if (! RExC_orig_utf8) {
4563         JMPENV_PUSH(jump_ret);
4564         used_setjump = TRUE;
4565     }
4566
4567     if (jump_ret == 0) {    /* First time through */
4568         exp = SvPV(pattern, plen);
4569         xend = exp + plen;
4570         /* ignore the utf8ness if the pattern is 0 length */
4571         if (plen == 0) {
4572             RExC_utf8 = RExC_orig_utf8 = 0;
4573         }
4574
4575         DEBUG_COMPILE_r({
4576             SV *dsv= sv_newmortal();
4577             RE_PV_QUOTED_DECL(s, RExC_utf8,
4578                 dsv, exp, plen, 60);
4579             PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
4580                            PL_colors[4],PL_colors[5],s);
4581         });
4582     }
4583     else {  /* longjumped back */
4584         STRLEN len = plen;
4585
4586         /* If the cause for the longjmp was other than changing to utf8, pop
4587          * our own setjmp, and longjmp to the correct handler */
4588         if (jump_ret != UTF8_LONGJMP) {
4589             JMPENV_POP;
4590             JMPENV_JUMP(jump_ret);
4591         }
4592
4593         GET_RE_DEBUG_FLAGS;
4594
4595         /* It's possible to write a regexp in ascii that represents Unicode
4596         codepoints outside of the byte range, such as via \x{100}. If we
4597         detect such a sequence we have to convert the entire pattern to utf8
4598         and then recompile, as our sizing calculation will have been based
4599         on 1 byte == 1 character, but we will need to use utf8 to encode
4600         at least some part of the pattern, and therefore must convert the whole
4601         thing.
4602         -- dmq */
4603         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
4604             "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
4605         exp = (char*)Perl_bytes_to_utf8(aTHX_ (U8*)SvPV(pattern, plen), &len);
4606         xend = exp + len;
4607         RExC_orig_utf8 = RExC_utf8 = 1;
4608         SAVEFREEPV(exp);
4609     }
4610
4611 #ifdef TRIE_STUDY_OPT
4612     restudied = 0;
4613 #endif
4614
4615     pm_flags = orig_pm_flags;
4616
4617     if (initial_charset == REGEX_LOCALE_CHARSET) {
4618         RExC_contains_locale = 1;
4619     }
4620     else if (RExC_utf8 && initial_charset == REGEX_DEPENDS_CHARSET) {
4621
4622         /* Set to use unicode semantics if the pattern is in utf8 and has the
4623          * 'depends' charset specified, as it means unicode when utf8  */
4624         set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
4625     }
4626
4627     RExC_precomp = exp;
4628     RExC_flags = pm_flags;
4629     RExC_sawback = 0;
4630
4631     RExC_seen = 0;
4632     RExC_in_lookbehind = 0;
4633     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
4634     RExC_seen_evals = 0;
4635     RExC_extralen = 0;
4636     RExC_override_recoding = 0;
4637
4638     /* First pass: determine size, legality. */
4639     RExC_parse = exp;
4640     RExC_start = exp;
4641     RExC_end = xend;
4642     RExC_naughty = 0;
4643     RExC_npar = 1;
4644     RExC_nestroot = 0;
4645     RExC_size = 0L;
4646     RExC_emit = &PL_regdummy;
4647     RExC_whilem_seen = 0;
4648     RExC_open_parens = NULL;
4649     RExC_close_parens = NULL;
4650     RExC_opend = NULL;
4651     RExC_paren_names = NULL;
4652 #ifdef DEBUGGING
4653     RExC_paren_name_list = NULL;
4654 #endif
4655     RExC_recurse = NULL;
4656     RExC_recurse_count = 0;
4657
4658 #if 0 /* REGC() is (currently) a NOP at the first pass.
4659        * Clever compilers notice this and complain. --jhi */
4660     REGC((U8)REG_MAGIC, (char*)RExC_emit);
4661 #endif
4662     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n"));
4663     if (reg(pRExC_state, 0, &flags,1) == NULL) {
4664         RExC_precomp = NULL;
4665         return(NULL);
4666     }
4667
4668     /* Here, finished first pass.  Get rid of any added setjmp */
4669     if (used_setjump) {
4670         JMPENV_POP;
4671     }
4672
4673     DEBUG_PARSE_r({
4674         PerlIO_printf(Perl_debug_log, 
4675             "Required size %"IVdf" nodes\n"
4676             "Starting second pass (creation)\n", 
4677             (IV)RExC_size);
4678         RExC_lastnum=0; 
4679         RExC_lastparse=NULL; 
4680     });
4681
4682     /* The first pass could have found things that force Unicode semantics */
4683     if ((RExC_utf8 || RExC_uni_semantics)
4684          && get_regex_charset(pm_flags) == REGEX_DEPENDS_CHARSET)
4685     {
4686         set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
4687     }
4688
4689     /* Small enough for pointer-storage convention?
4690        If extralen==0, this means that we will not need long jumps. */
4691     if (RExC_size >= 0x10000L && RExC_extralen)
4692         RExC_size += RExC_extralen;
4693     else
4694         RExC_extralen = 0;
4695     if (RExC_whilem_seen > 15)
4696         RExC_whilem_seen = 15;
4697
4698     /* Allocate space and zero-initialize. Note, the two step process 
4699        of zeroing when in debug mode, thus anything assigned has to 
4700        happen after that */
4701     rx = (REGEXP*) newSV_type(SVt_REGEXP);
4702     r = (struct regexp*)SvANY(rx);
4703     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
4704          char, regexp_internal);
4705     if ( r == NULL || ri == NULL )
4706         FAIL("Regexp out of space");
4707 #ifdef DEBUGGING
4708     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
4709     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char);
4710 #else 
4711     /* bulk initialize base fields with 0. */
4712     Zero(ri, sizeof(regexp_internal), char);        
4713 #endif
4714
4715     /* non-zero initialization begins here */
4716     RXi_SET( r, ri );
4717     r->engine= RE_ENGINE_PTR;
4718     r->extflags = pm_flags;
4719     {
4720         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
4721         bool has_charset = (get_regex_charset(r->extflags) != REGEX_DEPENDS_CHARSET);
4722
4723         /* The caret is output if there are any defaults: if not all the STD
4724          * flags are set, or if no character set specifier is needed */
4725         bool has_default =
4726                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
4727                     || ! has_charset);
4728         bool has_runon = ((RExC_seen & REG_SEEN_RUN_ON_COMMENT)==REG_SEEN_RUN_ON_COMMENT);
4729         U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD)
4730                             >> RXf_PMf_STD_PMMOD_SHIFT);
4731         const char *fptr = STD_PAT_MODS;        /*"msix"*/
4732         char *p;
4733         /* Allocate for the worst case, which is all the std flags are turned
4734          * on.  If more precision is desired, we could do a population count of
4735          * the flags set.  This could be done with a small lookup table, or by
4736          * shifting, masking and adding, or even, when available, assembly
4737          * language for a machine-language population count.
4738          * We never output a minus, as all those are defaults, so are
4739          * covered by the caret */
4740         const STRLEN wraplen = plen + has_p + has_runon
4741             + has_default       /* If needs a caret */
4742
4743                 /* If needs a character set specifier */
4744             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
4745             + (sizeof(STD_PAT_MODS) - 1)
4746             + (sizeof("(?:)") - 1);
4747
4748         p = sv_grow(MUTABLE_SV(rx), wraplen + 1); /* +1 for the ending NUL */
4749         SvPOK_on(rx);
4750         SvFLAGS(rx) |= SvUTF8(pattern);
4751         *p++='('; *p++='?';
4752
4753         /* If a default, cover it using the caret */
4754         if (has_default) {
4755             *p++= DEFAULT_PAT_MOD;
4756         }
4757         if (has_charset) {
4758             STRLEN len;
4759             const char* const name = get_regex_charset_name(r->extflags, &len);
4760             Copy(name, p, len, char);
4761             p += len;
4762         }
4763         if (has_p)
4764             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
4765         {
4766             char ch;
4767             while((ch = *fptr++)) {
4768                 if(reganch & 1)
4769                     *p++ = ch;
4770                 reganch >>= 1;
4771             }
4772         }
4773
4774         *p++ = ':';
4775         Copy(RExC_precomp, p, plen, char);
4776         assert ((RX_WRAPPED(rx) - p) < 16);
4777         r->pre_prefix = p - RX_WRAPPED(rx);
4778         p += plen;
4779         if (has_runon)
4780             *p++ = '\n';
4781         *p++ = ')';
4782         *p = 0;
4783         SvCUR_set(rx, p - SvPVX_const(rx));
4784     }
4785
4786     r->intflags = 0;
4787     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
4788     
4789     if (RExC_seen & REG_SEEN_RECURSE) {
4790         Newxz(RExC_open_parens, RExC_npar,regnode *);
4791         SAVEFREEPV(RExC_open_parens);
4792         Newxz(RExC_close_parens,RExC_npar,regnode *);
4793         SAVEFREEPV(RExC_close_parens);
4794     }
4795
4796     /* Useful during FAIL. */
4797 #ifdef RE_TRACK_PATTERN_OFFSETS
4798     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
4799     DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
4800                           "%s %"UVuf" bytes for offset annotations.\n",
4801                           ri->u.offsets ? "Got" : "Couldn't get",
4802                           (UV)((2*RExC_size+1) * sizeof(U32))));
4803 #endif
4804     SetProgLen(ri,RExC_size);
4805     RExC_rx_sv = rx;
4806     RExC_rx = r;
4807     RExC_rxi = ri;
4808     REH_CALL_COMP_BEGIN_HOOK(pRExC_state->rx);
4809
4810     /* Second pass: emit code. */
4811     RExC_flags = pm_flags;      /* don't let top level (?i) bleed */
4812     RExC_parse = exp;
4813     RExC_end = xend;
4814     RExC_naughty = 0;
4815     RExC_npar = 1;
4816     RExC_emit_start = ri->program;
4817     RExC_emit = ri->program;
4818     RExC_emit_bound = ri->program + RExC_size + 1;
4819
4820     /* Store the count of eval-groups for security checks: */
4821     RExC_rx->seen_evals = RExC_seen_evals;
4822     REGC((U8)REG_MAGIC, (char*) RExC_emit++);
4823     if (reg(pRExC_state, 0, &flags,1) == NULL) {
4824         ReREFCNT_dec(rx);   
4825         return(NULL);
4826     }
4827     /* XXXX To minimize changes to RE engine we always allocate
4828        3-units-long substrs field. */
4829     Newx(r->substrs, 1, struct reg_substr_data);
4830     if (RExC_recurse_count) {
4831         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
4832         SAVEFREEPV(RExC_recurse);
4833     }
4834
4835 reStudy:
4836     r->minlen = minlen = sawlookahead = sawplus = sawopen = 0;
4837     Zero(r->substrs, 1, struct reg_substr_data);
4838
4839 #ifdef TRIE_STUDY_OPT
4840     if (!restudied) {
4841         StructCopy(&zero_scan_data, &data, scan_data_t);
4842         copyRExC_state = RExC_state;
4843     } else {
4844         U32 seen=RExC_seen;
4845         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
4846         
4847         RExC_state = copyRExC_state;
4848         if (seen & REG_TOP_LEVEL_BRANCHES) 
4849             RExC_seen |= REG_TOP_LEVEL_BRANCHES;
4850         else
4851             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES;
4852         if (data.last_found) {
4853             SvREFCNT_dec(data.longest_fixed);
4854             SvREFCNT_dec(data.longest_float);
4855             SvREFCNT_dec(data.last_found);
4856         }
4857         StructCopy(&zero_scan_data, &data, scan_data_t);
4858     }
4859 #else
4860     StructCopy(&zero_scan_data, &data, scan_data_t);
4861 #endif    
4862
4863     /* Dig out information for optimizations. */
4864     r->extflags = RExC_flags; /* was pm_op */
4865     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
4866  
4867     if (UTF)
4868         SvUTF8_on(rx);  /* Unicode in it? */
4869     ri->regstclass = NULL;
4870     if (RExC_naughty >= 10)     /* Probably an expensive pattern. */
4871         r->intflags |= PREGf_NAUGHTY;
4872     scan = ri->program + 1;             /* First BRANCH. */
4873
4874     /* testing for BRANCH here tells us whether there is "must appear"
4875        data in the pattern. If there is then we can use it for optimisations */
4876     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /*  Only one top-level choice. */
4877         I32 fake;
4878         STRLEN longest_float_length, longest_fixed_length;
4879         struct regnode_charclass_class ch_class; /* pointed to by data */
4880         int stclass_flag;
4881         I32 last_close = 0; /* pointed to by data */
4882         regnode *first= scan;
4883         regnode *first_next= regnext(first);
4884         /*
4885          * Skip introductions and multiplicators >= 1
4886          * so that we can extract the 'meat' of the pattern that must 
4887          * match in the large if() sequence following.
4888          * NOTE that EXACT is NOT covered here, as it is normally
4889          * picked up by the optimiser separately. 
4890          *
4891          * This is unfortunate as the optimiser isnt handling lookahead
4892          * properly currently.
4893          *
4894          */
4895         while ((OP(first) == OPEN && (sawopen = 1)) ||
4896                /* An OR of *one* alternative - should not happen now. */
4897             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
4898             /* for now we can't handle lookbehind IFMATCH*/
4899             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
4900             (OP(first) == PLUS) ||
4901             (OP(first) == MINMOD) ||
4902                /* An {n,m} with n>0 */
4903             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
4904             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
4905         {
4906                 /* 
4907                  * the only op that could be a regnode is PLUS, all the rest
4908                  * will be regnode_1 or regnode_2.
4909                  *
4910                  */
4911                 if (OP(first) == PLUS)
4912                     sawplus = 1;
4913                 else
4914                     first += regarglen[OP(first)];
4915                 
4916                 first = NEXTOPER(first);
4917                 first_next= regnext(first);
4918         }
4919
4920         /* Starting-point info. */
4921       again:
4922         DEBUG_PEEP("first:",first,0);
4923         /* Ignore EXACT as we deal with it later. */
4924         if (PL_regkind[OP(first)] == EXACT) {
4925             if (OP(first) == EXACT)
4926                 NOOP;   /* Empty, get anchored substr later. */
4927             else
4928                 ri->regstclass = first;
4929         }
4930 #ifdef TRIE_STCLASS     
4931         else if (PL_regkind[OP(first)] == TRIE &&
4932                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0) 
4933         {
4934             regnode *trie_op;
4935             /* this can happen only on restudy */
4936             if ( OP(first) == TRIE ) {
4937                 struct regnode_1 *trieop = (struct regnode_1 *)
4938                     PerlMemShared_calloc(1, sizeof(struct regnode_1));
4939                 StructCopy(first,trieop,struct regnode_1);
4940                 trie_op=(regnode *)trieop;
4941             } else {
4942                 struct regnode_charclass *trieop = (struct regnode_charclass *)
4943                     PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
4944                 StructCopy(first,trieop,struct regnode_charclass);
4945                 trie_op=(regnode *)trieop;
4946             }
4947             OP(trie_op)+=2;
4948             make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
4949             ri->regstclass = trie_op;
4950         }
4951 #endif  
4952         else if (REGNODE_SIMPLE(OP(first)))
4953             ri->regstclass = first;
4954         else if (PL_regkind[OP(first)] == BOUND ||
4955                  PL_regkind[OP(first)] == NBOUND)
4956             ri->regstclass = first;
4957         else if (PL_regkind[OP(first)] == BOL) {
4958             r->extflags |= (OP(first) == MBOL
4959                            ? RXf_ANCH_MBOL
4960                            : (OP(first) == SBOL
4961                               ? RXf_ANCH_SBOL
4962                               : RXf_ANCH_BOL));
4963             first = NEXTOPER(first);
4964             goto again;
4965         }
4966         else if (OP(first) == GPOS) {
4967             r->extflags |= RXf_ANCH_GPOS;
4968             first = NEXTOPER(first);
4969             goto again;
4970         }
4971         else if ((!sawopen || !RExC_sawback) &&
4972             (OP(first) == STAR &&
4973             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
4974             !(r->extflags & RXf_ANCH) && !(RExC_seen & REG_SEEN_EVAL))
4975         {
4976             /* turn .* into ^.* with an implied $*=1 */
4977             const int type =
4978                 (OP(NEXTOPER(first)) == REG_ANY)
4979                     ? RXf_ANCH_MBOL
4980                     : RXf_ANCH_SBOL;
4981             r->extflags |= type;
4982             r->intflags |= PREGf_IMPLICIT;
4983             first = NEXTOPER(first);
4984             goto again;
4985         }
4986         if (sawplus && !sawlookahead && (!sawopen || !RExC_sawback)
4987             && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
4988             /* x+ must match at the 1st pos of run of x's */
4989             r->intflags |= PREGf_SKIP;
4990
4991         /* Scan is after the zeroth branch, first is atomic matcher. */
4992 #ifdef TRIE_STUDY_OPT
4993         DEBUG_PARSE_r(
4994             if (!restudied)
4995                 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
4996                               (IV)(first - scan + 1))
4997         );
4998 #else
4999         DEBUG_PARSE_r(
5000             PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
5001                 (IV)(first - scan + 1))
5002         );
5003 #endif
5004
5005
5006         /*
5007         * If there's something expensive in the r.e., find the
5008         * longest literal string that must appear and make it the
5009         * regmust.  Resolve ties in favor of later strings, since
5010         * the regstart check works with the beginning of the r.e.
5011         * and avoiding duplication strengthens checking.  Not a
5012         * strong reason, but sufficient in the absence of others.
5013         * [Now we resolve ties in favor of the earlier string if
5014         * it happens that c_offset_min has been invalidated, since the
5015         * earlier string may buy us something the later one won't.]
5016         */
5017         
5018         data.longest_fixed = newSVpvs("");
5019         data.longest_float = newSVpvs("");
5020         data.last_found = newSVpvs("");
5021         data.longest = &(data.longest_fixed);
5022         first = scan;
5023         if (!ri->regstclass) {
5024             cl_init(pRExC_state, &ch_class);
5025             data.start_class = &ch_class;
5026             stclass_flag = SCF_DO_STCLASS_AND;
5027         } else                          /* XXXX Check for BOUND? */
5028             stclass_flag = 0;
5029         data.last_closep = &last_close;
5030         
5031         minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */
5032             &data, -1, NULL, NULL,
5033             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
5034
5035         
5036         CHECK_RESTUDY_GOTO;
5037
5038
5039         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
5040              && data.last_start_min == 0 && data.last_end > 0
5041              && !RExC_seen_zerolen
5042              && !(RExC_seen & REG_SEEN_VERBARG)
5043              && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
5044             r->extflags |= RXf_CHECK_ALL;
5045         scan_commit(pRExC_state, &data,&minlen,0);
5046         SvREFCNT_dec(data.last_found);
5047
5048         /* Note that code very similar to this but for anchored string 
5049            follows immediately below, changes may need to be made to both. 
5050            Be careful. 
5051          */
5052         longest_float_length = CHR_SVLEN(data.longest_float);
5053         if (longest_float_length
5054             || (data.flags & SF_FL_BEFORE_EOL
5055                 && (!(data.flags & SF_FL_BEFORE_MEOL)
5056                     || (RExC_flags & RXf_PMf_MULTILINE)))) 
5057         {
5058             I32 t,ml;
5059
5060             if (SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
5061                 && data.offset_fixed == data.offset_float_min
5062                 && SvCUR(data.longest_fixed) == SvCUR(data.longest_float))
5063                     goto remove_float;          /* As in (a)+. */
5064
5065             /* copy the information about the longest float from the reg_scan_data
5066                over to the program. */
5067             if (SvUTF8(data.longest_float)) {
5068                 r->float_utf8 = data.longest_float;
5069                 r->float_substr = NULL;
5070             } else {
5071                 r->float_substr = data.longest_float;
5072                 r->float_utf8 = NULL;
5073             }
5074             /* float_end_shift is how many chars that must be matched that 
5075                follow this item. We calculate it ahead of time as once the
5076                lookbehind offset is added in we lose the ability to correctly
5077                calculate it.*/
5078             ml = data.minlen_float ? *(data.minlen_float) 
5079                                    : (I32)longest_float_length;
5080             r->float_end_shift = ml - data.offset_float_min
5081                 - longest_float_length + (SvTAIL(data.longest_float) != 0)
5082                 + data.lookbehind_float;
5083             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
5084             r->float_max_offset = data.offset_float_max;
5085             if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
5086                 r->float_max_offset -= data.lookbehind_float;
5087             
5088             t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
5089                        && (!(data.flags & SF_FL_BEFORE_MEOL)
5090                            || (RExC_flags & RXf_PMf_MULTILINE)));
5091             fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0);
5092         }
5093         else {
5094           remove_float:
5095             r->float_substr = r->float_utf8 = NULL;
5096             SvREFCNT_dec(data.longest_float);
5097             longest_float_length = 0;
5098         }
5099
5100         /* Note that code very similar to this but for floating string 
5101            is immediately above, changes may need to be made to both. 
5102            Be careful. 
5103          */
5104         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
5105         if (longest_fixed_length
5106             || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
5107                 && (!(data.flags & SF_FIX_BEFORE_MEOL)
5108                     || (RExC_flags & RXf_PMf_MULTILINE)))) 
5109         {
5110             I32 t,ml;
5111
5112             /* copy the information about the longest fixed 
5113                from the reg_scan_data over to the program. */
5114             if (SvUTF8(data.longest_fixed)) {
5115                 r->anchored_utf8 = data.longest_fixed;
5116                 r->anchored_substr = NULL;
5117             } else {
5118                 r->anchored_substr = data.longest_fixed;
5119                 r->anchored_utf8 = NULL;
5120             }
5121             /* fixed_end_shift is how many chars that must be matched that 
5122                follow this item. We calculate it ahead of time as once the
5123                lookbehind offset is added in we lose the ability to correctly
5124                calculate it.*/
5125             ml = data.minlen_fixed ? *(data.minlen_fixed) 
5126                                    : (I32)longest_fixed_length;
5127             r->anchored_end_shift = ml - data.offset_fixed
5128                 - longest_fixed_length + (SvTAIL(data.longest_fixed) != 0)
5129                 + data.lookbehind_fixed;
5130             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
5131
5132             t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
5133                  && (!(data.flags & SF_FIX_BEFORE_MEOL)
5134                      || (RExC_flags & RXf_PMf_MULTILINE)));
5135             fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0);
5136         }
5137         else {
5138             r->anchored_substr = r->anchored_utf8 = NULL;
5139             SvREFCNT_dec(data.longest_fixed);
5140             longest_fixed_length = 0;
5141         }
5142         if (ri->regstclass
5143             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
5144             ri->regstclass = NULL;
5145
5146         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
5147             && stclass_flag
5148             && !(data.start_class->flags & ANYOF_EOS)
5149             && !cl_is_anything(data.start_class))
5150         {
5151             const U32 n = add_data(pRExC_state, 1, "f");
5152             data.start_class->flags |= ANYOF_IS_SYNTHETIC;
5153
5154             Newx(RExC_rxi->data->data[n], 1,
5155                 struct regnode_charclass_class);
5156             StructCopy(data.start_class,
5157                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
5158                        struct regnode_charclass_class);
5159             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5160             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5161             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
5162                       regprop(r, sv, (regnode*)data.start_class);
5163                       PerlIO_printf(Perl_debug_log,
5164                                     "synthetic stclass \"%s\".\n",
5165                                     SvPVX_const(sv));});
5166         }
5167
5168         /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
5169         if (longest_fixed_length > longest_float_length) {
5170             r->check_end_shift = r->anchored_end_shift;
5171             r->check_substr = r->anchored_substr;
5172             r->check_utf8 = r->anchored_utf8;
5173             r->check_offset_min = r->check_offset_max = r->anchored_offset;
5174             if (r->extflags & RXf_ANCH_SINGLE)
5175                 r->extflags |= RXf_NOSCAN;
5176         }
5177         else {
5178             r->check_end_shift = r->float_end_shift;
5179             r->check_substr = r->float_substr;
5180             r->check_utf8 = r->float_utf8;
5181             r->check_offset_min = r->float_min_offset;
5182             r->check_offset_max = r->float_max_offset;
5183         }
5184         /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
5185            This should be changed ASAP!  */
5186         if ((r->check_substr || r->check_utf8) && !(r->extflags & RXf_ANCH_GPOS)) {
5187             r->extflags |= RXf_USE_INTUIT;
5188             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
5189                 r->extflags |= RXf_INTUIT_TAIL;
5190         }
5191         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
5192         if ( (STRLEN)minlen < longest_float_length )
5193             minlen= longest_float_length;
5194         if ( (STRLEN)minlen < longest_fixed_length )
5195             minlen= longest_fixed_length;     
5196         */
5197     }
5198     else {
5199         /* Several toplevels. Best we can is to set minlen. */
5200         I32 fake;
5201         struct regnode_charclass_class ch_class;
5202         I32 last_close = 0;
5203         
5204         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
5205
5206         scan = ri->program + 1;
5207         cl_init(pRExC_state, &ch_class);
5208         data.start_class = &ch_class;
5209         data.last_closep = &last_close;
5210
5211         
5212         minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
5213             &data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
5214         
5215         CHECK_RESTUDY_GOTO;
5216
5217         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
5218                 = r->float_substr = r->float_utf8 = NULL;
5219
5220         if (!(data.start_class->flags & ANYOF_EOS)
5221             && !cl_is_anything(data.start_class))
5222         {
5223             const U32 n = add_data(pRExC_state, 1, "f");
5224             data.start_class->flags |= ANYOF_IS_SYNTHETIC;
5225
5226             Newx(RExC_rxi->data->data[n], 1,
5227                 struct regnode_charclass_class);
5228             StructCopy(data.start_class,
5229                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
5230                        struct regnode_charclass_class);
5231             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5232             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5233             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
5234                       regprop(r, sv, (regnode*)data.start_class);
5235                       PerlIO_printf(Perl_debug_log,
5236                                     "synthetic stclass \"%s\".\n",
5237                                     SvPVX_const(sv));});
5238         }
5239     }
5240
5241     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
5242        the "real" pattern. */
5243     DEBUG_OPTIMISE_r({
5244         PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n",
5245                       (IV)minlen, (IV)r->minlen);
5246     });
5247     r->minlenret = minlen;
5248     if (r->minlen < minlen) 
5249         r->minlen = minlen;
5250     
5251     if (RExC_seen & REG_SEEN_GPOS)
5252         r->extflags |= RXf_GPOS_SEEN;
5253     if (RExC_seen & REG_SEEN_LOOKBEHIND)
5254         r->extflags |= RXf_LOOKBEHIND_SEEN;
5255     if (RExC_seen & REG_SEEN_EVAL)
5256         r->extflags |= RXf_EVAL_SEEN;
5257     if (RExC_seen & REG_SEEN_CANY)
5258         r->extflags |= RXf_CANY_SEEN;
5259     if (RExC_seen & REG_SEEN_VERBARG)
5260         r->intflags |= PREGf_VERBARG_SEEN;
5261     if (RExC_seen & REG_SEEN_CUTGROUP)
5262         r->intflags |= PREGf_CUTGROUP_SEEN;
5263     if (RExC_paren_names)
5264         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
5265     else
5266         RXp_PAREN_NAMES(r) = NULL;
5267
5268 #ifdef STUPID_PATTERN_CHECKS            
5269     if (RX_PRELEN(rx) == 0)
5270         r->extflags |= RXf_NULL;
5271     if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5272         /* XXX: this should happen BEFORE we compile */
5273         r->extflags |= (RXf_SKIPWHITE|RXf_WHITE); 
5274     else if (RX_PRELEN(rx) == 3 && memEQ("\\s+", RX_PRECOMP(rx), 3))
5275         r->extflags |= RXf_WHITE;
5276     else if (RX_PRELEN(rx) == 1 && RXp_PRECOMP(rx)[0] == '^')
5277         r->extflags |= RXf_START_ONLY;
5278 #else
5279     if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5280             /* XXX: this should happen BEFORE we compile */
5281             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE); 
5282     else {
5283         regnode *first = ri->program + 1;
5284         U8 fop = OP(first);
5285
5286         if (PL_regkind[fop] == NOTHING && OP(NEXTOPER(first)) == END)
5287             r->extflags |= RXf_NULL;
5288         else if (PL_regkind[fop] == BOL && OP(NEXTOPER(first)) == END)
5289             r->extflags |= RXf_START_ONLY;
5290         else if (fop == PLUS && OP(NEXTOPER(first)) == SPACE
5291                              && OP(regnext(first)) == END)
5292             r->extflags |= RXf_WHITE;    
5293     }
5294 #endif
5295 #ifdef DEBUGGING
5296     if (RExC_paren_names) {
5297         ri->name_list_idx = add_data( pRExC_state, 1, "a" );
5298         ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list);
5299     } else
5300 #endif
5301         ri->name_list_idx = 0;
5302
5303     if (RExC_recurse_count) {
5304         for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
5305             const regnode *scan = RExC_recurse[RExC_recurse_count-1];
5306             ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
5307         }
5308     }
5309     Newxz(r->offs, RExC_npar, regexp_paren_pair);
5310     /* assume we don't need to swap parens around before we match */
5311
5312     DEBUG_DUMP_r({
5313         PerlIO_printf(Perl_debug_log,"Final program:\n");
5314         regdump(r);
5315     });
5316 #ifdef RE_TRACK_PATTERN_OFFSETS
5317     DEBUG_OFFSETS_r(if (ri->u.offsets) {
5318         const U32 len = ri->u.offsets[0];
5319         U32 i;
5320         GET_RE_DEBUG_FLAGS_DECL;
5321         PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
5322         for (i = 1; i <= len; i++) {
5323             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
5324                 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
5325                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
5326             }
5327         PerlIO_printf(Perl_debug_log, "\n");
5328     });
5329 #endif
5330     return rx;
5331 }
5332
5333 #undef RE_ENGINE_PTR
5334
5335
5336 SV*
5337 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
5338                     const U32 flags)
5339 {
5340     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
5341
5342     PERL_UNUSED_ARG(value);
5343
5344     if (flags & RXapif_FETCH) {
5345         return reg_named_buff_fetch(rx, key, flags);
5346     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
5347         Perl_croak_no_modify(aTHX);
5348         return NULL;
5349     } else if (flags & RXapif_EXISTS) {
5350         return reg_named_buff_exists(rx, key, flags)
5351             ? &PL_sv_yes
5352             : &PL_sv_no;
5353     } else if (flags & RXapif_REGNAMES) {
5354         return reg_named_buff_all(rx, flags);
5355     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
5356         return reg_named_buff_scalar(rx, flags);
5357     } else {
5358         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
5359         return NULL;
5360     }
5361 }
5362
5363 SV*
5364 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
5365                          const U32 flags)
5366 {
5367     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
5368     PERL_UNUSED_ARG(lastkey);
5369
5370     if (flags & RXapif_FIRSTKEY)
5371         return reg_named_buff_firstkey(rx, flags);
5372     else if (flags & RXapif_NEXTKEY)
5373         return reg_named_buff_nextkey(rx, flags);
5374     else {
5375         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter", (int)flags);
5376         return NULL;
5377     }
5378 }
5379
5380 SV*
5381 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
5382                           const U32 flags)
5383 {
5384     AV *retarray = NULL;
5385     SV *ret;
5386     struct regexp *const rx = (struct regexp *)SvANY(r);
5387
5388     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
5389
5390     if (flags & RXapif_ALL)
5391         retarray=newAV();
5392
5393     if (rx && RXp_PAREN_NAMES(rx)) {
5394         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
5395         if (he_str) {
5396             IV i;
5397             SV* sv_dat=HeVAL(he_str);
5398             I32 *nums=(I32*)SvPVX(sv_dat);
5399             for ( i=0; i<SvIVX(sv_dat); i++ ) {
5400                 if ((I32)(rx->nparens) >= nums[i]
5401                     && rx->offs[nums[i]].start != -1
5402                     && rx->offs[nums[i]].end != -1)
5403                 {
5404                     ret = newSVpvs("");
5405                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
5406                     if (!retarray)
5407                         return ret;
5408                 } else {
5409                     ret = newSVsv(&PL_sv_undef);
5410                 }
5411                 if (retarray)
5412                     av_push(retarray, ret);
5413             }
5414             if (retarray)
5415                 return newRV_noinc(MUTABLE_SV(retarray));
5416         }
5417     }
5418     return NULL;
5419 }
5420
5421 bool
5422 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
5423                            const U32 flags)
5424 {
5425     struct regexp *const rx = (struct regexp *)SvANY(r);
5426
5427     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
5428
5429     if (rx && RXp_PAREN_NAMES(rx)) {
5430         if (flags & RXapif_ALL) {
5431             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
5432         } else {
5433             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
5434             if (sv) {
5435                 SvREFCNT_dec(sv);
5436                 return TRUE;
5437             } else {
5438                 return FALSE;
5439             }
5440         }
5441     } else {
5442         return FALSE;
5443     }
5444 }
5445
5446 SV*
5447 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
5448 {
5449     struct regexp *const rx = (struct regexp *)SvANY(r);
5450
5451     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
5452
5453     if ( rx && RXp_PAREN_NAMES(rx) ) {
5454         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
5455
5456         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
5457     } else {
5458         return FALSE;
5459     }
5460 }
5461
5462 SV*
5463 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
5464 {
5465     struct regexp *const rx = (struct regexp *)SvANY(r);
5466     GET_RE_DEBUG_FLAGS_DECL;
5467
5468     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
5469
5470     if (rx && RXp_PAREN_NAMES(rx)) {
5471         HV *hv = RXp_PAREN_NAMES(rx);
5472         HE *temphe;
5473         while ( (temphe = hv_iternext_flags(hv,0)) ) {
5474             IV i;
5475             IV parno = 0;
5476             SV* sv_dat = HeVAL(temphe);
5477             I32 *nums = (I32*)SvPVX(sv_dat);
5478             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5479                 if ((I32)(rx->lastparen) >= nums[i] &&
5480                     rx->offs[nums[i]].start != -1 &&
5481                     rx->offs[nums[i]].end != -1)
5482                 {
5483                     parno = nums[i];
5484                     break;
5485                 }
5486             }
5487             if (parno || flags & RXapif_ALL) {
5488                 return newSVhek(HeKEY_hek(temphe));
5489             }
5490         }
5491     }
5492     return NULL;
5493 }
5494
5495 SV*
5496 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
5497 {
5498     SV *ret;
5499     AV *av;
5500     I32 length;
5501     struct regexp *const rx = (struct regexp *)SvANY(r);
5502
5503     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
5504
5505     if (rx && RXp_PAREN_NAMES(rx)) {
5506         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
5507             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
5508         } else if (flags & RXapif_ONE) {
5509             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
5510             av = MUTABLE_AV(SvRV(ret));
5511             length = av_len(av);
5512             SvREFCNT_dec(ret);
5513             return newSViv(length + 1);
5514         } else {
5515             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", (int)flags);
5516             return NULL;
5517         }
5518     }
5519     return &PL_sv_undef;
5520 }
5521
5522 SV*
5523 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
5524 {
5525     struct regexp *const rx = (struct regexp *)SvANY(r);
5526     AV *av = newAV();
5527
5528     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
5529
5530     if (rx && RXp_PAREN_NAMES(rx)) {
5531         HV *hv= RXp_PAREN_NAMES(rx);
5532         HE *temphe;
5533         (void)hv_iterinit(hv);
5534         while ( (temphe = hv_iternext_flags(hv,0)) ) {
5535             IV i;
5536             IV parno = 0;
5537             SV* sv_dat = HeVAL(temphe);
5538             I32 *nums = (I32*)SvPVX(sv_dat);
5539             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5540                 if ((I32)(rx->lastparen) >= nums[i] &&
5541                     rx->offs[nums[i]].start != -1 &&
5542                     rx->offs[nums[i]].end != -1)
5543                 {
5544                     parno = nums[i];
5545                     break;
5546                 }
5547             }
5548             if (parno || flags & RXapif_ALL) {
5549                 av_push(av, newSVhek(HeKEY_hek(temphe)));
5550             }
5551         }
5552     }
5553
5554     return newRV_noinc(MUTABLE_SV(av));
5555 }
5556
5557 void
5558 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
5559                              SV * const sv)
5560 {
5561     struct regexp *const rx = (struct regexp *)SvANY(r);
5562     char *s = NULL;
5563     I32 i = 0;
5564     I32 s1, t1;
5565
5566     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
5567         
5568     if (!rx->subbeg) {
5569         sv_setsv(sv,&PL_sv_undef);
5570         return;
5571     } 
5572     else               
5573     if (paren == RX_BUFF_IDX_PREMATCH && rx->offs[0].start != -1) {
5574         /* $` */
5575         i = rx->offs[0].start;
5576         s = rx->subbeg;
5577     }
5578     else 
5579     if (paren == RX_BUFF_IDX_POSTMATCH && rx->offs[0].end != -1) {
5580         /* $' */
5581         s = rx->subbeg + rx->offs[0].end;
5582         i = rx->sublen - rx->offs[0].end;
5583     } 
5584     else
5585     if ( 0 <= paren && paren <= (I32)rx->nparens &&
5586         (s1 = rx->offs[paren].start) != -1 &&
5587         (t1 = rx->offs[paren].end) != -1)
5588     {
5589         /* $& $1 ... */
5590         i = t1 - s1;
5591         s = rx->subbeg + s1;
5592     } else {
5593         sv_setsv(sv,&PL_sv_undef);
5594         return;
5595     }          
5596     assert(rx->sublen >= (s - rx->subbeg) + i );
5597     if (i >= 0) {
5598         const int oldtainted = PL_tainted;
5599         TAINT_NOT;
5600         sv_setpvn(sv, s, i);
5601         PL_tainted = oldtainted;
5602         if ( (rx->extflags & RXf_CANY_SEEN)
5603             ? (RXp_MATCH_UTF8(rx)
5604                         && (!i || is_utf8_string((U8*)s, i)))
5605             : (RXp_MATCH_UTF8(rx)) )
5606         {
5607             SvUTF8_on(sv);
5608         }
5609         else
5610             SvUTF8_off(sv);
5611         if (PL_tainting) {
5612             if (RXp_MATCH_TAINTED(rx)) {
5613                 if (SvTYPE(sv) >= SVt_PVMG) {
5614                     MAGIC* const mg = SvMAGIC(sv);
5615                     MAGIC* mgt;
5616                     PL_tainted = 1;
5617                     SvMAGIC_set(sv, mg->mg_moremagic);
5618                     SvTAINT(sv);
5619                     if ((mgt = SvMAGIC(sv))) {
5620                         mg->mg_moremagic = mgt;
5621                         SvMAGIC_set(sv, mg);
5622                     }
5623                 } else {
5624                     PL_tainted = 1;
5625                     SvTAINT(sv);
5626                 }
5627             } else 
5628                 SvTAINTED_off(sv);
5629         }
5630     } else {
5631         sv_setsv(sv,&PL_sv_undef);
5632         return;
5633     }
5634 }
5635
5636 void
5637 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
5638                                                          SV const * const value)
5639 {
5640     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
5641
5642     PERL_UNUSED_ARG(rx);
5643     PERL_UNUSED_ARG(paren);
5644     PERL_UNUSED_ARG(value);
5645
5646     if (!PL_localizing)
5647         Perl_croak_no_modify(aTHX);
5648 }
5649
5650 I32
5651 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
5652                               const I32 paren)
5653 {
5654     struct regexp *const rx = (struct regexp *)SvANY(r);
5655     I32 i;
5656     I32 s1, t1;
5657
5658     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
5659
5660     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
5661         switch (paren) {
5662       /* $` / ${^PREMATCH} */
5663       case RX_BUFF_IDX_PREMATCH:
5664         if (rx->offs[0].start != -1) {
5665                         i = rx->offs[0].start;
5666                         if (i > 0) {
5667                                 s1 = 0;
5668                                 t1 = i;
5669                                 goto getlen;
5670                         }
5671             }
5672         return 0;
5673       /* $' / ${^POSTMATCH} */
5674       case RX_BUFF_IDX_POSTMATCH:
5675             if (rx->offs[0].end != -1) {
5676                         i = rx->sublen - rx->offs[0].end;
5677                         if (i > 0) {
5678                                 s1 = rx->offs[0].end;
5679                                 t1 = rx->sublen;
5680                                 goto getlen;
5681                         }
5682             }
5683         return 0;
5684       /* $& / ${^MATCH}, $1, $2, ... */
5685       default:
5686             if (paren <= (I32)rx->nparens &&
5687             (s1 = rx->offs[paren].start) != -1 &&
5688             (t1 = rx->offs[paren].end) != -1)
5689             {
5690             i = t1 - s1;
5691             goto getlen;
5692         } else {
5693             if (ckWARN(WARN_UNINITIALIZED))
5694                 report_uninit((const SV *)sv);
5695             return 0;
5696         }
5697     }
5698   getlen:
5699     if (i > 0 && RXp_MATCH_UTF8(rx)) {
5700         const char * const s = rx->subbeg + s1;
5701         const U8 *ep;
5702         STRLEN el;
5703
5704         i = t1 - s1;
5705         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
5706                         i = el;
5707     }
5708     return i;
5709 }
5710
5711 SV*
5712 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
5713 {
5714     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
5715         PERL_UNUSED_ARG(rx);
5716         if (0)
5717             return NULL;
5718         else
5719             return newSVpvs("Regexp");
5720 }
5721
5722 /* Scans the name of a named buffer from the pattern.
5723  * If flags is REG_RSN_RETURN_NULL returns null.
5724  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
5725  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
5726  * to the parsed name as looked up in the RExC_paren_names hash.
5727  * If there is an error throws a vFAIL().. type exception.
5728  */
5729
5730 #define REG_RSN_RETURN_NULL    0
5731 #define REG_RSN_RETURN_NAME    1
5732 #define REG_RSN_RETURN_DATA    2
5733
5734 STATIC SV*
5735 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
5736 {
5737     char *name_start = RExC_parse;
5738
5739     PERL_ARGS_ASSERT_REG_SCAN_NAME;
5740
5741     if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
5742          /* skip IDFIRST by using do...while */
5743         if (UTF)
5744             do {
5745                 RExC_parse += UTF8SKIP(RExC_parse);
5746             } while (isALNUM_utf8((U8*)RExC_parse));
5747         else
5748             do {
5749                 RExC_parse++;
5750             } while (isALNUM(*RExC_parse));
5751     }
5752
5753     if ( flags ) {
5754         SV* sv_name
5755             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
5756                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
5757         if ( flags == REG_RSN_RETURN_NAME)
5758             return sv_name;
5759         else if (flags==REG_RSN_RETURN_DATA) {
5760             HE *he_str = NULL;
5761             SV *sv_dat = NULL;
5762             if ( ! sv_name )      /* should not happen*/
5763                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
5764             if (RExC_paren_names)
5765                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
5766             if ( he_str )
5767                 sv_dat = HeVAL(he_str);
5768             if ( ! sv_dat )
5769                 vFAIL("Reference to nonexistent named group");
5770             return sv_dat;
5771         }
5772         else {
5773             Perl_croak(aTHX_ "panic: bad flag in reg_scan_name");
5774         }
5775         /* NOT REACHED */
5776     }
5777     return NULL;
5778 }
5779
5780 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
5781     int rem=(int)(RExC_end - RExC_parse);                       \
5782     int cut;                                                    \
5783     int num;                                                    \
5784     int iscut=0;                                                \
5785     if (rem>10) {                                               \
5786         rem=10;                                                 \
5787         iscut=1;                                                \
5788     }                                                           \
5789     cut=10-rem;                                                 \
5790     if (RExC_lastparse!=RExC_parse)                             \
5791         PerlIO_printf(Perl_debug_log," >%.*s%-*s",              \
5792             rem, RExC_parse,                                    \
5793             cut + 4,                                            \
5794             iscut ? "..." : "<"                                 \
5795         );                                                      \
5796     else                                                        \
5797         PerlIO_printf(Perl_debug_log,"%16s","");                \
5798                                                                 \
5799     if (SIZE_ONLY)                                              \
5800        num = RExC_size + 1;                                     \
5801     else                                                        \
5802        num=REG_NODE_NUM(RExC_emit);                             \
5803     if (RExC_lastnum!=num)                                      \
5804        PerlIO_printf(Perl_debug_log,"|%4d",num);                \
5805     else                                                        \
5806        PerlIO_printf(Perl_debug_log,"|%4s","");                 \
5807     PerlIO_printf(Perl_debug_log,"|%*s%-4s",                    \
5808         (int)((depth*2)), "",                                   \
5809         (funcname)                                              \
5810     );                                                          \
5811     RExC_lastnum=num;                                           \
5812     RExC_lastparse=RExC_parse;                                  \
5813 })
5814
5815
5816
5817 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
5818     DEBUG_PARSE_MSG((funcname));                            \
5819     PerlIO_printf(Perl_debug_log,"%4s","\n");               \
5820 })
5821 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({           \
5822     DEBUG_PARSE_MSG((funcname));                            \
5823     PerlIO_printf(Perl_debug_log,fmt "\n",args);               \
5824 })
5825
5826 /* This section of code defines the inversion list object and its methods.  The
5827  * interfaces are highly subject to change, so as much as possible is static to
5828  * this file.  An inversion list is here implemented as a malloc'd C array with
5829  * some added info.  More will be coming when functionality is added later.
5830  *
5831  * It is currently implemented as an HV to the outside world, but is actually
5832  * an SV pointing to an array of UVs that the SV thinks are bytes.  This allows
5833  * us to have an array of UV whose memory management is automatically handled
5834  * by the existing facilities for SV's.
5835  *
5836  * Some of the methods should always be private to the implementation, and some
5837  * should eventually be made public */
5838
5839 #define INVLIST_INITIAL_LEN 10
5840
5841 PERL_STATIC_INLINE UV*
5842 S_invlist_array(pTHX_ HV* const invlist)
5843 {
5844     /* Returns the pointer to the inversion list's array.  Every time the
5845      * length changes, this needs to be called in case malloc or realloc moved
5846      * it */
5847
5848     PERL_ARGS_ASSERT_INVLIST_ARRAY;
5849
5850     return (UV *) SvPVX(invlist);
5851 }
5852
5853 PERL_STATIC_INLINE UV
5854 S_invlist_len(pTHX_ HV* const invlist)
5855 {
5856     /* Returns the current number of elements in the inversion list's array */
5857
5858     PERL_ARGS_ASSERT_INVLIST_LEN;
5859
5860     return SvCUR(invlist) / sizeof(UV);
5861 }
5862
5863 PERL_STATIC_INLINE UV
5864 S_invlist_max(pTHX_ HV* const invlist)
5865 {
5866     /* Returns the maximum number of elements storable in the inversion list's
5867      * array, without having to realloc() */
5868
5869     PERL_ARGS_ASSERT_INVLIST_MAX;
5870
5871     return SvLEN(invlist) / sizeof(UV);
5872 }
5873
5874 PERL_STATIC_INLINE void
5875 S_invlist_set_len(pTHX_ HV* const invlist, const UV len)
5876 {
5877     /* Sets the current number of elements stored in the inversion list */
5878
5879     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
5880
5881     SvCUR_set(invlist, len * sizeof(UV));
5882 }
5883
5884 PERL_STATIC_INLINE void
5885 S_invlist_set_max(pTHX_ HV* const invlist, const UV max)
5886 {
5887
5888     /* Sets the maximum number of elements storable in the inversion list
5889      * without having to realloc() */
5890
5891     PERL_ARGS_ASSERT_INVLIST_SET_MAX;
5892
5893     if (max < invlist_len(invlist)) {
5894         Perl_croak(aTHX_ "panic: Can't make max size '%"UVuf"' less than current length %"UVuf" in inversion list", invlist_max(invlist), invlist_len(invlist));
5895     }
5896
5897     SvLEN_set(invlist, max * sizeof(UV));
5898 }
5899
5900 #ifndef PERL_IN_XSUB_RE
5901 HV*
5902 Perl__new_invlist(pTHX_ IV initial_size)
5903 {
5904
5905     /* Return a pointer to a newly constructed inversion list, with enough
5906      * space to store 'initial_size' elements.  If that number is negative, a
5907      * system default is used instead */
5908
5909     if (initial_size < 0) {
5910         initial_size = INVLIST_INITIAL_LEN;
5911     }
5912
5913     /* Allocate the initial space */
5914     return (HV *) newSV(initial_size * sizeof(UV));
5915 }
5916 #endif
5917
5918 PERL_STATIC_INLINE void
5919 S_invlist_destroy(pTHX_ HV* const invlist)
5920 {
5921    /* Inversion list destructor */
5922
5923     PERL_ARGS_ASSERT_INVLIST_DESTROY;
5924
5925     SvREFCNT_dec(invlist);
5926 }
5927
5928 STATIC void
5929 S_invlist_extend(pTHX_ HV* const invlist, const UV new_max)
5930 {
5931     /* Grow the maximum size of an inversion list */
5932
5933     PERL_ARGS_ASSERT_INVLIST_EXTEND;
5934
5935     SvGROW((SV *)invlist, new_max * sizeof(UV));
5936 }
5937
5938 PERL_STATIC_INLINE void
5939 S_invlist_trim(pTHX_ HV* const invlist)
5940 {
5941     PERL_ARGS_ASSERT_INVLIST_TRIM;
5942
5943     /* Change the length of the inversion list to how many entries it currently
5944      * has */
5945
5946     SvPV_shrink_to_cur((SV *) invlist);
5947 }
5948
5949 /* An element is in an inversion list iff its index is even numbered: 0, 2, 4,
5950  * etc */
5951
5952 #define ELEMENT_IN_INVLIST_SET(i) (! ((i) & 1))
5953 #define PREV_ELEMENT_IN_INVLIST_SET(i) ! ELEMENT_IN_INVLIST_SET(i)
5954
5955 #ifndef PERL_IN_XSUB_RE
5956 void
5957 Perl__append_range_to_invlist(pTHX_ HV* const invlist, const UV start, const UV end)
5958 {
5959    /* Subject to change or removal.  Append the range from 'start' to 'end' at
5960     * the end of the inversion list.  The range must be above any existing
5961     * ones. */
5962
5963     UV* array = invlist_array(invlist);
5964     UV max = invlist_max(invlist);
5965     UV len = invlist_len(invlist);
5966
5967     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
5968
5969     if (len > 0) {
5970
5971         /* Here, the existing list is non-empty. The current max entry in the
5972          * list is generally the first value not in the set, except when the
5973          * set extends to the end of permissible values, in which case it is
5974          * the first entry in that final set, and so this call is an attempt to
5975          * append out-of-order */
5976
5977         UV final_element = len - 1;
5978         if (array[final_element] > start
5979             || ELEMENT_IN_INVLIST_SET(final_element))
5980         {
5981             Perl_croak(aTHX_ "panic: attempting to append to an inversion list, but wasn't at the end of the list");
5982         }
5983
5984         /* Here, it is a legal append.  If the new range begins with the first
5985          * value not in the set, it is extending the set, so the new first
5986          * value not in the set is one greater than the newly extended range.
5987          * */
5988         if (array[final_element] == start) {
5989             if (end != UV_MAX) {
5990                 array[final_element] = end + 1;
5991             }
5992             else {
5993                 /* But if the end is the maximum representable on the machine,
5994                  * just let the range that this would extend have no end */
5995                 invlist_set_len(invlist, len - 1);
5996             }
5997             return;
5998         }
5999     }
6000
6001     /* Here the new range doesn't extend any existing set.  Add it */
6002
6003     len += 2;   /* Includes an element each for the start and end of range */
6004
6005     /* If overflows the existing space, extend, which may cause the array to be
6006      * moved */
6007     if (max < len) {
6008         invlist_extend(invlist, len);
6009         array = invlist_array(invlist);
6010     }
6011
6012     invlist_set_len(invlist, len);
6013
6014     /* The next item on the list starts the range, the one after that is
6015      * one past the new range.  */
6016     array[len - 2] = start;
6017     if (end != UV_MAX) {
6018         array[len - 1] = end + 1;
6019     }
6020     else {
6021         /* But if the end is the maximum representable on the machine, just let
6022          * the range have no end */
6023         invlist_set_len(invlist, len - 1);
6024     }
6025 }
6026 #endif
6027
6028 STATIC HV*
6029 S_invlist_union(pTHX_ HV* const a, HV* const b)
6030 {
6031     /* Return a new inversion list which is the union of two inversion lists.
6032      * The basis for this comes from "Unicode Demystified" Chapter 13 by
6033      * Richard Gillam, published by Addison-Wesley, and explained at some
6034      * length there.  The preface says to incorporate its examples into your
6035      * code at your own risk.
6036      *
6037      * The algorithm is like a merge sort.
6038      *
6039      * XXX A potential performance improvement is to keep track as we go along
6040      * if only one of the inputs contributes to the result, meaning the other
6041      * is a subset of that one.  In that case, we can skip the final copy and
6042      * return the larger of the input lists */
6043
6044     UV* array_a = invlist_array(a);   /* a's array */
6045     UV* array_b = invlist_array(b);
6046     UV len_a = invlist_len(a);  /* length of a's array */
6047     UV len_b = invlist_len(b);
6048
6049     HV* u;                      /* the resulting union */
6050     UV* array_u;
6051     UV len_u;
6052
6053     UV i_a = 0;             /* current index into a's array */
6054     UV i_b = 0;
6055     UV i_u = 0;
6056
6057     /* running count, as explained in the algorithm source book; items are
6058      * stopped accumulating and are output when the count changes to/from 0.
6059      * The count is incremented when we start a range that's in the set, and
6060      * decremented when we start a range that's not in the set.  So its range
6061      * is 0 to 2.  Only when the count is zero is something not in the set.
6062      */
6063     UV count = 0;
6064
6065     PERL_ARGS_ASSERT_INVLIST_UNION;
6066
6067     /* Size the union for the worst case: that the sets are completely
6068      * disjoint */
6069     u = _new_invlist(len_a + len_b);
6070     array_u = invlist_array(u);
6071
6072     /* Go through each list item by item, stopping when exhausted one of
6073      * them */
6074     while (i_a < len_a && i_b < len_b) {
6075         UV cp;      /* The element to potentially add to the union's array */
6076         bool cp_in_set;   /* is it in the the input list's set or not */
6077
6078         /* We need to take one or the other of the two inputs for the union.
6079          * Since we are merging two sorted lists, we take the smaller of the
6080          * next items.  In case of a tie, we take the one that is in its set
6081          * first.  If we took one not in the set first, it would decrement the
6082          * count, possibly to 0 which would cause it to be output as ending the
6083          * range, and the next time through we would take the same number, and
6084          * output it again as beginning the next range.  By doing it the
6085          * opposite way, there is no possibility that the count will be
6086          * momentarily decremented to 0, and thus the two adjoining ranges will
6087          * be seamlessly merged.  (In a tie and both are in the set or both not
6088          * in the set, it doesn't matter which we take first.) */
6089         if (array_a[i_a] < array_b[i_b]
6090             || (array_a[i_a] == array_b[i_b] && ELEMENT_IN_INVLIST_SET(i_a)))
6091         {
6092             cp_in_set = ELEMENT_IN_INVLIST_SET(i_a);
6093             cp= array_a[i_a++];
6094         }
6095         else {
6096             cp_in_set = ELEMENT_IN_INVLIST_SET(i_b);
6097             cp= array_b[i_b++];
6098         }
6099
6100         /* Here, have chosen which of the two inputs to look at.  Only output
6101          * if the running count changes to/from 0, which marks the
6102          * beginning/end of a range in that's in the set */
6103         if (cp_in_set) {
6104             if (count == 0) {
6105                 array_u[i_u++] = cp;
6106             }
6107             count++;
6108         }
6109         else {
6110             count--;
6111             if (count == 0) {
6112                 array_u[i_u++] = cp;
6113             }
6114         }
6115     }
6116
6117     /* Here, we are finished going through at least one of the lists, which
6118      * means there is something remaining in at most one.  We check if the list
6119      * that hasn't been exhausted is positioned such that we are in the middle
6120      * of a range in its set or not.  (i_a and i_b point to the element beyond
6121      * the one we care about.) If in the set, we decrement 'count'; if 0, there
6122      * is potentially more to output.
6123      * There are four cases:
6124      *  1) Both weren't in their sets, count is 0, and remains 0.  What's left
6125      *     in the union is entirely from the non-exhausted set.
6126      *  2) Both were in their sets, count is 2.  Nothing further should
6127      *     be output, as everything that remains will be in the exhausted
6128      *     list's set, hence in the union; decrementing to 1 but not 0 insures
6129      *     that
6130      *  3) the exhausted was in its set, non-exhausted isn't, count is 1.
6131      *     Nothing further should be output because the union includes
6132      *     everything from the exhausted set.  Not decrementing ensures that.
6133      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1;
6134      *     decrementing to 0 insures that we look at the remainder of the
6135      *     non-exhausted set */
6136     if ((i_a != len_a && PREV_ELEMENT_IN_INVLIST_SET(i_a))
6137         || (i_b != len_b && PREV_ELEMENT_IN_INVLIST_SET(i_b)))
6138     {
6139         count--;
6140     }
6141
6142     /* The final length is what we've output so far, plus what else is about to
6143      * be output.  (If 'count' is non-zero, then the input list we exhausted
6144      * has everything remaining up to the machine's limit in its set, and hence
6145      * in the union, so there will be no further output. */
6146     len_u = i_u;
6147     if (count == 0) {
6148         /* At most one of the subexpressions will be non-zero */
6149         len_u += (len_a - i_a) + (len_b - i_b);
6150     }
6151
6152     /* Set result to final length, which can change the pointer to array_u, so
6153      * re-find it */
6154     if (len_u != invlist_len(u)) {
6155         invlist_set_len(u, len_u);
6156         invlist_trim(u);
6157         array_u = invlist_array(u);
6158     }
6159
6160     /* When 'count' is 0, the list that was exhausted (if one was shorter than
6161      * the other) ended with everything above it not in its set.  That means
6162      * that the remaining part of the union is precisely the same as the
6163      * non-exhausted list, so can just copy it unchanged.  (If both list were
6164      * exhausted at the same time, then the operations below will be both 0.)
6165      */
6166     if (count == 0) {
6167         IV copy_count; /* At most one will have a non-zero copy count */
6168         if ((copy_count = len_a - i_a) > 0) {
6169             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
6170         }
6171         else if ((copy_count = len_b - i_b) > 0) {
6172             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
6173         }
6174     }
6175
6176     return u;
6177 }
6178
6179 STATIC HV*
6180 S_invlist_intersection(pTHX_ HV* const a, HV* const b)
6181 {
6182     /* Return the intersection of two inversion lists.  The basis for this
6183      * comes from "Unicode Demystified" Chapter 13 by Richard Gillam, published
6184      * by Addison-Wesley, and explained at some length there.  The preface says
6185      * to incorporate its examples into your code at your own risk.  In fact,
6186      * it had bugs
6187      *
6188      * The algorithm is like a merge sort, and is essentially the same as the
6189      * union above
6190      */
6191
6192     UV* array_a = invlist_array(a);   /* a's array */
6193     UV* array_b = invlist_array(b);
6194     UV len_a = invlist_len(a);  /* length of a's array */
6195     UV len_b = invlist_len(b);
6196
6197     HV* r;                   /* the resulting intersection */
6198     UV* array_r;
6199     UV len_r;
6200
6201     UV i_a = 0;             /* current index into a's array */
6202     UV i_b = 0;
6203     UV i_r = 0;
6204
6205     /* running count, as explained in the algorithm source book; items are
6206      * stopped accumulating and are output when the count changes to/from 2.
6207      * The count is incremented when we start a range that's in the set, and
6208      * decremented when we start a range that's not in the set.  So its range
6209      * is 0 to 2.  Only when the count is 2 is something in the intersection.
6210      */
6211     UV count = 0;
6212
6213     PERL_ARGS_ASSERT_INVLIST_INTERSECTION;
6214
6215     /* Size the intersection for the worst case: that the intersection ends up
6216      * fragmenting everything to be completely disjoint */
6217     r= _new_invlist(len_a + len_b);
6218     array_r = invlist_array(r);
6219
6220     /* Go through each list item by item, stopping when exhausted one of
6221      * them */
6222     while (i_a < len_a && i_b < len_b) {
6223         UV cp;      /* The element to potentially add to the intersection's
6224                        array */
6225         bool cp_in_set; /* Is it in the input list's set or not */
6226
6227         /* We need to take one or the other of the two inputs for the
6228          * intersection.  Since we are merging two sorted lists, we take the
6229          * smaller of the next items.  In case of a tie, we take the one that
6230          * is not in its set first (a difference from the union algorithm).  If
6231          * we took one in the set first, it would increment the count, possibly
6232          * to 2 which would cause it to be output as starting a range in the
6233          * intersection, and the next time through we would take that same
6234          * number, and output it again as ending the set.  By doing it the
6235          * opposite of this, there is no possibility that the count will be
6236          * momentarily incremented to 2.  (In a tie and both are in the set or
6237          * both not in the set, it doesn't matter which we take first.) */
6238         if (array_a[i_a] < array_b[i_b]
6239             || (array_a[i_a] == array_b[i_b] && ! ELEMENT_IN_INVLIST_SET(i_a)))
6240         {
6241             cp_in_set = ELEMENT_IN_INVLIST_SET(i_a);
6242             cp= array_a[i_a++];
6243         }
6244         else {
6245             cp_in_set = ELEMENT_IN_INVLIST_SET(i_b);
6246             cp= array_b[i_b++];
6247         }
6248
6249         /* Here, have chosen which of the two inputs to look at.  Only output
6250          * if the running count changes to/from 2, which marks the
6251          * beginning/end of a range that's in the intersection */
6252         if (cp_in_set) {
6253             count++;
6254             if (count == 2) {
6255                 array_r[i_r++] = cp;
6256             }
6257         }
6258         else {
6259             if (count == 2) {
6260                 array_r[i_r++] = cp;
6261             }
6262             count--;
6263         }
6264     }
6265
6266     /* Here, we are finished going through at least one of the lists, which
6267      * means there is something remaining in at most one.  We check if the list
6268      * that has been exhausted is positioned such that we are in the middle
6269      * of a range in its set or not.  (i_a and i_b point to elements 1 beyond
6270      * the ones we care about.)  There are four cases:
6271      *  1) Both weren't in their sets, count is 0, and remains 0.  There's
6272      *     nothing left in the intersection.
6273      *  2) Both were in their sets, count is 2 and perhaps is incremented to
6274      *     above 2.  What should be output is exactly that which is in the
6275      *     non-exhausted set, as everything it has is also in the intersection
6276      *     set, and everything it doesn't have can't be in the intersection
6277      *  3) The exhausted was in its set, non-exhausted isn't, count is 1, and
6278      *     gets incremented to 2.  Like the previous case, the intersection is
6279      *     everything that remains in the non-exhausted set.
6280      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1, and
6281      *     remains 1.  And the intersection has nothing more. */
6282     if ((i_a == len_a && PREV_ELEMENT_IN_INVLIST_SET(i_a))
6283         || (i_b == len_b && PREV_ELEMENT_IN_INVLIST_SET(i_b)))
6284     {
6285         count++;
6286     }
6287
6288     /* The final length is what we've output so far plus what else is in the
6289      * intersection.  At most one of the subexpressions below will be non-zero */
6290     len_r = i_r;
6291     if (count >= 2) {
6292         len_r += (len_a - i_a) + (len_b - i_b);
6293     }
6294
6295     /* Set result to final length, which can change the pointer to array_r, so
6296      * re-find it */
6297     if (len_r != invlist_len(r)) {
6298         invlist_set_len(r, len_r);
6299         invlist_trim(r);
6300         array_r = invlist_array(r);
6301     }
6302
6303     /* Finish outputting any remaining */
6304     if (count >= 2) { /* At most one will have a non-zero copy count */
6305         IV copy_count;
6306         if ((copy_count = len_a - i_a) > 0) {
6307             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
6308         }
6309         else if ((copy_count = len_b - i_b) > 0) {
6310             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
6311         }
6312     }
6313
6314     return r;
6315 }
6316
6317 STATIC HV*
6318 S_add_range_to_invlist(pTHX_ HV* invlist, const UV start, const UV end)
6319 {
6320     /* Add the range from 'start' to 'end' inclusive to the inversion list's
6321      * set.  A pointer to the inversion list is returned.  This may actually be
6322      * a new list, in which case the passed in one has been destroyed.  The
6323      * passed in inversion list can be NULL, in which case a new one is created
6324      * with just the one range in it */
6325
6326     HV* range_invlist;
6327     HV* added_invlist;
6328     UV len;
6329
6330     if (invlist == NULL) {
6331         invlist = _new_invlist(2);
6332         len = 0;
6333     }
6334     else {
6335         len = invlist_len(invlist);
6336     }
6337
6338     /* If comes after the final entry, can just append it to the end */
6339     if (len == 0
6340         || start >= invlist_array(invlist)
6341                                     [invlist_len(invlist) - 1])
6342     {
6343         _append_range_to_invlist(invlist, start, end);
6344         return invlist;
6345     }
6346
6347     /* Here, can't just append things, create and return a new inversion list
6348      * which is the union of this range and the existing inversion list */
6349     range_invlist = _new_invlist(2);
6350     _append_range_to_invlist(range_invlist, start, end);
6351
6352     added_invlist = invlist_union(invlist, range_invlist);
6353
6354     /* The passed in list can be freed, as well as our temporary */
6355     invlist_destroy(range_invlist);
6356     if (invlist != added_invlist) {
6357         invlist_destroy(invlist);
6358     }
6359
6360     return added_invlist;
6361 }
6362
6363 PERL_STATIC_INLINE HV*
6364 S_add_cp_to_invlist(pTHX_ HV* invlist, const UV cp) {
6365     return add_range_to_invlist(invlist, cp, cp);
6366 }
6367
6368 /* End of inversion list object */
6369
6370 /*
6371  - reg - regular expression, i.e. main body or parenthesized thing
6372  *
6373  * Caller must absorb opening parenthesis.
6374  *
6375  * Combining parenthesis handling with the base level of regular expression
6376  * is a trifle forced, but the need to tie the tails of the branches to what
6377  * follows makes it hard to avoid.
6378  */
6379 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
6380 #ifdef DEBUGGING
6381 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
6382 #else
6383 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
6384 #endif
6385
6386 STATIC regnode *
6387 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
6388     /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
6389 {
6390     dVAR;
6391     register regnode *ret;              /* Will be the head of the group. */
6392     register regnode *br;
6393     register regnode *lastbr;
6394     register regnode *ender = NULL;
6395     register I32 parno = 0;
6396     I32 flags;
6397     U32 oregflags = RExC_flags;
6398     bool have_branch = 0;
6399     bool is_open = 0;
6400     I32 freeze_paren = 0;
6401     I32 after_freeze = 0;
6402
6403     /* for (?g), (?gc), and (?o) warnings; warning
6404        about (?c) will warn about (?g) -- japhy    */
6405
6406 #define WASTED_O  0x01
6407 #define WASTED_G  0x02
6408 #define WASTED_C  0x04
6409 #define WASTED_GC (0x02|0x04)
6410     I32 wastedflags = 0x00;
6411
6412     char * parse_start = RExC_parse; /* MJD */
6413     char * const oregcomp_parse = RExC_parse;
6414
6415     GET_RE_DEBUG_FLAGS_DECL;
6416
6417     PERL_ARGS_ASSERT_REG;
6418     DEBUG_PARSE("reg ");
6419
6420     *flagp = 0;                         /* Tentatively. */
6421
6422
6423     /* Make an OPEN node, if parenthesized. */
6424     if (paren) {
6425         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
6426             char *start_verb = RExC_parse;
6427             STRLEN verb_len = 0;
6428             char *start_arg = NULL;
6429             unsigned char op = 0;
6430             int argok = 1;
6431             int internal_argval = 0; /* internal_argval is only useful if !argok */
6432             while ( *RExC_parse && *RExC_parse != ')' ) {
6433                 if ( *RExC_parse == ':' ) {
6434                     start_arg = RExC_parse + 1;
6435                     break;
6436                 }
6437                 RExC_parse++;
6438             }
6439             ++start_verb;
6440             verb_len = RExC_parse - start_verb;
6441             if ( start_arg ) {
6442                 RExC_parse++;
6443                 while ( *RExC_parse && *RExC_parse != ')' ) 
6444                     RExC_parse++;
6445                 if ( *RExC_parse != ')' ) 
6446                     vFAIL("Unterminated verb pattern argument");
6447                 if ( RExC_parse == start_arg )
6448                     start_arg = NULL;
6449             } else {
6450                 if ( *RExC_parse != ')' )
6451                     vFAIL("Unterminated verb pattern");
6452             }
6453             
6454             switch ( *start_verb ) {
6455             case 'A':  /* (*ACCEPT) */
6456                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
6457                     op = ACCEPT;
6458                     internal_argval = RExC_nestroot;
6459                 }
6460                 break;
6461             case 'C':  /* (*COMMIT) */
6462                 if ( memEQs(start_verb,verb_len,"COMMIT") )
6463                     op = COMMIT;
6464                 break;
6465             case 'F':  /* (*FAIL) */
6466                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
6467                     op = OPFAIL;
6468                     argok = 0;
6469                 }
6470                 break;
6471             case ':':  /* (*:NAME) */
6472             case 'M':  /* (*MARK:NAME) */
6473                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
6474                     op = MARKPOINT;
6475                     argok = -1;
6476                 }
6477                 break;
6478             case 'P':  /* (*PRUNE) */
6479                 if ( memEQs(start_verb,verb_len,"PRUNE") )
6480                     op = PRUNE;
6481                 break;
6482             case 'S':   /* (*SKIP) */  
6483                 if ( memEQs(start_verb,verb_len,"SKIP") ) 
6484                     op = SKIP;
6485                 break;
6486             case 'T':  /* (*THEN) */
6487                 /* [19:06] <TimToady> :: is then */
6488                 if ( memEQs(start_verb,verb_len,"THEN") ) {
6489                     op = CUTGROUP;
6490                     RExC_seen |= REG_SEEN_CUTGROUP;
6491                 }
6492                 break;
6493             }
6494             if ( ! op ) {
6495                 RExC_parse++;
6496                 vFAIL3("Unknown verb pattern '%.*s'",
6497                     verb_len, start_verb);
6498             }
6499             if ( argok ) {
6500                 if ( start_arg && internal_argval ) {
6501                     vFAIL3("Verb pattern '%.*s' may not have an argument",
6502                         verb_len, start_verb); 
6503                 } else if ( argok < 0 && !start_arg ) {
6504                     vFAIL3("Verb pattern '%.*s' has a mandatory argument",
6505                         verb_len, start_verb);    
6506                 } else {
6507                     ret = reganode(pRExC_state, op, internal_argval);
6508                     if ( ! internal_argval && ! SIZE_ONLY ) {
6509                         if (start_arg) {
6510                             SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
6511                             ARG(ret) = add_data( pRExC_state, 1, "S" );
6512                             RExC_rxi->data->data[ARG(ret)]=(void*)sv;
6513                             ret->flags = 0;
6514                         } else {
6515                             ret->flags = 1; 
6516                         }
6517                     }               
6518                 }
6519                 if (!internal_argval)
6520                     RExC_seen |= REG_SEEN_VERBARG;
6521             } else if ( start_arg ) {
6522                 vFAIL3("Verb pattern '%.*s' may not have an argument",
6523                         verb_len, start_verb);    
6524             } else {
6525                 ret = reg_node(pRExC_state, op);
6526             }
6527             nextchar(pRExC_state);
6528             return ret;
6529         } else 
6530         if (*RExC_parse == '?') { /* (?...) */
6531             bool is_logical = 0;
6532             const char * const seqstart = RExC_parse;
6533             bool has_use_defaults = FALSE;
6534
6535             RExC_parse++;
6536             paren = *RExC_parse++;
6537             ret = NULL;                 /* For look-ahead/behind. */
6538             switch (paren) {
6539
6540             case 'P':   /* (?P...) variants for those used to PCRE/Python */
6541                 paren = *RExC_parse++;
6542                 if ( paren == '<')         /* (?P<...>) named capture */
6543                     goto named_capture;
6544                 else if (paren == '>') {   /* (?P>name) named recursion */
6545                     goto named_recursion;
6546                 }
6547                 else if (paren == '=') {   /* (?P=...)  named backref */
6548                     /* this pretty much dupes the code for \k<NAME> in regatom(), if
6549                        you change this make sure you change that */
6550                     char* name_start = RExC_parse;
6551                     U32 num = 0;
6552                     SV *sv_dat = reg_scan_name(pRExC_state,
6553                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6554                     if (RExC_parse == name_start || *RExC_parse != ')')
6555                         vFAIL2("Sequence %.3s... not terminated",parse_start);
6556
6557                     if (!SIZE_ONLY) {
6558                         num = add_data( pRExC_state, 1, "S" );
6559                         RExC_rxi->data->data[num]=(void*)sv_dat;
6560                         SvREFCNT_inc_simple_void(sv_dat);
6561                     }
6562                     RExC_sawback = 1;
6563                     ret = reganode(pRExC_state,
6564                                    ((! FOLD)
6565                                      ? NREF
6566                                      : (MORE_ASCII_RESTRICTED)
6567                                        ? NREFFA
6568                                        : (AT_LEAST_UNI_SEMANTICS)
6569                                          ? NREFFU
6570                                          : (LOC)
6571                                            ? NREFFL
6572                                            : NREFF),
6573                                     num);
6574                     *flagp |= HASWIDTH;
6575
6576                     Set_Node_Offset(ret, parse_start+1);
6577                     Set_Node_Cur_Length(ret); /* MJD */
6578
6579                     nextchar(pRExC_state);
6580                     return ret;
6581                 }
6582                 RExC_parse++;
6583                 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
6584                 /*NOTREACHED*/
6585             case '<':           /* (?<...) */
6586                 if (*RExC_parse == '!')
6587                     paren = ',';
6588                 else if (*RExC_parse != '=') 
6589               named_capture:
6590                 {               /* (?<...>) */
6591                     char *name_start;
6592                     SV *svname;
6593                     paren= '>';
6594             case '\'':          /* (?'...') */
6595                     name_start= RExC_parse;
6596                     svname = reg_scan_name(pRExC_state,
6597                         SIZE_ONLY ?  /* reverse test from the others */
6598                         REG_RSN_RETURN_NAME : 
6599                         REG_RSN_RETURN_NULL);
6600                     if (RExC_parse == name_start) {
6601                         RExC_parse++;
6602                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
6603                         /*NOTREACHED*/
6604                     }
6605                     if (*RExC_parse != paren)
6606                         vFAIL2("Sequence (?%c... not terminated",
6607                             paren=='>' ? '<' : paren);
6608                     if (SIZE_ONLY) {
6609                         HE *he_str;
6610                         SV *sv_dat = NULL;
6611                         if (!svname) /* shouldn't happen */
6612                             Perl_croak(aTHX_
6613                                 "panic: reg_scan_name returned NULL");
6614                         if (!RExC_paren_names) {
6615                             RExC_paren_names= newHV();
6616                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
6617 #ifdef DEBUGGING
6618                             RExC_paren_name_list= newAV();
6619                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
6620 #endif
6621                         }
6622                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
6623                         if ( he_str )
6624                             sv_dat = HeVAL(he_str);
6625                         if ( ! sv_dat ) {
6626                             /* croak baby croak */
6627                             Perl_croak(aTHX_
6628                                 "panic: paren_name hash element allocation failed");
6629                         } else if ( SvPOK(sv_dat) ) {
6630                             /* (?|...) can mean we have dupes so scan to check
6631                                its already been stored. Maybe a flag indicating
6632                                we are inside such a construct would be useful,
6633                                but the arrays are likely to be quite small, so
6634                                for now we punt -- dmq */
6635                             IV count = SvIV(sv_dat);
6636                             I32 *pv = (I32*)SvPVX(sv_dat);
6637                             IV i;
6638                             for ( i = 0 ; i < count ; i++ ) {
6639                                 if ( pv[i] == RExC_npar ) {
6640                                     count = 0;
6641                                     break;
6642                                 }
6643                             }
6644                             if ( count ) {
6645                                 pv = (I32*)SvGROW(sv_dat, SvCUR(sv_dat) + sizeof(I32)+1);
6646                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
6647                                 pv[count] = RExC_npar;
6648                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
6649                             }
6650                         } else {
6651                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
6652                             sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
6653                             SvIOK_on(sv_dat);
6654                             SvIV_set(sv_dat, 1);
6655                         }
6656 #ifdef DEBUGGING
6657                         /* Yes this does cause a memory leak in debugging Perls */
6658                         if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
6659                             SvREFCNT_dec(svname);
6660 #endif
6661
6662                         /*sv_dump(sv_dat);*/
6663                     }
6664                     nextchar(pRExC_state);
6665                     paren = 1;
6666                     goto capturing_parens;
6667                 }
6668                 RExC_seen |= REG_SEEN_LOOKBEHIND;
6669                 RExC_in_lookbehind++;
6670                 RExC_parse++;
6671             case '=':           /* (?=...) */
6672                 RExC_seen_zerolen++;
6673                 break;
6674             case '!':           /* (?!...) */
6675                 RExC_seen_zerolen++;
6676                 if (*RExC_parse == ')') {
6677                     ret=reg_node(pRExC_state, OPFAIL);
6678                     nextchar(pRExC_state);
6679                     return ret;
6680                 }
6681                 break;
6682             case '|':           /* (?|...) */
6683                 /* branch reset, behave like a (?:...) except that
6684                    buffers in alternations share the same numbers */
6685                 paren = ':'; 
6686                 after_freeze = freeze_paren = RExC_npar;
6687                 break;
6688             case ':':           /* (?:...) */
6689             case '>':           /* (?>...) */
6690                 break;
6691             case '$':           /* (?$...) */
6692             case '@':           /* (?@...) */
6693                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
6694                 break;
6695             case '#':           /* (?#...) */
6696                 while (*RExC_parse && *RExC_parse != ')')
6697                     RExC_parse++;
6698                 if (*RExC_parse != ')')
6699                     FAIL("Sequence (?#... not terminated");
6700                 nextchar(pRExC_state);
6701                 *flagp = TRYAGAIN;
6702                 return NULL;
6703             case '0' :           /* (?0) */
6704             case 'R' :           /* (?R) */
6705                 if (*RExC_parse != ')')
6706                     FAIL("Sequence (?R) not terminated");
6707                 ret = reg_node(pRExC_state, GOSTART);
6708                 *flagp |= POSTPONED;
6709                 nextchar(pRExC_state);
6710                 return ret;
6711                 /*notreached*/
6712             { /* named and numeric backreferences */
6713                 I32 num;
6714             case '&':            /* (?&NAME) */
6715                 parse_start = RExC_parse - 1;
6716               named_recursion:
6717                 {
6718                     SV *sv_dat = reg_scan_name(pRExC_state,
6719                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6720                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
6721                 }
6722                 goto gen_recurse_regop;
6723                 /* NOT REACHED */
6724             case '+':
6725                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
6726                     RExC_parse++;
6727                     vFAIL("Illegal pattern");
6728                 }
6729                 goto parse_recursion;
6730                 /* NOT REACHED*/
6731             case '-': /* (?-1) */
6732                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
6733                     RExC_parse--; /* rewind to let it be handled later */
6734                     goto parse_flags;
6735                 } 
6736                 /*FALLTHROUGH */
6737             case '1': case '2': case '3': case '4': /* (?1) */
6738             case '5': case '6': case '7': case '8': case '9':
6739                 RExC_parse--;
6740               parse_recursion:
6741                 num = atoi(RExC_parse);
6742                 parse_start = RExC_parse - 1; /* MJD */
6743                 if (*RExC_parse == '-')
6744                     RExC_parse++;
6745                 while (isDIGIT(*RExC_parse))
6746                         RExC_parse++;
6747                 if (*RExC_parse!=')') 
6748                     vFAIL("Expecting close bracket");
6749                         
6750               gen_recurse_regop:
6751                 if ( paren == '-' ) {
6752                     /*
6753                     Diagram of capture buffer numbering.
6754                     Top line is the normal capture buffer numbers
6755                     Bottom line is the negative indexing as from
6756                     the X (the (?-2))
6757
6758                     +   1 2    3 4 5 X          6 7
6759                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
6760                     -   5 4    3 2 1 X          x x
6761
6762                     */
6763                     num = RExC_npar + num;
6764                     if (num < 1)  {
6765                         RExC_parse++;
6766                         vFAIL("Reference to nonexistent group");
6767                     }
6768                 } else if ( paren == '+' ) {
6769                     num = RExC_npar + num - 1;
6770                 }
6771
6772                 ret = reganode(pRExC_state, GOSUB, num);
6773                 if (!SIZE_ONLY) {
6774                     if (num > (I32)RExC_rx->nparens) {
6775                         RExC_parse++;
6776                         vFAIL("Reference to nonexistent group");
6777                     }
6778                     ARG2L_SET( ret, RExC_recurse_count++);
6779                     RExC_emit++;
6780                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
6781                         "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
6782                 } else {
6783                     RExC_size++;
6784                 }
6785                 RExC_seen |= REG_SEEN_RECURSE;
6786                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
6787                 Set_Node_Offset(ret, parse_start); /* MJD */
6788
6789                 *flagp |= POSTPONED;
6790                 nextchar(pRExC_state);
6791                 return ret;
6792             } /* named and numeric backreferences */
6793             /* NOT REACHED */
6794
6795             case '?':           /* (??...) */
6796                 is_logical = 1;
6797                 if (*RExC_parse != '{') {
6798                     RExC_parse++;
6799                     vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
6800                     /*NOTREACHED*/
6801                 }
6802                 *flagp |= POSTPONED;
6803                 paren = *RExC_parse++;
6804                 /* FALL THROUGH */
6805             case '{':           /* (?{...}) */
6806             {
6807                 I32 count = 1;
6808                 U32 n = 0;
6809                 char c;
6810                 char *s = RExC_parse;
6811
6812                 RExC_seen_zerolen++;
6813                 RExC_seen |= REG_SEEN_EVAL;
6814                 while (count && (c = *RExC_parse)) {
6815                     if (c == '\\') {
6816                         if (RExC_parse[1])
6817                             RExC_parse++;
6818                     }
6819                     else if (c == '{')
6820                         count++;
6821                     else if (c == '}')
6822                         count--;
6823                     RExC_parse++;
6824                 }
6825                 if (*RExC_parse != ')') {
6826                     RExC_parse = s;             
6827                     vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
6828                 }
6829                 if (!SIZE_ONLY) {
6830                     PAD *pad;
6831                     OP_4tree *sop, *rop;
6832                     SV * const sv = newSVpvn(s, RExC_parse - 1 - s);
6833
6834                     ENTER;
6835                     Perl_save_re_context(aTHX);
6836                     rop = Perl_sv_compile_2op_is_broken(aTHX_ sv, &sop, "re", &pad);
6837                     sop->op_private |= OPpREFCOUNTED;
6838                     /* re_dup will OpREFCNT_inc */
6839                     OpREFCNT_set(sop, 1);
6840                     LEAVE;
6841
6842                     n = add_data(pRExC_state, 3, "nop");
6843                     RExC_rxi->data->data[n] = (void*)rop;
6844                     RExC_rxi->data->data[n+1] = (void*)sop;
6845                     RExC_rxi->data->data[n+2] = (void*)pad;
6846                     SvREFCNT_dec(sv);
6847                 }
6848                 else {                                          /* First pass */
6849                     if (PL_reginterp_cnt < ++RExC_seen_evals
6850                         && IN_PERL_RUNTIME)
6851                         /* No compiled RE interpolated, has runtime
6852                            components ===> unsafe.  */
6853                         FAIL("Eval-group not allowed at runtime, use re 'eval'");
6854                     if (PL_tainting && PL_tainted)
6855                         FAIL("Eval-group in insecure regular expression");
6856 #if PERL_VERSION > 8
6857                     if (IN_PERL_COMPILETIME)
6858                         PL_cv_has_eval = 1;
6859 #endif
6860                 }
6861
6862                 nextchar(pRExC_state);
6863                 if (is_logical) {
6864                     ret = reg_node(pRExC_state, LOGICAL);
6865                     if (!SIZE_ONLY)
6866                         ret->flags = 2;
6867                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
6868                     /* deal with the length of this later - MJD */
6869                     return ret;
6870                 }
6871                 ret = reganode(pRExC_state, EVAL, n);
6872                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
6873                 Set_Node_Offset(ret, parse_start);
6874                 return ret;
6875             }
6876             case '(':           /* (?(?{...})...) and (?(?=...)...) */
6877             {
6878                 int is_define= 0;
6879                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
6880                     if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
6881                         || RExC_parse[1] == '<'
6882                         || RExC_parse[1] == '{') { /* Lookahead or eval. */
6883                         I32 flag;
6884                         
6885                         ret = reg_node(pRExC_state, LOGICAL);
6886                         if (!SIZE_ONLY)
6887                             ret->flags = 1;
6888                         REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
6889                         goto insert_if;
6890                     }
6891                 }
6892                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
6893                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
6894                 {
6895                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
6896                     char *name_start= RExC_parse++;
6897                     U32 num = 0;
6898                     SV *sv_dat=reg_scan_name(pRExC_state,
6899                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6900                     if (RExC_parse == name_start || *RExC_parse != ch)
6901                         vFAIL2("Sequence (?(%c... not terminated",
6902                             (ch == '>' ? '<' : ch));
6903                     RExC_parse++;
6904                     if (!SIZE_ONLY) {
6905                         num = add_data( pRExC_state, 1, "S" );
6906                         RExC_rxi->data->data[num]=(void*)sv_dat;
6907                         SvREFCNT_inc_simple_void(sv_dat);
6908                     }
6909                     ret = reganode(pRExC_state,NGROUPP,num);
6910                     goto insert_if_check_paren;
6911                 }
6912                 else if (RExC_parse[0] == 'D' &&
6913                          RExC_parse[1] == 'E' &&
6914                          RExC_parse[2] == 'F' &&
6915                          RExC_parse[3] == 'I' &&
6916                          RExC_parse[4] == 'N' &&
6917                          RExC_parse[5] == 'E')
6918                 {
6919                     ret = reganode(pRExC_state,DEFINEP,0);
6920                     RExC_parse +=6 ;
6921                     is_define = 1;
6922                     goto insert_if_check_paren;
6923                 }
6924                 else if (RExC_parse[0] == 'R') {
6925                     RExC_parse++;
6926                     parno = 0;
6927                     if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
6928                         parno = atoi(RExC_parse++);
6929                         while (isDIGIT(*RExC_parse))
6930                             RExC_parse++;
6931                     } else if (RExC_parse[0] == '&') {
6932                         SV *sv_dat;
6933                         RExC_parse++;
6934                         sv_dat = reg_scan_name(pRExC_state,
6935                             SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6936                         parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
6937                     }
6938                     ret = reganode(pRExC_state,INSUBP,parno); 
6939                     goto insert_if_check_paren;
6940                 }
6941                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
6942                     /* (?(1)...) */
6943                     char c;
6944                     parno = atoi(RExC_parse++);
6945
6946                     while (isDIGIT(*RExC_parse))
6947                         RExC_parse++;
6948                     ret = reganode(pRExC_state, GROUPP, parno);
6949
6950                  insert_if_check_paren:
6951                     if ((c = *nextchar(pRExC_state)) != ')')
6952                         vFAIL("Switch condition not recognized");
6953                   insert_if:
6954                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
6955                     br = regbranch(pRExC_state, &flags, 1,depth+1);
6956                     if (br == NULL)
6957                         br = reganode(pRExC_state, LONGJMP, 0);
6958                     else
6959                         REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
6960                     c = *nextchar(pRExC_state);
6961                     if (flags&HASWIDTH)
6962                         *flagp |= HASWIDTH;
6963                     if (c == '|') {
6964                         if (is_define) 
6965                             vFAIL("(?(DEFINE)....) does not allow branches");
6966                         lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
6967                         regbranch(pRExC_state, &flags, 1,depth+1);
6968                         REGTAIL(pRExC_state, ret, lastbr);
6969                         if (flags&HASWIDTH)
6970                             *flagp |= HASWIDTH;
6971                         c = *nextchar(pRExC_state);
6972                     }
6973                     else
6974                         lastbr = NULL;
6975                     if (c != ')')
6976                         vFAIL("Switch (?(condition)... contains too many branches");
6977                     ender = reg_node(pRExC_state, TAIL);
6978                     REGTAIL(pRExC_state, br, ender);
6979                     if (lastbr) {
6980                         REGTAIL(pRExC_state, lastbr, ender);
6981                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
6982                     }
6983                     else
6984                         REGTAIL(pRExC_state, ret, ender);
6985                     RExC_size++; /* XXX WHY do we need this?!!
6986                                     For large programs it seems to be required
6987                                     but I can't figure out why. -- dmq*/
6988                     return ret;
6989                 }
6990                 else {
6991                     vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
6992                 }
6993             }
6994             case 0:
6995                 RExC_parse--; /* for vFAIL to print correctly */
6996                 vFAIL("Sequence (? incomplete");
6997                 break;
6998             case DEFAULT_PAT_MOD:   /* Use default flags with the exceptions
6999                                        that follow */
7000                 has_use_defaults = TRUE;
7001                 STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
7002                 set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
7003                                                 ? REGEX_UNICODE_CHARSET
7004                                                 : REGEX_DEPENDS_CHARSET);
7005                 goto parse_flags;
7006             default:
7007                 --RExC_parse;
7008                 parse_flags:      /* (?i) */  
7009             {
7010                 U32 posflags = 0, negflags = 0;
7011                 U32 *flagsp = &posflags;
7012                 char has_charset_modifier = '\0';
7013                 regex_charset cs = (RExC_utf8 || RExC_uni_semantics)
7014                                     ? REGEX_UNICODE_CHARSET
7015                                     : REGEX_DEPENDS_CHARSET;
7016
7017                 while (*RExC_parse) {
7018                     /* && strchr("iogcmsx", *RExC_parse) */
7019                     /* (?g), (?gc) and (?o) are useless here
7020                        and must be globally applied -- japhy */
7021                     switch (*RExC_parse) {
7022                     CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
7023                     case LOCALE_PAT_MOD:
7024                         if (has_charset_modifier) {
7025                             goto excess_modifier;
7026                         }
7027                         else if (flagsp == &negflags) {
7028                             goto neg_modifier;
7029                         }
7030                         cs = REGEX_LOCALE_CHARSET;
7031                         has_charset_modifier = LOCALE_PAT_MOD;
7032                         RExC_contains_locale = 1;
7033                         break;
7034                     case UNICODE_PAT_MOD:
7035                         if (has_charset_modifier) {
7036                             goto excess_modifier;
7037                         }
7038                         else if (flagsp == &negflags) {
7039                             goto neg_modifier;
7040                         }
7041                         cs = REGEX_UNICODE_CHARSET;
7042                         has_charset_modifier = UNICODE_PAT_MOD;
7043                         break;
7044                     case ASCII_RESTRICT_PAT_MOD:
7045                         if (flagsp == &negflags) {
7046                             goto neg_modifier;
7047                         }
7048                         if (has_charset_modifier) {
7049                             if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
7050                                 goto excess_modifier;
7051                             }
7052                             /* Doubled modifier implies more restricted */
7053                             cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
7054                         }
7055                         else {
7056                             cs = REGEX_ASCII_RESTRICTED_CHARSET;
7057                         }
7058                         has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
7059                         break;
7060                     case DEPENDS_PAT_MOD:
7061                         if (has_use_defaults) {
7062                             goto fail_modifiers;
7063                         }
7064                         else if (flagsp == &negflags) {
7065                             goto neg_modifier;
7066                         }
7067                         else if (has_charset_modifier) {
7068                             goto excess_modifier;
7069                         }
7070
7071                         /* The dual charset means unicode semantics if the
7072                          * pattern (or target, not known until runtime) are
7073                          * utf8, or something in the pattern indicates unicode
7074                          * semantics */
7075                         cs = (RExC_utf8 || RExC_uni_semantics)
7076                              ? REGEX_UNICODE_CHARSET
7077                              : REGEX_DEPENDS_CHARSET;
7078                         has_charset_modifier = DEPENDS_PAT_MOD;
7079                         break;
7080                     excess_modifier:
7081                         RExC_parse++;
7082                         if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
7083                             vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
7084                         }
7085                         else if (has_charset_modifier == *(RExC_parse - 1)) {
7086                             vFAIL2("Regexp modifier \"%c\" may not appear twice", *(RExC_parse - 1));
7087                         }
7088                         else {
7089                             vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
7090                         }
7091                         /*NOTREACHED*/
7092                     neg_modifier:
7093                         RExC_parse++;
7094                         vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", *(RExC_parse - 1));
7095                         /*NOTREACHED*/
7096                     case ONCE_PAT_MOD: /* 'o' */
7097                     case GLOBAL_PAT_MOD: /* 'g' */
7098                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
7099                             const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
7100                             if (! (wastedflags & wflagbit) ) {
7101                                 wastedflags |= wflagbit;
7102                                 vWARN5(
7103                                     RExC_parse + 1,
7104                                     "Useless (%s%c) - %suse /%c modifier",
7105                                     flagsp == &negflags ? "?-" : "?",
7106                                     *RExC_parse,
7107                                     flagsp == &negflags ? "don't " : "",
7108                                     *RExC_parse
7109                                 );
7110                             }
7111                         }
7112                         break;
7113                         
7114                     case CONTINUE_PAT_MOD: /* 'c' */
7115                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
7116                             if (! (wastedflags & WASTED_C) ) {
7117                                 wastedflags |= WASTED_GC;
7118                                 vWARN3(
7119                                     RExC_parse + 1,
7120                                     "Useless (%sc) - %suse /gc modifier",
7121                                     flagsp == &negflags ? "?-" : "?",
7122                                     flagsp == &negflags ? "don't " : ""
7123                                 );
7124                             }
7125                         }
7126                         break;
7127                     case KEEPCOPY_PAT_MOD: /* 'p' */
7128                         if (flagsp == &negflags) {
7129                             if (SIZE_ONLY)
7130                                 ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
7131                         } else {
7132                             *flagsp |= RXf_PMf_KEEPCOPY;
7133                         }
7134                         break;
7135                     case '-':
7136                         /* A flag is a default iff it is following a minus, so
7137                          * if there is a minus, it means will be trying to
7138                          * re-specify a default which is an error */
7139                         if (has_use_defaults || flagsp == &negflags) {
7140             fail_modifiers:
7141                             RExC_parse++;
7142                             vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7143                             /*NOTREACHED*/
7144                         }
7145                         flagsp = &negflags;
7146                         wastedflags = 0;  /* reset so (?g-c) warns twice */
7147                         break;
7148                     case ':':
7149                         paren = ':';
7150                         /*FALLTHROUGH*/
7151                     case ')':
7152                         RExC_flags |= posflags;
7153                         RExC_flags &= ~negflags;
7154                         set_regex_charset(&RExC_flags, cs);
7155                         if (paren != ':') {
7156                             oregflags |= posflags;
7157                             oregflags &= ~negflags;
7158                             set_regex_charset(&oregflags, cs);
7159                         }
7160                         nextchar(pRExC_state);
7161                         if (paren != ':') {
7162                             *flagp = TRYAGAIN;
7163                             return NULL;
7164                         } else {
7165                             ret = NULL;
7166                             goto parse_rest;
7167                         }
7168                         /*NOTREACHED*/
7169                     default:
7170                         RExC_parse++;
7171                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7172                         /*NOTREACHED*/
7173                     }                           
7174                     ++RExC_parse;
7175                 }
7176             }} /* one for the default block, one for the switch */
7177         }
7178         else {                  /* (...) */
7179           capturing_parens:
7180             parno = RExC_npar;
7181             RExC_npar++;
7182             
7183             ret = reganode(pRExC_state, OPEN, parno);
7184             if (!SIZE_ONLY ){
7185                 if (!RExC_nestroot) 
7186                     RExC_nestroot = parno;
7187                 if (RExC_seen & REG_SEEN_RECURSE
7188                     && !RExC_open_parens[parno-1])
7189                 {
7190                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
7191                         "Setting open paren #%"IVdf" to %d\n", 
7192                         (IV)parno, REG_NODE_NUM(ret)));
7193                     RExC_open_parens[parno-1]= ret;
7194                 }
7195             }
7196             Set_Node_Length(ret, 1); /* MJD */
7197             Set_Node_Offset(ret, RExC_parse); /* MJD */
7198             is_open = 1;
7199         }
7200     }
7201     else                        /* ! paren */
7202         ret = NULL;
7203    
7204    parse_rest:
7205     /* Pick up the branches, linking them together. */
7206     parse_start = RExC_parse;   /* MJD */
7207     br = regbranch(pRExC_state, &flags, 1,depth+1);
7208
7209     /*     branch_len = (paren != 0); */
7210
7211     if (br == NULL)
7212         return(NULL);
7213     if (*RExC_parse == '|') {
7214         if (!SIZE_ONLY && RExC_extralen) {
7215             reginsert(pRExC_state, BRANCHJ, br, depth+1);
7216         }
7217         else {                  /* MJD */
7218             reginsert(pRExC_state, BRANCH, br, depth+1);
7219             Set_Node_Length(br, paren != 0);
7220             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
7221         }
7222         have_branch = 1;
7223         if (SIZE_ONLY)
7224             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
7225     }
7226     else if (paren == ':') {
7227         *flagp |= flags&SIMPLE;
7228     }
7229     if (is_open) {                              /* Starts with OPEN. */
7230         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
7231     }
7232     else if (paren != '?')              /* Not Conditional */
7233         ret = br;
7234     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
7235     lastbr = br;
7236     while (*RExC_parse == '|') {
7237         if (!SIZE_ONLY && RExC_extralen) {
7238             ender = reganode(pRExC_state, LONGJMP,0);
7239             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
7240         }
7241         if (SIZE_ONLY)
7242             RExC_extralen += 2;         /* Account for LONGJMP. */
7243         nextchar(pRExC_state);
7244         if (freeze_paren) {
7245             if (RExC_npar > after_freeze)
7246                 after_freeze = RExC_npar;
7247             RExC_npar = freeze_paren;       
7248         }
7249         br = regbranch(pRExC_state, &flags, 0, depth+1);
7250
7251         if (br == NULL)
7252             return(NULL);
7253         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
7254         lastbr = br;
7255         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
7256     }
7257
7258     if (have_branch || paren != ':') {
7259         /* Make a closing node, and hook it on the end. */
7260         switch (paren) {
7261         case ':':
7262             ender = reg_node(pRExC_state, TAIL);
7263             break;
7264         case 1:
7265             ender = reganode(pRExC_state, CLOSE, parno);
7266             if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
7267                 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
7268                         "Setting close paren #%"IVdf" to %d\n", 
7269                         (IV)parno, REG_NODE_NUM(ender)));
7270                 RExC_close_parens[parno-1]= ender;
7271                 if (RExC_nestroot == parno) 
7272                     RExC_nestroot = 0;
7273             }       
7274             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
7275             Set_Node_Length(ender,1); /* MJD */
7276             break;
7277         case '<':
7278         case ',':
7279         case '=':
7280         case '!':
7281             *flagp &= ~HASWIDTH;
7282             /* FALL THROUGH */
7283         case '>':
7284             ender = reg_node(pRExC_state, SUCCEED);
7285             break;
7286         case 0:
7287             ender = reg_node(pRExC_state, END);
7288             if (!SIZE_ONLY) {
7289                 assert(!RExC_opend); /* there can only be one! */
7290                 RExC_opend = ender;
7291             }
7292             break;
7293         }
7294         REGTAIL(pRExC_state, lastbr, ender);
7295
7296         if (have_branch && !SIZE_ONLY) {
7297             if (depth==1)
7298                 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
7299
7300             /* Hook the tails of the branches to the closing node. */
7301             for (br = ret; br; br = regnext(br)) {
7302                 const U8 op = PL_regkind[OP(br)];
7303                 if (op == BRANCH) {
7304                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
7305                 }
7306                 else if (op == BRANCHJ) {
7307                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
7308                 }
7309             }
7310         }
7311     }
7312
7313     {
7314         const char *p;
7315         static const char parens[] = "=!<,>";
7316
7317         if (paren && (p = strchr(parens, paren))) {
7318             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
7319             int flag = (p - parens) > 1;
7320
7321             if (paren == '>')
7322                 node = SUSPEND, flag = 0;
7323             reginsert(pRExC_state, node,ret, depth+1);
7324             Set_Node_Cur_Length(ret);
7325             Set_Node_Offset(ret, parse_start + 1);
7326             ret->flags = flag;
7327             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
7328         }
7329     }
7330
7331     /* Check for proper termination. */
7332     if (paren) {
7333         RExC_flags = oregflags;
7334         if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
7335             RExC_parse = oregcomp_parse;
7336             vFAIL("Unmatched (");
7337         }
7338     }
7339     else if (!paren && RExC_parse < RExC_end) {
7340         if (*RExC_parse == ')') {
7341             RExC_parse++;
7342             vFAIL("Unmatched )");
7343         }
7344         else
7345             FAIL("Junk on end of regexp");      /* "Can't happen". */
7346         /* NOTREACHED */
7347     }
7348
7349     if (RExC_in_lookbehind) {
7350         RExC_in_lookbehind--;
7351     }
7352     if (after_freeze > RExC_npar)
7353         RExC_npar = after_freeze;
7354     return(ret);
7355 }
7356
7357 /*
7358  - regbranch - one alternative of an | operator
7359  *
7360  * Implements the concatenation operator.
7361  */
7362 STATIC regnode *
7363 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
7364 {
7365     dVAR;
7366     register regnode *ret;
7367     register regnode *chain = NULL;
7368     register regnode *latest;
7369     I32 flags = 0, c = 0;
7370     GET_RE_DEBUG_FLAGS_DECL;
7371
7372     PERL_ARGS_ASSERT_REGBRANCH;
7373
7374     DEBUG_PARSE("brnc");
7375
7376     if (first)
7377         ret = NULL;
7378     else {
7379         if (!SIZE_ONLY && RExC_extralen)
7380             ret = reganode(pRExC_state, BRANCHJ,0);
7381         else {
7382             ret = reg_node(pRExC_state, BRANCH);
7383             Set_Node_Length(ret, 1);
7384         }
7385     }
7386         
7387     if (!first && SIZE_ONLY)
7388         RExC_extralen += 1;                     /* BRANCHJ */
7389
7390     *flagp = WORST;                     /* Tentatively. */
7391
7392     RExC_parse--;
7393     nextchar(pRExC_state);
7394     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
7395         flags &= ~TRYAGAIN;
7396         latest = regpiece(pRExC_state, &flags,depth+1);
7397         if (latest == NULL) {
7398             if (flags & TRYAGAIN)
7399                 continue;
7400             return(NULL);
7401         }
7402         else if (ret == NULL)
7403             ret = latest;
7404         *flagp |= flags&(HASWIDTH|POSTPONED);
7405         if (chain == NULL)      /* First piece. */
7406             *flagp |= flags&SPSTART;
7407         else {
7408             RExC_naughty++;
7409             REGTAIL(pRExC_state, chain, latest);
7410         }
7411         chain = latest;
7412         c++;
7413     }
7414     if (chain == NULL) {        /* Loop ran zero times. */
7415         chain = reg_node(pRExC_state, NOTHING);
7416         if (ret == NULL)
7417             ret = chain;
7418     }
7419     if (c == 1) {
7420         *flagp |= flags&SIMPLE;
7421     }
7422
7423     return ret;
7424 }
7425
7426 /*
7427  - regpiece - something followed by possible [*+?]
7428  *
7429  * Note that the branching code sequences used for ? and the general cases
7430  * of * and + are somewhat optimized:  they use the same NOTHING node as
7431  * both the endmarker for their branch list and the body of the last branch.
7432  * It might seem that this node could be dispensed with entirely, but the
7433  * endmarker role is not redundant.
7434  */
7435 STATIC regnode *
7436 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
7437 {
7438     dVAR;
7439     register regnode *ret;
7440     register char op;
7441     register char *next;
7442     I32 flags;
7443     const char * const origparse = RExC_parse;
7444     I32 min;
7445     I32 max = REG_INFTY;
7446 #ifdef RE_TRACK_PATTERN_OFFSETS
7447     char *parse_start;
7448 #endif
7449     const char *maxpos = NULL;
7450     GET_RE_DEBUG_FLAGS_DECL;
7451
7452     PERL_ARGS_ASSERT_REGPIECE;
7453
7454     DEBUG_PARSE("piec");
7455
7456     ret = regatom(pRExC_state, &flags,depth+1);
7457     if (ret == NULL) {
7458         if (flags & TRYAGAIN)
7459             *flagp |= TRYAGAIN;
7460         return(NULL);
7461     }
7462
7463     op = *RExC_parse;
7464
7465     if (op == '{' && regcurly(RExC_parse)) {
7466         maxpos = NULL;
7467 #ifdef RE_TRACK_PATTERN_OFFSETS
7468         parse_start = RExC_parse; /* MJD */
7469 #endif
7470         next = RExC_parse + 1;
7471         while (isDIGIT(*next) || *next == ',') {
7472             if (*next == ',') {
7473                 if (maxpos)
7474                     break;
7475                 else
7476                     maxpos = next;
7477             }
7478             next++;
7479         }
7480         if (*next == '}') {             /* got one */
7481             if (!maxpos)
7482                 maxpos = next;
7483             RExC_parse++;
7484             min = atoi(RExC_parse);
7485             if (*maxpos == ',')
7486                 maxpos++;
7487             else
7488                 maxpos = RExC_parse;
7489             max = atoi(maxpos);
7490             if (!max && *maxpos != '0')
7491                 max = REG_INFTY;                /* meaning "infinity" */
7492             else if (max >= REG_INFTY)
7493                 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
7494             RExC_parse = next;
7495             nextchar(pRExC_state);
7496
7497         do_curly:
7498             if ((flags&SIMPLE)) {
7499                 RExC_naughty += 2 + RExC_naughty / 2;
7500                 reginsert(pRExC_state, CURLY, ret, depth+1);
7501                 Set_Node_Offset(ret, parse_start+1); /* MJD */
7502                 Set_Node_Cur_Length(ret);
7503             }
7504             else {
7505                 regnode * const w = reg_node(pRExC_state, WHILEM);
7506
7507                 w->flags = 0;
7508                 REGTAIL(pRExC_state, ret, w);
7509                 if (!SIZE_ONLY && RExC_extralen) {
7510                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
7511                     reginsert(pRExC_state, NOTHING,ret, depth+1);
7512                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
7513                 }
7514                 reginsert(pRExC_state, CURLYX,ret, depth+1);
7515                                 /* MJD hk */
7516                 Set_Node_Offset(ret, parse_start+1);
7517                 Set_Node_Length(ret,
7518                                 op == '{' ? (RExC_parse - parse_start) : 1);
7519
7520                 if (!SIZE_ONLY && RExC_extralen)
7521                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
7522                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
7523                 if (SIZE_ONLY)
7524                     RExC_whilem_seen++, RExC_extralen += 3;
7525                 RExC_naughty += 4 + RExC_naughty;       /* compound interest */
7526             }
7527             ret->flags = 0;
7528
7529             if (min > 0)
7530                 *flagp = WORST;
7531             if (max > 0)
7532                 *flagp |= HASWIDTH;
7533             if (max < min)
7534                 vFAIL("Can't do {n,m} with n > m");
7535             if (!SIZE_ONLY) {
7536                 ARG1_SET(ret, (U16)min);
7537                 ARG2_SET(ret, (U16)max);
7538             }
7539
7540             goto nest_check;
7541         }
7542     }
7543
7544     if (!ISMULT1(op)) {
7545         *flagp = flags;
7546         return(ret);
7547     }
7548
7549 #if 0                           /* Now runtime fix should be reliable. */
7550
7551     /* if this is reinstated, don't forget to put this back into perldiag:
7552
7553             =item Regexp *+ operand could be empty at {#} in regex m/%s/
7554
7555            (F) The part of the regexp subject to either the * or + quantifier
7556            could match an empty string. The {#} shows in the regular
7557            expression about where the problem was discovered.
7558
7559     */
7560
7561     if (!(flags&HASWIDTH) && op != '?')
7562       vFAIL("Regexp *+ operand could be empty");
7563 #endif
7564
7565 #ifdef RE_TRACK_PATTERN_OFFSETS
7566     parse_start = RExC_parse;
7567 #endif
7568     nextchar(pRExC_state);
7569
7570     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
7571
7572     if (op == '*' && (flags&SIMPLE)) {
7573         reginsert(pRExC_state, STAR, ret, depth+1);
7574         ret->flags = 0;
7575         RExC_naughty += 4;
7576     }
7577     else if (op == '*') {
7578         min = 0;
7579         goto do_curly;
7580     }
7581     else if (op == '+' && (flags&SIMPLE)) {
7582         reginsert(pRExC_state, PLUS, ret, depth+1);
7583         ret->flags = 0;
7584         RExC_naughty += 3;
7585     }
7586     else if (op == '+') {
7587         min = 1;
7588         goto do_curly;
7589     }
7590     else if (op == '?') {
7591         min = 0; max = 1;
7592         goto do_curly;
7593     }
7594   nest_check:
7595     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
7596         ckWARN3reg(RExC_parse,
7597                    "%.*s matches null string many times",
7598                    (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
7599                    origparse);
7600     }
7601
7602     if (RExC_parse < RExC_end && *RExC_parse == '?') {
7603         nextchar(pRExC_state);
7604         reginsert(pRExC_state, MINMOD, ret, depth+1);
7605         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
7606     }
7607 #ifndef REG_ALLOW_MINMOD_SUSPEND
7608     else
7609 #endif
7610     if (RExC_parse < RExC_end && *RExC_parse == '+') {
7611         regnode *ender;
7612         nextchar(pRExC_state);
7613         ender = reg_node(pRExC_state, SUCCEED);
7614         REGTAIL(pRExC_state, ret, ender);
7615         reginsert(pRExC_state, SUSPEND, ret, depth+1);
7616         ret->flags = 0;
7617         ender = reg_node(pRExC_state, TAIL);
7618         REGTAIL(pRExC_state, ret, ender);
7619         /*ret= ender;*/
7620     }
7621
7622     if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
7623         RExC_parse++;
7624         vFAIL("Nested quantifiers");
7625     }
7626
7627     return(ret);
7628 }
7629
7630
7631 /* reg_namedseq(pRExC_state,UVp, UV depth)
7632    
7633    This is expected to be called by a parser routine that has 
7634    recognized '\N' and needs to handle the rest. RExC_parse is
7635    expected to point at the first char following the N at the time
7636    of the call.
7637
7638    The \N may be inside (indicated by valuep not being NULL) or outside a
7639    character class.
7640
7641    \N may begin either a named sequence, or if outside a character class, mean
7642    to match a non-newline.  For non single-quoted regexes, the tokenizer has
7643    attempted to decide which, and in the case of a named sequence converted it
7644    into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...},
7645    where c1... are the characters in the sequence.  For single-quoted regexes,
7646    the tokenizer passes the \N sequence through unchanged; this code will not
7647    attempt to determine this nor expand those.  The net effect is that if the
7648    beginning of the passed-in pattern isn't '{U+' or there is no '}', it
7649    signals that this \N occurrence means to match a non-newline.
7650    
7651    Only the \N{U+...} form should occur in a character class, for the same
7652    reason that '.' inside a character class means to just match a period: it
7653    just doesn't make sense.
7654    
7655    If valuep is non-null then it is assumed that we are parsing inside 
7656    of a charclass definition and the first codepoint in the resolved
7657    string is returned via *valuep and the routine will return NULL. 
7658    In this mode if a multichar string is returned from the charnames 
7659    handler, a warning will be issued, and only the first char in the 
7660    sequence will be examined. If the string returned is zero length
7661    then the value of *valuep is undefined and NON-NULL will 
7662    be returned to indicate failure. (This will NOT be a valid pointer 
7663    to a regnode.)
7664    
7665    If valuep is null then it is assumed that we are parsing normal text and a
7666    new EXACT node is inserted into the program containing the resolved string,
7667    and a pointer to the new node is returned.  But if the string is zero length
7668    a NOTHING node is emitted instead.
7669
7670    On success RExC_parse is set to the char following the endbrace.
7671    Parsing failures will generate a fatal error via vFAIL(...)
7672  */
7673 STATIC regnode *
7674 S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep, I32 *flagp, U32 depth)
7675 {
7676     char * endbrace;    /* '}' following the name */
7677     regnode *ret = NULL;
7678     char* p;
7679
7680     GET_RE_DEBUG_FLAGS_DECL;
7681  
7682     PERL_ARGS_ASSERT_REG_NAMEDSEQ;
7683
7684     GET_RE_DEBUG_FLAGS;
7685
7686     /* The [^\n] meaning of \N ignores spaces and comments under the /x
7687      * modifier.  The other meaning does not */
7688     p = (RExC_flags & RXf_PMf_EXTENDED)
7689         ? regwhite( pRExC_state, RExC_parse )
7690         : RExC_parse;
7691    
7692     /* Disambiguate between \N meaning a named character versus \N meaning
7693      * [^\n].  The former is assumed when it can't be the latter. */
7694     if (*p != '{' || regcurly(p)) {
7695         RExC_parse = p;
7696         if (valuep) {
7697             /* no bare \N in a charclass */
7698             vFAIL("\\N in a character class must be a named character: \\N{...}");
7699         }
7700         nextchar(pRExC_state);
7701         ret = reg_node(pRExC_state, REG_ANY);
7702         *flagp |= HASWIDTH|SIMPLE;
7703         RExC_naughty++;
7704         RExC_parse--;
7705         Set_Node_Length(ret, 1); /* MJD */
7706         return ret;
7707     }
7708
7709     /* Here, we have decided it should be a named sequence */
7710
7711     /* The test above made sure that the next real character is a '{', but
7712      * under the /x modifier, it could be separated by space (or a comment and
7713      * \n) and this is not allowed (for consistency with \x{...} and the
7714      * tokenizer handling of \N{NAME}). */
7715     if (*RExC_parse != '{') {
7716         vFAIL("Missing braces on \\N{}");
7717     }
7718
7719     RExC_parse++;       /* Skip past the '{' */
7720
7721     if (! (endbrace = strchr(RExC_parse, '}')) /* no trailing brace */
7722         || ! (endbrace == RExC_parse            /* nothing between the {} */
7723               || (endbrace - RExC_parse >= 2    /* U+ (bad hex is checked below */
7724                   && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg) */
7725     {
7726         if (endbrace) RExC_parse = endbrace;    /* position msg's '<--HERE' */
7727         vFAIL("\\N{NAME} must be resolved by the lexer");
7728     }
7729
7730     if (endbrace == RExC_parse) {   /* empty: \N{} */
7731         if (! valuep) {
7732             RExC_parse = endbrace + 1;  
7733             return reg_node(pRExC_state,NOTHING);
7734         }
7735
7736         if (SIZE_ONLY) {
7737             ckWARNreg(RExC_parse,
7738                     "Ignoring zero length \\N{} in character class"
7739             );
7740             RExC_parse = endbrace + 1;  
7741         }
7742         *valuep = 0;
7743         return (regnode *) &RExC_parse; /* Invalid regnode pointer */
7744     }
7745
7746     REQUIRE_UTF8;       /* named sequences imply Unicode semantics */
7747     RExC_parse += 2;    /* Skip past the 'U+' */
7748
7749     if (valuep) {   /* In a bracketed char class */
7750         /* We only pay attention to the first char of 
7751         multichar strings being returned. I kinda wonder
7752         if this makes sense as it does change the behaviour
7753         from earlier versions, OTOH that behaviour was broken
7754         as well. XXX Solution is to recharacterize as
7755         [rest-of-class]|multi1|multi2... */
7756
7757         STRLEN length_of_hex;
7758         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
7759             | PERL_SCAN_DISALLOW_PREFIX
7760             | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
7761     
7762         char * endchar = RExC_parse + strcspn(RExC_parse, ".}");
7763         if (endchar < endbrace) {
7764             ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
7765         }
7766
7767         length_of_hex = (STRLEN)(endchar - RExC_parse);
7768         *valuep = grok_hex(RExC_parse, &length_of_hex, &flags, NULL);
7769
7770         /* The tokenizer should have guaranteed validity, but it's possible to
7771          * bypass it by using single quoting, so check */
7772         if (length_of_hex == 0
7773             || length_of_hex != (STRLEN)(endchar - RExC_parse) )
7774         {
7775             RExC_parse += length_of_hex;        /* Includes all the valid */
7776             RExC_parse += (RExC_orig_utf8)      /* point to after 1st invalid */
7777                             ? UTF8SKIP(RExC_parse)
7778                             : 1;
7779             /* Guard against malformed utf8 */
7780             if (RExC_parse >= endchar) RExC_parse = endchar;
7781             vFAIL("Invalid hexadecimal number in \\N{U+...}");
7782         }    
7783
7784         RExC_parse = endbrace + 1;
7785         if (endchar == endbrace) return NULL;
7786
7787         ret = (regnode *) &RExC_parse;  /* Invalid regnode pointer */
7788     }
7789     else {      /* Not a char class */
7790
7791         /* What is done here is to convert this to a sub-pattern of the form
7792          * (?:\x{char1}\x{char2}...)
7793          * and then call reg recursively.  That way, it retains its atomicness,
7794          * while not having to worry about special handling that some code
7795          * points may have.  toke.c has converted the original Unicode values
7796          * to native, so that we can just pass on the hex values unchanged.  We
7797          * do have to set a flag to keep recoding from happening in the
7798          * recursion */
7799
7800         SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP);
7801         STRLEN len;
7802         char *endchar;      /* Points to '.' or '}' ending cur char in the input
7803                                stream */
7804         char *orig_end = RExC_end;
7805
7806         while (RExC_parse < endbrace) {
7807
7808             /* Code points are separated by dots.  If none, there is only one
7809              * code point, and is terminated by the brace */
7810             endchar = RExC_parse + strcspn(RExC_parse, ".}");
7811
7812             /* Convert to notation the rest of the code understands */
7813             sv_catpv(substitute_parse, "\\x{");
7814             sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
7815             sv_catpv(substitute_parse, "}");
7816
7817             /* Point to the beginning of the next character in the sequence. */
7818             RExC_parse = endchar + 1;
7819         }
7820         sv_catpv(substitute_parse, ")");
7821
7822         RExC_parse = SvPV(substitute_parse, len);
7823
7824         /* Don't allow empty number */
7825         if (len < 8) {
7826             vFAIL("Invalid hexadecimal number in \\N{U+...}");
7827         }
7828         RExC_end = RExC_parse + len;
7829
7830         /* The values are Unicode, and therefore not subject to recoding */
7831         RExC_override_recoding = 1;
7832
7833         ret = reg(pRExC_state, 1, flagp, depth+1);
7834
7835         RExC_parse = endbrace;
7836         RExC_end = orig_end;
7837         RExC_override_recoding = 0;
7838
7839         nextchar(pRExC_state);
7840     }
7841
7842     return ret;
7843 }
7844
7845
7846 /*
7847  * reg_recode
7848  *
7849  * It returns the code point in utf8 for the value in *encp.
7850  *    value: a code value in the source encoding
7851  *    encp:  a pointer to an Encode object
7852  *
7853  * If the result from Encode is not a single character,
7854  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
7855  */
7856 STATIC UV
7857 S_reg_recode(pTHX_ const char value, SV **encp)
7858 {
7859     STRLEN numlen = 1;
7860     SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP);
7861     const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
7862     const STRLEN newlen = SvCUR(sv);
7863     UV uv = UNICODE_REPLACEMENT;
7864
7865     PERL_ARGS_ASSERT_REG_RECODE;
7866
7867     if (newlen)
7868         uv = SvUTF8(sv)
7869              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
7870              : *(U8*)s;
7871
7872     if (!newlen || numlen != newlen) {
7873         uv = UNICODE_REPLACEMENT;
7874         *encp = NULL;
7875     }
7876     return uv;
7877 }
7878
7879
7880 /*
7881  - regatom - the lowest level
7882
7883    Try to identify anything special at the start of the pattern. If there
7884    is, then handle it as required. This may involve generating a single regop,
7885    such as for an assertion; or it may involve recursing, such as to
7886    handle a () structure.
7887
7888    If the string doesn't start with something special then we gobble up
7889    as much literal text as we can.
7890
7891    Once we have been able to handle whatever type of thing started the
7892    sequence, we return.
7893
7894    Note: we have to be careful with escapes, as they can be both literal
7895    and special, and in the case of \10 and friends can either, depending
7896    on context. Specifically there are two separate switches for handling
7897    escape sequences, with the one for handling literal escapes requiring
7898    a dummy entry for all of the special escapes that are actually handled
7899    by the other.
7900 */
7901
7902 STATIC regnode *
7903 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
7904 {
7905     dVAR;
7906     register regnode *ret = NULL;
7907     I32 flags;
7908     char *parse_start = RExC_parse;
7909     U8 op;
7910     GET_RE_DEBUG_FLAGS_DECL;
7911     DEBUG_PARSE("atom");
7912     *flagp = WORST;             /* Tentatively. */
7913
7914     PERL_ARGS_ASSERT_REGATOM;
7915
7916 tryagain:
7917     switch ((U8)*RExC_parse) {
7918     case '^':
7919         RExC_seen_zerolen++;
7920         nextchar(pRExC_state);
7921         if (RExC_flags & RXf_PMf_MULTILINE)
7922             ret = reg_node(pRExC_state, MBOL);
7923         else if (RExC_flags & RXf_PMf_SINGLELINE)
7924             ret = reg_node(pRExC_state, SBOL);
7925         else
7926             ret = reg_node(pRExC_state, BOL);
7927         Set_Node_Length(ret, 1); /* MJD */
7928         break;
7929     case '$':
7930         nextchar(pRExC_state);
7931         if (*RExC_parse)
7932             RExC_seen_zerolen++;
7933         if (RExC_flags & RXf_PMf_MULTILINE)
7934             ret = reg_node(pRExC_state, MEOL);
7935         else if (RExC_flags & RXf_PMf_SINGLELINE)
7936             ret = reg_node(pRExC_state, SEOL);
7937         else
7938             ret = reg_node(pRExC_state, EOL);
7939         Set_Node_Length(ret, 1); /* MJD */
7940         break;
7941     case '.':
7942         nextchar(pRExC_state);
7943         if (RExC_flags & RXf_PMf_SINGLELINE)
7944             ret = reg_node(pRExC_state, SANY);
7945         else
7946             ret = reg_node(pRExC_state, REG_ANY);
7947         *flagp |= HASWIDTH|SIMPLE;
7948         RExC_naughty++;
7949         Set_Node_Length(ret, 1); /* MJD */
7950         break;
7951     case '[':
7952     {
7953         char * const oregcomp_parse = ++RExC_parse;
7954         ret = regclass(pRExC_state,depth+1);
7955         if (*RExC_parse != ']') {
7956             RExC_parse = oregcomp_parse;
7957             vFAIL("Unmatched [");
7958         }
7959         nextchar(pRExC_state);
7960         *flagp |= HASWIDTH|SIMPLE;
7961         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
7962         break;
7963     }
7964     case '(':
7965         nextchar(pRExC_state);
7966         ret = reg(pRExC_state, 1, &flags,depth+1);
7967         if (ret == NULL) {
7968                 if (flags & TRYAGAIN) {
7969                     if (RExC_parse == RExC_end) {
7970                          /* Make parent create an empty node if needed. */
7971                         *flagp |= TRYAGAIN;
7972                         return(NULL);
7973                     }
7974                     goto tryagain;
7975                 }
7976                 return(NULL);
7977         }
7978         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
7979         break;
7980     case '|':
7981     case ')':
7982         if (flags & TRYAGAIN) {
7983             *flagp |= TRYAGAIN;
7984             return NULL;
7985         }
7986         vFAIL("Internal urp");
7987                                 /* Supposed to be caught earlier. */
7988         break;
7989     case '{':
7990         if (!regcurly(RExC_parse)) {
7991             RExC_parse++;
7992             goto defchar;
7993         }
7994         /* FALL THROUGH */
7995     case '?':
7996     case '+':
7997     case '*':
7998         RExC_parse++;
7999         vFAIL("Quantifier follows nothing");
8000         break;
8001     case '\\':
8002         /* Special Escapes
8003
8004            This switch handles escape sequences that resolve to some kind
8005            of special regop and not to literal text. Escape sequnces that
8006            resolve to literal text are handled below in the switch marked
8007            "Literal Escapes".
8008
8009            Every entry in this switch *must* have a corresponding entry
8010            in the literal escape switch. However, the opposite is not
8011            required, as the default for this switch is to jump to the
8012            literal text handling code.
8013         */
8014         switch ((U8)*++RExC_parse) {
8015         /* Special Escapes */
8016         case 'A':
8017             RExC_seen_zerolen++;
8018             ret = reg_node(pRExC_state, SBOL);
8019             *flagp |= SIMPLE;
8020             goto finish_meta_pat;
8021         case 'G':
8022             ret = reg_node(pRExC_state, GPOS);
8023             RExC_seen |= REG_SEEN_GPOS;
8024             *flagp |= SIMPLE;
8025             goto finish_meta_pat;
8026         case 'K':
8027             RExC_seen_zerolen++;
8028             ret = reg_node(pRExC_state, KEEPS);
8029             *flagp |= SIMPLE;
8030             /* XXX:dmq : disabling in-place substitution seems to
8031              * be necessary here to avoid cases of memory corruption, as
8032              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
8033              */
8034             RExC_seen |= REG_SEEN_LOOKBEHIND;
8035             goto finish_meta_pat;
8036         case 'Z':
8037             ret = reg_node(pRExC_state, SEOL);
8038             *flagp |= SIMPLE;
8039             RExC_seen_zerolen++;                /* Do not optimize RE away */
8040             goto finish_meta_pat;
8041         case 'z':
8042             ret = reg_node(pRExC_state, EOS);
8043             *flagp |= SIMPLE;
8044             RExC_seen_zerolen++;                /* Do not optimize RE away */
8045             goto finish_meta_pat;
8046         case 'C':
8047             ret = reg_node(pRExC_state, CANY);
8048             RExC_seen |= REG_SEEN_CANY;
8049             *flagp |= HASWIDTH|SIMPLE;
8050             goto finish_meta_pat;
8051         case 'X':
8052             ret = reg_node(pRExC_state, CLUMP);
8053             *flagp |= HASWIDTH;
8054             goto finish_meta_pat;
8055         case 'w':
8056             switch (get_regex_charset(RExC_flags)) {
8057                 case REGEX_LOCALE_CHARSET:
8058                     op = ALNUML;
8059                     break;
8060                 case REGEX_UNICODE_CHARSET:
8061                     op = ALNUMU;
8062                     break;
8063                 case REGEX_ASCII_RESTRICTED_CHARSET:
8064                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8065                     op = ALNUMA;
8066                     break;
8067                 case REGEX_DEPENDS_CHARSET:
8068                     op = ALNUM;
8069                     break;
8070                 default:
8071                     goto bad_charset;
8072             }
8073             ret = reg_node(pRExC_state, op);
8074             *flagp |= HASWIDTH|SIMPLE;
8075             goto finish_meta_pat;
8076         case 'W':
8077             switch (get_regex_charset(RExC_flags)) {
8078                 case REGEX_LOCALE_CHARSET:
8079                     op = NALNUML;
8080                     break;
8081                 case REGEX_UNICODE_CHARSET:
8082                     op = NALNUMU;
8083                     break;
8084                 case REGEX_ASCII_RESTRICTED_CHARSET:
8085                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8086                     op = NALNUMA;
8087                     break;
8088                 case REGEX_DEPENDS_CHARSET:
8089                     op = NALNUM;
8090                     break;
8091                 default:
8092                     goto bad_charset;
8093             }
8094             ret = reg_node(pRExC_state, op);
8095             *flagp |= HASWIDTH|SIMPLE;
8096             goto finish_meta_pat;
8097         case 'b':
8098             RExC_seen_zerolen++;
8099             RExC_seen |= REG_SEEN_LOOKBEHIND;
8100             switch (get_regex_charset(RExC_flags)) {
8101                 case REGEX_LOCALE_CHARSET:
8102                     op = BOUNDL;
8103                     break;
8104                 case REGEX_UNICODE_CHARSET:
8105                     op = BOUNDU;
8106                     break;
8107                 case REGEX_ASCII_RESTRICTED_CHARSET:
8108                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8109                     op = BOUNDA;
8110                     break;
8111                 case REGEX_DEPENDS_CHARSET:
8112                     op = BOUND;
8113                     break;
8114                 default:
8115                     goto bad_charset;
8116             }
8117             ret = reg_node(pRExC_state, op);
8118             FLAGS(ret) = get_regex_charset(RExC_flags);
8119             *flagp |= SIMPLE;
8120             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
8121                 ckWARNregdep(RExC_parse, "\"\\b{\" is deprecated; use \"\\b\\{\" instead");
8122             }
8123             goto finish_meta_pat;
8124         case 'B':
8125             RExC_seen_zerolen++;
8126             RExC_seen |= REG_SEEN_LOOKBEHIND;
8127             switch (get_regex_charset(RExC_flags)) {
8128                 case REGEX_LOCALE_CHARSET:
8129                     op = NBOUNDL;
8130                     break;
8131                 case REGEX_UNICODE_CHARSET:
8132                     op = NBOUNDU;
8133                     break;
8134                 case REGEX_ASCII_RESTRICTED_CHARSET:
8135                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8136                     op = NBOUNDA;
8137                     break;
8138                 case REGEX_DEPENDS_CHARSET:
8139                     op = NBOUND;
8140                     break;
8141                 default:
8142                     goto bad_charset;
8143             }
8144             ret = reg_node(pRExC_state, op);
8145             FLAGS(ret) = get_regex_charset(RExC_flags);
8146             *flagp |= SIMPLE;
8147             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
8148                 ckWARNregdep(RExC_parse, "\"\\B{\" is deprecated; use \"\\B\\{\" instead");
8149             }
8150             goto finish_meta_pat;
8151         case 's':
8152             switch (get_regex_charset(RExC_flags)) {
8153                 case REGEX_LOCALE_CHARSET:
8154                     op = SPACEL;
8155                     break;
8156                 case REGEX_UNICODE_CHARSET:
8157                     op = SPACEU;
8158                     break;
8159                 case REGEX_ASCII_RESTRICTED_CHARSET:
8160                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8161                     op = SPACEA;
8162                     break;
8163                 case REGEX_DEPENDS_CHARSET:
8164                     op = SPACE;
8165                     break;
8166                 default:
8167                     goto bad_charset;
8168             }
8169             ret = reg_node(pRExC_state, op);
8170             *flagp |= HASWIDTH|SIMPLE;
8171             goto finish_meta_pat;
8172         case 'S':
8173             switch (get_regex_charset(RExC_flags)) {
8174                 case REGEX_LOCALE_CHARSET:
8175                     op = NSPACEL;
8176                     break;
8177                 case REGEX_UNICODE_CHARSET:
8178                     op = NSPACEU;
8179                     break;
8180                 case REGEX_ASCII_RESTRICTED_CHARSET:
8181                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8182                     op = NSPACEA;
8183                     break;
8184                 case REGEX_DEPENDS_CHARSET:
8185                     op = NSPACE;
8186                     break;
8187                 default:
8188                     goto bad_charset;
8189             }
8190             ret = reg_node(pRExC_state, op);
8191             *flagp |= HASWIDTH|SIMPLE;
8192             goto finish_meta_pat;
8193         case 'd':
8194             switch (get_regex_charset(RExC_flags)) {
8195                 case REGEX_LOCALE_CHARSET:
8196                     op = DIGITL;
8197                     break;
8198                 case REGEX_ASCII_RESTRICTED_CHARSET:
8199                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8200                     op = DIGITA;
8201                     break;
8202                 case REGEX_DEPENDS_CHARSET: /* No difference between these */
8203                 case REGEX_UNICODE_CHARSET:
8204                     op = DIGIT;
8205                     break;
8206                 default:
8207                     goto bad_charset;
8208             }
8209             ret = reg_node(pRExC_state, op);
8210             *flagp |= HASWIDTH|SIMPLE;
8211             goto finish_meta_pat;
8212         case 'D':
8213             switch (get_regex_charset(RExC_flags)) {
8214                 case REGEX_LOCALE_CHARSET:
8215                     op = NDIGITL;
8216                     break;
8217                 case REGEX_ASCII_RESTRICTED_CHARSET:
8218                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8219                     op = NDIGITA;
8220                     break;
8221                 case REGEX_DEPENDS_CHARSET: /* No difference between these */
8222                 case REGEX_UNICODE_CHARSET:
8223                     op = NDIGIT;
8224                     break;
8225                 default:
8226                     goto bad_charset;
8227             }
8228             ret = reg_node(pRExC_state, op);
8229             *flagp |= HASWIDTH|SIMPLE;
8230             goto finish_meta_pat;
8231         case 'R':
8232             ret = reg_node(pRExC_state, LNBREAK);
8233             *flagp |= HASWIDTH|SIMPLE;
8234             goto finish_meta_pat;
8235         case 'h':
8236             ret = reg_node(pRExC_state, HORIZWS);
8237             *flagp |= HASWIDTH|SIMPLE;
8238             goto finish_meta_pat;
8239         case 'H':
8240             ret = reg_node(pRExC_state, NHORIZWS);
8241             *flagp |= HASWIDTH|SIMPLE;
8242             goto finish_meta_pat;
8243         case 'v':
8244             ret = reg_node(pRExC_state, VERTWS);
8245             *flagp |= HASWIDTH|SIMPLE;
8246             goto finish_meta_pat;
8247         case 'V':
8248             ret = reg_node(pRExC_state, NVERTWS);
8249             *flagp |= HASWIDTH|SIMPLE;
8250          finish_meta_pat:           
8251             nextchar(pRExC_state);
8252             Set_Node_Length(ret, 2); /* MJD */
8253             break;          
8254         case 'p':
8255         case 'P':
8256             {   
8257                 char* const oldregxend = RExC_end;
8258 #ifdef DEBUGGING
8259                 char* parse_start = RExC_parse - 2;
8260 #endif
8261
8262                 if (RExC_parse[1] == '{') {
8263                   /* a lovely hack--pretend we saw [\pX] instead */
8264                     RExC_end = strchr(RExC_parse, '}');
8265                     if (!RExC_end) {
8266                         const U8 c = (U8)*RExC_parse;
8267                         RExC_parse += 2;
8268                         RExC_end = oldregxend;
8269                         vFAIL2("Missing right brace on \\%c{}", c);
8270                     }
8271                     RExC_end++;
8272                 }
8273                 else {
8274                     RExC_end = RExC_parse + 2;
8275                     if (RExC_end > oldregxend)
8276                         RExC_end = oldregxend;
8277                 }
8278                 RExC_parse--;
8279
8280                 ret = regclass(pRExC_state,depth+1);
8281
8282                 RExC_end = oldregxend;
8283                 RExC_parse--;
8284
8285                 Set_Node_Offset(ret, parse_start + 2);
8286                 Set_Node_Cur_Length(ret);
8287                 nextchar(pRExC_state);
8288                 *flagp |= HASWIDTH|SIMPLE;
8289             }
8290             break;
8291         case 'N': 
8292             /* Handle \N and \N{NAME} here and not below because it can be
8293             multicharacter. join_exact() will join them up later on. 
8294             Also this makes sure that things like /\N{BLAH}+/ and 
8295             \N{BLAH} being multi char Just Happen. dmq*/
8296             ++RExC_parse;
8297             ret= reg_namedseq(pRExC_state, NULL, flagp, depth);
8298             break;
8299         case 'k':    /* Handle \k<NAME> and \k'NAME' */
8300         parse_named_seq:
8301         {   
8302             char ch= RExC_parse[1];         
8303             if (ch != '<' && ch != '\'' && ch != '{') {
8304                 RExC_parse++;
8305                 vFAIL2("Sequence %.2s... not terminated",parse_start);
8306             } else {
8307                 /* this pretty much dupes the code for (?P=...) in reg(), if
8308                    you change this make sure you change that */
8309                 char* name_start = (RExC_parse += 2);
8310                 U32 num = 0;
8311                 SV *sv_dat = reg_scan_name(pRExC_state,
8312                     SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8313                 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
8314                 if (RExC_parse == name_start || *RExC_parse != ch)
8315                     vFAIL2("Sequence %.3s... not terminated",parse_start);
8316
8317                 if (!SIZE_ONLY) {
8318                     num = add_data( pRExC_state, 1, "S" );
8319                     RExC_rxi->data->data[num]=(void*)sv_dat;
8320                     SvREFCNT_inc_simple_void(sv_dat);
8321                 }
8322
8323                 RExC_sawback = 1;
8324                 ret = reganode(pRExC_state,
8325                                ((! FOLD)
8326                                  ? NREF
8327                                  : (MORE_ASCII_RESTRICTED)
8328                                    ? NREFFA
8329                                    : (AT_LEAST_UNI_SEMANTICS)
8330                                      ? NREFFU
8331                                      : (LOC)
8332                                        ? NREFFL
8333                                        : NREFF),
8334                                 num);
8335                 *flagp |= HASWIDTH;
8336
8337                 /* override incorrect value set in reganode MJD */
8338                 Set_Node_Offset(ret, parse_start+1);
8339                 Set_Node_Cur_Length(ret); /* MJD */
8340                 nextchar(pRExC_state);
8341
8342             }
8343             break;
8344         }
8345         case 'g': 
8346         case '1': case '2': case '3': case '4':
8347         case '5': case '6': case '7': case '8': case '9':
8348             {
8349                 I32 num;
8350                 bool isg = *RExC_parse == 'g';
8351                 bool isrel = 0; 
8352                 bool hasbrace = 0;
8353                 if (isg) {
8354                     RExC_parse++;
8355                     if (*RExC_parse == '{') {
8356                         RExC_parse++;
8357                         hasbrace = 1;
8358                     }
8359                     if (*RExC_parse == '-') {
8360                         RExC_parse++;
8361                         isrel = 1;
8362                     }
8363                     if (hasbrace && !isDIGIT(*RExC_parse)) {
8364                         if (isrel) RExC_parse--;
8365                         RExC_parse -= 2;                            
8366                         goto parse_named_seq;
8367                 }   }
8368                 num = atoi(RExC_parse);
8369                 if (isg && num == 0)
8370                     vFAIL("Reference to invalid group 0");
8371                 if (isrel) {
8372                     num = RExC_npar - num;
8373                     if (num < 1)
8374                         vFAIL("Reference to nonexistent or unclosed group");
8375                 }
8376                 if (!isg && num > 9 && num >= RExC_npar)
8377                     goto defchar;
8378                 else {
8379                     char * const parse_start = RExC_parse - 1; /* MJD */
8380                     while (isDIGIT(*RExC_parse))
8381                         RExC_parse++;
8382                     if (parse_start == RExC_parse - 1) 
8383                         vFAIL("Unterminated \\g... pattern");
8384                     if (hasbrace) {
8385                         if (*RExC_parse != '}') 
8386                             vFAIL("Unterminated \\g{...} pattern");
8387                         RExC_parse++;
8388                     }    
8389                     if (!SIZE_ONLY) {
8390                         if (num > (I32)RExC_rx->nparens)
8391                             vFAIL("Reference to nonexistent group");
8392                     }
8393                     RExC_sawback = 1;
8394                     ret = reganode(pRExC_state,
8395                                    ((! FOLD)
8396                                      ? REF
8397                                      : (MORE_ASCII_RESTRICTED)
8398                                        ? REFFA
8399                                        : (AT_LEAST_UNI_SEMANTICS)
8400                                          ? REFFU
8401                                          : (LOC)
8402                                            ? REFFL
8403                                            : REFF),
8404                                     num);
8405                     *flagp |= HASWIDTH;
8406
8407                     /* override incorrect value set in reganode MJD */
8408                     Set_Node_Offset(ret, parse_start+1);
8409                     Set_Node_Cur_Length(ret); /* MJD */
8410                     RExC_parse--;
8411                     nextchar(pRExC_state);
8412                 }
8413             }
8414             break;
8415         case '\0':
8416             if (RExC_parse >= RExC_end)
8417                 FAIL("Trailing \\");
8418             /* FALL THROUGH */
8419         default:
8420             /* Do not generate "unrecognized" warnings here, we fall
8421                back into the quick-grab loop below */
8422             parse_start--;
8423             goto defchar;
8424         }
8425         break;
8426
8427     case '#':
8428         if (RExC_flags & RXf_PMf_EXTENDED) {
8429             if ( reg_skipcomment( pRExC_state ) )
8430                 goto tryagain;
8431         }
8432         /* FALL THROUGH */
8433
8434     default:
8435
8436             parse_start = RExC_parse - 1;
8437
8438             RExC_parse++;
8439
8440         defchar: {
8441             typedef enum {
8442                 generic_char = 0,
8443                 char_s,
8444                 upsilon_1,
8445                 upsilon_2,
8446                 iota_1,
8447                 iota_2,
8448             } char_state;
8449             char_state latest_char_state = generic_char;
8450             register STRLEN len;
8451             register UV ender;
8452             register char *p;
8453             char *s;
8454             STRLEN foldlen;
8455             U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
8456             regnode * orig_emit;
8457
8458             ender = 0;
8459             orig_emit = RExC_emit; /* Save the original output node position in
8460                                       case we need to output a different node
8461                                       type */
8462             ret = reg_node(pRExC_state,
8463                            (U8) ((! FOLD) ? EXACT
8464                                           : (LOC)
8465                                              ? EXACTFL
8466                                              : (MORE_ASCII_RESTRICTED)
8467                                                ? EXACTFA
8468                                                : (AT_LEAST_UNI_SEMANTICS)
8469                                                  ? EXACTFU
8470                                                  : EXACTF)
8471                     );
8472             s = STRING(ret);
8473             for (len = 0, p = RExC_parse - 1;
8474               len < 127 && p < RExC_end;
8475               len++)
8476             {
8477                 char * const oldp = p;
8478
8479                 if (RExC_flags & RXf_PMf_EXTENDED)
8480                     p = regwhite( pRExC_state, p );
8481                 switch ((U8)*p) {
8482                 case '^':
8483                 case '$':
8484                 case '.':
8485                 case '[':
8486                 case '(':
8487                 case ')':
8488                 case '|':
8489                     goto loopdone;
8490                 case '\\':
8491                     /* Literal Escapes Switch
8492
8493                        This switch is meant to handle escape sequences that
8494                        resolve to a literal character.
8495
8496                        Every escape sequence that represents something
8497                        else, like an assertion or a char class, is handled
8498                        in the switch marked 'Special Escapes' above in this
8499                        routine, but also has an entry here as anything that
8500                        isn't explicitly mentioned here will be treated as
8501                        an unescaped equivalent literal.
8502                     */
8503
8504                     switch ((U8)*++p) {
8505                     /* These are all the special escapes. */
8506                     case 'A':             /* Start assertion */
8507                     case 'b': case 'B':   /* Word-boundary assertion*/
8508                     case 'C':             /* Single char !DANGEROUS! */
8509                     case 'd': case 'D':   /* digit class */
8510                     case 'g': case 'G':   /* generic-backref, pos assertion */
8511                     case 'h': case 'H':   /* HORIZWS */
8512                     case 'k': case 'K':   /* named backref, keep marker */
8513                     case 'N':             /* named char sequence */
8514                     case 'p': case 'P':   /* Unicode property */
8515                               case 'R':   /* LNBREAK */
8516                     case 's': case 'S':   /* space class */
8517                     case 'v': case 'V':   /* VERTWS */
8518                     case 'w': case 'W':   /* word class */
8519                     case 'X':             /* eXtended Unicode "combining character sequence" */
8520                     case 'z': case 'Z':   /* End of line/string assertion */
8521                         --p;
8522                         goto loopdone;
8523
8524                     /* Anything after here is an escape that resolves to a
8525                        literal. (Except digits, which may or may not)
8526                      */
8527                     case 'n':
8528                         ender = '\n';
8529                         p++;
8530                         break;
8531                     case 'r':
8532                         ender = '\r';
8533                         p++;
8534                         break;
8535                     case 't':
8536                         ender = '\t';
8537                         p++;
8538                         break;
8539                     case 'f':
8540                         ender = '\f';
8541                         p++;
8542                         break;
8543                     case 'e':
8544                           ender = ASCII_TO_NATIVE('\033');
8545                         p++;
8546                         break;
8547                     case 'a':
8548                           ender = ASCII_TO_NATIVE('\007');
8549                         p++;
8550                         break;
8551                     case 'o':
8552                         {
8553                             STRLEN brace_len = len;
8554                             UV result;
8555                             const char* error_msg;
8556
8557                             bool valid = grok_bslash_o(p,
8558                                                        &result,
8559                                                        &brace_len,
8560                                                        &error_msg,
8561                                                        1);
8562                             p += brace_len;
8563                             if (! valid) {
8564                                 RExC_parse = p; /* going to die anyway; point
8565                                                    to exact spot of failure */
8566                                 vFAIL(error_msg);
8567                             }
8568                             else
8569                             {
8570                                 ender = result;
8571                             }
8572                             if (PL_encoding && ender < 0x100) {
8573                                 goto recode_encoding;
8574                             }
8575                             if (ender > 0xff) {
8576                                 REQUIRE_UTF8;
8577                             }
8578                             break;
8579                         }
8580                     case 'x':
8581                         if (*++p == '{') {
8582                             char* const e = strchr(p, '}');
8583         
8584                             if (!e) {
8585                                 RExC_parse = p + 1;
8586                                 vFAIL("Missing right brace on \\x{}");
8587                             }
8588                             else {
8589                                 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
8590                                     | PERL_SCAN_DISALLOW_PREFIX;
8591                                 STRLEN numlen = e - p - 1;
8592                                 ender = grok_hex(p + 1, &numlen, &flags, NULL);
8593                                 if (ender > 0xff)
8594                                     REQUIRE_UTF8;
8595                                 p = e + 1;
8596                             }
8597                         }
8598                         else {
8599                             I32 flags = PERL_SCAN_DISALLOW_PREFIX;
8600                             STRLEN numlen = 2;
8601                             ender = grok_hex(p, &numlen, &flags, NULL);
8602                             p += numlen;
8603                         }
8604                         if (PL_encoding && ender < 0x100)
8605                             goto recode_encoding;
8606                         break;
8607                     case 'c':
8608                         p++;
8609                         ender = grok_bslash_c(*p++, UTF, SIZE_ONLY);
8610                         break;
8611                     case '0': case '1': case '2': case '3':case '4':
8612                     case '5': case '6': case '7': case '8':case '9':
8613                         if (*p == '0' ||
8614                             (isDIGIT(p[1]) && atoi(p) >= RExC_npar))
8615                         {
8616                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
8617                             STRLEN numlen = 3;
8618                             ender = grok_oct(p, &numlen, &flags, NULL);
8619                             if (ender > 0xff) {
8620                                 REQUIRE_UTF8;
8621                             }
8622                             p += numlen;
8623                         }
8624                         else {
8625                             --p;
8626                             goto loopdone;
8627                         }
8628                         if (PL_encoding && ender < 0x100)
8629                             goto recode_encoding;
8630                         break;
8631                     recode_encoding:
8632                         if (! RExC_override_recoding) {
8633                             SV* enc = PL_encoding;
8634                             ender = reg_recode((const char)(U8)ender, &enc);
8635                             if (!enc && SIZE_ONLY)
8636                                 ckWARNreg(p, "Invalid escape in the specified encoding");
8637                             REQUIRE_UTF8;
8638                         }
8639                         break;
8640                     case '\0':
8641                         if (p >= RExC_end)
8642                             FAIL("Trailing \\");
8643                         /* FALL THROUGH */
8644                     default:
8645                         if (!SIZE_ONLY&& isALPHA(*p)) {
8646                             /* Include any { following the alpha to emphasize
8647                              * that it could be part of an escape at some point
8648                              * in the future */
8649                             int len = (*(p + 1) == '{') ? 2 : 1;
8650                             ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
8651                         }
8652                         goto normal_default;
8653                     }
8654                     break;
8655                 default:
8656                   normal_default:
8657                     if (UTF8_IS_START(*p) && UTF) {
8658                         STRLEN numlen;
8659                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
8660                                                &numlen, UTF8_ALLOW_DEFAULT);
8661                         p += numlen;
8662                     }
8663                     else
8664                         ender = (U8) *p++;
8665                     break;
8666                 } /* End of switch on the literal */
8667
8668                 /* Certain characters are problematic because their folded
8669                  * length is so different from their original length that it
8670                  * isn't handleable by the optimizer.  They are therefore not
8671                  * placed in an EXACTish node; and are here handled specially.
8672                  * (Even if the optimizer handled LATIN_SMALL_LETTER_SHARP_S,
8673                  * putting it in a special node keeps regexec from having to
8674                  * deal with a non-utf8 multi-char fold */
8675                 if (FOLD
8676                     && (ender > 255 || (! MORE_ASCII_RESTRICTED && ! LOC)))
8677                 {
8678                     /* We look for either side of the fold.  For example \xDF
8679                      * folds to 'ss'.  We look for both the single character
8680                      * \xDF and the sequence 'ss'.  When we find something that
8681                      * could be one of those, we stop and flush whatever we
8682                      * have output so far into the EXACTish node that was being
8683                      * built.  Then restore the input pointer to what it was.
8684                      * regatom will return that EXACT node, and will be called
8685                      * again, positioned so the first character is the one in
8686                      * question, which we return in a different node type.
8687                      * The multi-char folds are a sequence, so the occurrence
8688                      * of the first character in that sequence doesn't
8689                      * necessarily mean that what follows is the rest of the
8690                      * sequence.  We keep track of that with a state machine,
8691                      * with the state being set to the latest character
8692                      * processed before the current one.  Most characters will
8693                      * set the state to 0, but if one occurs that is part of a
8694                      * potential tricky fold sequence, the state is set to that
8695                      * character, and the next loop iteration sees if the state
8696                      * should progress towards the final folded-from character,
8697                      * or if it was a false alarm.  If it turns out to be a
8698                      * false alarm, the character(s) will be output in a new
8699                      * EXACTish node, and join_exact() will later combine them.
8700                      * In the case of the 'ss' sequence, which is more common
8701                      * and more easily checked, some look-ahead is done to
8702                      * save time by ruling-out some false alarms */
8703                     switch (ender) {
8704                         default:
8705                             latest_char_state = generic_char;
8706                             break;
8707                         case 's':
8708                         case 'S':
8709                         case 0x17F: /* LATIN SMALL LETTER LONG S */
8710                              if (AT_LEAST_UNI_SEMANTICS) {
8711                                 if (latest_char_state == char_s) {  /* 'ss' */
8712                                     ender = LATIN_SMALL_LETTER_SHARP_S;
8713                                     goto do_tricky;
8714                                 }
8715                                 else if (p < RExC_end) {
8716
8717                                     /* Look-ahead at the next character.  If it
8718                                      * is also an s, we handle as a sharp s
8719                                      * tricky regnode.  */
8720                                     if (*p == 's' || *p == 'S') {
8721
8722                                         /* But first flush anything in the
8723                                          * EXACTish buffer */
8724                                         if (len != 0) {
8725                                             p = oldp;
8726                                             goto loopdone;
8727                                         }
8728                                         p++;    /* Account for swallowing this
8729                                                    's' up */
8730                                         ender = LATIN_SMALL_LETTER_SHARP_S;
8731                                         goto do_tricky;
8732                                     }
8733                                         /* Here, the next character is not a
8734                                          * literal 's', but still could
8735                                          * evaluate to one if part of a \o{},
8736                                          * \x or \OCTAL-DIGIT.  The minimum
8737                                          * length required for that is 4, eg
8738                                          * \x53 or \123 */
8739                                     else if (*p == '\\'
8740                                              && p < RExC_end - 4
8741                                              && (isDIGIT(*(p + 1))
8742                                                  || *(p + 1) == 'x'
8743                                                  || *(p + 1) == 'o' ))
8744                                     {
8745
8746                                         /* Here, it could be an 's', too much
8747                                          * bother to figure it out here.  Flush
8748                                          * the buffer if any; when come back
8749                                          * here, set the state so know that the
8750                                          * previous char was an 's' */
8751                                         if (len != 0) {
8752                                             latest_char_state = generic_char;
8753                                             p = oldp;
8754                                             goto loopdone;
8755                                         }
8756                                         latest_char_state = char_s;
8757                                         break;
8758                                     }
8759                                 }
8760                             }
8761
8762                             /* Here, can't be an 'ss' sequence, or at least not
8763                              * one that could fold to/from the sharp ss */
8764                             latest_char_state = generic_char;
8765                             break;
8766                         case 0x03C5:    /* First char in upsilon series */
8767                         case 0x03A5:    /* Also capital UPSILON, which folds to
8768                                            03C5, and hence exhibits the same
8769                                            problem */
8770                             if (p < RExC_end - 4) { /* Need >= 4 bytes left */
8771                                 latest_char_state = upsilon_1;
8772                                 if (len != 0) {
8773                                     p = oldp;
8774                                     goto loopdone;
8775                                 }
8776                             }
8777                             else {
8778                                 latest_char_state = generic_char;
8779                             }
8780                             break;
8781                         case 0x03B9:    /* First char in iota series */
8782                         case 0x0399:    /* Also capital IOTA */
8783                         case 0x1FBE:    /* GREEK PROSGEGRAMMENI folds to 3B9 */
8784                         case 0x0345:    /* COMBINING GREEK YPOGEGRAMMENI folds
8785                                            to 3B9 */
8786                             if (p < RExC_end - 4) {
8787                                 latest_char_state = iota_1;
8788                                 if (len != 0) {
8789                                     p = oldp;
8790                                     goto loopdone;
8791                                 }
8792                             }
8793                             else {
8794                                 latest_char_state = generic_char;
8795                             }
8796                             break;
8797                         case 0x0308:
8798                             if (latest_char_state == upsilon_1) {
8799                                 latest_char_state = upsilon_2;
8800                             }
8801                             else if (latest_char_state == iota_1) {
8802                                 latest_char_state = iota_2;
8803                             }
8804                             else {
8805                                 latest_char_state = generic_char;
8806                             }
8807                             break;
8808                         case 0x301:
8809                             if (latest_char_state == upsilon_2) {
8810                                 ender = GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS;
8811                                 goto do_tricky;
8812                             }
8813                             else if (latest_char_state == iota_2) {
8814                                 ender = GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS;
8815                                 goto do_tricky;
8816                             }
8817                             latest_char_state = generic_char;
8818                             break;
8819
8820                         /* These are the tricky fold characters.  Flush any
8821                          * buffer first. (When adding to this list, also should
8822                          * add them to fold_grind.t to make sure get tested) */
8823                         case GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS:
8824                         case GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS:
8825                         case LATIN_SMALL_LETTER_SHARP_S:
8826                         case LATIN_CAPITAL_LETTER_SHARP_S:
8827                         case 0x1FD3: /* GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA */
8828                         case 0x1FE3: /* GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA */
8829                             if (len != 0) {
8830                                 p = oldp;
8831                                 goto loopdone;
8832                             }
8833                             /* FALL THROUGH */
8834                         do_tricky: {
8835                             char* const oldregxend = RExC_end;
8836                             U8 tmpbuf[UTF8_MAXBYTES+1];
8837
8838                             /* Here, we know we need to generate a special
8839                              * regnode, and 'ender' contains the tricky
8840                              * character.  What's done is to pretend it's in a
8841                              * [bracketed] class, and let the code that deals
8842                              * with those handle it, as that code has all the
8843                              * intelligence necessary.  First save the current
8844                              * parse state, get rid of the already allocated
8845                              * but empty EXACT node that the ANYOFV node will
8846                              * replace, and point the parse to a buffer which
8847                              * we fill with the character we want the regclass
8848                              * code to think is being parsed */
8849                             RExC_emit = orig_emit;
8850                             RExC_parse = (char *) tmpbuf;
8851                             if (UTF) {
8852                                 U8 *d = uvchr_to_utf8(tmpbuf, ender);
8853                                 *d = '\0';
8854                                 RExC_end = (char *) d;
8855                             }
8856                             else {  /* ender above 255 already excluded */
8857                                 tmpbuf[0] = (U8) ender;
8858                                 tmpbuf[1] = '\0';
8859                                 RExC_end = RExC_parse + 1;
8860                             }
8861
8862                             ret = regclass(pRExC_state,depth+1);
8863
8864                             /* Here, have parsed the buffer.  Reset the parse to
8865                              * the actual input, and return */
8866                             RExC_end = oldregxend;
8867                             RExC_parse = p - 1;
8868
8869                             Set_Node_Offset(ret, RExC_parse);
8870                             Set_Node_Cur_Length(ret);
8871                             nextchar(pRExC_state);
8872                             *flagp |= HASWIDTH|SIMPLE;
8873                             return ret;
8874                         }
8875                     }
8876                 }
8877
8878                 if ( RExC_flags & RXf_PMf_EXTENDED)
8879                     p = regwhite( pRExC_state, p );
8880                 if (UTF && FOLD) {
8881                     /* Prime the casefolded buffer.  Locale rules, which apply
8882                      * only to code points < 256, aren't known until execution,
8883                      * so for them, just output the original character using
8884                      * utf8 */
8885                     if (LOC && ender < 256) {
8886                         if (UNI_IS_INVARIANT(ender)) {
8887                             *tmpbuf = (U8) ender;
8888                             foldlen = 1;
8889                         } else {
8890                             *tmpbuf = UTF8_TWO_BYTE_HI(ender);
8891                             *(tmpbuf + 1) = UTF8_TWO_BYTE_LO(ender);
8892                             foldlen = 2;
8893                         }
8894                     }
8895                     else if (isASCII(ender)) {  /* Note: Here can't also be LOC
8896                                                  */
8897                         ender = toLOWER(ender);
8898                         *tmpbuf = (U8) ender;
8899                         foldlen = 1;
8900                     }
8901                     else if (! MORE_ASCII_RESTRICTED && ! LOC) {
8902
8903                         /* Locale and /aa require more selectivity about the
8904                          * fold, so are handled below.  Otherwise, here, just
8905                          * use the fold */
8906                         ender = toFOLD_uni(ender, tmpbuf, &foldlen);
8907                     }
8908                     else {
8909                         /* Under locale rules or /aa we are not to mix,
8910                          * respectively, ords < 256 or ASCII with non-.  So
8911                          * reject folds that mix them, using only the
8912                          * non-folded code point.  So do the fold to a
8913                          * temporary, and inspect each character in it. */
8914                         U8 trialbuf[UTF8_MAXBYTES_CASE+1];
8915                         U8* s = trialbuf;
8916                         UV tmpender = toFOLD_uni(ender, trialbuf, &foldlen);
8917                         U8* e = s + foldlen;
8918                         bool fold_ok = TRUE;
8919
8920                         while (s < e) {
8921                             if (isASCII(*s)
8922                                 || (LOC && (UTF8_IS_INVARIANT(*s)
8923                                            || UTF8_IS_DOWNGRADEABLE_START(*s))))
8924                             {
8925                                 fold_ok = FALSE;
8926                                 break;
8927                             }
8928                             s += UTF8SKIP(s);
8929                         }
8930                         if (fold_ok) {
8931                             Copy(trialbuf, tmpbuf, foldlen, U8);
8932                             ender = tmpender;
8933                         }
8934                         else {
8935                             uvuni_to_utf8(tmpbuf, ender);
8936                             foldlen = UNISKIP(ender);
8937                         }
8938                     }
8939                 }
8940                 if (p < RExC_end && ISMULT2(p)) { /* Back off on ?+*. */
8941                     if (len)
8942                         p = oldp;
8943                     else if (UTF) {
8944                          if (FOLD) {
8945                               /* Emit all the Unicode characters. */
8946                               STRLEN numlen;
8947                               for (foldbuf = tmpbuf;
8948                                    foldlen;
8949                                    foldlen -= numlen) {
8950                                    ender = utf8_to_uvchr(foldbuf, &numlen);
8951                                    if (numlen > 0) {
8952                                         const STRLEN unilen = reguni(pRExC_state, ender, s);
8953                                         s       += unilen;
8954                                         len     += unilen;
8955                                         /* In EBCDIC the numlen
8956                                          * and unilen can differ. */
8957                                         foldbuf += numlen;
8958                                         if (numlen >= foldlen)
8959                                              break;
8960                                    }
8961                                    else
8962                                         break; /* "Can't happen." */
8963                               }
8964                          }
8965                          else {
8966                               const STRLEN unilen = reguni(pRExC_state, ender, s);
8967                               if (unilen > 0) {
8968                                    s   += unilen;
8969                                    len += unilen;
8970                               }
8971                          }
8972                     }
8973                     else {
8974                         len++;
8975                         REGC((char)ender, s++);
8976                     }
8977                     break;
8978                 }
8979                 if (UTF) {
8980                      if (FOLD) {
8981                           /* Emit all the Unicode characters. */
8982                           STRLEN numlen;
8983                           for (foldbuf = tmpbuf;
8984                                foldlen;
8985                                foldlen -= numlen) {
8986                                ender = utf8_to_uvchr(foldbuf, &numlen);
8987                                if (numlen > 0) {
8988                                     const STRLEN unilen = reguni(pRExC_state, ender, s);
8989                                     len     += unilen;
8990                                     s       += unilen;
8991                                     /* In EBCDIC the numlen
8992                                      * and unilen can differ. */
8993                                     foldbuf += numlen;
8994                                     if (numlen >= foldlen)
8995                                          break;
8996                                }
8997                                else
8998                                     break;
8999                           }
9000                      }
9001                      else {
9002                           const STRLEN unilen = reguni(pRExC_state, ender, s);
9003                           if (unilen > 0) {
9004                                s   += unilen;
9005                                len += unilen;
9006                           }
9007                      }
9008                      len--;
9009                 }
9010                 else {
9011                     REGC((char)ender, s++);
9012                 }
9013             }
9014         loopdone:   /* Jumped to when encounters something that shouldn't be in
9015                        the node */
9016             RExC_parse = p - 1;
9017             Set_Node_Cur_Length(ret); /* MJD */
9018             nextchar(pRExC_state);
9019             {
9020                 /* len is STRLEN which is unsigned, need to copy to signed */
9021                 IV iv = len;
9022                 if (iv < 0)
9023                     vFAIL("Internal disaster");
9024             }
9025             if (len > 0)
9026                 *flagp |= HASWIDTH;
9027             if (len == 1 && UNI_IS_INVARIANT(ender))
9028                 *flagp |= SIMPLE;
9029                 
9030             if (SIZE_ONLY)
9031                 RExC_size += STR_SZ(len);
9032             else {
9033                 STR_LEN(ret) = len;
9034                 RExC_emit += STR_SZ(len);
9035             }
9036         }
9037         break;
9038     }
9039
9040     return(ret);
9041
9042 /* Jumped to when an unrecognized character set is encountered */
9043 bad_charset:
9044     Perl_croak(aTHX_ "panic: Unknown regex character set encoding: %u", get_regex_charset(RExC_flags));
9045     return(NULL);
9046 }
9047
9048 STATIC char *
9049 S_regwhite( RExC_state_t *pRExC_state, char *p )
9050 {
9051     const char *e = RExC_end;
9052
9053     PERL_ARGS_ASSERT_REGWHITE;
9054
9055     while (p < e) {
9056         if (isSPACE(*p))
9057             ++p;
9058         else if (*p == '#') {
9059             bool ended = 0;
9060             do {
9061                 if (*p++ == '\n') {
9062                     ended = 1;
9063                     break;
9064                 }
9065             } while (p < e);
9066             if (!ended)
9067                 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
9068         }
9069         else
9070             break;
9071     }
9072     return p;
9073 }
9074
9075 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
9076    Character classes ([:foo:]) can also be negated ([:^foo:]).
9077    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
9078    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
9079    but trigger failures because they are currently unimplemented. */
9080
9081 #define POSIXCC_DONE(c)   ((c) == ':')
9082 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
9083 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
9084
9085 STATIC I32
9086 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
9087 {
9088     dVAR;
9089     I32 namedclass = OOB_NAMEDCLASS;
9090
9091     PERL_ARGS_ASSERT_REGPPOSIXCC;
9092
9093     if (value == '[' && RExC_parse + 1 < RExC_end &&
9094         /* I smell either [: or [= or [. -- POSIX has been here, right? */
9095         POSIXCC(UCHARAT(RExC_parse))) {
9096         const char c = UCHARAT(RExC_parse);
9097         char* const s = RExC_parse++;
9098         
9099         while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
9100             RExC_parse++;
9101         if (RExC_parse == RExC_end)
9102             /* Grandfather lone [:, [=, [. */
9103             RExC_parse = s;
9104         else {
9105             const char* const t = RExC_parse++; /* skip over the c */
9106             assert(*t == c);
9107
9108             if (UCHARAT(RExC_parse) == ']') {
9109                 const char *posixcc = s + 1;
9110                 RExC_parse++; /* skip over the ending ] */
9111
9112                 if (*s == ':') {
9113                     const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
9114                     const I32 skip = t - posixcc;
9115
9116                     /* Initially switch on the length of the name.  */
9117                     switch (skip) {
9118                     case 4:
9119                         if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
9120                             namedclass = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
9121                         break;
9122                     case 5:
9123                         /* Names all of length 5.  */
9124                         /* alnum alpha ascii blank cntrl digit graph lower
9125                            print punct space upper  */
9126                         /* Offset 4 gives the best switch position.  */
9127                         switch (posixcc[4]) {
9128                         case 'a':
9129                             if (memEQ(posixcc, "alph", 4)) /* alpha */
9130                                 namedclass = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
9131                             break;
9132                         case 'e':
9133                             if (memEQ(posixcc, "spac", 4)) /* space */
9134                                 namedclass = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
9135                             break;
9136                         case 'h':
9137                             if (memEQ(posixcc, "grap", 4)) /* graph */
9138                                 namedclass = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
9139                             break;
9140                         case 'i':
9141                             if (memEQ(posixcc, "asci", 4)) /* ascii */
9142                                 namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII;
9143                             break;
9144                         case 'k':
9145                             if (memEQ(posixcc, "blan", 4)) /* blank */
9146                                 namedclass = complement ? ANYOF_NBLANK : ANYOF_BLANK;
9147                             break;
9148                         case 'l':
9149                             if (memEQ(posixcc, "cntr", 4)) /* cntrl */
9150                                 namedclass = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
9151                             break;
9152                         case 'm':
9153                             if (memEQ(posixcc, "alnu", 4)) /* alnum */
9154                                 namedclass = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
9155                             break;
9156                         case 'r':
9157                             if (memEQ(posixcc, "lowe", 4)) /* lower */
9158                                 namedclass = complement ? ANYOF_NLOWER : ANYOF_LOWER;
9159                             else if (memEQ(posixcc, "uppe", 4)) /* upper */
9160                                 namedclass = complement ? ANYOF_NUPPER : ANYOF_UPPER;
9161                             break;
9162                         case 't':
9163                             if (memEQ(posixcc, "digi", 4)) /* digit */
9164                                 namedclass = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
9165                             else if (memEQ(posixcc, "prin", 4)) /* print */
9166                                 namedclass = complement ? ANYOF_NPRINT : ANYOF_PRINT;
9167                             else if (memEQ(posixcc, "punc", 4)) /* punct */
9168                                 namedclass = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
9169                             break;
9170                         }
9171                         break;
9172                     case 6:
9173                         if (memEQ(posixcc, "xdigit", 6))
9174                             namedclass = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
9175                         break;
9176                     }
9177
9178                     if (namedclass == OOB_NAMEDCLASS)
9179                         Simple_vFAIL3("POSIX class [:%.*s:] unknown",
9180                                       t - s - 1, s + 1);
9181                     assert (posixcc[skip] == ':');
9182                     assert (posixcc[skip+1] == ']');
9183                 } else if (!SIZE_ONLY) {
9184                     /* [[=foo=]] and [[.foo.]] are still future. */
9185
9186                     /* adjust RExC_parse so the warning shows after
9187                        the class closes */
9188                     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
9189                         RExC_parse++;
9190                     Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
9191                 }
9192             } else {
9193                 /* Maternal grandfather:
9194                  * "[:" ending in ":" but not in ":]" */
9195                 RExC_parse = s;
9196             }
9197         }
9198     }
9199
9200     return namedclass;
9201 }
9202
9203 STATIC void
9204 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
9205 {
9206     dVAR;
9207
9208     PERL_ARGS_ASSERT_CHECKPOSIXCC;
9209
9210     if (POSIXCC(UCHARAT(RExC_parse))) {
9211         const char *s = RExC_parse;
9212         const char  c = *s++;
9213
9214         while (isALNUM(*s))
9215             s++;
9216         if (*s && c == *s && s[1] == ']') {
9217             ckWARN3reg(s+2,
9218                        "POSIX syntax [%c %c] belongs inside character classes",
9219                        c, c);
9220
9221             /* [[=foo=]] and [[.foo.]] are still future. */
9222             if (POSIXCC_NOTYET(c)) {
9223                 /* adjust RExC_parse so the error shows after
9224                    the class closes */
9225                 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
9226                     NOOP;
9227                 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
9228             }
9229         }
9230     }
9231 }
9232
9233 /* No locale test, and always Unicode semantics */
9234 #define _C_C_T_NOLOC_(NAME,TEST,WORD)                                          \
9235 ANYOF_##NAME:                                                                  \
9236         for (value = 0; value < 256; value++)                                  \
9237             if (TEST)                                                          \
9238             stored += set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);  \
9239     yesno = '+';                                                               \
9240     what = WORD;                                                               \
9241     break;                                                                     \
9242 case ANYOF_N##NAME:                                                            \
9243         for (value = 0; value < 256; value++)                                  \
9244             if (!TEST)                                                         \
9245             stored += set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);  \
9246     yesno = '!';                                                               \
9247     what = WORD;                                                               \
9248     break
9249
9250 /* Like the above, but there are differences if we are in uni-8-bit or not, so
9251  * there are two tests passed in, to use depending on that. There aren't any
9252  * cases where the label is different from the name, so no need for that
9253  * parameter */
9254 #define _C_C_T_(NAME, TEST_8, TEST_7, WORD)                                    \
9255 ANYOF_##NAME:                                                                  \
9256     if (LOC) ANYOF_CLASS_SET(ret, ANYOF_##NAME);                               \
9257     else if (UNI_SEMANTICS) {                                                  \
9258         for (value = 0; value < 256; value++) {                                \
9259             if (TEST_8(value)) stored +=                                       \
9260                       set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);  \
9261         }                                                                      \
9262     }                                                                          \
9263     else {                                                                     \
9264         for (value = 0; value < 128; value++) {                                \
9265             if (TEST_7(UNI_TO_NATIVE(value))) stored +=                        \
9266                 set_regclass_bit(pRExC_state, ret,                     \
9267                                    (U8) UNI_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate);                 \
9268         }                                                                      \
9269     }                                                                          \
9270     yesno = '+';                                                               \
9271     what = WORD;                                                               \
9272     break;                                                                     \
9273 case ANYOF_N##NAME:                                                            \
9274     if (LOC) ANYOF_CLASS_SET(ret, ANYOF_N##NAME);                              \
9275     else if (UNI_SEMANTICS) {                                                  \
9276         for (value = 0; value < 256; value++) {                                \
9277             if (! TEST_8(value)) stored +=                                     \
9278                     set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);    \
9279         }                                                                      \
9280     }                                                                          \
9281     else {                                                                     \
9282         for (value = 0; value < 128; value++) {                                \
9283             if (! TEST_7(UNI_TO_NATIVE(value))) stored += set_regclass_bit(  \
9284                         pRExC_state, ret, (U8) UNI_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate);    \
9285         }                                                                      \
9286         if (AT_LEAST_ASCII_RESTRICTED) {                                       \
9287             for (value = 128; value < 256; value++) {                          \
9288              stored += set_regclass_bit(                                     \
9289                            pRExC_state, ret, (U8) UNI_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate); \
9290             }                                                                  \
9291             ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;                             \
9292         }                                                                      \
9293         else {                                                                 \
9294             /* For a non-ut8 target string with DEPENDS semantics, all above   \
9295              * ASCII Latin1 code points match the complement of any of the     \
9296              * classes.  But in utf8, they have their Unicode semantics, so    \
9297              * can't just set them in the bitmap, or else regexec.c will think \
9298              * they matched when they shouldn't. */                            \
9299             ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL;                     \
9300         }                                                                      \
9301     }                                                                          \
9302     yesno = '!';                                                               \
9303     what = WORD;                                                               \
9304     break
9305
9306 STATIC U8
9307 S_set_regclass_bit_fold(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, HV** invlist_ptr, AV** alternate_ptr)
9308 {
9309
9310     /* Handle the setting of folds in the bitmap for non-locale ANYOF nodes.
9311      * Locale folding is done at run-time, so this function should not be
9312      * called for nodes that are for locales.
9313      *
9314      * This function sets the bit corresponding to the fold of the input
9315      * 'value', if not already set.  The fold of 'f' is 'F', and the fold of
9316      * 'F' is 'f'.
9317      *
9318      * It also knows about the characters that are in the bitmap that have
9319      * folds that are matchable only outside it, and sets the appropriate lists
9320      * and flags.
9321      *
9322      * It returns the number of bits that actually changed from 0 to 1 */
9323
9324     U8 stored = 0;
9325     U8 fold;
9326
9327     PERL_ARGS_ASSERT_SET_REGCLASS_BIT_FOLD;
9328
9329     fold = (AT_LEAST_UNI_SEMANTICS) ? PL_fold_latin1[value]
9330                                     : PL_fold[value];
9331
9332     /* It assumes the bit for 'value' has already been set */
9333     if (fold != value && ! ANYOF_BITMAP_TEST(node, fold)) {
9334         ANYOF_BITMAP_SET(node, fold);
9335         stored++;
9336     }
9337     if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value) && (! isASCII(value) || ! MORE_ASCII_RESTRICTED)) {
9338         /* Certain Latin1 characters have matches outside the bitmap.  To get
9339          * here, 'value' is one of those characters.   None of these matches is
9340          * valid for ASCII characters under /aa, which have been excluded by
9341          * the 'if' above.  The matches fall into three categories:
9342          * 1) They are singly folded-to or -from an above 255 character, as
9343          *    LATIN SMALL LETTER Y WITH DIAERESIS and LATIN CAPITAL LETTER Y
9344          *    WITH DIAERESIS;
9345          * 2) They are part of a multi-char fold with another character in the
9346          *    bitmap, only LATIN SMALL LETTER SHARP S => "ss" fits that bill;
9347          * 3) They are part of a multi-char fold with a character not in the
9348          *    bitmap, such as various ligatures.
9349          * We aren't dealing fully with multi-char folds, except we do deal
9350          * with the pattern containing a character that has a multi-char fold
9351          * (not so much the inverse).
9352          * For types 1) and 3), the matches only happen when the target string
9353          * is utf8; that's not true for 2), and we set a flag for it.
9354          *
9355          * The code below adds to the passed in inversion list the single fold
9356          * closures for 'value'.  The values are hard-coded here so that an
9357          * innocent-looking character class, like /[ks]/i won't have to go out
9358          * to disk to find the possible matches.  XXX It would be better to
9359          * generate these via regen, in case a new version of the Unicode
9360          * standard adds new mappings, though that is not really likely. */
9361         switch (value) {
9362             case 'k':
9363             case 'K':
9364                 /* KELVIN SIGN */
9365                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212A);
9366                 break;
9367             case 's':
9368             case 'S':
9369                 /* LATIN SMALL LETTER LONG S */
9370                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x017F);
9371                 break;
9372             case MICRO_SIGN:
9373                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9374                                                  GREEK_SMALL_LETTER_MU);
9375                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9376                                                  GREEK_CAPITAL_LETTER_MU);
9377                 break;
9378             case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
9379             case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
9380                 /* ANGSTROM SIGN */
9381                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212B);
9382                 if (DEPENDS_SEMANTICS) {    /* See DEPENDS comment below */
9383                     *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9384                                                      PL_fold_latin1[value]);
9385                 }
9386                 break;
9387             case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
9388                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9389                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
9390                 break;
9391             case LATIN_SMALL_LETTER_SHARP_S:
9392                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9393                                         LATIN_CAPITAL_LETTER_SHARP_S);
9394
9395                 /* Under /a, /d, and /u, this can match the two chars "ss" */
9396                 if (! MORE_ASCII_RESTRICTED) {
9397                     add_alternate(alternate_ptr, (U8 *) "ss", 2);
9398
9399                     /* And under /u or /a, it can match even if the target is
9400                      * not utf8 */
9401                     if (AT_LEAST_UNI_SEMANTICS) {
9402                         ANYOF_FLAGS(node) |= ANYOF_NONBITMAP_NON_UTF8;
9403                     }
9404                 }
9405                 break;
9406             case 'F': case 'f':
9407             case 'I': case 'i':
9408             case 'L': case 'l':
9409             case 'T': case 't':
9410             case 'A': case 'a':
9411             case 'H': case 'h':
9412             case 'J': case 'j':
9413             case 'N': case 'n':
9414             case 'W': case 'w':
9415             case 'Y': case 'y':
9416                 /* These all are targets of multi-character folds from code
9417                  * points that require UTF8 to express, so they can't match
9418                  * unless the target string is in UTF-8, so no action here is
9419                  * necessary, as regexec.c properly handles the general case
9420                  * for UTF-8 matching */
9421                 break;
9422             default:
9423                 /* Use deprecated warning to increase the chances of this
9424                  * being output */
9425                 ckWARN2regdep(RExC_parse, "Perl folding rules are not up-to-date for 0x%x; please use the perlbug utility to report;", value);
9426                 break;
9427         }
9428     }
9429     else if (DEPENDS_SEMANTICS
9430             && ! isASCII(value)
9431             && PL_fold_latin1[value] != value)
9432     {
9433            /* Under DEPENDS rules, non-ASCII Latin1 characters match their
9434             * folds only when the target string is in UTF-8.  We add the fold
9435             * here to the list of things to match outside the bitmap, which
9436             * won't be looked at unless it is UTF8 (or else if something else
9437             * says to look even if not utf8, but those things better not happen
9438             * under DEPENDS semantics. */
9439         *invlist_ptr = add_cp_to_invlist(*invlist_ptr, PL_fold_latin1[value]);
9440     }
9441
9442     return stored;
9443 }
9444
9445
9446 PERL_STATIC_INLINE U8
9447 S_set_regclass_bit(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, HV** invlist_ptr, AV** alternate_ptr)
9448 {
9449     /* This inline function sets a bit in the bitmap if not already set, and if
9450      * appropriate, its fold, returning the number of bits that actually
9451      * changed from 0 to 1 */
9452
9453     U8 stored;
9454
9455     PERL_ARGS_ASSERT_SET_REGCLASS_BIT;
9456
9457     if (ANYOF_BITMAP_TEST(node, value)) {   /* Already set */
9458         return 0;
9459     }
9460
9461     ANYOF_BITMAP_SET(node, value);
9462     stored = 1;
9463
9464     if (FOLD && ! LOC) {        /* Locale folds aren't known until runtime */
9465         stored += set_regclass_bit_fold(pRExC_state, node, value, invlist_ptr, alternate_ptr);
9466     }
9467
9468     return stored;
9469 }
9470
9471 STATIC void
9472 S_add_alternate(pTHX_ AV** alternate_ptr, U8* string, STRLEN len)
9473 {
9474     /* Adds input 'string' with length 'len' to the ANYOF node's unicode
9475      * alternate list, pointed to by 'alternate_ptr'.  This is an array of
9476      * the multi-character folds of characters in the node */
9477     SV *sv;
9478
9479     PERL_ARGS_ASSERT_ADD_ALTERNATE;
9480
9481     if (! *alternate_ptr) {
9482         *alternate_ptr = newAV();
9483     }
9484     sv = newSVpvn_utf8((char*)string, len, TRUE);
9485     av_push(*alternate_ptr, sv);
9486     return;
9487 }
9488
9489 /*
9490    parse a class specification and produce either an ANYOF node that
9491    matches the pattern or perhaps will be optimized into an EXACTish node
9492    instead. The node contains a bit map for the first 256 characters, with the
9493    corresponding bit set if that character is in the list.  For characters
9494    above 255, a range list is used */
9495
9496 STATIC regnode *
9497 S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
9498 {
9499     dVAR;
9500     register UV nextvalue;
9501     register IV prevvalue = OOB_UNICODE;
9502     register IV range = 0;
9503     UV value = 0; /* XXX:dmq: needs to be referenceable (unfortunately) */
9504     register regnode *ret;
9505     STRLEN numlen;
9506     IV namedclass;
9507     char *rangebegin = NULL;
9508     bool need_class = 0;
9509     bool allow_full_fold = TRUE;   /* Assume wants multi-char folding */
9510     SV *listsv = NULL;
9511     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
9512                                       than just initialized.  */
9513     UV n;
9514
9515     /* code points this node matches that can't be stored in the bitmap */
9516     HV* nonbitmap = NULL;
9517
9518     /* The items that are to match that aren't stored in the bitmap, but are a
9519      * result of things that are stored there.  This is the fold closure of
9520      * such a character, either because it has DEPENDS semantics and shouldn't
9521      * be matched unless the target string is utf8, or is a code point that is
9522      * too large for the bit map, as for example, the fold of the MICRO SIGN is
9523      * above 255.  This all is solely for performance reasons.  By having this
9524      * code know the outside-the-bitmap folds that the bitmapped characters are
9525      * involved with, we don't have to go out to disk to find the list of
9526      * matches, unless the character class includes code points that aren't
9527      * storable in the bit map.  That means that a character class with an 's'
9528      * in it, for example, doesn't need to go out to disk to find everything
9529      * that matches.  A 2nd list is used so that the 'nonbitmap' list is kept
9530      * empty unless there is something whose fold we don't know about, and will
9531      * have to go out to the disk to find. */
9532     HV* l1_fold_invlist = NULL;
9533
9534     /* List of multi-character folds that are matched by this node */
9535     AV* unicode_alternate  = NULL;
9536 #ifdef EBCDIC
9537     UV literal_endpoint = 0;
9538 #endif
9539     UV stored = 0;  /* how many chars stored in the bitmap */
9540
9541     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
9542         case we need to change the emitted regop to an EXACT. */
9543     const char * orig_parse = RExC_parse;
9544     GET_RE_DEBUG_FLAGS_DECL;
9545
9546     PERL_ARGS_ASSERT_REGCLASS;
9547 #ifndef DEBUGGING
9548     PERL_UNUSED_ARG(depth);
9549 #endif
9550
9551     DEBUG_PARSE("clas");
9552
9553     /* Assume we are going to generate an ANYOF node. */
9554     ret = reganode(pRExC_state, ANYOF, 0);
9555
9556
9557     if (!SIZE_ONLY) {
9558         ANYOF_FLAGS(ret) = 0;
9559     }
9560
9561     if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
9562         RExC_naughty++;
9563         RExC_parse++;
9564         if (!SIZE_ONLY)
9565             ANYOF_FLAGS(ret) |= ANYOF_INVERT;
9566
9567         /* We have decided to not allow multi-char folds in inverted character
9568          * classes, due to the confusion that can happen, especially with
9569          * classes that are designed for a non-Unicode world:  You have the
9570          * peculiar case that:
9571             "s s" =~ /^[^\xDF]+$/i => Y
9572             "ss"  =~ /^[^\xDF]+$/i => N
9573          *
9574          * See [perl #89750] */
9575         allow_full_fold = FALSE;
9576     }
9577
9578     if (SIZE_ONLY) {
9579         RExC_size += ANYOF_SKIP;
9580         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
9581     }
9582     else {
9583         RExC_emit += ANYOF_SKIP;
9584         if (LOC) {
9585             ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
9586         }
9587         ANYOF_BITMAP_ZERO(ret);
9588         listsv = newSVpvs("# comment\n");
9589         initial_listsv_len = SvCUR(listsv);
9590     }
9591
9592     nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
9593
9594     if (!SIZE_ONLY && POSIXCC(nextvalue))
9595         checkposixcc(pRExC_state);
9596
9597     /* allow 1st char to be ] (allowing it to be - is dealt with later) */
9598     if (UCHARAT(RExC_parse) == ']')
9599         goto charclassloop;
9600
9601 parseit:
9602     while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
9603
9604     charclassloop:
9605
9606         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
9607
9608         if (!range)
9609             rangebegin = RExC_parse;
9610         if (UTF) {
9611             value = utf8n_to_uvchr((U8*)RExC_parse,
9612                                    RExC_end - RExC_parse,
9613                                    &numlen, UTF8_ALLOW_DEFAULT);
9614             RExC_parse += numlen;
9615         }
9616         else
9617             value = UCHARAT(RExC_parse++);
9618
9619         nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
9620         if (value == '[' && POSIXCC(nextvalue))
9621             namedclass = regpposixcc(pRExC_state, value);
9622         else if (value == '\\') {
9623             if (UTF) {
9624                 value = utf8n_to_uvchr((U8*)RExC_parse,
9625                                    RExC_end - RExC_parse,
9626                                    &numlen, UTF8_ALLOW_DEFAULT);
9627                 RExC_parse += numlen;
9628             }
9629             else
9630                 value = UCHARAT(RExC_parse++);
9631             /* Some compilers cannot handle switching on 64-bit integer
9632              * values, therefore value cannot be an UV.  Yes, this will
9633              * be a problem later if we want switch on Unicode.
9634              * A similar issue a little bit later when switching on
9635              * namedclass. --jhi */
9636             switch ((I32)value) {
9637             case 'w':   namedclass = ANYOF_ALNUM;       break;
9638             case 'W':   namedclass = ANYOF_NALNUM;      break;
9639             case 's':   namedclass = ANYOF_SPACE;       break;
9640             case 'S':   namedclass = ANYOF_NSPACE;      break;
9641             case 'd':   namedclass = ANYOF_DIGIT;       break;
9642             case 'D':   namedclass = ANYOF_NDIGIT;      break;
9643             case 'v':   namedclass = ANYOF_VERTWS;      break;
9644             case 'V':   namedclass = ANYOF_NVERTWS;     break;
9645             case 'h':   namedclass = ANYOF_HORIZWS;     break;
9646             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
9647             case 'N':  /* Handle \N{NAME} in class */
9648                 {
9649                     /* We only pay attention to the first char of 
9650                     multichar strings being returned. I kinda wonder
9651                     if this makes sense as it does change the behaviour
9652                     from earlier versions, OTOH that behaviour was broken
9653                     as well. */
9654                     UV v; /* value is register so we cant & it /grrr */
9655                     if (reg_namedseq(pRExC_state, &v, NULL, depth)) {
9656                         goto parseit;
9657                     }
9658                     value= v; 
9659                 }
9660                 break;
9661             case 'p':
9662             case 'P':
9663                 {
9664                 char *e;
9665                 if (RExC_parse >= RExC_end)
9666                     vFAIL2("Empty \\%c{}", (U8)value);
9667                 if (*RExC_parse == '{') {
9668                     const U8 c = (U8)value;
9669                     e = strchr(RExC_parse++, '}');
9670                     if (!e)
9671                         vFAIL2("Missing right brace on \\%c{}", c);
9672                     while (isSPACE(UCHARAT(RExC_parse)))
9673                         RExC_parse++;
9674                     if (e == RExC_parse)
9675                         vFAIL2("Empty \\%c{}", c);
9676                     n = e - RExC_parse;
9677                     while (isSPACE(UCHARAT(RExC_parse + n - 1)))
9678                         n--;
9679                 }
9680                 else {
9681                     e = RExC_parse;
9682                     n = 1;
9683                 }
9684                 if (!SIZE_ONLY) {
9685                     if (UCHARAT(RExC_parse) == '^') {
9686                          RExC_parse++;
9687                          n--;
9688                          value = value == 'p' ? 'P' : 'p'; /* toggle */
9689                          while (isSPACE(UCHARAT(RExC_parse))) {
9690                               RExC_parse++;
9691                               n--;
9692                          }
9693                     }
9694
9695                     /* Add the property name to the list.  If /i matching, give
9696                      * a different name which consists of the normal name
9697                      * sandwiched between two underscores and '_i'.  The design
9698                      * is discussed in the commit message for this. */
9699                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s%.*s%s\n",
9700                                         (value=='p' ? '+' : '!'),
9701                                         (FOLD) ? "__" : "",
9702                                         (int)n,
9703                                         RExC_parse,
9704                                         (FOLD) ? "_i" : ""
9705                                     );
9706                 }
9707                 RExC_parse = e + 1;
9708
9709                 /* The \p could match something in the Latin1 range, hence
9710                  * something that isn't utf8 */
9711                 ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
9712                 namedclass = ANYOF_MAX;  /* no official name, but it's named */
9713
9714                 /* \p means they want Unicode semantics */
9715                 RExC_uni_semantics = 1;
9716                 }
9717                 break;
9718             case 'n':   value = '\n';                   break;
9719             case 'r':   value = '\r';                   break;
9720             case 't':   value = '\t';                   break;
9721             case 'f':   value = '\f';                   break;
9722             case 'b':   value = '\b';                   break;
9723             case 'e':   value = ASCII_TO_NATIVE('\033');break;
9724             case 'a':   value = ASCII_TO_NATIVE('\007');break;
9725             case 'o':
9726                 RExC_parse--;   /* function expects to be pointed at the 'o' */
9727                 {
9728                     const char* error_msg;
9729                     bool valid = grok_bslash_o(RExC_parse,
9730                                                &value,
9731                                                &numlen,
9732                                                &error_msg,
9733                                                SIZE_ONLY);
9734                     RExC_parse += numlen;
9735                     if (! valid) {
9736                         vFAIL(error_msg);
9737                     }
9738                 }
9739                 if (PL_encoding && value < 0x100) {
9740                     goto recode_encoding;
9741                 }
9742                 break;
9743             case 'x':
9744                 if (*RExC_parse == '{') {
9745                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
9746                         | PERL_SCAN_DISALLOW_PREFIX;
9747                     char * const e = strchr(RExC_parse++, '}');
9748                     if (!e)
9749                         vFAIL("Missing right brace on \\x{}");
9750
9751                     numlen = e - RExC_parse;
9752                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
9753                     RExC_parse = e + 1;
9754                 }
9755                 else {
9756                     I32 flags = PERL_SCAN_DISALLOW_PREFIX;
9757                     numlen = 2;
9758                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
9759                     RExC_parse += numlen;
9760                 }
9761                 if (PL_encoding && value < 0x100)
9762                     goto recode_encoding;
9763                 break;
9764             case 'c':
9765                 value = grok_bslash_c(*RExC_parse++, UTF, SIZE_ONLY);
9766                 break;
9767             case '0': case '1': case '2': case '3': case '4':
9768             case '5': case '6': case '7':
9769                 {
9770                     /* Take 1-3 octal digits */
9771                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
9772                     numlen = 3;
9773                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
9774                     RExC_parse += numlen;
9775                     if (PL_encoding && value < 0x100)
9776                         goto recode_encoding;
9777                     break;
9778                 }
9779             recode_encoding:
9780                 if (! RExC_override_recoding) {
9781                     SV* enc = PL_encoding;
9782                     value = reg_recode((const char)(U8)value, &enc);
9783                     if (!enc && SIZE_ONLY)
9784                         ckWARNreg(RExC_parse,
9785                                   "Invalid escape in the specified encoding");
9786                     break;
9787                 }
9788             default:
9789                 /* Allow \_ to not give an error */
9790                 if (!SIZE_ONLY && isALNUM(value) && value != '_') {
9791                     ckWARN2reg(RExC_parse,
9792                                "Unrecognized escape \\%c in character class passed through",
9793                                (int)value);
9794                 }
9795                 break;
9796             }
9797         } /* end of \blah */
9798 #ifdef EBCDIC
9799         else
9800             literal_endpoint++;
9801 #endif
9802
9803         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
9804
9805             /* What matches in a locale is not known until runtime, so need to
9806              * (one time per class) allocate extra space to pass to regexec.
9807              * The space will contain a bit for each named class that is to be
9808              * matched against.  This isn't needed for \p{} and pseudo-classes,
9809              * as they are not affected by locale, and hence are dealt with
9810              * separately */
9811             if (LOC && namedclass < ANYOF_MAX && ! need_class) {
9812                 need_class = 1;
9813                 if (SIZE_ONLY) {
9814                     RExC_size += ANYOF_CLASS_SKIP - ANYOF_SKIP;
9815                 }
9816                 else {
9817                     RExC_emit += ANYOF_CLASS_SKIP - ANYOF_SKIP;
9818                     ANYOF_CLASS_ZERO(ret);
9819                 }
9820                 ANYOF_FLAGS(ret) |= ANYOF_CLASS;
9821             }
9822
9823             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
9824              * literal, as is the character that began the false range, i.e.
9825              * the 'a' in the examples */
9826             if (range) {
9827                 if (!SIZE_ONLY) {
9828                     const int w =
9829                         RExC_parse >= rangebegin ?
9830                         RExC_parse - rangebegin : 0;
9831                     ckWARN4reg(RExC_parse,
9832                                "False [] range \"%*.*s\"",
9833                                w, w, rangebegin);
9834
9835                     stored +=
9836                          set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
9837                     if (prevvalue < 256) {
9838                         stored +=
9839                          set_regclass_bit(pRExC_state, ret, (U8) prevvalue, &l1_fold_invlist, &unicode_alternate);
9840                     }
9841                     else {
9842                         nonbitmap = add_cp_to_invlist(nonbitmap, prevvalue);
9843                     }
9844                 }
9845
9846                 range = 0; /* this was not a true range */
9847             }
9848
9849
9850     
9851             if (!SIZE_ONLY) {
9852                 const char *what = NULL;
9853                 char yesno = 0;
9854
9855                 /* Possible truncation here but in some 64-bit environments
9856                  * the compiler gets heartburn about switch on 64-bit values.
9857                  * A similar issue a little earlier when switching on value.
9858                  * --jhi */
9859                 switch ((I32)namedclass) {
9860                 
9861                 case _C_C_T_(ALNUMC, isALNUMC_L1, isALNUMC, "XPosixAlnum");
9862                 case _C_C_T_(ALPHA, isALPHA_L1, isALPHA, "XPosixAlpha");
9863                 case _C_C_T_(BLANK, isBLANK_L1, isBLANK, "XPosixBlank");
9864                 case _C_C_T_(CNTRL, isCNTRL_L1, isCNTRL, "XPosixCntrl");
9865                 case _C_C_T_(GRAPH, isGRAPH_L1, isGRAPH, "XPosixGraph");
9866                 case _C_C_T_(LOWER, isLOWER_L1, isLOWER, "XPosixLower");
9867                 case _C_C_T_(PRINT, isPRINT_L1, isPRINT, "XPosixPrint");
9868                 case _C_C_T_(PSXSPC, isPSXSPC_L1, isPSXSPC, "XPosixSpace");
9869                 case _C_C_T_(PUNCT, isPUNCT_L1, isPUNCT, "XPosixPunct");
9870                 case _C_C_T_(UPPER, isUPPER_L1, isUPPER, "XPosixUpper");
9871                 /* \s, \w match all unicode if utf8. */
9872                 case _C_C_T_(SPACE, isSPACE_L1, isSPACE, "SpacePerl");
9873                 case _C_C_T_(ALNUM, isWORDCHAR_L1, isALNUM, "Word");
9874                 case _C_C_T_(XDIGIT, isXDIGIT_L1, isXDIGIT, "XPosixXDigit");
9875                 case _C_C_T_NOLOC_(VERTWS, is_VERTWS_latin1(&value), "VertSpace");
9876                 case _C_C_T_NOLOC_(HORIZWS, is_HORIZWS_latin1(&value), "HorizSpace");
9877                 case ANYOF_ASCII:
9878                     if (LOC)
9879                         ANYOF_CLASS_SET(ret, ANYOF_ASCII);
9880                     else {
9881                         for (value = 0; value < 128; value++)
9882                             stored +=
9883                               set_regclass_bit(pRExC_state, ret, (U8) ASCII_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate);
9884                     }
9885                     yesno = '+';
9886                     what = NULL;        /* Doesn't match outside ascii, so
9887                                            don't want to add +utf8:: */
9888                     break;
9889                 case ANYOF_NASCII:
9890                     if (LOC)
9891                         ANYOF_CLASS_SET(ret, ANYOF_NASCII);
9892                     else {
9893                         for (value = 128; value < 256; value++)
9894                             stored +=
9895                               set_regclass_bit(pRExC_state, ret, (U8) ASCII_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate);
9896                     }
9897                     ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
9898                     yesno = '!';
9899                     what = "ASCII";
9900                     break;              
9901                 case ANYOF_DIGIT:
9902                     if (LOC)
9903                         ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
9904                     else {
9905                         /* consecutive digits assumed */
9906                         for (value = '0'; value <= '9'; value++)
9907                             stored +=
9908                               set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);
9909                     }
9910                     yesno = '+';
9911                     what = "Digit";
9912                     break;
9913                 case ANYOF_NDIGIT:
9914                     if (LOC)
9915                         ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
9916                     else {
9917                         /* consecutive digits assumed */
9918                         for (value = 0; value < '0'; value++)
9919                             stored +=
9920                               set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);
9921                         for (value = '9' + 1; value < 256; value++)
9922                             stored +=
9923                               set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);
9924                     }
9925                     yesno = '!';
9926                     what = "Digit";
9927                     if (AT_LEAST_ASCII_RESTRICTED ) {
9928                         ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
9929                     }
9930                     break;              
9931                 case ANYOF_MAX:
9932                     /* this is to handle \p and \P */
9933                     break;
9934                 default:
9935                     vFAIL("Invalid [::] class");
9936                     break;
9937                 }
9938                 if (what && ! (AT_LEAST_ASCII_RESTRICTED)) {
9939                     /* Strings such as "+utf8::isWord\n" */
9940                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::Is%s\n", yesno, what);
9941                 }
9942
9943                 continue;
9944             }
9945         } /* end of namedclass \blah */
9946
9947         if (range) {
9948             if (prevvalue > (IV)value) /* b-a */ {
9949                 const int w = RExC_parse - rangebegin;
9950                 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
9951                 range = 0; /* not a valid range */
9952             }
9953         }
9954         else {
9955             prevvalue = value; /* save the beginning of the range */
9956             if (RExC_parse+1 < RExC_end
9957                 && *RExC_parse == '-'
9958                 && RExC_parse[1] != ']')
9959             {
9960                 RExC_parse++;
9961
9962                 /* a bad range like \w-, [:word:]- ? */
9963                 if (namedclass > OOB_NAMEDCLASS) {
9964                     if (ckWARN(WARN_REGEXP)) {
9965                         const int w =
9966                             RExC_parse >= rangebegin ?
9967                             RExC_parse - rangebegin : 0;
9968                         vWARN4(RExC_parse,
9969                                "False [] range \"%*.*s\"",
9970                                w, w, rangebegin);
9971                     }
9972                     if (!SIZE_ONLY)
9973                         stored +=
9974                             set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
9975                 } else
9976                     range = 1;  /* yeah, it's a range! */
9977                 continue;       /* but do it the next time */
9978             }
9979         }
9980
9981         /* non-Latin1 code point implies unicode semantics.  Must be set in
9982          * pass1 so is there for the whole of pass 2 */
9983         if (value > 255) {
9984             RExC_uni_semantics = 1;
9985         }
9986
9987         /* now is the next time */
9988         if (!SIZE_ONLY) {
9989             if (prevvalue < 256) {
9990                 const IV ceilvalue = value < 256 ? value : 255;
9991                 IV i;
9992 #ifdef EBCDIC
9993                 /* In EBCDIC [\x89-\x91] should include
9994                  * the \x8e but [i-j] should not. */
9995                 if (literal_endpoint == 2 &&
9996                     ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
9997                      (isUPPER(prevvalue) && isUPPER(ceilvalue))))
9998                 {
9999                     if (isLOWER(prevvalue)) {
10000                         for (i = prevvalue; i <= ceilvalue; i++)
10001                             if (isLOWER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
10002                                 stored +=
10003                                   set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
10004                             }
10005                     } else {
10006                         for (i = prevvalue; i <= ceilvalue; i++)
10007                             if (isUPPER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
10008                                 stored +=
10009                                   set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
10010                             }
10011                     }
10012                 }
10013                 else
10014 #endif
10015                       for (i = prevvalue; i <= ceilvalue; i++) {
10016                         stored += set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
10017                       }
10018           }
10019           if (value > 255) {
10020             const UV prevnatvalue  = NATIVE_TO_UNI(prevvalue);
10021             const UV natvalue      = NATIVE_TO_UNI(value);
10022             nonbitmap = add_range_to_invlist(nonbitmap, prevnatvalue, natvalue);
10023         }
10024 #ifdef EBCDIC
10025             literal_endpoint = 0;
10026 #endif
10027         }
10028
10029         range = 0; /* this range (if it was one) is done now */
10030     }
10031
10032
10033
10034     if (SIZE_ONLY)
10035         return ret;
10036     /****** !SIZE_ONLY AFTER HERE *********/
10037
10038     /* If folding and there are code points above 255, we calculate all
10039      * characters that could fold to or from the ones already on the list */
10040     if (FOLD && nonbitmap) {
10041         UV i;
10042
10043         HV* fold_intersection;
10044         UV* fold_list;
10045
10046         /* This is a list of all the characters that participate in folds
10047             * (except marks, etc in multi-char folds */
10048         if (! PL_utf8_foldable) {
10049             SV* swash = swash_init("utf8", "Cased", &PL_sv_undef, 1, 0);
10050             PL_utf8_foldable = _swash_to_invlist(swash);
10051         }
10052
10053         /* This is a hash that for a particular fold gives all characters
10054             * that are involved in it */
10055         if (! PL_utf8_foldclosures) {
10056
10057             /* If we were unable to find any folds, then we likely won't be
10058              * able to find the closures.  So just create an empty list.
10059              * Folding will effectively be restricted to the non-Unicode rules
10060              * hard-coded into Perl.  (This case happens legitimately during
10061              * compilation of Perl itself before the Unicode tables are
10062              * generated) */
10063             if (invlist_len(PL_utf8_foldable) == 0) {
10064                 PL_utf8_foldclosures = _new_invlist(0);
10065             } else {
10066                 /* If the folds haven't been read in, call a fold function
10067                     * to force that */
10068                 if (! PL_utf8_tofold) {
10069                     U8 dummy[UTF8_MAXBYTES+1];
10070                     STRLEN dummy_len;
10071                     to_utf8_fold((U8*) "A", dummy, &dummy_len);
10072                 }
10073                 PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
10074             }
10075         }
10076
10077         /* Only the characters in this class that participate in folds need
10078             * be checked.  Get the intersection of this class and all the
10079             * possible characters that are foldable.  This can quickly narrow
10080             * down a large class */
10081         fold_intersection = invlist_intersection(PL_utf8_foldable, nonbitmap);
10082
10083         /* Now look at the foldable characters in this class individually */
10084         fold_list = invlist_array(fold_intersection);
10085         for (i = 0; i < invlist_len(fold_intersection); i++) {
10086             UV j;
10087
10088             /* The next entry is the beginning of the range that is in the
10089              * class */
10090             UV start = fold_list[i++];
10091
10092
10093             /* The next entry is the beginning of the next range, which
10094                 * isn't in the class, so the end of the current range is one
10095                 * less than that */
10096             UV end = fold_list[i] - 1;
10097
10098             /* Look at every character in the range */
10099             for (j = start; j <= end; j++) {
10100
10101                 /* Get its fold */
10102                 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
10103                 STRLEN foldlen;
10104                 const UV f =
10105                     _to_uni_fold_flags(j, foldbuf, &foldlen, allow_full_fold);
10106
10107                 if (foldlen > (STRLEN)UNISKIP(f)) {
10108
10109                     /* Any multicharacter foldings (disallowed in
10110                         * lookbehind patterns) require the following
10111                         * transform: [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst) where
10112                         * E folds into "pq" and F folds into "rst", all other
10113                         * characters fold to single characters.  We save away
10114                         * these multicharacter foldings, to be later saved as
10115                         * part of the additional "s" data. */
10116                     if (! RExC_in_lookbehind) {
10117                         U8* loc = foldbuf;
10118                         U8* e = foldbuf + foldlen;
10119
10120                         /* If any of the folded characters of this are in
10121                             * the Latin1 range, tell the regex engine that
10122                             * this can match a non-utf8 target string.  The
10123                             * only multi-byte fold whose source is in the
10124                             * Latin1 range (U+00DF) applies only when the
10125                             * target string is utf8, or under unicode rules */
10126                         if (j > 255 || AT_LEAST_UNI_SEMANTICS) {
10127                             while (loc < e) {
10128
10129                                 /* Can't mix ascii with non- under /aa */
10130                                 if (MORE_ASCII_RESTRICTED
10131                                     && (isASCII(*loc) != isASCII(j)))
10132                                 {
10133                                     goto end_multi_fold;
10134                                 }
10135                                 if (UTF8_IS_INVARIANT(*loc)
10136                                     || UTF8_IS_DOWNGRADEABLE_START(*loc))
10137                                 {
10138                                     /* Can't mix above and below 256 under
10139                                         * LOC */
10140                                     if (LOC) {
10141                                         goto end_multi_fold;
10142                                     }
10143                                     ANYOF_FLAGS(ret)
10144                                             |= ANYOF_NONBITMAP_NON_UTF8;
10145                                     break;
10146                                 }
10147                                 loc += UTF8SKIP(loc);
10148                             }
10149                         }
10150
10151                         add_alternate(&unicode_alternate, foldbuf, foldlen);
10152                     end_multi_fold: ;
10153                     }
10154
10155                     /* This is special-cased, as it is the only letter which
10156                      * has both a multi-fold and single-fold in Latin1.  All
10157                      * the other chars that have single and multi-folds are
10158                      * always in utf8, and the utf8 folding algorithm catches
10159                      * them */
10160                     if (! LOC && j == LATIN_CAPITAL_LETTER_SHARP_S) {
10161                         stored += set_regclass_bit(pRExC_state,
10162                                         ret,
10163                                         LATIN_SMALL_LETTER_SHARP_S,
10164                                         &l1_fold_invlist, &unicode_alternate);
10165                     }
10166                 }
10167                 else {
10168                     /* Single character fold.  Add everything in its fold
10169                         * closure to the list that this node should match */
10170                     SV** listp;
10171
10172                     /* The fold closures data structure is a hash with the
10173                         * keys being every character that is folded to, like
10174                         * 'k', and the values each an array of everything that
10175                         * folds to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ] */
10176                     if ((listp = hv_fetch(PL_utf8_foldclosures,
10177                                     (char *) foldbuf, foldlen, FALSE)))
10178                     {
10179                         AV* list = (AV*) *listp;
10180                         IV k;
10181                         for (k = 0; k <= av_len(list); k++) {
10182                             SV** c_p = av_fetch(list, k, FALSE);
10183                             UV c;
10184                             if (c_p == NULL) {
10185                                 Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
10186                             }
10187                             c = SvUV(*c_p);
10188
10189                             /* /aa doesn't allow folds between ASCII and
10190                                 * non-; /l doesn't allow them between above
10191                                 * and below 256 */
10192                             if ((MORE_ASCII_RESTRICTED
10193                                  && (isASCII(c) != isASCII(j)))
10194                                     || (LOC && ((c < 256) != (j < 256))))
10195                             {
10196                                 continue;
10197                             }
10198
10199                             if (c < 256 && AT_LEAST_UNI_SEMANTICS) {
10200                                 stored += set_regclass_bit(pRExC_state,
10201                                         ret,
10202                                         (U8) c,
10203                                         &l1_fold_invlist, &unicode_alternate);
10204                             }
10205                                 /* It may be that the code point is already
10206                                     * in this range or already in the bitmap,
10207                                     * in which case we need do nothing */
10208                             else if ((c < start || c > end)
10209                                         && (c > 255
10210                                             || ! ANYOF_BITMAP_TEST(ret, c)))
10211                             {
10212                                 nonbitmap = add_cp_to_invlist(nonbitmap, c);
10213                             }
10214                         }
10215                     }
10216                 }
10217             }
10218         }
10219         invlist_destroy(fold_intersection);
10220     }
10221
10222     /* Combine the two lists into one. */
10223     if (l1_fold_invlist) {
10224         if (nonbitmap) {
10225             HV* temp = invlist_union(nonbitmap, l1_fold_invlist);
10226             invlist_destroy(nonbitmap);
10227             nonbitmap = temp;
10228             invlist_destroy(l1_fold_invlist);
10229         }
10230         else {
10231             nonbitmap = l1_fold_invlist;
10232         }
10233     }
10234
10235     /* Here, we have calculated what code points should be in the character
10236      * class.   Now we can see about various optimizations.  Fold calculation
10237      * needs to take place before inversion.  Otherwise /[^k]/i would invert to
10238      * include K, which under /i would match k. */
10239
10240     /* Optimize inverted simple patterns (e.g. [^a-z]).  Note that we haven't
10241      * set the FOLD flag yet, so this this does optimize those.  It doesn't
10242      * optimize locale.  Doing so perhaps could be done as long as there is
10243      * nothing like \w in it; some thought also would have to be given to the
10244      * interaction with above 0x100 chars */
10245     if (! LOC
10246         && (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT
10247         && ! unicode_alternate
10248         && ! nonbitmap
10249         && SvCUR(listsv) == initial_listsv_len)
10250     {
10251         for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
10252             ANYOF_BITMAP(ret)[value] ^= 0xFF;
10253         stored = 256 - stored;
10254
10255         /* The inversion means that everything above 255 is matched; and at the
10256          * same time we clear the invert flag */
10257         ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL;
10258     }
10259
10260     /* Folding in the bitmap is taken care of above, but not for locale (for
10261      * which we have to wait to see what folding is in effect at runtime), and
10262      * for things not in the bitmap.  Set run-time fold flag for these */
10263     if (FOLD && (LOC || nonbitmap || unicode_alternate)) {
10264         ANYOF_FLAGS(ret) |= ANYOF_LOC_NONBITMAP_FOLD;
10265     }
10266
10267     /* A single character class can be "optimized" into an EXACTish node.
10268      * Note that since we don't currently count how many characters there are
10269      * outside the bitmap, we are XXX missing optimization possibilities for
10270      * them.  This optimization can't happen unless this is a truly single
10271      * character class, which means that it can't be an inversion into a
10272      * many-character class, and there must be no possibility of there being
10273      * things outside the bitmap.  'stored' (only) for locales doesn't include
10274      * \w, etc, so have to make a special test that they aren't present
10275      *
10276      * Similarly A 2-character class of the very special form like [bB] can be
10277      * optimized into an EXACTFish node, but only for non-locales, and for
10278      * characters which only have the two folds; so things like 'fF' and 'Ii'
10279      * wouldn't work because they are part of the fold of 'LATIN SMALL LIGATURE
10280      * FI'. */
10281     if (! nonbitmap
10282         && ! unicode_alternate
10283         && SvCUR(listsv) == initial_listsv_len
10284         && ! (ANYOF_FLAGS(ret) & (ANYOF_INVERT|ANYOF_UNICODE_ALL))
10285         && (((stored == 1 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
10286                               || (! ANYOF_CLASS_TEST_ANY_SET(ret)))))
10287             || (stored == 2 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
10288                                  && (! _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value))
10289                                  /* If the latest code point has a fold whose
10290                                   * bit is set, it must be the only other one */
10291                                 && ((prevvalue = PL_fold_latin1[value]) != (IV)value)
10292                                  && ANYOF_BITMAP_TEST(ret, prevvalue)))))
10293     {
10294         /* Note that the information needed to decide to do this optimization
10295          * is not currently available until the 2nd pass, and that the actually
10296          * used EXACTish node takes less space than the calculated ANYOF node,
10297          * and hence the amount of space calculated in the first pass is larger
10298          * than actually used, so this optimization doesn't gain us any space.
10299          * But an EXACT node is faster than an ANYOF node, and can be combined
10300          * with any adjacent EXACT nodes later by the optimizer for further
10301          * gains.  The speed of executing an EXACTF is similar to an ANYOF
10302          * node, so the optimization advantage comes from the ability to join
10303          * it to adjacent EXACT nodes */
10304
10305         const char * cur_parse= RExC_parse;
10306         U8 op;
10307         RExC_emit = (regnode *)orig_emit;
10308         RExC_parse = (char *)orig_parse;
10309
10310         if (stored == 1) {
10311
10312             /* A locale node with one point can be folded; all the other cases
10313              * with folding will have two points, since we calculate them above
10314              */
10315             if (ANYOF_FLAGS(ret) & ANYOF_LOC_NONBITMAP_FOLD) {
10316                  op = EXACTFL;
10317             }
10318             else {
10319                 op = EXACT;
10320             }
10321         }   /* else 2 chars in the bit map: the folds of each other */
10322         else if (AT_LEAST_UNI_SEMANTICS || !isASCII(value)) {
10323
10324             /* To join adjacent nodes, they must be the exact EXACTish type.
10325              * Try to use the most likely type, by using EXACTFU if the regex
10326              * calls for them, or is required because the character is
10327              * non-ASCII */
10328             op = EXACTFU;
10329         }
10330         else {    /* Otherwise, more likely to be EXACTF type */
10331             op = EXACTF;
10332         }
10333
10334         ret = reg_node(pRExC_state, op);
10335         RExC_parse = (char *)cur_parse;
10336         if (UTF && ! NATIVE_IS_INVARIANT(value)) {
10337             *STRING(ret)= UTF8_EIGHT_BIT_HI((U8) value);
10338             *(STRING(ret) + 1)= UTF8_EIGHT_BIT_LO((U8) value);
10339             STR_LEN(ret)= 2;
10340             RExC_emit += STR_SZ(2);
10341         }
10342         else {
10343             *STRING(ret)= (char)value;
10344             STR_LEN(ret)= 1;
10345             RExC_emit += STR_SZ(1);
10346         }
10347         SvREFCNT_dec(listsv);
10348         return ret;
10349     }
10350
10351     if (nonbitmap) {
10352         UV* nonbitmap_array = invlist_array(nonbitmap);
10353         UV nonbitmap_len = invlist_len(nonbitmap);
10354         UV i;
10355
10356         /*  Here have the full list of items to match that aren't in the
10357          *  bitmap.  Convert to the structure that the rest of the code is
10358          *  expecting.   XXX That rest of the code should convert to this
10359          *  structure */
10360         for (i = 0; i < nonbitmap_len; i++) {
10361
10362             /* The next entry is the beginning of the range that is in the
10363              * class */
10364             UV start = nonbitmap_array[i++];
10365             UV end;
10366
10367             /* The next entry is the beginning of the next range, which isn't
10368              * in the class, so the end of the current range is one less than
10369              * that.  But if there is no next range, it means that the range
10370              * begun by 'start' extends to infinity, which for this platform
10371              * ends at UV_MAX */
10372             if (i == nonbitmap_len) {
10373                 end = UV_MAX;
10374             }
10375             else {
10376                 end = nonbitmap_array[i] - 1;
10377             }
10378
10379             if (start == end) {
10380                 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", start);
10381             }
10382             else {
10383                 /* The \t sets the whole range */
10384                 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
10385                         /* XXX EBCDIC */
10386                                    start, end);
10387             }
10388         }
10389         invlist_destroy(nonbitmap);
10390     }
10391
10392     if (SvCUR(listsv) == initial_listsv_len && ! unicode_alternate) {
10393         ARG_SET(ret, ANYOF_NONBITMAP_EMPTY);
10394         SvREFCNT_dec(listsv);
10395         SvREFCNT_dec(unicode_alternate);
10396     }
10397     else {
10398
10399         AV * const av = newAV();
10400         SV *rv;
10401         /* The 0th element stores the character class description
10402          * in its textual form: used later (regexec.c:Perl_regclass_swash())
10403          * to initialize the appropriate swash (which gets stored in
10404          * the 1st element), and also useful for dumping the regnode.
10405          * The 2nd element stores the multicharacter foldings,
10406          * used later (regexec.c:S_reginclass()). */
10407         av_store(av, 0, listsv);
10408         av_store(av, 1, NULL);
10409
10410         /* Store any computed multi-char folds only if we are allowing
10411          * them */
10412         if (allow_full_fold) {
10413             av_store(av, 2, MUTABLE_SV(unicode_alternate));
10414             if (unicode_alternate) { /* This node is variable length */
10415                 OP(ret) = ANYOFV;
10416             }
10417         }
10418         else {
10419             av_store(av, 2, NULL);
10420         }
10421         rv = newRV_noinc(MUTABLE_SV(av));
10422         n = add_data(pRExC_state, 1, "s");
10423         RExC_rxi->data->data[n] = (void*)rv;
10424         ARG_SET(ret, n);
10425     }
10426     return ret;
10427 }
10428 #undef _C_C_T_
10429
10430
10431 /* reg_skipcomment()
10432
10433    Absorbs an /x style # comments from the input stream.
10434    Returns true if there is more text remaining in the stream.
10435    Will set the REG_SEEN_RUN_ON_COMMENT flag if the comment
10436    terminates the pattern without including a newline.
10437
10438    Note its the callers responsibility to ensure that we are
10439    actually in /x mode
10440
10441 */
10442
10443 STATIC bool
10444 S_reg_skipcomment(pTHX_ RExC_state_t *pRExC_state)
10445 {
10446     bool ended = 0;
10447
10448     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
10449
10450     while (RExC_parse < RExC_end)
10451         if (*RExC_parse++ == '\n') {
10452             ended = 1;
10453             break;
10454         }
10455     if (!ended) {
10456         /* we ran off the end of the pattern without ending
10457            the comment, so we have to add an \n when wrapping */
10458         RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
10459         return 0;
10460     } else
10461         return 1;
10462 }
10463
10464 /* nextchar()
10465
10466    Advances the parse position, and optionally absorbs
10467    "whitespace" from the inputstream.
10468
10469    Without /x "whitespace" means (?#...) style comments only,
10470    with /x this means (?#...) and # comments and whitespace proper.
10471
10472    Returns the RExC_parse point from BEFORE the scan occurs.
10473
10474    This is the /x friendly way of saying RExC_parse++.
10475 */
10476
10477 STATIC char*
10478 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
10479 {
10480     char* const retval = RExC_parse++;
10481
10482     PERL_ARGS_ASSERT_NEXTCHAR;
10483
10484     for (;;) {
10485         if (*RExC_parse == '(' && RExC_parse[1] == '?' &&
10486                 RExC_parse[2] == '#') {
10487             while (*RExC_parse != ')') {
10488                 if (RExC_parse == RExC_end)
10489                     FAIL("Sequence (?#... not terminated");
10490                 RExC_parse++;
10491             }
10492             RExC_parse++;
10493             continue;
10494         }
10495         if (RExC_flags & RXf_PMf_EXTENDED) {
10496             if (isSPACE(*RExC_parse)) {
10497                 RExC_parse++;
10498                 continue;
10499             }
10500             else if (*RExC_parse == '#') {
10501                 if ( reg_skipcomment( pRExC_state ) )
10502                     continue;
10503             }
10504         }
10505         return retval;
10506     }
10507 }
10508
10509 /*
10510 - reg_node - emit a node
10511 */
10512 STATIC regnode *                        /* Location. */
10513 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
10514 {
10515     dVAR;
10516     register regnode *ptr;
10517     regnode * const ret = RExC_emit;
10518     GET_RE_DEBUG_FLAGS_DECL;
10519
10520     PERL_ARGS_ASSERT_REG_NODE;
10521
10522     if (SIZE_ONLY) {
10523         SIZE_ALIGN(RExC_size);
10524         RExC_size += 1;
10525         return(ret);
10526     }
10527     if (RExC_emit >= RExC_emit_bound)
10528         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d", op);
10529
10530     NODE_ALIGN_FILL(ret);
10531     ptr = ret;
10532     FILL_ADVANCE_NODE(ptr, op);
10533     REH_CALL_REGCOMP_HOOK(pRExC_state->rx, (ptr) - 1);
10534 #ifdef RE_TRACK_PATTERN_OFFSETS
10535     if (RExC_offsets) {         /* MJD */
10536         MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n", 
10537               "reg_node", __LINE__, 
10538               PL_reg_name[op],
10539               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] 
10540                 ? "Overwriting end of array!\n" : "OK",
10541               (UV)(RExC_emit - RExC_emit_start),
10542               (UV)(RExC_parse - RExC_start),
10543               (UV)RExC_offsets[0])); 
10544         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
10545     }
10546 #endif
10547     RExC_emit = ptr;
10548     return(ret);
10549 }
10550
10551 /*
10552 - reganode - emit a node with an argument
10553 */
10554 STATIC regnode *                        /* Location. */
10555 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
10556 {
10557     dVAR;
10558     register regnode *ptr;
10559     regnode * const ret = RExC_emit;
10560     GET_RE_DEBUG_FLAGS_DECL;
10561
10562     PERL_ARGS_ASSERT_REGANODE;
10563
10564     if (SIZE_ONLY) {
10565         SIZE_ALIGN(RExC_size);
10566         RExC_size += 2;
10567         /* 
10568            We can't do this:
10569            
10570            assert(2==regarglen[op]+1); 
10571         
10572            Anything larger than this has to allocate the extra amount.
10573            If we changed this to be:
10574            
10575            RExC_size += (1 + regarglen[op]);
10576            
10577            then it wouldn't matter. Its not clear what side effect
10578            might come from that so its not done so far.
10579            -- dmq
10580         */
10581         return(ret);
10582     }
10583     if (RExC_emit >= RExC_emit_bound)
10584         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d", op);
10585
10586     NODE_ALIGN_FILL(ret);
10587     ptr = ret;
10588     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
10589     REH_CALL_REGCOMP_HOOK(pRExC_state->rx, (ptr) - 2);
10590 #ifdef RE_TRACK_PATTERN_OFFSETS
10591     if (RExC_offsets) {         /* MJD */
10592         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
10593               "reganode",
10594               __LINE__,
10595               PL_reg_name[op],
10596               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? 
10597               "Overwriting end of array!\n" : "OK",
10598               (UV)(RExC_emit - RExC_emit_start),
10599               (UV)(RExC_parse - RExC_start),
10600               (UV)RExC_offsets[0])); 
10601         Set_Cur_Node_Offset;
10602     }
10603 #endif            
10604     RExC_emit = ptr;
10605     return(ret);
10606 }
10607
10608 /*
10609 - reguni - emit (if appropriate) a Unicode character
10610 */
10611 STATIC STRLEN
10612 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
10613 {
10614     dVAR;
10615
10616     PERL_ARGS_ASSERT_REGUNI;
10617
10618     return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
10619 }
10620
10621 /*
10622 - reginsert - insert an operator in front of already-emitted operand
10623 *
10624 * Means relocating the operand.
10625 */
10626 STATIC void
10627 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
10628 {
10629     dVAR;
10630     register regnode *src;
10631     register regnode *dst;
10632     register regnode *place;
10633     const int offset = regarglen[(U8)op];
10634     const int size = NODE_STEP_REGNODE + offset;
10635     GET_RE_DEBUG_FLAGS_DECL;
10636
10637     PERL_ARGS_ASSERT_REGINSERT;
10638     PERL_UNUSED_ARG(depth);
10639 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
10640     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
10641     if (SIZE_ONLY) {
10642         RExC_size += size;
10643         return;
10644     }
10645
10646     src = RExC_emit;
10647     RExC_emit += size;
10648     dst = RExC_emit;
10649     if (RExC_open_parens) {
10650         int paren;
10651         /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
10652         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
10653             if ( RExC_open_parens[paren] >= opnd ) {
10654                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
10655                 RExC_open_parens[paren] += size;
10656             } else {
10657                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
10658             }
10659             if ( RExC_close_parens[paren] >= opnd ) {
10660                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
10661                 RExC_close_parens[paren] += size;
10662             } else {
10663                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
10664             }
10665         }
10666     }
10667
10668     while (src > opnd) {
10669         StructCopy(--src, --dst, regnode);
10670 #ifdef RE_TRACK_PATTERN_OFFSETS
10671         if (RExC_offsets) {     /* MJD 20010112 */
10672             MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
10673                   "reg_insert",
10674                   __LINE__,
10675                   PL_reg_name[op],
10676                   (UV)(dst - RExC_emit_start) > RExC_offsets[0] 
10677                     ? "Overwriting end of array!\n" : "OK",
10678                   (UV)(src - RExC_emit_start),
10679                   (UV)(dst - RExC_emit_start),
10680                   (UV)RExC_offsets[0])); 
10681             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
10682             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
10683         }
10684 #endif
10685     }
10686     
10687
10688     place = opnd;               /* Op node, where operand used to be. */
10689 #ifdef RE_TRACK_PATTERN_OFFSETS
10690     if (RExC_offsets) {         /* MJD */
10691         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
10692               "reginsert",
10693               __LINE__,
10694               PL_reg_name[op],
10695               (UV)(place - RExC_emit_start) > RExC_offsets[0] 
10696               ? "Overwriting end of array!\n" : "OK",
10697               (UV)(place - RExC_emit_start),
10698               (UV)(RExC_parse - RExC_start),
10699               (UV)RExC_offsets[0]));
10700         Set_Node_Offset(place, RExC_parse);
10701         Set_Node_Length(place, 1);
10702     }
10703 #endif    
10704     src = NEXTOPER(place);
10705     FILL_ADVANCE_NODE(place, op);
10706     REH_CALL_REGCOMP_HOOK(pRExC_state->rx, (place) - 1);
10707     Zero(src, offset, regnode);
10708 }
10709
10710 /*
10711 - regtail - set the next-pointer at the end of a node chain of p to val.
10712 - SEE ALSO: regtail_study
10713 */
10714 /* TODO: All three parms should be const */
10715 STATIC void
10716 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
10717 {
10718     dVAR;
10719     register regnode *scan;
10720     GET_RE_DEBUG_FLAGS_DECL;
10721
10722     PERL_ARGS_ASSERT_REGTAIL;
10723 #ifndef DEBUGGING
10724     PERL_UNUSED_ARG(depth);
10725 #endif
10726
10727     if (SIZE_ONLY)
10728         return;
10729
10730     /* Find last node. */
10731     scan = p;
10732     for (;;) {
10733         regnode * const temp = regnext(scan);
10734         DEBUG_PARSE_r({
10735             SV * const mysv=sv_newmortal();
10736             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
10737             regprop(RExC_rx, mysv, scan);
10738             PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
10739                 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
10740                     (temp == NULL ? "->" : ""),
10741                     (temp == NULL ? PL_reg_name[OP(val)] : "")
10742             );
10743         });
10744         if (temp == NULL)
10745             break;
10746         scan = temp;
10747     }
10748
10749     if (reg_off_by_arg[OP(scan)]) {
10750         ARG_SET(scan, val - scan);
10751     }
10752     else {
10753         NEXT_OFF(scan) = val - scan;
10754     }
10755 }
10756
10757 #ifdef DEBUGGING
10758 /*
10759 - regtail_study - set the next-pointer at the end of a node chain of p to val.
10760 - Look for optimizable sequences at the same time.
10761 - currently only looks for EXACT chains.
10762
10763 This is experimental code. The idea is to use this routine to perform 
10764 in place optimizations on branches and groups as they are constructed,
10765 with the long term intention of removing optimization from study_chunk so
10766 that it is purely analytical.
10767
10768 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
10769 to control which is which.
10770
10771 */
10772 /* TODO: All four parms should be const */
10773
10774 STATIC U8
10775 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
10776 {
10777     dVAR;
10778     register regnode *scan;
10779     U8 exact = PSEUDO;
10780 #ifdef EXPERIMENTAL_INPLACESCAN
10781     I32 min = 0;
10782 #endif
10783     GET_RE_DEBUG_FLAGS_DECL;
10784
10785     PERL_ARGS_ASSERT_REGTAIL_STUDY;
10786
10787
10788     if (SIZE_ONLY)
10789         return exact;
10790
10791     /* Find last node. */
10792
10793     scan = p;
10794     for (;;) {
10795         regnode * const temp = regnext(scan);
10796 #ifdef EXPERIMENTAL_INPLACESCAN
10797         if (PL_regkind[OP(scan)] == EXACT)
10798             if (join_exact(pRExC_state,scan,&min,1,val,depth+1))
10799                 return EXACT;
10800 #endif
10801         if ( exact ) {
10802             switch (OP(scan)) {
10803                 case EXACT:
10804                 case EXACTF:
10805                 case EXACTFA:
10806                 case EXACTFU:
10807                 case EXACTFL:
10808                         if( exact == PSEUDO )
10809                             exact= OP(scan);
10810                         else if ( exact != OP(scan) )
10811                             exact= 0;
10812                 case NOTHING:
10813                     break;
10814                 default:
10815                     exact= 0;
10816             }
10817         }
10818         DEBUG_PARSE_r({
10819             SV * const mysv=sv_newmortal();
10820             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
10821             regprop(RExC_rx, mysv, scan);
10822             PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
10823                 SvPV_nolen_const(mysv),
10824                 REG_NODE_NUM(scan),
10825                 PL_reg_name[exact]);
10826         });
10827         if (temp == NULL)
10828             break;
10829         scan = temp;
10830     }
10831     DEBUG_PARSE_r({
10832         SV * const mysv_val=sv_newmortal();
10833         DEBUG_PARSE_MSG("");
10834         regprop(RExC_rx, mysv_val, val);
10835         PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
10836                       SvPV_nolen_const(mysv_val),
10837                       (IV)REG_NODE_NUM(val),
10838                       (IV)(val - scan)
10839         );
10840     });
10841     if (reg_off_by_arg[OP(scan)]) {
10842         ARG_SET(scan, val - scan);
10843     }
10844     else {
10845         NEXT_OFF(scan) = val - scan;
10846     }
10847
10848     return exact;
10849 }
10850 #endif
10851
10852 /*
10853  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
10854  */
10855 #ifdef DEBUGGING
10856 static void 
10857 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
10858 {
10859     int bit;
10860     int set=0;
10861     regex_charset cs;
10862
10863     for (bit=0; bit<32; bit++) {
10864         if (flags & (1<<bit)) {
10865             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
10866                 continue;
10867             }
10868             if (!set++ && lead) 
10869                 PerlIO_printf(Perl_debug_log, "%s",lead);
10870             PerlIO_printf(Perl_debug_log, "%s ",PL_reg_extflags_name[bit]);
10871         }               
10872     }      
10873     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
10874             if (!set++ && lead) {
10875                 PerlIO_printf(Perl_debug_log, "%s",lead);
10876             }
10877             switch (cs) {
10878                 case REGEX_UNICODE_CHARSET:
10879                     PerlIO_printf(Perl_debug_log, "UNICODE");
10880                     break;
10881                 case REGEX_LOCALE_CHARSET:
10882                     PerlIO_printf(Perl_debug_log, "LOCALE");
10883                     break;
10884                 case REGEX_ASCII_RESTRICTED_CHARSET:
10885                     PerlIO_printf(Perl_debug_log, "ASCII-RESTRICTED");
10886                     break;
10887                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
10888                     PerlIO_printf(Perl_debug_log, "ASCII-MORE_RESTRICTED");
10889                     break;
10890                 default:
10891                     PerlIO_printf(Perl_debug_log, "UNKNOWN CHARACTER SET");
10892                     break;
10893             }
10894     }
10895     if (lead)  {
10896         if (set) 
10897             PerlIO_printf(Perl_debug_log, "\n");
10898         else 
10899             PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
10900     }            
10901 }   
10902 #endif
10903
10904 void
10905 Perl_regdump(pTHX_ const regexp *r)
10906 {
10907 #ifdef DEBUGGING
10908     dVAR;
10909     SV * const sv = sv_newmortal();
10910     SV *dsv= sv_newmortal();
10911     RXi_GET_DECL(r,ri);
10912     GET_RE_DEBUG_FLAGS_DECL;
10913
10914     PERL_ARGS_ASSERT_REGDUMP;
10915
10916     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
10917
10918     /* Header fields of interest. */
10919     if (r->anchored_substr) {
10920         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr), 
10921             RE_SV_DUMPLEN(r->anchored_substr), 30);
10922         PerlIO_printf(Perl_debug_log,
10923                       "anchored %s%s at %"IVdf" ",
10924                       s, RE_SV_TAIL(r->anchored_substr),
10925                       (IV)r->anchored_offset);
10926     } else if (r->anchored_utf8) {
10927         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8), 
10928             RE_SV_DUMPLEN(r->anchored_utf8), 30);
10929         PerlIO_printf(Perl_debug_log,
10930                       "anchored utf8 %s%s at %"IVdf" ",
10931                       s, RE_SV_TAIL(r->anchored_utf8),
10932                       (IV)r->anchored_offset);
10933     }                 
10934     if (r->float_substr) {
10935         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr), 
10936             RE_SV_DUMPLEN(r->float_substr), 30);
10937         PerlIO_printf(Perl_debug_log,
10938                       "floating %s%s at %"IVdf"..%"UVuf" ",
10939                       s, RE_SV_TAIL(r->float_substr),
10940                       (IV)r->float_min_offset, (UV)r->float_max_offset);
10941     } else if (r->float_utf8) {
10942         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8), 
10943             RE_SV_DUMPLEN(r->float_utf8), 30);
10944         PerlIO_printf(Perl_debug_log,
10945                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
10946                       s, RE_SV_TAIL(r->float_utf8),
10947                       (IV)r->float_min_offset, (UV)r->float_max_offset);
10948     }
10949     if (r->check_substr || r->check_utf8)
10950         PerlIO_printf(Perl_debug_log,
10951                       (const char *)
10952                       (r->check_substr == r->float_substr
10953                        && r->check_utf8 == r->float_utf8
10954                        ? "(checking floating" : "(checking anchored"));
10955     if (r->extflags & RXf_NOSCAN)
10956         PerlIO_printf(Perl_debug_log, " noscan");
10957     if (r->extflags & RXf_CHECK_ALL)
10958         PerlIO_printf(Perl_debug_log, " isall");
10959     if (r->check_substr || r->check_utf8)
10960         PerlIO_printf(Perl_debug_log, ") ");
10961
10962     if (ri->regstclass) {
10963         regprop(r, sv, ri->regstclass);
10964         PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
10965     }
10966     if (r->extflags & RXf_ANCH) {
10967         PerlIO_printf(Perl_debug_log, "anchored");
10968         if (r->extflags & RXf_ANCH_BOL)
10969             PerlIO_printf(Perl_debug_log, "(BOL)");
10970         if (r->extflags & RXf_ANCH_MBOL)
10971             PerlIO_printf(Perl_debug_log, "(MBOL)");
10972         if (r->extflags & RXf_ANCH_SBOL)
10973             PerlIO_printf(Perl_debug_log, "(SBOL)");
10974         if (r->extflags & RXf_ANCH_GPOS)
10975             PerlIO_printf(Perl_debug_log, "(GPOS)");
10976         PerlIO_putc(Perl_debug_log, ' ');
10977     }
10978     if (r->extflags & RXf_GPOS_SEEN)
10979         PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
10980     if (r->intflags & PREGf_SKIP)
10981         PerlIO_printf(Perl_debug_log, "plus ");
10982     if (r->intflags & PREGf_IMPLICIT)
10983         PerlIO_printf(Perl_debug_log, "implicit ");
10984     PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
10985     if (r->extflags & RXf_EVAL_SEEN)
10986         PerlIO_printf(Perl_debug_log, "with eval ");
10987     PerlIO_printf(Perl_debug_log, "\n");
10988     DEBUG_FLAGS_r(regdump_extflags("r->extflags: ",r->extflags));            
10989 #else
10990     PERL_ARGS_ASSERT_REGDUMP;
10991     PERL_UNUSED_CONTEXT;
10992     PERL_UNUSED_ARG(r);
10993 #endif  /* DEBUGGING */
10994 }
10995
10996 /*
10997 - regprop - printable representation of opcode
10998 */
10999 #define EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags) \
11000 STMT_START { \
11001         if (do_sep) {                           \
11002             Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]); \
11003             if (flags & ANYOF_INVERT)           \
11004                 /*make sure the invert info is in each */ \
11005                 sv_catpvs(sv, "^");             \
11006             do_sep = 0;                         \
11007         }                                       \
11008 } STMT_END
11009
11010 void
11011 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
11012 {
11013 #ifdef DEBUGGING
11014     dVAR;
11015     register int k;
11016     RXi_GET_DECL(prog,progi);
11017     GET_RE_DEBUG_FLAGS_DECL;
11018     
11019     PERL_ARGS_ASSERT_REGPROP;
11020
11021     sv_setpvs(sv, "");
11022
11023     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
11024         /* It would be nice to FAIL() here, but this may be called from
11025            regexec.c, and it would be hard to supply pRExC_state. */
11026         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
11027     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
11028
11029     k = PL_regkind[OP(o)];
11030
11031     if (k == EXACT) {
11032         sv_catpvs(sv, " ");
11033         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT) 
11034          * is a crude hack but it may be the best for now since 
11035          * we have no flag "this EXACTish node was UTF-8" 
11036          * --jhi */
11037         pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
11038                   PERL_PV_ESCAPE_UNI_DETECT |
11039                   PERL_PV_ESCAPE_NONASCII   |
11040                   PERL_PV_PRETTY_ELLIPSES   |
11041                   PERL_PV_PRETTY_LTGT       |
11042                   PERL_PV_PRETTY_NOCLEAR
11043                   );
11044     } else if (k == TRIE) {
11045         /* print the details of the trie in dumpuntil instead, as
11046          * progi->data isn't available here */
11047         const char op = OP(o);
11048         const U32 n = ARG(o);
11049         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
11050                (reg_ac_data *)progi->data->data[n] :
11051                NULL;
11052         const reg_trie_data * const trie
11053             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
11054         
11055         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
11056         DEBUG_TRIE_COMPILE_r(
11057             Perl_sv_catpvf(aTHX_ sv,
11058                 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
11059                 (UV)trie->startstate,
11060                 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
11061                 (UV)trie->wordcount,
11062                 (UV)trie->minlen,
11063                 (UV)trie->maxlen,
11064                 (UV)TRIE_CHARCOUNT(trie),
11065                 (UV)trie->uniquecharcount
11066             )
11067         );
11068         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
11069             int i;
11070             int rangestart = -1;
11071             U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
11072             sv_catpvs(sv, "[");
11073             for (i = 0; i <= 256; i++) {
11074                 if (i < 256 && BITMAP_TEST(bitmap,i)) {
11075                     if (rangestart == -1)
11076                         rangestart = i;
11077                 } else if (rangestart != -1) {
11078                     if (i <= rangestart + 3)
11079                         for (; rangestart < i; rangestart++)
11080                             put_byte(sv, rangestart);
11081                     else {
11082                         put_byte(sv, rangestart);
11083                         sv_catpvs(sv, "-");
11084                         put_byte(sv, i - 1);
11085                     }
11086                     rangestart = -1;
11087                 }
11088             }
11089             sv_catpvs(sv, "]");
11090         } 
11091          
11092     } else if (k == CURLY) {
11093         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
11094             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
11095         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
11096     }
11097     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
11098         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
11099     else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
11100         Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
11101         if ( RXp_PAREN_NAMES(prog) ) {
11102             if ( k != REF || (OP(o) < NREF)) {
11103                 AV *list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
11104                 SV **name= av_fetch(list, ARG(o), 0 );
11105                 if (name)
11106                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
11107             }       
11108             else {
11109                 AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]);
11110                 SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]);
11111                 I32 *nums=(I32*)SvPVX(sv_dat);
11112                 SV **name= av_fetch(list, nums[0], 0 );
11113                 I32 n;
11114                 if (name) {
11115                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
11116                         Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
11117                                     (n ? "," : ""), (IV)nums[n]);
11118                     }
11119                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
11120                 }
11121             }
11122         }            
11123     } else if (k == GOSUB) 
11124         Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
11125     else if (k == VERB) {
11126         if (!o->flags) 
11127             Perl_sv_catpvf(aTHX_ sv, ":%"SVf, 
11128                            SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
11129     } else if (k == LOGICAL)
11130         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);     /* 2: embedded, otherwise 1 */
11131     else if (k == FOLDCHAR)
11132         Perl_sv_catpvf(aTHX_ sv, "[0x%"UVXf"]", PTR2UV(ARG(o)) );
11133     else if (k == ANYOF) {
11134         int i, rangestart = -1;
11135         const U8 flags = ANYOF_FLAGS(o);
11136         int do_sep = 0;
11137
11138         /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
11139         static const char * const anyofs[] = {
11140             "\\w",
11141             "\\W",
11142             "\\s",
11143             "\\S",
11144             "\\d",
11145             "\\D",
11146             "[:alnum:]",
11147             "[:^alnum:]",
11148             "[:alpha:]",
11149             "[:^alpha:]",
11150             "[:ascii:]",
11151             "[:^ascii:]",
11152             "[:cntrl:]",
11153             "[:^cntrl:]",
11154             "[:graph:]",
11155             "[:^graph:]",
11156             "[:lower:]",
11157             "[:^lower:]",
11158             "[:print:]",
11159             "[:^print:]",
11160             "[:punct:]",
11161             "[:^punct:]",
11162             "[:upper:]",
11163             "[:^upper:]",
11164             "[:xdigit:]",
11165             "[:^xdigit:]",
11166             "[:space:]",
11167             "[:^space:]",
11168             "[:blank:]",
11169             "[:^blank:]"
11170         };
11171
11172         if (flags & ANYOF_LOCALE)
11173             sv_catpvs(sv, "{loc}");
11174         if (flags & ANYOF_LOC_NONBITMAP_FOLD)
11175             sv_catpvs(sv, "{i}");
11176         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
11177         if (flags & ANYOF_INVERT)
11178             sv_catpvs(sv, "^");
11179         
11180         /* output what the standard cp 0-255 bitmap matches */
11181         for (i = 0; i <= 256; i++) {
11182             if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
11183                 if (rangestart == -1)
11184                     rangestart = i;
11185             } else if (rangestart != -1) {
11186                 if (i <= rangestart + 3)
11187                     for (; rangestart < i; rangestart++)
11188                         put_byte(sv, rangestart);
11189                 else {
11190                     put_byte(sv, rangestart);
11191                     sv_catpvs(sv, "-");
11192                     put_byte(sv, i - 1);
11193                 }
11194                 do_sep = 1;
11195                 rangestart = -1;
11196             }
11197         }
11198         
11199         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
11200         /* output any special charclass tests (used entirely under use locale) */
11201         if (ANYOF_CLASS_TEST_ANY_SET(o))
11202             for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
11203                 if (ANYOF_CLASS_TEST(o,i)) {
11204                     sv_catpv(sv, anyofs[i]);
11205                     do_sep = 1;
11206                 }
11207         
11208         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
11209         
11210         if (flags & ANYOF_NON_UTF8_LATIN1_ALL) {
11211             sv_catpvs(sv, "{non-utf8-latin1-all}");
11212         }
11213
11214         /* output information about the unicode matching */
11215         if (flags & ANYOF_UNICODE_ALL)
11216             sv_catpvs(sv, "{unicode_all}");
11217         else if (ANYOF_NONBITMAP(o))
11218             sv_catpvs(sv, "{unicode}");
11219         if (flags & ANYOF_NONBITMAP_NON_UTF8)
11220             sv_catpvs(sv, "{outside bitmap}");
11221
11222         if (ANYOF_NONBITMAP(o)) {
11223             SV *lv;
11224             SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
11225         
11226             if (lv) {
11227                 if (sw) {
11228                     U8 s[UTF8_MAXBYTES_CASE+1];
11229
11230                     for (i = 0; i <= 256; i++) { /* just the first 256 */
11231                         uvchr_to_utf8(s, i);
11232                         
11233                         if (i < 256 && swash_fetch(sw, s, TRUE)) {
11234                             if (rangestart == -1)
11235                                 rangestart = i;
11236                         } else if (rangestart != -1) {
11237                             if (i <= rangestart + 3)
11238                                 for (; rangestart < i; rangestart++) {
11239                                     const U8 * const e = uvchr_to_utf8(s,rangestart);
11240                                     U8 *p;
11241                                     for(p = s; p < e; p++)
11242                                         put_byte(sv, *p);
11243                                 }
11244                             else {
11245                                 const U8 *e = uvchr_to_utf8(s,rangestart);
11246                                 U8 *p;
11247                                 for (p = s; p < e; p++)
11248                                     put_byte(sv, *p);
11249                                 sv_catpvs(sv, "-");
11250                                 e = uvchr_to_utf8(s, i-1);
11251                                 for (p = s; p < e; p++)
11252                                     put_byte(sv, *p);
11253                                 }
11254                                 rangestart = -1;
11255                             }
11256                         }
11257                         
11258                     sv_catpvs(sv, "..."); /* et cetera */
11259                 }
11260
11261                 {
11262                     char *s = savesvpv(lv);
11263                     char * const origs = s;
11264                 
11265                     while (*s && *s != '\n')
11266                         s++;
11267                 
11268                     if (*s == '\n') {
11269                         const char * const t = ++s;
11270                         
11271                         while (*s) {
11272                             if (*s == '\n')
11273                                 *s = ' ';
11274                             s++;
11275                         }
11276                         if (s[-1] == ' ')
11277                             s[-1] = 0;
11278                         
11279                         sv_catpv(sv, t);
11280                     }
11281                 
11282                     Safefree(origs);
11283                 }
11284             }
11285         }
11286
11287         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
11288     }
11289     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
11290         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
11291 #else
11292     PERL_UNUSED_CONTEXT;
11293     PERL_UNUSED_ARG(sv);
11294     PERL_UNUSED_ARG(o);
11295     PERL_UNUSED_ARG(prog);
11296 #endif  /* DEBUGGING */
11297 }
11298
11299 SV *
11300 Perl_re_intuit_string(pTHX_ REGEXP * const r)
11301 {                               /* Assume that RE_INTUIT is set */
11302     dVAR;
11303     struct regexp *const prog = (struct regexp *)SvANY(r);
11304     GET_RE_DEBUG_FLAGS_DECL;
11305
11306     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
11307     PERL_UNUSED_CONTEXT;
11308
11309     DEBUG_COMPILE_r(
11310         {
11311             const char * const s = SvPV_nolen_const(prog->check_substr
11312                       ? prog->check_substr : prog->check_utf8);
11313
11314             if (!PL_colorset) reginitcolors();
11315             PerlIO_printf(Perl_debug_log,
11316                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
11317                       PL_colors[4],
11318                       prog->check_substr ? "" : "utf8 ",
11319                       PL_colors[5],PL_colors[0],
11320                       s,
11321                       PL_colors[1],
11322                       (strlen(s) > 60 ? "..." : ""));
11323         } );
11324
11325     return prog->check_substr ? prog->check_substr : prog->check_utf8;
11326 }
11327
11328 /* 
11329    pregfree() 
11330    
11331    handles refcounting and freeing the perl core regexp structure. When 
11332    it is necessary to actually free the structure the first thing it 
11333    does is call the 'free' method of the regexp_engine associated to
11334    the regexp, allowing the handling of the void *pprivate; member 
11335    first. (This routine is not overridable by extensions, which is why 
11336    the extensions free is called first.)
11337    
11338    See regdupe and regdupe_internal if you change anything here. 
11339 */
11340 #ifndef PERL_IN_XSUB_RE
11341 void
11342 Perl_pregfree(pTHX_ REGEXP *r)
11343 {
11344     SvREFCNT_dec(r);
11345 }
11346
11347 void
11348 Perl_pregfree2(pTHX_ REGEXP *rx)
11349 {
11350     dVAR;
11351     struct regexp *const r = (struct regexp *)SvANY(rx);
11352     GET_RE_DEBUG_FLAGS_DECL;
11353
11354     PERL_ARGS_ASSERT_PREGFREE2;
11355
11356     if (r->mother_re) {
11357         ReREFCNT_dec(r->mother_re);
11358     } else {
11359         CALLREGFREE_PVT(rx); /* free the private data */
11360         SvREFCNT_dec(RXp_PAREN_NAMES(r));
11361     }        
11362     if (r->substrs) {
11363         SvREFCNT_dec(r->anchored_substr);
11364         SvREFCNT_dec(r->anchored_utf8);
11365         SvREFCNT_dec(r->float_substr);
11366         SvREFCNT_dec(r->float_utf8);
11367         Safefree(r->substrs);
11368     }
11369     RX_MATCH_COPY_FREE(rx);
11370 #ifdef PERL_OLD_COPY_ON_WRITE
11371     SvREFCNT_dec(r->saved_copy);
11372 #endif
11373     Safefree(r->offs);
11374 }
11375
11376 /*  reg_temp_copy()
11377     
11378     This is a hacky workaround to the structural issue of match results
11379     being stored in the regexp structure which is in turn stored in
11380     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
11381     could be PL_curpm in multiple contexts, and could require multiple
11382     result sets being associated with the pattern simultaneously, such
11383     as when doing a recursive match with (??{$qr})
11384     
11385     The solution is to make a lightweight copy of the regexp structure 
11386     when a qr// is returned from the code executed by (??{$qr}) this
11387     lightweight copy doesn't actually own any of its data except for
11388     the starp/end and the actual regexp structure itself. 
11389     
11390 */    
11391     
11392     
11393 REGEXP *
11394 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
11395 {
11396     struct regexp *ret;
11397     struct regexp *const r = (struct regexp *)SvANY(rx);
11398     register const I32 npar = r->nparens+1;
11399
11400     PERL_ARGS_ASSERT_REG_TEMP_COPY;
11401
11402     if (!ret_x)
11403         ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
11404     ret = (struct regexp *)SvANY(ret_x);
11405     
11406     (void)ReREFCNT_inc(rx);
11407     /* We can take advantage of the existing "copied buffer" mechanism in SVs
11408        by pointing directly at the buffer, but flagging that the allocated
11409        space in the copy is zero. As we've just done a struct copy, it's now
11410        a case of zero-ing that, rather than copying the current length.  */
11411     SvPV_set(ret_x, RX_WRAPPED(rx));
11412     SvFLAGS(ret_x) |= SvFLAGS(rx) & (SVf_POK|SVp_POK|SVf_UTF8);
11413     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
11414            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
11415     SvLEN_set(ret_x, 0);
11416     SvSTASH_set(ret_x, NULL);
11417     SvMAGIC_set(ret_x, NULL);
11418     Newx(ret->offs, npar, regexp_paren_pair);
11419     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
11420     if (r->substrs) {
11421         Newx(ret->substrs, 1, struct reg_substr_data);
11422         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
11423
11424         SvREFCNT_inc_void(ret->anchored_substr);
11425         SvREFCNT_inc_void(ret->anchored_utf8);
11426         SvREFCNT_inc_void(ret->float_substr);
11427         SvREFCNT_inc_void(ret->float_utf8);
11428
11429         /* check_substr and check_utf8, if non-NULL, point to either their
11430            anchored or float namesakes, and don't hold a second reference.  */
11431     }
11432     RX_MATCH_COPIED_off(ret_x);
11433 #ifdef PERL_OLD_COPY_ON_WRITE
11434     ret->saved_copy = NULL;
11435 #endif
11436     ret->mother_re = rx;
11437     
11438     return ret_x;
11439 }
11440 #endif
11441
11442 /* regfree_internal() 
11443
11444    Free the private data in a regexp. This is overloadable by 
11445    extensions. Perl takes care of the regexp structure in pregfree(), 
11446    this covers the *pprivate pointer which technically perl doesn't 
11447    know about, however of course we have to handle the 
11448    regexp_internal structure when no extension is in use. 
11449    
11450    Note this is called before freeing anything in the regexp 
11451    structure. 
11452  */
11453  
11454 void
11455 Perl_regfree_internal(pTHX_ REGEXP * const rx)
11456 {
11457     dVAR;
11458     struct regexp *const r = (struct regexp *)SvANY(rx);
11459     RXi_GET_DECL(r,ri);
11460     GET_RE_DEBUG_FLAGS_DECL;
11461
11462     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
11463
11464     DEBUG_COMPILE_r({
11465         if (!PL_colorset)
11466             reginitcolors();
11467         {
11468             SV *dsv= sv_newmortal();
11469             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
11470                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
11471             PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n", 
11472                 PL_colors[4],PL_colors[5],s);
11473         }
11474     });
11475 #ifdef RE_TRACK_PATTERN_OFFSETS
11476     if (ri->u.offsets)
11477         Safefree(ri->u.offsets);             /* 20010421 MJD */
11478 #endif
11479     if (ri->data) {
11480         int n = ri->data->count;
11481         PAD* new_comppad = NULL;
11482         PAD* old_comppad;
11483         PADOFFSET refcnt;
11484
11485         while (--n >= 0) {
11486           /* If you add a ->what type here, update the comment in regcomp.h */
11487             switch (ri->data->what[n]) {
11488             case 'a':
11489             case 's':
11490             case 'S':
11491             case 'u':
11492                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
11493                 break;
11494             case 'f':
11495                 Safefree(ri->data->data[n]);
11496                 break;
11497             case 'p':
11498                 new_comppad = MUTABLE_AV(ri->data->data[n]);
11499                 break;
11500             case 'o':
11501                 if (new_comppad == NULL)
11502                     Perl_croak(aTHX_ "panic: pregfree comppad");
11503                 PAD_SAVE_LOCAL(old_comppad,
11504                     /* Watch out for global destruction's random ordering. */
11505                     (SvTYPE(new_comppad) == SVt_PVAV) ? new_comppad : NULL
11506                 );
11507                 OP_REFCNT_LOCK;
11508                 refcnt = OpREFCNT_dec((OP_4tree*)ri->data->data[n]);
11509                 OP_REFCNT_UNLOCK;
11510                 if (!refcnt)
11511                     op_free((OP_4tree*)ri->data->data[n]);
11512
11513                 PAD_RESTORE_LOCAL(old_comppad);
11514                 SvREFCNT_dec(MUTABLE_SV(new_comppad));
11515                 new_comppad = NULL;
11516                 break;
11517             case 'n':
11518                 break;
11519             case 'T':           
11520                 { /* Aho Corasick add-on structure for a trie node.
11521                      Used in stclass optimization only */
11522                     U32 refcount;
11523                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
11524                     OP_REFCNT_LOCK;
11525                     refcount = --aho->refcount;
11526                     OP_REFCNT_UNLOCK;
11527                     if ( !refcount ) {
11528                         PerlMemShared_free(aho->states);
11529                         PerlMemShared_free(aho->fail);
11530                          /* do this last!!!! */
11531                         PerlMemShared_free(ri->data->data[n]);
11532                         PerlMemShared_free(ri->regstclass);
11533                     }
11534                 }
11535                 break;
11536             case 't':
11537                 {
11538                     /* trie structure. */
11539                     U32 refcount;
11540                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
11541                     OP_REFCNT_LOCK;
11542                     refcount = --trie->refcount;
11543                     OP_REFCNT_UNLOCK;
11544                     if ( !refcount ) {
11545                         PerlMemShared_free(trie->charmap);
11546                         PerlMemShared_free(trie->states);
11547                         PerlMemShared_free(trie->trans);
11548                         if (trie->bitmap)
11549                             PerlMemShared_free(trie->bitmap);
11550                         if (trie->jump)
11551                             PerlMemShared_free(trie->jump);
11552                         PerlMemShared_free(trie->wordinfo);
11553                         /* do this last!!!! */
11554                         PerlMemShared_free(ri->data->data[n]);
11555                     }
11556                 }
11557                 break;
11558             default:
11559                 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
11560             }
11561         }
11562         Safefree(ri->data->what);
11563         Safefree(ri->data);
11564     }
11565
11566     Safefree(ri);
11567 }
11568
11569 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
11570 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
11571 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
11572
11573 /* 
11574    re_dup - duplicate a regexp. 
11575    
11576    This routine is expected to clone a given regexp structure. It is only
11577    compiled under USE_ITHREADS.
11578
11579    After all of the core data stored in struct regexp is duplicated
11580    the regexp_engine.dupe method is used to copy any private data
11581    stored in the *pprivate pointer. This allows extensions to handle
11582    any duplication it needs to do.
11583
11584    See pregfree() and regfree_internal() if you change anything here. 
11585 */
11586 #if defined(USE_ITHREADS)
11587 #ifndef PERL_IN_XSUB_RE
11588 void
11589 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
11590 {
11591     dVAR;
11592     I32 npar;
11593     const struct regexp *r = (const struct regexp *)SvANY(sstr);
11594     struct regexp *ret = (struct regexp *)SvANY(dstr);
11595     
11596     PERL_ARGS_ASSERT_RE_DUP_GUTS;
11597
11598     npar = r->nparens+1;
11599     Newx(ret->offs, npar, regexp_paren_pair);
11600     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
11601     if(ret->swap) {
11602         /* no need to copy these */
11603         Newx(ret->swap, npar, regexp_paren_pair);
11604     }
11605
11606     if (ret->substrs) {
11607         /* Do it this way to avoid reading from *r after the StructCopy().
11608            That way, if any of the sv_dup_inc()s dislodge *r from the L1
11609            cache, it doesn't matter.  */
11610         const bool anchored = r->check_substr
11611             ? r->check_substr == r->anchored_substr
11612             : r->check_utf8 == r->anchored_utf8;
11613         Newx(ret->substrs, 1, struct reg_substr_data);
11614         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
11615
11616         ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
11617         ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
11618         ret->float_substr = sv_dup_inc(ret->float_substr, param);
11619         ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
11620
11621         /* check_substr and check_utf8, if non-NULL, point to either their
11622            anchored or float namesakes, and don't hold a second reference.  */
11623
11624         if (ret->check_substr) {
11625             if (anchored) {
11626                 assert(r->check_utf8 == r->anchored_utf8);
11627                 ret->check_substr = ret->anchored_substr;
11628                 ret->check_utf8 = ret->anchored_utf8;
11629             } else {
11630                 assert(r->check_substr == r->float_substr);
11631                 assert(r->check_utf8 == r->float_utf8);
11632                 ret->check_substr = ret->float_substr;
11633                 ret->check_utf8 = ret->float_utf8;
11634             }
11635         } else if (ret->check_utf8) {
11636             if (anchored) {
11637                 ret->check_utf8 = ret->anchored_utf8;
11638             } else {
11639                 ret->check_utf8 = ret->float_utf8;
11640             }
11641         }
11642     }
11643
11644     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
11645
11646     if (ret->pprivate)
11647         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
11648
11649     if (RX_MATCH_COPIED(dstr))
11650         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
11651     else
11652         ret->subbeg = NULL;
11653 #ifdef PERL_OLD_COPY_ON_WRITE
11654     ret->saved_copy = NULL;
11655 #endif
11656
11657     if (ret->mother_re) {
11658         if (SvPVX_const(dstr) == SvPVX_const(ret->mother_re)) {
11659             /* Our storage points directly to our mother regexp, but that's
11660                1: a buffer in a different thread
11661                2: something we no longer hold a reference on
11662                so we need to copy it locally.  */
11663             /* Note we need to sue SvCUR() on our mother_re, because it, in
11664                turn, may well be pointing to its own mother_re.  */
11665             SvPV_set(dstr, SAVEPVN(SvPVX_const(ret->mother_re),
11666                                    SvCUR(ret->mother_re)+1));
11667             SvLEN_set(dstr, SvCUR(ret->mother_re)+1);
11668         }
11669         ret->mother_re      = NULL;
11670     }
11671     ret->gofs = 0;
11672 }
11673 #endif /* PERL_IN_XSUB_RE */
11674
11675 /*
11676    regdupe_internal()
11677    
11678    This is the internal complement to regdupe() which is used to copy
11679    the structure pointed to by the *pprivate pointer in the regexp.
11680    This is the core version of the extension overridable cloning hook.
11681    The regexp structure being duplicated will be copied by perl prior
11682    to this and will be provided as the regexp *r argument, however 
11683    with the /old/ structures pprivate pointer value. Thus this routine
11684    may override any copying normally done by perl.
11685    
11686    It returns a pointer to the new regexp_internal structure.
11687 */
11688
11689 void *
11690 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
11691 {
11692     dVAR;
11693     struct regexp *const r = (struct regexp *)SvANY(rx);
11694     regexp_internal *reti;
11695     int len;
11696     RXi_GET_DECL(r,ri);
11697
11698     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
11699     
11700     len = ProgLen(ri);
11701     
11702     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), char, regexp_internal);
11703     Copy(ri->program, reti->program, len+1, regnode);
11704     
11705
11706     reti->regstclass = NULL;
11707
11708     if (ri->data) {
11709         struct reg_data *d;
11710         const int count = ri->data->count;
11711         int i;
11712
11713         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
11714                 char, struct reg_data);
11715         Newx(d->what, count, U8);
11716
11717         d->count = count;
11718         for (i = 0; i < count; i++) {
11719             d->what[i] = ri->data->what[i];
11720             switch (d->what[i]) {
11721                 /* legal options are one of: sSfpontTua
11722                    see also regcomp.h and pregfree() */
11723             case 'a': /* actually an AV, but the dup function is identical.  */
11724             case 's':
11725             case 'S':
11726             case 'p': /* actually an AV, but the dup function is identical.  */
11727             case 'u': /* actually an HV, but the dup function is identical.  */
11728                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
11729                 break;
11730             case 'f':
11731                 /* This is cheating. */
11732                 Newx(d->data[i], 1, struct regnode_charclass_class);
11733                 StructCopy(ri->data->data[i], d->data[i],
11734                             struct regnode_charclass_class);
11735                 reti->regstclass = (regnode*)d->data[i];
11736                 break;
11737             case 'o':
11738                 /* Compiled op trees are readonly and in shared memory,
11739                    and can thus be shared without duplication. */
11740                 OP_REFCNT_LOCK;
11741                 d->data[i] = (void*)OpREFCNT_inc((OP*)ri->data->data[i]);
11742                 OP_REFCNT_UNLOCK;
11743                 break;
11744             case 'T':
11745                 /* Trie stclasses are readonly and can thus be shared
11746                  * without duplication. We free the stclass in pregfree
11747                  * when the corresponding reg_ac_data struct is freed.
11748                  */
11749                 reti->regstclass= ri->regstclass;
11750                 /* Fall through */
11751             case 't':
11752                 OP_REFCNT_LOCK;
11753                 ((reg_trie_data*)ri->data->data[i])->refcount++;
11754                 OP_REFCNT_UNLOCK;
11755                 /* Fall through */
11756             case 'n':
11757                 d->data[i] = ri->data->data[i];
11758                 break;
11759             default:
11760                 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
11761             }
11762         }
11763
11764         reti->data = d;
11765     }
11766     else
11767         reti->data = NULL;
11768
11769     reti->name_list_idx = ri->name_list_idx;
11770
11771 #ifdef RE_TRACK_PATTERN_OFFSETS
11772     if (ri->u.offsets) {
11773         Newx(reti->u.offsets, 2*len+1, U32);
11774         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
11775     }
11776 #else
11777     SetProgLen(reti,len);
11778 #endif
11779
11780     return (void*)reti;
11781 }
11782
11783 #endif    /* USE_ITHREADS */
11784
11785 #ifndef PERL_IN_XSUB_RE
11786
11787 /*
11788  - regnext - dig the "next" pointer out of a node
11789  */
11790 regnode *
11791 Perl_regnext(pTHX_ register regnode *p)
11792 {
11793     dVAR;
11794     register I32 offset;
11795
11796     if (!p)
11797         return(NULL);
11798
11799     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
11800         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(p), (int)REGNODE_MAX);
11801     }
11802
11803     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
11804     if (offset == 0)
11805         return(NULL);
11806
11807     return(p+offset);
11808 }
11809 #endif
11810
11811 STATIC void     
11812 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
11813 {
11814     va_list args;
11815     STRLEN l1 = strlen(pat1);
11816     STRLEN l2 = strlen(pat2);
11817     char buf[512];
11818     SV *msv;
11819     const char *message;
11820
11821     PERL_ARGS_ASSERT_RE_CROAK2;
11822
11823     if (l1 > 510)
11824         l1 = 510;
11825     if (l1 + l2 > 510)
11826         l2 = 510 - l1;
11827     Copy(pat1, buf, l1 , char);
11828     Copy(pat2, buf + l1, l2 , char);
11829     buf[l1 + l2] = '\n';
11830     buf[l1 + l2 + 1] = '\0';
11831 #ifdef I_STDARG
11832     /* ANSI variant takes additional second argument */
11833     va_start(args, pat2);
11834 #else
11835     va_start(args);
11836 #endif
11837     msv = vmess(buf, &args);
11838     va_end(args);
11839     message = SvPV_const(msv,l1);
11840     if (l1 > 512)
11841         l1 = 512;
11842     Copy(message, buf, l1 , char);
11843     buf[l1-1] = '\0';                   /* Overwrite \n */
11844     Perl_croak(aTHX_ "%s", buf);
11845 }
11846
11847 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
11848
11849 #ifndef PERL_IN_XSUB_RE
11850 void
11851 Perl_save_re_context(pTHX)
11852 {
11853     dVAR;
11854
11855     struct re_save_state *state;
11856
11857     SAVEVPTR(PL_curcop);
11858     SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
11859
11860     state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
11861     PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
11862     SSPUSHUV(SAVEt_RE_STATE);
11863
11864     Copy(&PL_reg_state, state, 1, struct re_save_state);
11865
11866     PL_reg_start_tmp = 0;
11867     PL_reg_start_tmpl = 0;
11868     PL_reg_oldsaved = NULL;
11869     PL_reg_oldsavedlen = 0;
11870     PL_reg_maxiter = 0;
11871     PL_reg_leftiter = 0;
11872     PL_reg_poscache = NULL;
11873     PL_reg_poscache_size = 0;
11874 #ifdef PERL_OLD_COPY_ON_WRITE
11875     PL_nrs = NULL;
11876 #endif
11877
11878     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
11879     if (PL_curpm) {
11880         const REGEXP * const rx = PM_GETRE(PL_curpm);
11881         if (rx) {
11882             U32 i;
11883             for (i = 1; i <= RX_NPARENS(rx); i++) {
11884                 char digits[TYPE_CHARS(long)];
11885                 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
11886                 GV *const *const gvp
11887                     = (GV**)hv_fetch(PL_defstash, digits, len, 0);
11888
11889                 if (gvp) {
11890                     GV * const gv = *gvp;
11891                     if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
11892                         save_scalar(gv);
11893                 }
11894             }
11895         }
11896     }
11897 }
11898 #endif
11899
11900 static void
11901 clear_re(pTHX_ void *r)
11902 {
11903     dVAR;
11904     ReREFCNT_dec((REGEXP *)r);
11905 }
11906
11907 #ifdef DEBUGGING
11908
11909 STATIC void
11910 S_put_byte(pTHX_ SV *sv, int c)
11911 {
11912     PERL_ARGS_ASSERT_PUT_BYTE;
11913
11914     /* Our definition of isPRINT() ignores locales, so only bytes that are
11915        not part of UTF-8 are considered printable. I assume that the same
11916        holds for UTF-EBCDIC.
11917        Also, code point 255 is not printable in either (it's E0 in EBCDIC,
11918        which Wikipedia says:
11919
11920        EO, or Eight Ones, is an 8-bit EBCDIC character code represented as all
11921        ones (binary 1111 1111, hexadecimal FF). It is similar, but not
11922        identical, to the ASCII delete (DEL) or rubout control character.
11923        ) So the old condition can be simplified to !isPRINT(c)  */
11924     if (!isPRINT(c)) {
11925         if (c < 256) {
11926             Perl_sv_catpvf(aTHX_ sv, "\\x%02x", c);
11927         }
11928         else {
11929             Perl_sv_catpvf(aTHX_ sv, "\\x{%x}", c);
11930         }
11931     }
11932     else {
11933         const char string = c;
11934         if (c == '-' || c == ']' || c == '\\' || c == '^')
11935             sv_catpvs(sv, "\\");
11936         sv_catpvn(sv, &string, 1);
11937     }
11938 }
11939
11940
11941 #define CLEAR_OPTSTART \
11942     if (optstart) STMT_START { \
11943             DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
11944             optstart=NULL; \
11945     } STMT_END
11946
11947 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
11948
11949 STATIC const regnode *
11950 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
11951             const regnode *last, const regnode *plast, 
11952             SV* sv, I32 indent, U32 depth)
11953 {
11954     dVAR;
11955     register U8 op = PSEUDO;    /* Arbitrary non-END op. */
11956     register const regnode *next;
11957     const regnode *optstart= NULL;
11958     
11959     RXi_GET_DECL(r,ri);
11960     GET_RE_DEBUG_FLAGS_DECL;
11961
11962     PERL_ARGS_ASSERT_DUMPUNTIL;
11963
11964 #ifdef DEBUG_DUMPUNTIL
11965     PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
11966         last ? last-start : 0,plast ? plast-start : 0);
11967 #endif
11968             
11969     if (plast && plast < last) 
11970         last= plast;
11971
11972     while (PL_regkind[op] != END && (!last || node < last)) {
11973         /* While that wasn't END last time... */
11974         NODE_ALIGN(node);
11975         op = OP(node);
11976         if (op == CLOSE || op == WHILEM)
11977             indent--;
11978         next = regnext((regnode *)node);
11979
11980         /* Where, what. */
11981         if (OP(node) == OPTIMIZED) {
11982             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
11983                 optstart = node;
11984             else
11985                 goto after_print;
11986         } else
11987             CLEAR_OPTSTART;
11988         
11989         regprop(r, sv, node);
11990         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
11991                       (int)(2*indent + 1), "", SvPVX_const(sv));
11992         
11993         if (OP(node) != OPTIMIZED) {                  
11994             if (next == NULL)           /* Next ptr. */
11995                 PerlIO_printf(Perl_debug_log, " (0)");
11996             else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
11997                 PerlIO_printf(Perl_debug_log, " (FAIL)");
11998             else 
11999                 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
12000             (void)PerlIO_putc(Perl_debug_log, '\n'); 
12001         }
12002         
12003       after_print:
12004         if (PL_regkind[(U8)op] == BRANCHJ) {
12005             assert(next);
12006             {
12007                 register const regnode *nnode = (OP(next) == LONGJMP
12008                                              ? regnext((regnode *)next)
12009                                              : next);
12010                 if (last && nnode > last)
12011                     nnode = last;
12012                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
12013             }
12014         }
12015         else if (PL_regkind[(U8)op] == BRANCH) {
12016             assert(next);
12017             DUMPUNTIL(NEXTOPER(node), next);
12018         }
12019         else if ( PL_regkind[(U8)op]  == TRIE ) {
12020             const regnode *this_trie = node;
12021             const char op = OP(node);
12022             const U32 n = ARG(node);
12023             const reg_ac_data * const ac = op>=AHOCORASICK ?
12024                (reg_ac_data *)ri->data->data[n] :
12025                NULL;
12026             const reg_trie_data * const trie =
12027                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
12028 #ifdef DEBUGGING
12029             AV *const trie_words = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
12030 #endif
12031             const regnode *nextbranch= NULL;
12032             I32 word_idx;
12033             sv_setpvs(sv, "");
12034             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
12035                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
12036                 
12037                 PerlIO_printf(Perl_debug_log, "%*s%s ",
12038                    (int)(2*(indent+3)), "",
12039                     elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
12040                             PL_colors[0], PL_colors[1],
12041                             (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
12042                             PERL_PV_PRETTY_ELLIPSES    |
12043                             PERL_PV_PRETTY_LTGT
12044                             )
12045                             : "???"
12046                 );
12047                 if (trie->jump) {
12048                     U16 dist= trie->jump[word_idx+1];
12049                     PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
12050                                   (UV)((dist ? this_trie + dist : next) - start));
12051                     if (dist) {
12052                         if (!nextbranch)
12053                             nextbranch= this_trie + trie->jump[0];    
12054                         DUMPUNTIL(this_trie + dist, nextbranch);
12055                     }
12056                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
12057                         nextbranch= regnext((regnode *)nextbranch);
12058                 } else {
12059                     PerlIO_printf(Perl_debug_log, "\n");
12060                 }
12061             }
12062             if (last && next > last)
12063                 node= last;
12064             else
12065                 node= next;
12066         }
12067         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
12068             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
12069                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
12070         }
12071         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
12072             assert(next);
12073             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
12074         }
12075         else if ( op == PLUS || op == STAR) {
12076             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
12077         }
12078         else if (PL_regkind[(U8)op] == ANYOF) {
12079             /* arglen 1 + class block */
12080             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_CLASS)
12081                     ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
12082             node = NEXTOPER(node);
12083         }
12084         else if (PL_regkind[(U8)op] == EXACT) {
12085             /* Literal string, where present. */
12086             node += NODE_SZ_STR(node) - 1;
12087             node = NEXTOPER(node);
12088         }
12089         else {
12090             node = NEXTOPER(node);
12091             node += regarglen[(U8)op];
12092         }
12093         if (op == CURLYX || op == OPEN)
12094             indent++;
12095     }
12096     CLEAR_OPTSTART;
12097 #ifdef DEBUG_DUMPUNTIL    
12098     PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
12099 #endif
12100     return node;
12101 }
12102
12103 #endif  /* DEBUGGING */
12104
12105 /*
12106  * Local variables:
12107  * c-indentation-style: bsd
12108  * c-basic-offset: 4
12109  * indent-tabs-mode: t
12110  * End:
12111  *
12112  * ex: set ts=8 sts=4 sw=4 noet:
12113  */