]> git.vpit.fr Git - perl/modules/re-engine-Hooks.git/blob - src/5017002/orig/regcomp.c
Show progression while the tarballs are downloaded
[perl/modules/re-engine-Hooks.git] / src / 5017002 / orig / regcomp.c
1 /*    regcomp.c
2  */
3
4 /*
5  * 'A fair jaw-cracker dwarf-language must be.'            --Samwise Gamgee
6  *
7  *     [p.285 of _The Lord of the Rings_, II/iii: "The Ring Goes South"]
8  */
9
10 /* This file contains functions for compiling a regular expression.  See
11  * also regexec.c which funnily enough, contains functions for executing
12  * a regular expression.
13  *
14  * This file is also copied at build time to ext/re/re_comp.c, where
15  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
16  * This causes the main functions to be compiled under new names and with
17  * debugging support added, which makes "use re 'debug'" work.
18  */
19
20 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
21  * confused with the original package (see point 3 below).  Thanks, Henry!
22  */
23
24 /* Additional note: this code is very heavily munged from Henry's version
25  * in places.  In some spots I've traded clarity for efficiency, so don't
26  * blame Henry for some of the lack of readability.
27  */
28
29 /* The names of the functions have been changed from regcomp and
30  * regexec to pregcomp and pregexec in order to avoid conflicts
31  * with the POSIX routines of the same names.
32 */
33
34 #ifdef PERL_EXT_RE_BUILD
35 #include "re_top.h"
36 #endif
37
38 /*
39  * pregcomp and pregexec -- regsub and regerror are not used in perl
40  *
41  *      Copyright (c) 1986 by University of Toronto.
42  *      Written by Henry Spencer.  Not derived from licensed software.
43  *
44  *      Permission is granted to anyone to use this software for any
45  *      purpose on any computer system, and to redistribute it freely,
46  *      subject to the following restrictions:
47  *
48  *      1. The author is not responsible for the consequences of use of
49  *              this software, no matter how awful, even if they arise
50  *              from defects in it.
51  *
52  *      2. The origin of this software must not be misrepresented, either
53  *              by explicit claim or by omission.
54  *
55  *      3. Altered versions must be plainly marked as such, and must not
56  *              be misrepresented as being the original software.
57  *
58  *
59  ****    Alterations to Henry's code are...
60  ****
61  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
62  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
63  ****    by Larry Wall and others
64  ****
65  ****    You may distribute under the terms of either the GNU General Public
66  ****    License or the Artistic License, as specified in the README file.
67
68  *
69  * Beware that some of this code is subtly aware of the way operator
70  * precedence is structured in regular expressions.  Serious changes in
71  * regular-expression syntax might require a total rethink.
72  */
73 #include "EXTERN.h"
74 #define PERL_IN_REGCOMP_C
75 #include "perl.h"
76
77 #ifndef PERL_IN_XSUB_RE
78 #  include "INTERN.h"
79 #endif
80
81 #define REG_COMP_C
82 #ifdef PERL_IN_XSUB_RE
83 #  include "re_comp.h"
84 #else
85 #  include "regcomp.h"
86 #endif
87
88 #include "dquote_static.c"
89 #ifndef PERL_IN_XSUB_RE
90 #  include "charclass_invlists.h"
91 #endif
92
93 #define HAS_NONLATIN1_FOLD_CLOSURE(i) _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
94
95 #ifdef op
96 #undef op
97 #endif /* op */
98
99 #ifdef MSDOS
100 #  if defined(BUGGY_MSC6)
101  /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
102 #    pragma optimize("a",off)
103  /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
104 #    pragma optimize("w",on )
105 #  endif /* BUGGY_MSC6 */
106 #endif /* MSDOS */
107
108 #ifndef STATIC
109 #define STATIC  static
110 #endif
111
112
113 typedef struct RExC_state_t {
114     U32         flags;                  /* RXf_* are we folding, multilining? */
115     U32         pm_flags;               /* PMf_* stuff from the calling PMOP */
116     char        *precomp;               /* uncompiled string. */
117     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
118     regexp      *rx;                    /* perl core regexp structure */
119     regexp_internal     *rxi;           /* internal data for regexp object pprivate field */        
120     char        *start;                 /* Start of input for compile */
121     char        *end;                   /* End of input for compile */
122     char        *parse;                 /* Input-scan pointer. */
123     I32         whilem_seen;            /* number of WHILEM in this expr */
124     regnode     *emit_start;            /* Start of emitted-code area */
125     regnode     *emit_bound;            /* First regnode outside of the allocated space */
126     regnode     *emit;                  /* Code-emit pointer; &regdummy = don't = compiling */
127     I32         naughty;                /* How bad is this pattern? */
128     I32         sawback;                /* Did we see \1, ...? */
129     U32         seen;
130     I32         size;                   /* Code size. */
131     I32         npar;                   /* Capture buffer count, (OPEN). */
132     I32         cpar;                   /* Capture buffer count, (CLOSE). */
133     I32         nestroot;               /* root parens we are in - used by accept */
134     I32         extralen;
135     I32         seen_zerolen;
136     regnode     **open_parens;          /* pointers to open parens */
137     regnode     **close_parens;         /* pointers to close parens */
138     regnode     *opend;                 /* END node in program */
139     I32         utf8;           /* whether the pattern is utf8 or not */
140     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
141                                 /* XXX use this for future optimisation of case
142                                  * where pattern must be upgraded to utf8. */
143     I32         uni_semantics;  /* If a d charset modifier should use unicode
144                                    rules, even if the pattern is not in
145                                    utf8 */
146     HV          *paren_names;           /* Paren names */
147     
148     regnode     **recurse;              /* Recurse regops */
149     I32         recurse_count;          /* Number of recurse regops */
150     I32         in_lookbehind;
151     I32         contains_locale;
152     I32         override_recoding;
153     struct reg_code_block *code_blocks; /* positions of literal (?{})
154                                             within pattern */
155     int         num_code_blocks;        /* size of code_blocks[] */
156     int         code_index;             /* next code_blocks[] slot */
157 #if ADD_TO_REGEXEC
158     char        *starttry;              /* -Dr: where regtry was called. */
159 #define RExC_starttry   (pRExC_state->starttry)
160 #endif
161     SV          *runtime_code_qr;       /* qr with the runtime code blocks */
162 #ifdef DEBUGGING
163     const char  *lastparse;
164     I32         lastnum;
165     AV          *paren_name_list;       /* idx -> name */
166 #define RExC_lastparse  (pRExC_state->lastparse)
167 #define RExC_lastnum    (pRExC_state->lastnum)
168 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
169 #endif
170 } RExC_state_t;
171
172 #define RExC_flags      (pRExC_state->flags)
173 #define RExC_pm_flags   (pRExC_state->pm_flags)
174 #define RExC_precomp    (pRExC_state->precomp)
175 #define RExC_rx_sv      (pRExC_state->rx_sv)
176 #define RExC_rx         (pRExC_state->rx)
177 #define RExC_rxi        (pRExC_state->rxi)
178 #define RExC_start      (pRExC_state->start)
179 #define RExC_end        (pRExC_state->end)
180 #define RExC_parse      (pRExC_state->parse)
181 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
182 #ifdef RE_TRACK_PATTERN_OFFSETS
183 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the others */
184 #endif
185 #define RExC_emit       (pRExC_state->emit)
186 #define RExC_emit_start (pRExC_state->emit_start)
187 #define RExC_emit_bound (pRExC_state->emit_bound)
188 #define RExC_naughty    (pRExC_state->naughty)
189 #define RExC_sawback    (pRExC_state->sawback)
190 #define RExC_seen       (pRExC_state->seen)
191 #define RExC_size       (pRExC_state->size)
192 #define RExC_npar       (pRExC_state->npar)
193 #define RExC_nestroot   (pRExC_state->nestroot)
194 #define RExC_extralen   (pRExC_state->extralen)
195 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
196 #define RExC_utf8       (pRExC_state->utf8)
197 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
198 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
199 #define RExC_open_parens        (pRExC_state->open_parens)
200 #define RExC_close_parens       (pRExC_state->close_parens)
201 #define RExC_opend      (pRExC_state->opend)
202 #define RExC_paren_names        (pRExC_state->paren_names)
203 #define RExC_recurse    (pRExC_state->recurse)
204 #define RExC_recurse_count      (pRExC_state->recurse_count)
205 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
206 #define RExC_contains_locale    (pRExC_state->contains_locale)
207 #define RExC_override_recoding  (pRExC_state->override_recoding)
208
209
210 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
211 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
212         ((*s) == '{' && regcurly(s)))
213
214 #ifdef SPSTART
215 #undef SPSTART          /* dratted cpp namespace... */
216 #endif
217 /*
218  * Flags to be passed up and down.
219  */
220 #define WORST           0       /* Worst case. */
221 #define HASWIDTH        0x01    /* Known to match non-null strings. */
222
223 /* Simple enough to be STAR/PLUS operand, in an EXACT node must be a single
224  * character, and if utf8, must be invariant.  Note that this is not the same
225  * thing as REGNODE_SIMPLE */
226 #define SIMPLE          0x02
227 #define SPSTART         0x04    /* Starts with * or +. */
228 #define TRYAGAIN        0x08    /* Weeded out a declaration. */
229 #define POSTPONED       0x10    /* (?1),(?&name), (??{...}) or similar */
230
231 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
232
233 /* whether trie related optimizations are enabled */
234 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
235 #define TRIE_STUDY_OPT
236 #define FULL_TRIE_STUDY
237 #define TRIE_STCLASS
238 #endif
239
240
241
242 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
243 #define PBITVAL(paren) (1 << ((paren) & 7))
244 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
245 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
246 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
247
248 /* If not already in utf8, do a longjmp back to the beginning */
249 #define UTF8_LONGJMP 42 /* Choose a value not likely to ever conflict */
250 #define REQUIRE_UTF8    STMT_START {                                       \
251                                      if (! UTF) JMPENV_JUMP(UTF8_LONGJMP); \
252                         } STMT_END
253
254 /* About scan_data_t.
255
256   During optimisation we recurse through the regexp program performing
257   various inplace (keyhole style) optimisations. In addition study_chunk
258   and scan_commit populate this data structure with information about
259   what strings MUST appear in the pattern. We look for the longest 
260   string that must appear at a fixed location, and we look for the
261   longest string that may appear at a floating location. So for instance
262   in the pattern:
263   
264     /FOO[xX]A.*B[xX]BAR/
265     
266   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
267   strings (because they follow a .* construct). study_chunk will identify
268   both FOO and BAR as being the longest fixed and floating strings respectively.
269   
270   The strings can be composites, for instance
271   
272      /(f)(o)(o)/
273      
274   will result in a composite fixed substring 'foo'.
275   
276   For each string some basic information is maintained:
277   
278   - offset or min_offset
279     This is the position the string must appear at, or not before.
280     It also implicitly (when combined with minlenp) tells us how many
281     characters must match before the string we are searching for.
282     Likewise when combined with minlenp and the length of the string it
283     tells us how many characters must appear after the string we have 
284     found.
285   
286   - max_offset
287     Only used for floating strings. This is the rightmost point that
288     the string can appear at. If set to I32 max it indicates that the
289     string can occur infinitely far to the right.
290   
291   - minlenp
292     A pointer to the minimum length of the pattern that the string 
293     was found inside. This is important as in the case of positive 
294     lookahead or positive lookbehind we can have multiple patterns 
295     involved. Consider
296     
297     /(?=FOO).*F/
298     
299     The minimum length of the pattern overall is 3, the minimum length
300     of the lookahead part is 3, but the minimum length of the part that
301     will actually match is 1. So 'FOO's minimum length is 3, but the 
302     minimum length for the F is 1. This is important as the minimum length
303     is used to determine offsets in front of and behind the string being 
304     looked for.  Since strings can be composites this is the length of the
305     pattern at the time it was committed with a scan_commit. Note that
306     the length is calculated by study_chunk, so that the minimum lengths
307     are not known until the full pattern has been compiled, thus the 
308     pointer to the value.
309   
310   - lookbehind
311   
312     In the case of lookbehind the string being searched for can be
313     offset past the start point of the final matching string. 
314     If this value was just blithely removed from the min_offset it would
315     invalidate some of the calculations for how many chars must match
316     before or after (as they are derived from min_offset and minlen and
317     the length of the string being searched for). 
318     When the final pattern is compiled and the data is moved from the
319     scan_data_t structure into the regexp structure the information
320     about lookbehind is factored in, with the information that would 
321     have been lost precalculated in the end_shift field for the 
322     associated string.
323
324   The fields pos_min and pos_delta are used to store the minimum offset
325   and the delta to the maximum offset at the current point in the pattern.    
326
327 */
328
329 typedef struct scan_data_t {
330     /*I32 len_min;      unused */
331     /*I32 len_delta;    unused */
332     I32 pos_min;
333     I32 pos_delta;
334     SV *last_found;
335     I32 last_end;           /* min value, <0 unless valid. */
336     I32 last_start_min;
337     I32 last_start_max;
338     SV **longest;           /* Either &l_fixed, or &l_float. */
339     SV *longest_fixed;      /* longest fixed string found in pattern */
340     I32 offset_fixed;       /* offset where it starts */
341     I32 *minlen_fixed;      /* pointer to the minlen relevant to the string */
342     I32 lookbehind_fixed;   /* is the position of the string modfied by LB */
343     SV *longest_float;      /* longest floating string found in pattern */
344     I32 offset_float_min;   /* earliest point in string it can appear */
345     I32 offset_float_max;   /* latest point in string it can appear */
346     I32 *minlen_float;      /* pointer to the minlen relevant to the string */
347     I32 lookbehind_float;   /* is the position of the string modified by LB */
348     I32 flags;
349     I32 whilem_c;
350     I32 *last_closep;
351     struct regnode_charclass_class *start_class;
352 } scan_data_t;
353
354 /*
355  * Forward declarations for pregcomp()'s friends.
356  */
357
358 static const scan_data_t zero_scan_data =
359   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
360
361 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
362 #define SF_BEFORE_SEOL          0x0001
363 #define SF_BEFORE_MEOL          0x0002
364 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
365 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
366
367 #ifdef NO_UNARY_PLUS
368 #  define SF_FIX_SHIFT_EOL      (0+2)
369 #  define SF_FL_SHIFT_EOL               (0+4)
370 #else
371 #  define SF_FIX_SHIFT_EOL      (+2)
372 #  define SF_FL_SHIFT_EOL               (+4)
373 #endif
374
375 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
376 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
377
378 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
379 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
380 #define SF_IS_INF               0x0040
381 #define SF_HAS_PAR              0x0080
382 #define SF_IN_PAR               0x0100
383 #define SF_HAS_EVAL             0x0200
384 #define SCF_DO_SUBSTR           0x0400
385 #define SCF_DO_STCLASS_AND      0x0800
386 #define SCF_DO_STCLASS_OR       0x1000
387 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
388 #define SCF_WHILEM_VISITED_POS  0x2000
389
390 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
391 #define SCF_SEEN_ACCEPT         0x8000 
392
393 #define UTF cBOOL(RExC_utf8)
394
395 /* The enums for all these are ordered so things work out correctly */
396 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
397 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_DEPENDS_CHARSET)
398 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
399 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags) >= REGEX_UNICODE_CHARSET)
400 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_RESTRICTED_CHARSET)
401 #define MORE_ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
402 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags) >= REGEX_ASCII_RESTRICTED_CHARSET)
403
404 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
405
406 #define OOB_UNICODE             12345678
407 #define OOB_NAMEDCLASS          -1
408
409 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
410 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
411
412
413 /* length of regex to show in messages that don't mark a position within */
414 #define RegexLengthToShowInErrorMessages 127
415
416 /*
417  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
418  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
419  * op/pragma/warn/regcomp.
420  */
421 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
422 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
423
424 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
425
426 /*
427  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
428  * arg. Show regex, up to a maximum length. If it's too long, chop and add
429  * "...".
430  */
431 #define _FAIL(code) STMT_START {                                        \
432     const char *ellipses = "";                                          \
433     IV len = RExC_end - RExC_precomp;                                   \
434                                                                         \
435     if (!SIZE_ONLY)                                                     \
436         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);                   \
437     if (len > RegexLengthToShowInErrorMessages) {                       \
438         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
439         len = RegexLengthToShowInErrorMessages - 10;                    \
440         ellipses = "...";                                               \
441     }                                                                   \
442     code;                                                               \
443 } STMT_END
444
445 #define FAIL(msg) _FAIL(                            \
446     Perl_croak(aTHX_ "%s in regex m/%.*s%s/",       \
447             msg, (int)len, RExC_precomp, ellipses))
448
449 #define FAIL2(msg,arg) _FAIL(                       \
450     Perl_croak(aTHX_ msg " in regex m/%.*s%s/",     \
451             arg, (int)len, RExC_precomp, ellipses))
452
453 /*
454  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
455  */
456 #define Simple_vFAIL(m) STMT_START {                                    \
457     const IV offset = RExC_parse - RExC_precomp;                        \
458     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
459             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
460 } STMT_END
461
462 /*
463  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
464  */
465 #define vFAIL(m) STMT_START {                           \
466     if (!SIZE_ONLY)                                     \
467         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);   \
468     Simple_vFAIL(m);                                    \
469 } STMT_END
470
471 /*
472  * Like Simple_vFAIL(), but accepts two arguments.
473  */
474 #define Simple_vFAIL2(m,a1) STMT_START {                        \
475     const IV offset = RExC_parse - RExC_precomp;                        \
476     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1,                   \
477             (int)offset, RExC_precomp, RExC_precomp + offset);  \
478 } STMT_END
479
480 /*
481  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
482  */
483 #define vFAIL2(m,a1) STMT_START {                       \
484     if (!SIZE_ONLY)                                     \
485         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);   \
486     Simple_vFAIL2(m, a1);                               \
487 } STMT_END
488
489
490 /*
491  * Like Simple_vFAIL(), but accepts three arguments.
492  */
493 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
494     const IV offset = RExC_parse - RExC_precomp;                \
495     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2,               \
496             (int)offset, RExC_precomp, RExC_precomp + offset);  \
497 } STMT_END
498
499 /*
500  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
501  */
502 #define vFAIL3(m,a1,a2) STMT_START {                    \
503     if (!SIZE_ONLY)                                     \
504         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);   \
505     Simple_vFAIL3(m, a1, a2);                           \
506 } STMT_END
507
508 /*
509  * Like Simple_vFAIL(), but accepts four arguments.
510  */
511 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
512     const IV offset = RExC_parse - RExC_precomp;                \
513     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3,           \
514             (int)offset, RExC_precomp, RExC_precomp + offset);  \
515 } STMT_END
516
517 #define ckWARNreg(loc,m) STMT_START {                                   \
518     const IV offset = loc - RExC_precomp;                               \
519     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
520             (int)offset, RExC_precomp, RExC_precomp + offset);          \
521 } STMT_END
522
523 #define ckWARNregdep(loc,m) STMT_START {                                \
524     const IV offset = loc - RExC_precomp;                               \
525     Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),     \
526             m REPORT_LOCATION,                                          \
527             (int)offset, RExC_precomp, RExC_precomp + offset);          \
528 } STMT_END
529
530 #define ckWARN2regdep(loc,m, a1) STMT_START {                           \
531     const IV offset = loc - RExC_precomp;                               \
532     Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),     \
533             m REPORT_LOCATION,                                          \
534             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
535 } STMT_END
536
537 #define ckWARN2reg(loc, m, a1) STMT_START {                             \
538     const IV offset = loc - RExC_precomp;                               \
539     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
540             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
541 } STMT_END
542
543 #define vWARN3(loc, m, a1, a2) STMT_START {                             \
544     const IV offset = loc - RExC_precomp;                               \
545     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
546             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
547 } STMT_END
548
549 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                         \
550     const IV offset = loc - RExC_precomp;                               \
551     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
552             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
553 } STMT_END
554
555 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
556     const IV offset = loc - RExC_precomp;                               \
557     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
558             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
559 } STMT_END
560
561 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
562     const IV offset = loc - RExC_precomp;                               \
563     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
564             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
565 } STMT_END
566
567 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
568     const IV offset = loc - RExC_precomp;                               \
569     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
570             a1, a2, a3, a4, (int)offset, RExC_precomp, RExC_precomp + offset); \
571 } STMT_END
572
573
574 /* Allow for side effects in s */
575 #define REGC(c,s) STMT_START {                  \
576     if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
577 } STMT_END
578
579 /* Macros for recording node offsets.   20001227 mjd@plover.com 
580  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
581  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
582  * Element 0 holds the number n.
583  * Position is 1 indexed.
584  */
585 #ifndef RE_TRACK_PATTERN_OFFSETS
586 #define Set_Node_Offset_To_R(node,byte)
587 #define Set_Node_Offset(node,byte)
588 #define Set_Cur_Node_Offset
589 #define Set_Node_Length_To_R(node,len)
590 #define Set_Node_Length(node,len)
591 #define Set_Node_Cur_Length(node)
592 #define Node_Offset(n) 
593 #define Node_Length(n) 
594 #define Set_Node_Offset_Length(node,offset,len)
595 #define ProgLen(ri) ri->u.proglen
596 #define SetProgLen(ri,x) ri->u.proglen = x
597 #else
598 #define ProgLen(ri) ri->u.offsets[0]
599 #define SetProgLen(ri,x) ri->u.offsets[0] = x
600 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
601     if (! SIZE_ONLY) {                                                  \
602         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
603                     __LINE__, (int)(node), (int)(byte)));               \
604         if((node) < 0) {                                                \
605             Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \
606         } else {                                                        \
607             RExC_offsets[2*(node)-1] = (byte);                          \
608         }                                                               \
609     }                                                                   \
610 } STMT_END
611
612 #define Set_Node_Offset(node,byte) \
613     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
614 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
615
616 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
617     if (! SIZE_ONLY) {                                                  \
618         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
619                 __LINE__, (int)(node), (int)(len)));                    \
620         if((node) < 0) {                                                \
621             Perl_croak(aTHX_ "value of node is %d in Length macro", (int)(node)); \
622         } else {                                                        \
623             RExC_offsets[2*(node)] = (len);                             \
624         }                                                               \
625     }                                                                   \
626 } STMT_END
627
628 #define Set_Node_Length(node,len) \
629     Set_Node_Length_To_R((node)-RExC_emit_start, len)
630 #define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
631 #define Set_Node_Cur_Length(node) \
632     Set_Node_Length(node, RExC_parse - parse_start)
633
634 /* Get offsets and lengths */
635 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
636 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
637
638 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
639     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
640     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
641 } STMT_END
642 #endif
643
644 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
645 #define EXPERIMENTAL_INPLACESCAN
646 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
647
648 #define DEBUG_STUDYDATA(str,data,depth)                              \
649 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
650     PerlIO_printf(Perl_debug_log,                                    \
651         "%*s" str "Pos:%"IVdf"/%"IVdf                                \
652         " Flags: 0x%"UVXf" Whilem_c: %"IVdf" Lcp: %"IVdf" %s",       \
653         (int)(depth)*2, "",                                          \
654         (IV)((data)->pos_min),                                       \
655         (IV)((data)->pos_delta),                                     \
656         (UV)((data)->flags),                                         \
657         (IV)((data)->whilem_c),                                      \
658         (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
659         is_inf ? "INF " : ""                                         \
660     );                                                               \
661     if ((data)->last_found)                                          \
662         PerlIO_printf(Perl_debug_log,                                \
663             "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
664             " %sFloat: '%s' @ %"IVdf"/%"IVdf"",                      \
665             SvPVX_const((data)->last_found),                         \
666             (IV)((data)->last_end),                                  \
667             (IV)((data)->last_start_min),                            \
668             (IV)((data)->last_start_max),                            \
669             ((data)->longest &&                                      \
670              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
671             SvPVX_const((data)->longest_fixed),                      \
672             (IV)((data)->offset_fixed),                              \
673             ((data)->longest &&                                      \
674              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
675             SvPVX_const((data)->longest_float),                      \
676             (IV)((data)->offset_float_min),                          \
677             (IV)((data)->offset_float_max)                           \
678         );                                                           \
679     PerlIO_printf(Perl_debug_log,"\n");                              \
680 });
681
682 static void clear_re(pTHX_ void *r);
683
684 /* Mark that we cannot extend a found fixed substring at this point.
685    Update the longest found anchored substring and the longest found
686    floating substrings if needed. */
687
688 STATIC void
689 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp, int is_inf)
690 {
691     const STRLEN l = CHR_SVLEN(data->last_found);
692     const STRLEN old_l = CHR_SVLEN(*data->longest);
693     GET_RE_DEBUG_FLAGS_DECL;
694
695     PERL_ARGS_ASSERT_SCAN_COMMIT;
696
697     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
698         SvSetMagicSV(*data->longest, data->last_found);
699         if (*data->longest == data->longest_fixed) {
700             data->offset_fixed = l ? data->last_start_min : data->pos_min;
701             if (data->flags & SF_BEFORE_EOL)
702                 data->flags
703                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
704             else
705                 data->flags &= ~SF_FIX_BEFORE_EOL;
706             data->minlen_fixed=minlenp;
707             data->lookbehind_fixed=0;
708         }
709         else { /* *data->longest == data->longest_float */
710             data->offset_float_min = l ? data->last_start_min : data->pos_min;
711             data->offset_float_max = (l
712                                       ? data->last_start_max
713                                       : data->pos_min + data->pos_delta);
714             if (is_inf || (U32)data->offset_float_max > (U32)I32_MAX)
715                 data->offset_float_max = I32_MAX;
716             if (data->flags & SF_BEFORE_EOL)
717                 data->flags
718                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
719             else
720                 data->flags &= ~SF_FL_BEFORE_EOL;
721             data->minlen_float=minlenp;
722             data->lookbehind_float=0;
723         }
724     }
725     SvCUR_set(data->last_found, 0);
726     {
727         SV * const sv = data->last_found;
728         if (SvUTF8(sv) && SvMAGICAL(sv)) {
729             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
730             if (mg)
731                 mg->mg_len = 0;
732         }
733     }
734     data->last_end = -1;
735     data->flags &= ~SF_BEFORE_EOL;
736     DEBUG_STUDYDATA("commit: ",data,0);
737 }
738
739 /* Can match anything (initialization) */
740 STATIC void
741 S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
742 {
743     PERL_ARGS_ASSERT_CL_ANYTHING;
744
745     ANYOF_BITMAP_SETALL(cl);
746     cl->flags = ANYOF_CLASS|ANYOF_EOS|ANYOF_UNICODE_ALL
747                 |ANYOF_LOC_NONBITMAP_FOLD|ANYOF_NON_UTF8_LATIN1_ALL;
748
749     /* If any portion of the regex is to operate under locale rules,
750      * initialization includes it.  The reason this isn't done for all regexes
751      * is that the optimizer was written under the assumption that locale was
752      * all-or-nothing.  Given the complexity and lack of documentation in the
753      * optimizer, and that there are inadequate test cases for locale, so many
754      * parts of it may not work properly, it is safest to avoid locale unless
755      * necessary. */
756     if (RExC_contains_locale) {
757         ANYOF_CLASS_SETALL(cl);     /* /l uses class */
758         cl->flags |= ANYOF_LOCALE;
759     }
760     else {
761         ANYOF_CLASS_ZERO(cl);       /* Only /l uses class now */
762     }
763 }
764
765 /* Can match anything (initialization) */
766 STATIC int
767 S_cl_is_anything(const struct regnode_charclass_class *cl)
768 {
769     int value;
770
771     PERL_ARGS_ASSERT_CL_IS_ANYTHING;
772
773     for (value = 0; value <= ANYOF_MAX; value += 2)
774         if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
775             return 1;
776     if (!(cl->flags & ANYOF_UNICODE_ALL))
777         return 0;
778     if (!ANYOF_BITMAP_TESTALLSET((const void*)cl))
779         return 0;
780     return 1;
781 }
782
783 /* Can match anything (initialization) */
784 STATIC void
785 S_cl_init(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
786 {
787     PERL_ARGS_ASSERT_CL_INIT;
788
789     Zero(cl, 1, struct regnode_charclass_class);
790     cl->type = ANYOF;
791     cl_anything(pRExC_state, cl);
792     ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
793 }
794
795 /* These two functions currently do the exact same thing */
796 #define cl_init_zero            S_cl_init
797
798 /* 'AND' a given class with another one.  Can create false positives.  'cl'
799  * should not be inverted.  'and_with->flags & ANYOF_CLASS' should be 0 if
800  * 'and_with' is a regnode_charclass instead of a regnode_charclass_class. */
801 STATIC void
802 S_cl_and(struct regnode_charclass_class *cl,
803         const struct regnode_charclass_class *and_with)
804 {
805     PERL_ARGS_ASSERT_CL_AND;
806
807     assert(and_with->type == ANYOF);
808
809     /* I (khw) am not sure all these restrictions are necessary XXX */
810     if (!(ANYOF_CLASS_TEST_ANY_SET(and_with))
811         && !(ANYOF_CLASS_TEST_ANY_SET(cl))
812         && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
813         && !(and_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
814         && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) {
815         int i;
816
817         if (and_with->flags & ANYOF_INVERT)
818             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
819                 cl->bitmap[i] &= ~and_with->bitmap[i];
820         else
821             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
822                 cl->bitmap[i] &= and_with->bitmap[i];
823     } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
824
825     if (and_with->flags & ANYOF_INVERT) {
826
827         /* Here, the and'ed node is inverted.  Get the AND of the flags that
828          * aren't affected by the inversion.  Those that are affected are
829          * handled individually below */
830         U8 affected_flags = cl->flags & ~INVERSION_UNAFFECTED_FLAGS;
831         cl->flags &= (and_with->flags & INVERSION_UNAFFECTED_FLAGS);
832         cl->flags |= affected_flags;
833
834         /* We currently don't know how to deal with things that aren't in the
835          * bitmap, but we know that the intersection is no greater than what
836          * is already in cl, so let there be false positives that get sorted
837          * out after the synthetic start class succeeds, and the node is
838          * matched for real. */
839
840         /* The inversion of these two flags indicate that the resulting
841          * intersection doesn't have them */
842         if (and_with->flags & ANYOF_UNICODE_ALL) {
843             cl->flags &= ~ANYOF_UNICODE_ALL;
844         }
845         if (and_with->flags & ANYOF_NON_UTF8_LATIN1_ALL) {
846             cl->flags &= ~ANYOF_NON_UTF8_LATIN1_ALL;
847         }
848     }
849     else {   /* and'd node is not inverted */
850         U8 outside_bitmap_but_not_utf8; /* Temp variable */
851
852         if (! ANYOF_NONBITMAP(and_with)) {
853
854             /* Here 'and_with' doesn't match anything outside the bitmap
855              * (except possibly ANYOF_UNICODE_ALL), which means the
856              * intersection can't either, except for ANYOF_UNICODE_ALL, in
857              * which case we don't know what the intersection is, but it's no
858              * greater than what cl already has, so can just leave it alone,
859              * with possible false positives */
860             if (! (and_with->flags & ANYOF_UNICODE_ALL)) {
861                 ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
862                 cl->flags &= ~ANYOF_NONBITMAP_NON_UTF8;
863             }
864         }
865         else if (! ANYOF_NONBITMAP(cl)) {
866
867             /* Here, 'and_with' does match something outside the bitmap, and cl
868              * doesn't have a list of things to match outside the bitmap.  If
869              * cl can match all code points above 255, the intersection will
870              * be those above-255 code points that 'and_with' matches.  If cl
871              * can't match all Unicode code points, it means that it can't
872              * match anything outside the bitmap (since the 'if' that got us
873              * into this block tested for that), so we leave the bitmap empty.
874              */
875             if (cl->flags & ANYOF_UNICODE_ALL) {
876                 ARG_SET(cl, ARG(and_with));
877
878                 /* and_with's ARG may match things that don't require UTF8.
879                  * And now cl's will too, in spite of this being an 'and'.  See
880                  * the comments below about the kludge */
881                 cl->flags |= and_with->flags & ANYOF_NONBITMAP_NON_UTF8;
882             }
883         }
884         else {
885             /* Here, both 'and_with' and cl match something outside the
886              * bitmap.  Currently we do not do the intersection, so just match
887              * whatever cl had at the beginning.  */
888         }
889
890
891         /* Take the intersection of the two sets of flags.  However, the
892          * ANYOF_NONBITMAP_NON_UTF8 flag is treated as an 'or'.  This is a
893          * kludge around the fact that this flag is not treated like the others
894          * which are initialized in cl_anything().  The way the optimizer works
895          * is that the synthetic start class (SSC) is initialized to match
896          * anything, and then the first time a real node is encountered, its
897          * values are AND'd with the SSC's with the result being the values of
898          * the real node.  However, there are paths through the optimizer where
899          * the AND never gets called, so those initialized bits are set
900          * inappropriately, which is not usually a big deal, as they just cause
901          * false positives in the SSC, which will just mean a probably
902          * imperceptible slow down in execution.  However this bit has a
903          * higher false positive consequence in that it can cause utf8.pm,
904          * utf8_heavy.pl ... to be loaded when not necessary, which is a much
905          * bigger slowdown and also causes significant extra memory to be used.
906          * In order to prevent this, the code now takes a different tack.  The
907          * bit isn't set unless some part of the regular expression needs it,
908          * but once set it won't get cleared.  This means that these extra
909          * modules won't get loaded unless there was some path through the
910          * pattern that would have required them anyway, and  so any false
911          * positives that occur by not ANDing them out when they could be
912          * aren't as severe as they would be if we treated this bit like all
913          * the others */
914         outside_bitmap_but_not_utf8 = (cl->flags | and_with->flags)
915                                       & ANYOF_NONBITMAP_NON_UTF8;
916         cl->flags &= and_with->flags;
917         cl->flags |= outside_bitmap_but_not_utf8;
918     }
919 }
920
921 /* 'OR' a given class with another one.  Can create false positives.  'cl'
922  * should not be inverted.  'or_with->flags & ANYOF_CLASS' should be 0 if
923  * 'or_with' is a regnode_charclass instead of a regnode_charclass_class. */
924 STATIC void
925 S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
926 {
927     PERL_ARGS_ASSERT_CL_OR;
928
929     if (or_with->flags & ANYOF_INVERT) {
930
931         /* Here, the or'd node is to be inverted.  This means we take the
932          * complement of everything not in the bitmap, but currently we don't
933          * know what that is, so give up and match anything */
934         if (ANYOF_NONBITMAP(or_with)) {
935             cl_anything(pRExC_state, cl);
936         }
937         /* We do not use
938          * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
939          *   <= (B1 | !B2) | (CL1 | !CL2)
940          * which is wasteful if CL2 is small, but we ignore CL2:
941          *   (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
942          * XXXX Can we handle case-fold?  Unclear:
943          *   (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
944          *   (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
945          */
946         else if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
947              && !(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
948              && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD) ) {
949             int i;
950
951             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
952                 cl->bitmap[i] |= ~or_with->bitmap[i];
953         } /* XXXX: logic is complicated otherwise */
954         else {
955             cl_anything(pRExC_state, cl);
956         }
957
958         /* And, we can just take the union of the flags that aren't affected
959          * by the inversion */
960         cl->flags |= or_with->flags & INVERSION_UNAFFECTED_FLAGS;
961
962         /* For the remaining flags:
963             ANYOF_UNICODE_ALL and inverted means to not match anything above
964                     255, which means that the union with cl should just be
965                     what cl has in it, so can ignore this flag
966             ANYOF_NON_UTF8_LATIN1_ALL and inverted means if not utf8 and ord
967                     is 127-255 to match them, but then invert that, so the
968                     union with cl should just be what cl has in it, so can
969                     ignore this flag
970          */
971     } else {    /* 'or_with' is not inverted */
972         /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
973         if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
974              && (!(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
975                  || (cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) ) {
976             int i;
977
978             /* OR char bitmap and class bitmap separately */
979             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
980                 cl->bitmap[i] |= or_with->bitmap[i];
981             if (ANYOF_CLASS_TEST_ANY_SET(or_with)) {
982                 for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++)
983                     cl->classflags[i] |= or_with->classflags[i];
984                 cl->flags |= ANYOF_CLASS;
985             }
986         }
987         else { /* XXXX: logic is complicated, leave it along for a moment. */
988             cl_anything(pRExC_state, cl);
989         }
990
991         if (ANYOF_NONBITMAP(or_with)) {
992
993             /* Use the added node's outside-the-bit-map match if there isn't a
994              * conflict.  If there is a conflict (both nodes match something
995              * outside the bitmap, but what they match outside is not the same
996              * pointer, and hence not easily compared until XXX we extend
997              * inversion lists this far), give up and allow the start class to
998              * match everything outside the bitmap.  If that stuff is all above
999              * 255, can just set UNICODE_ALL, otherwise caould be anything. */
1000             if (! ANYOF_NONBITMAP(cl)) {
1001                 ARG_SET(cl, ARG(or_with));
1002             }
1003             else if (ARG(cl) != ARG(or_with)) {
1004
1005                 if ((or_with->flags & ANYOF_NONBITMAP_NON_UTF8)) {
1006                     cl_anything(pRExC_state, cl);
1007                 }
1008                 else {
1009                     cl->flags |= ANYOF_UNICODE_ALL;
1010                 }
1011             }
1012         }
1013
1014         /* Take the union */
1015         cl->flags |= or_with->flags;
1016     }
1017 }
1018
1019 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1020 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
1021 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1022 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list ? (TRIE_LIST_CUR( idx ) - 1) : 0 )
1023
1024
1025 #ifdef DEBUGGING
1026 /*
1027    dump_trie(trie,widecharmap,revcharmap)
1028    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1029    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1030
1031    These routines dump out a trie in a somewhat readable format.
1032    The _interim_ variants are used for debugging the interim
1033    tables that are used to generate the final compressed
1034    representation which is what dump_trie expects.
1035
1036    Part of the reason for their existence is to provide a form
1037    of documentation as to how the different representations function.
1038
1039 */
1040
1041 /*
1042   Dumps the final compressed table form of the trie to Perl_debug_log.
1043   Used for debugging make_trie().
1044 */
1045
1046 STATIC void
1047 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1048             AV *revcharmap, U32 depth)
1049 {
1050     U32 state;
1051     SV *sv=sv_newmortal();
1052     int colwidth= widecharmap ? 6 : 4;
1053     U16 word;
1054     GET_RE_DEBUG_FLAGS_DECL;
1055
1056     PERL_ARGS_ASSERT_DUMP_TRIE;
1057
1058     PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
1059         (int)depth * 2 + 2,"",
1060         "Match","Base","Ofs" );
1061
1062     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1063         SV ** const tmp = av_fetch( revcharmap, state, 0);
1064         if ( tmp ) {
1065             PerlIO_printf( Perl_debug_log, "%*s", 
1066                 colwidth,
1067                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1068                             PL_colors[0], PL_colors[1],
1069                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1070                             PERL_PV_ESCAPE_FIRSTCHAR 
1071                 ) 
1072             );
1073         }
1074     }
1075     PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
1076         (int)depth * 2 + 2,"");
1077
1078     for( state = 0 ; state < trie->uniquecharcount ; state++ )
1079         PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
1080     PerlIO_printf( Perl_debug_log, "\n");
1081
1082     for( state = 1 ; state < trie->statecount ; state++ ) {
1083         const U32 base = trie->states[ state ].trans.base;
1084
1085         PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state);
1086
1087         if ( trie->states[ state ].wordnum ) {
1088             PerlIO_printf( Perl_debug_log, " W%4X", trie->states[ state ].wordnum );
1089         } else {
1090             PerlIO_printf( Perl_debug_log, "%6s", "" );
1091         }
1092
1093         PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
1094
1095         if ( base ) {
1096             U32 ofs = 0;
1097
1098             while( ( base + ofs  < trie->uniquecharcount ) ||
1099                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
1100                      && trie->trans[ base + ofs - trie->uniquecharcount ].check != state))
1101                     ofs++;
1102
1103             PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
1104
1105             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
1106                 if ( ( base + ofs >= trie->uniquecharcount ) &&
1107                      ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
1108                      trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
1109                 {
1110                    PerlIO_printf( Perl_debug_log, "%*"UVXf,
1111                     colwidth,
1112                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
1113                 } else {
1114                     PerlIO_printf( Perl_debug_log, "%*s",colwidth,"   ." );
1115                 }
1116             }
1117
1118             PerlIO_printf( Perl_debug_log, "]");
1119
1120         }
1121         PerlIO_printf( Perl_debug_log, "\n" );
1122     }
1123     PerlIO_printf(Perl_debug_log, "%*sword_info N:(prev,len)=", (int)depth*2, "");
1124     for (word=1; word <= trie->wordcount; word++) {
1125         PerlIO_printf(Perl_debug_log, " %d:(%d,%d)",
1126             (int)word, (int)(trie->wordinfo[word].prev),
1127             (int)(trie->wordinfo[word].len));
1128     }
1129     PerlIO_printf(Perl_debug_log, "\n" );
1130 }    
1131 /*
1132   Dumps a fully constructed but uncompressed trie in list form.
1133   List tries normally only are used for construction when the number of 
1134   possible chars (trie->uniquecharcount) is very high.
1135   Used for debugging make_trie().
1136 */
1137 STATIC void
1138 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
1139                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
1140                          U32 depth)
1141 {
1142     U32 state;
1143     SV *sv=sv_newmortal();
1144     int colwidth= widecharmap ? 6 : 4;
1145     GET_RE_DEBUG_FLAGS_DECL;
1146
1147     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
1148
1149     /* print out the table precompression.  */
1150     PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
1151         (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
1152         "------:-----+-----------------\n" );
1153     
1154     for( state=1 ; state < next_alloc ; state ++ ) {
1155         U16 charid;
1156     
1157         PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
1158             (int)depth * 2 + 2,"", (UV)state  );
1159         if ( ! trie->states[ state ].wordnum ) {
1160             PerlIO_printf( Perl_debug_log, "%5s| ","");
1161         } else {
1162             PerlIO_printf( Perl_debug_log, "W%4x| ",
1163                 trie->states[ state ].wordnum
1164             );
1165         }
1166         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
1167             SV ** const tmp = av_fetch( revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
1168             if ( tmp ) {
1169                 PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
1170                     colwidth,
1171                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1172                             PL_colors[0], PL_colors[1],
1173                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1174                             PERL_PV_ESCAPE_FIRSTCHAR 
1175                     ) ,
1176                     TRIE_LIST_ITEM(state,charid).forid,
1177                     (UV)TRIE_LIST_ITEM(state,charid).newstate
1178                 );
1179                 if (!(charid % 10)) 
1180                     PerlIO_printf(Perl_debug_log, "\n%*s| ",
1181                         (int)((depth * 2) + 14), "");
1182             }
1183         }
1184         PerlIO_printf( Perl_debug_log, "\n");
1185     }
1186 }    
1187
1188 /*
1189   Dumps a fully constructed but uncompressed trie in table form.
1190   This is the normal DFA style state transition table, with a few 
1191   twists to facilitate compression later. 
1192   Used for debugging make_trie().
1193 */
1194 STATIC void
1195 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
1196                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
1197                           U32 depth)
1198 {
1199     U32 state;
1200     U16 charid;
1201     SV *sv=sv_newmortal();
1202     int colwidth= widecharmap ? 6 : 4;
1203     GET_RE_DEBUG_FLAGS_DECL;
1204
1205     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
1206     
1207     /*
1208        print out the table precompression so that we can do a visual check
1209        that they are identical.
1210      */
1211     
1212     PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
1213
1214     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1215         SV ** const tmp = av_fetch( revcharmap, charid, 0);
1216         if ( tmp ) {
1217             PerlIO_printf( Perl_debug_log, "%*s", 
1218                 colwidth,
1219                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1220                             PL_colors[0], PL_colors[1],
1221                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1222                             PERL_PV_ESCAPE_FIRSTCHAR 
1223                 ) 
1224             );
1225         }
1226     }
1227
1228     PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
1229
1230     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
1231         PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
1232     }
1233
1234     PerlIO_printf( Perl_debug_log, "\n" );
1235
1236     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
1237
1238         PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ", 
1239             (int)depth * 2 + 2,"",
1240             (UV)TRIE_NODENUM( state ) );
1241
1242         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1243             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
1244             if (v)
1245                 PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
1246             else
1247                 PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
1248         }
1249         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1250             PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check );
1251         } else {
1252             PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n", (UV)trie->trans[ state ].check,
1253             trie->states[ TRIE_NODENUM( state ) ].wordnum );
1254         }
1255     }
1256 }
1257
1258 #endif
1259
1260
1261 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
1262   startbranch: the first branch in the whole branch sequence
1263   first      : start branch of sequence of branch-exact nodes.
1264                May be the same as startbranch
1265   last       : Thing following the last branch.
1266                May be the same as tail.
1267   tail       : item following the branch sequence
1268   count      : words in the sequence
1269   flags      : currently the OP() type we will be building one of /EXACT(|F|Fl)/
1270   depth      : indent depth
1271
1272 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
1273
1274 A trie is an N'ary tree where the branches are determined by digital
1275 decomposition of the key. IE, at the root node you look up the 1st character and
1276 follow that branch repeat until you find the end of the branches. Nodes can be
1277 marked as "accepting" meaning they represent a complete word. Eg:
1278
1279   /he|she|his|hers/
1280
1281 would convert into the following structure. Numbers represent states, letters
1282 following numbers represent valid transitions on the letter from that state, if
1283 the number is in square brackets it represents an accepting state, otherwise it
1284 will be in parenthesis.
1285
1286       +-h->+-e->[3]-+-r->(8)-+-s->[9]
1287       |    |
1288       |   (2)
1289       |    |
1290      (1)   +-i->(6)-+-s->[7]
1291       |
1292       +-s->(3)-+-h->(4)-+-e->[5]
1293
1294       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
1295
1296 This shows that when matching against the string 'hers' we will begin at state 1
1297 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
1298 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
1299 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
1300 single traverse. We store a mapping from accepting to state to which word was
1301 matched, and then when we have multiple possibilities we try to complete the
1302 rest of the regex in the order in which they occured in the alternation.
1303
1304 The only prior NFA like behaviour that would be changed by the TRIE support is
1305 the silent ignoring of duplicate alternations which are of the form:
1306
1307  / (DUPE|DUPE) X? (?{ ... }) Y /x
1308
1309 Thus EVAL blocks following a trie may be called a different number of times with
1310 and without the optimisation. With the optimisations dupes will be silently
1311 ignored. This inconsistent behaviour of EVAL type nodes is well established as
1312 the following demonstrates:
1313
1314  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
1315
1316 which prints out 'word' three times, but
1317
1318  'words'=~/(word|word|word)(?{ print $1 })S/
1319
1320 which doesnt print it out at all. This is due to other optimisations kicking in.
1321
1322 Example of what happens on a structural level:
1323
1324 The regexp /(ac|ad|ab)+/ will produce the following debug output:
1325
1326    1: CURLYM[1] {1,32767}(18)
1327    5:   BRANCH(8)
1328    6:     EXACT <ac>(16)
1329    8:   BRANCH(11)
1330    9:     EXACT <ad>(16)
1331   11:   BRANCH(14)
1332   12:     EXACT <ab>(16)
1333   16:   SUCCEED(0)
1334   17:   NOTHING(18)
1335   18: END(0)
1336
1337 This would be optimizable with startbranch=5, first=5, last=16, tail=16
1338 and should turn into:
1339
1340    1: CURLYM[1] {1,32767}(18)
1341    5:   TRIE(16)
1342         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
1343           <ac>
1344           <ad>
1345           <ab>
1346   16:   SUCCEED(0)
1347   17:   NOTHING(18)
1348   18: END(0)
1349
1350 Cases where tail != last would be like /(?foo|bar)baz/:
1351
1352    1: BRANCH(4)
1353    2:   EXACT <foo>(8)
1354    4: BRANCH(7)
1355    5:   EXACT <bar>(8)
1356    7: TAIL(8)
1357    8: EXACT <baz>(10)
1358   10: END(0)
1359
1360 which would be optimizable with startbranch=1, first=1, last=7, tail=8
1361 and would end up looking like:
1362
1363     1: TRIE(8)
1364       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
1365         <foo>
1366         <bar>
1367    7: TAIL(8)
1368    8: EXACT <baz>(10)
1369   10: END(0)
1370
1371     d = uvuni_to_utf8_flags(d, uv, 0);
1372
1373 is the recommended Unicode-aware way of saying
1374
1375     *(d++) = uv;
1376 */
1377
1378 #define TRIE_STORE_REVCHAR(val)                                            \
1379     STMT_START {                                                           \
1380         if (UTF) {                                                         \
1381             SV *zlopp = newSV(7); /* XXX: optimize me */                   \
1382             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
1383             unsigned const char *const kapow = uvuni_to_utf8(flrbbbbb, val); \
1384             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
1385             SvPOK_on(zlopp);                                               \
1386             SvUTF8_on(zlopp);                                              \
1387             av_push(revcharmap, zlopp);                                    \
1388         } else {                                                           \
1389             char ooooff = (char)val;                                           \
1390             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
1391         }                                                                  \
1392         } STMT_END
1393
1394 #define TRIE_READ_CHAR STMT_START {                                                     \
1395     wordlen++;                                                                          \
1396     if ( UTF ) {                                                                        \
1397         /* if it is UTF then it is either already folded, or does not need folding */   \
1398         uvc = utf8n_to_uvuni( (const U8*) uc, UTF8_MAXLEN, &len, uniflags);             \
1399     }                                                                                   \
1400     else if (folder == PL_fold_latin1) {                                                \
1401         /* if we use this folder we have to obey unicode rules on latin-1 data */       \
1402         if ( foldlen > 0 ) {                                                            \
1403            uvc = utf8n_to_uvuni( (const U8*) scan, UTF8_MAXLEN, &len, uniflags );       \
1404            foldlen -= len;                                                              \
1405            scan += len;                                                                 \
1406            len = 0;                                                                     \
1407         } else {                                                                        \
1408             len = 1;                                                                    \
1409             uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, 1);                     \
1410             skiplen = UNISKIP(uvc);                                                     \
1411             foldlen -= skiplen;                                                         \
1412             scan = foldbuf + skiplen;                                                   \
1413         }                                                                               \
1414     } else {                                                                            \
1415         /* raw data, will be folded later if needed */                                  \
1416         uvc = (U32)*uc;                                                                 \
1417         len = 1;                                                                        \
1418     }                                                                                   \
1419 } STMT_END
1420
1421
1422
1423 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
1424     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
1425         U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
1426         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
1427     }                                                           \
1428     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
1429     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
1430     TRIE_LIST_CUR( state )++;                                   \
1431 } STMT_END
1432
1433 #define TRIE_LIST_NEW(state) STMT_START {                       \
1434     Newxz( trie->states[ state ].trans.list,               \
1435         4, reg_trie_trans_le );                                 \
1436      TRIE_LIST_CUR( state ) = 1;                                \
1437      TRIE_LIST_LEN( state ) = 4;                                \
1438 } STMT_END
1439
1440 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
1441     U16 dupe= trie->states[ state ].wordnum;                    \
1442     regnode * const noper_next = regnext( noper );              \
1443                                                                 \
1444     DEBUG_r({                                                   \
1445         /* store the word for dumping */                        \
1446         SV* tmp;                                                \
1447         if (OP(noper) != NOTHING)                               \
1448             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
1449         else                                                    \
1450             tmp = newSVpvn_utf8( "", 0, UTF );                  \
1451         av_push( trie_words, tmp );                             \
1452     });                                                         \
1453                                                                 \
1454     curword++;                                                  \
1455     trie->wordinfo[curword].prev   = 0;                         \
1456     trie->wordinfo[curword].len    = wordlen;                   \
1457     trie->wordinfo[curword].accept = state;                     \
1458                                                                 \
1459     if ( noper_next < tail ) {                                  \
1460         if (!trie->jump)                                        \
1461             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, sizeof(U16) ); \
1462         trie->jump[curword] = (U16)(noper_next - convert);      \
1463         if (!jumper)                                            \
1464             jumper = noper_next;                                \
1465         if (!nextbranch)                                        \
1466             nextbranch= regnext(cur);                           \
1467     }                                                           \
1468                                                                 \
1469     if ( dupe ) {                                               \
1470         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
1471         /* chain, so that when the bits of chain are later    */\
1472         /* linked together, the dups appear in the chain      */\
1473         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
1474         trie->wordinfo[dupe].prev = curword;                    \
1475     } else {                                                    \
1476         /* we haven't inserted this word yet.                */ \
1477         trie->states[ state ].wordnum = curword;                \
1478     }                                                           \
1479 } STMT_END
1480
1481
1482 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
1483      ( ( base + charid >=  ucharcount                                   \
1484          && base + charid < ubound                                      \
1485          && state == trie->trans[ base - ucharcount + charid ].check    \
1486          && trie->trans[ base - ucharcount + charid ].next )            \
1487            ? trie->trans[ base - ucharcount + charid ].next             \
1488            : ( state==1 ? special : 0 )                                 \
1489       )
1490
1491 #define MADE_TRIE       1
1492 #define MADE_JUMP_TRIE  2
1493 #define MADE_EXACT_TRIE 4
1494
1495 STATIC I32
1496 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth)
1497 {
1498     dVAR;
1499     /* first pass, loop through and scan words */
1500     reg_trie_data *trie;
1501     HV *widecharmap = NULL;
1502     AV *revcharmap = newAV();
1503     regnode *cur;
1504     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1505     STRLEN len = 0;
1506     UV uvc = 0;
1507     U16 curword = 0;
1508     U32 next_alloc = 0;
1509     regnode *jumper = NULL;
1510     regnode *nextbranch = NULL;
1511     regnode *convert = NULL;
1512     U32 *prev_states; /* temp array mapping each state to previous one */
1513     /* we just use folder as a flag in utf8 */
1514     const U8 * folder = NULL;
1515
1516 #ifdef DEBUGGING
1517     const U32 data_slot = add_data( pRExC_state, 4, "tuuu" );
1518     AV *trie_words = NULL;
1519     /* along with revcharmap, this only used during construction but both are
1520      * useful during debugging so we store them in the struct when debugging.
1521      */
1522 #else
1523     const U32 data_slot = add_data( pRExC_state, 2, "tu" );
1524     STRLEN trie_charcount=0;
1525 #endif
1526     SV *re_trie_maxbuff;
1527     GET_RE_DEBUG_FLAGS_DECL;
1528
1529     PERL_ARGS_ASSERT_MAKE_TRIE;
1530 #ifndef DEBUGGING
1531     PERL_UNUSED_ARG(depth);
1532 #endif
1533
1534     switch (flags) {
1535         case EXACT: break;
1536         case EXACTFA:
1537         case EXACTFU_SS:
1538         case EXACTFU_TRICKYFOLD:
1539         case EXACTFU: folder = PL_fold_latin1; break;
1540         case EXACTF:  folder = PL_fold; break;
1541         case EXACTFL: folder = PL_fold_locale; break;
1542         default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
1543     }
1544
1545     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
1546     trie->refcount = 1;
1547     trie->startstate = 1;
1548     trie->wordcount = word_count;
1549     RExC_rxi->data->data[ data_slot ] = (void*)trie;
1550     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
1551     if (flags == EXACT)
1552         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
1553     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
1554                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
1555
1556     DEBUG_r({
1557         trie_words = newAV();
1558     });
1559
1560     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
1561     if (!SvIOK(re_trie_maxbuff)) {
1562         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
1563     }
1564     DEBUG_TRIE_COMPILE_r({
1565                 PerlIO_printf( Perl_debug_log,
1566                   "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
1567                   (int)depth * 2 + 2, "", 
1568                   REG_NODE_NUM(startbranch),REG_NODE_NUM(first), 
1569                   REG_NODE_NUM(last), REG_NODE_NUM(tail),
1570                   (int)depth);
1571     });
1572    
1573    /* Find the node we are going to overwrite */
1574     if ( first == startbranch && OP( last ) != BRANCH ) {
1575         /* whole branch chain */
1576         convert = first;
1577     } else {
1578         /* branch sub-chain */
1579         convert = NEXTOPER( first );
1580     }
1581         
1582     /*  -- First loop and Setup --
1583
1584        We first traverse the branches and scan each word to determine if it
1585        contains widechars, and how many unique chars there are, this is
1586        important as we have to build a table with at least as many columns as we
1587        have unique chars.
1588
1589        We use an array of integers to represent the character codes 0..255
1590        (trie->charmap) and we use a an HV* to store Unicode characters. We use the
1591        native representation of the character value as the key and IV's for the
1592        coded index.
1593
1594        *TODO* If we keep track of how many times each character is used we can
1595        remap the columns so that the table compression later on is more
1596        efficient in terms of memory by ensuring the most common value is in the
1597        middle and the least common are on the outside.  IMO this would be better
1598        than a most to least common mapping as theres a decent chance the most
1599        common letter will share a node with the least common, meaning the node
1600        will not be compressible. With a middle is most common approach the worst
1601        case is when we have the least common nodes twice.
1602
1603      */
1604
1605     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1606         regnode *noper = NEXTOPER( cur );
1607         const U8 *uc = (U8*)STRING( noper );
1608         const U8 *e  = uc + STR_LEN( noper );
1609         STRLEN foldlen = 0;
1610         U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1611         STRLEN skiplen = 0;
1612         const U8 *scan = (U8*)NULL;
1613         U32 wordlen      = 0;         /* required init */
1614         STRLEN chars = 0;
1615         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the bitmap?*/
1616
1617         if (OP(noper) == NOTHING) {
1618             regnode *noper_next= regnext(noper);
1619             if (noper_next != tail && OP(noper_next) == flags) {
1620                 noper = noper_next;
1621                 uc= (U8*)STRING(noper);
1622                 e= uc + STR_LEN(noper);
1623                 trie->minlen= STR_LEN(noper);
1624             } else {
1625                 trie->minlen= 0;
1626                 continue;
1627             }
1628         }
1629
1630         if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
1631             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
1632                                           regardless of encoding */
1633             if (OP( noper ) == EXACTFU_SS) {
1634                 /* false positives are ok, so just set this */
1635                 TRIE_BITMAP_SET(trie,0xDF);
1636             }
1637         }
1638         for ( ; uc < e ; uc += len ) {
1639             TRIE_CHARCOUNT(trie)++;
1640             TRIE_READ_CHAR;
1641             chars++;
1642             if ( uvc < 256 ) {
1643                 if ( folder ) {
1644                     U8 folded= folder[ (U8) uvc ];
1645                     if ( !trie->charmap[ folded ] ) {
1646                         trie->charmap[ folded ]=( ++trie->uniquecharcount );
1647                         TRIE_STORE_REVCHAR( folded );
1648                     }
1649                 }
1650                 if ( !trie->charmap[ uvc ] ) {
1651                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
1652                     TRIE_STORE_REVCHAR( uvc );
1653                 }
1654                 if ( set_bit ) {
1655                     /* store the codepoint in the bitmap, and its folded
1656                      * equivalent. */
1657                     TRIE_BITMAP_SET(trie, uvc);
1658
1659                     /* store the folded codepoint */
1660                     if ( folder ) TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);
1661
1662                     if ( !UTF ) {
1663                         /* store first byte of utf8 representation of
1664                            variant codepoints */
1665                         if (! UNI_IS_INVARIANT(uvc)) {
1666                             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));
1667                         }
1668                     }
1669                     set_bit = 0; /* We've done our bit :-) */
1670                 }
1671             } else {
1672                 SV** svpp;
1673                 if ( !widecharmap )
1674                     widecharmap = newHV();
1675
1676                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
1677
1678                 if ( !svpp )
1679                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
1680
1681                 if ( !SvTRUE( *svpp ) ) {
1682                     sv_setiv( *svpp, ++trie->uniquecharcount );
1683                     TRIE_STORE_REVCHAR(uvc);
1684                 }
1685             }
1686         }
1687         if( cur == first ) {
1688             trie->minlen = chars;
1689             trie->maxlen = chars;
1690         } else if (chars < trie->minlen) {
1691             trie->minlen = chars;
1692         } else if (chars > trie->maxlen) {
1693             trie->maxlen = chars;
1694         }
1695         if (OP( noper ) == EXACTFU_SS) {
1696             /* XXX: workaround - 'ss' could match "\x{DF}" so minlen could be 1 and not 2*/
1697             if (trie->minlen > 1)
1698                 trie->minlen= 1;
1699         }
1700         if (OP( noper ) == EXACTFU_TRICKYFOLD) {
1701             /* XXX: workround - things like "\x{1FBE}\x{0308}\x{0301}" can match "\x{0390}" 
1702              *                - We assume that any such sequence might match a 2 byte string */
1703             if (trie->minlen > 2 )
1704                 trie->minlen= 2;
1705         }
1706
1707     } /* end first pass */
1708     DEBUG_TRIE_COMPILE_r(
1709         PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
1710                 (int)depth * 2 + 2,"",
1711                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
1712                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
1713                 (int)trie->minlen, (int)trie->maxlen )
1714     );
1715
1716     /*
1717         We now know what we are dealing with in terms of unique chars and
1718         string sizes so we can calculate how much memory a naive
1719         representation using a flat table  will take. If it's over a reasonable
1720         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
1721         conservative but potentially much slower representation using an array
1722         of lists.
1723
1724         At the end we convert both representations into the same compressed
1725         form that will be used in regexec.c for matching with. The latter
1726         is a form that cannot be used to construct with but has memory
1727         properties similar to the list form and access properties similar
1728         to the table form making it both suitable for fast searches and
1729         small enough that its feasable to store for the duration of a program.
1730
1731         See the comment in the code where the compressed table is produced
1732         inplace from the flat tabe representation for an explanation of how
1733         the compression works.
1734
1735     */
1736
1737
1738     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
1739     prev_states[1] = 0;
1740
1741     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1) > SvIV(re_trie_maxbuff) ) {
1742         /*
1743             Second Pass -- Array Of Lists Representation
1744
1745             Each state will be represented by a list of charid:state records
1746             (reg_trie_trans_le) the first such element holds the CUR and LEN
1747             points of the allocated array. (See defines above).
1748
1749             We build the initial structure using the lists, and then convert
1750             it into the compressed table form which allows faster lookups
1751             (but cant be modified once converted).
1752         */
1753
1754         STRLEN transcount = 1;
1755
1756         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
1757             "%*sCompiling trie using list compiler\n",
1758             (int)depth * 2 + 2, ""));
1759
1760         trie->states = (reg_trie_state *)
1761             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1762                                   sizeof(reg_trie_state) );
1763         TRIE_LIST_NEW(1);
1764         next_alloc = 2;
1765
1766         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1767
1768             regnode *noper   = NEXTOPER( cur );
1769             U8 *uc           = (U8*)STRING( noper );
1770             const U8 *e      = uc + STR_LEN( noper );
1771             U32 state        = 1;         /* required init */
1772             U16 charid       = 0;         /* sanity init */
1773             U8 *scan         = (U8*)NULL; /* sanity init */
1774             STRLEN foldlen   = 0;         /* required init */
1775             U32 wordlen      = 0;         /* required init */
1776             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1777             STRLEN skiplen   = 0;
1778
1779             if (OP(noper) == NOTHING) {
1780                 regnode *noper_next= regnext(noper);
1781                 if (noper_next != tail && OP(noper_next) == flags) {
1782                     noper = noper_next;
1783                     uc= (U8*)STRING(noper);
1784                     e= uc + STR_LEN(noper);
1785                 }
1786             }
1787
1788             if (OP(noper) != NOTHING) {
1789                 for ( ; uc < e ; uc += len ) {
1790
1791                     TRIE_READ_CHAR;
1792
1793                     if ( uvc < 256 ) {
1794                         charid = trie->charmap[ uvc ];
1795                     } else {
1796                         SV** const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1797                         if ( !svpp ) {
1798                             charid = 0;
1799                         } else {
1800                             charid=(U16)SvIV( *svpp );
1801                         }
1802                     }
1803                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
1804                     if ( charid ) {
1805
1806                         U16 check;
1807                         U32 newstate = 0;
1808
1809                         charid--;
1810                         if ( !trie->states[ state ].trans.list ) {
1811                             TRIE_LIST_NEW( state );
1812                         }
1813                         for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) {
1814                             if ( TRIE_LIST_ITEM( state, check ).forid == charid ) {
1815                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
1816                                 break;
1817                             }
1818                         }
1819                         if ( ! newstate ) {
1820                             newstate = next_alloc++;
1821                             prev_states[newstate] = state;
1822                             TRIE_LIST_PUSH( state, charid, newstate );
1823                             transcount++;
1824                         }
1825                         state = newstate;
1826                     } else {
1827                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1828                     }
1829                 }
1830             }
1831             TRIE_HANDLE_WORD(state);
1832
1833         } /* end second pass */
1834
1835         /* next alloc is the NEXT state to be allocated */
1836         trie->statecount = next_alloc; 
1837         trie->states = (reg_trie_state *)
1838             PerlMemShared_realloc( trie->states,
1839                                    next_alloc
1840                                    * sizeof(reg_trie_state) );
1841
1842         /* and now dump it out before we compress it */
1843         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
1844                                                          revcharmap, next_alloc,
1845                                                          depth+1)
1846         );
1847
1848         trie->trans = (reg_trie_trans *)
1849             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
1850         {
1851             U32 state;
1852             U32 tp = 0;
1853             U32 zp = 0;
1854
1855
1856             for( state=1 ; state < next_alloc ; state ++ ) {
1857                 U32 base=0;
1858
1859                 /*
1860                 DEBUG_TRIE_COMPILE_MORE_r(
1861                     PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
1862                 );
1863                 */
1864
1865                 if (trie->states[state].trans.list) {
1866                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
1867                     U16 maxid=minid;
1868                     U16 idx;
1869
1870                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1871                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
1872                         if ( forid < minid ) {
1873                             minid=forid;
1874                         } else if ( forid > maxid ) {
1875                             maxid=forid;
1876                         }
1877                     }
1878                     if ( transcount < tp + maxid - minid + 1) {
1879                         transcount *= 2;
1880                         trie->trans = (reg_trie_trans *)
1881                             PerlMemShared_realloc( trie->trans,
1882                                                      transcount
1883                                                      * sizeof(reg_trie_trans) );
1884                         Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans );
1885                     }
1886                     base = trie->uniquecharcount + tp - minid;
1887                     if ( maxid == minid ) {
1888                         U32 set = 0;
1889                         for ( ; zp < tp ; zp++ ) {
1890                             if ( ! trie->trans[ zp ].next ) {
1891                                 base = trie->uniquecharcount + zp - minid;
1892                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1893                                 trie->trans[ zp ].check = state;
1894                                 set = 1;
1895                                 break;
1896                             }
1897                         }
1898                         if ( !set ) {
1899                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1900                             trie->trans[ tp ].check = state;
1901                             tp++;
1902                             zp = tp;
1903                         }
1904                     } else {
1905                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1906                             const U32 tid = base -  trie->uniquecharcount + TRIE_LIST_ITEM( state, idx ).forid;
1907                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state, idx ).newstate;
1908                             trie->trans[ tid ].check = state;
1909                         }
1910                         tp += ( maxid - minid + 1 );
1911                     }
1912                     Safefree(trie->states[ state ].trans.list);
1913                 }
1914                 /*
1915                 DEBUG_TRIE_COMPILE_MORE_r(
1916                     PerlIO_printf( Perl_debug_log, " base: %d\n",base);
1917                 );
1918                 */
1919                 trie->states[ state ].trans.base=base;
1920             }
1921             trie->lasttrans = tp + 1;
1922         }
1923     } else {
1924         /*
1925            Second Pass -- Flat Table Representation.
1926
1927            we dont use the 0 slot of either trans[] or states[] so we add 1 to each.
1928            We know that we will need Charcount+1 trans at most to store the data
1929            (one row per char at worst case) So we preallocate both structures
1930            assuming worst case.
1931
1932            We then construct the trie using only the .next slots of the entry
1933            structs.
1934
1935            We use the .check field of the first entry of the node temporarily to
1936            make compression both faster and easier by keeping track of how many non
1937            zero fields are in the node.
1938
1939            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
1940            transition.
1941
1942            There are two terms at use here: state as a TRIE_NODEIDX() which is a
1943            number representing the first entry of the node, and state as a
1944            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1) and
1945            TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3) if there
1946            are 2 entrys per node. eg:
1947
1948              A B       A B
1949           1. 2 4    1. 3 7
1950           2. 0 3    3. 0 5
1951           3. 0 0    5. 0 0
1952           4. 0 0    7. 0 0
1953
1954            The table is internally in the right hand, idx form. However as we also
1955            have to deal with the states array which is indexed by nodenum we have to
1956            use TRIE_NODENUM() to convert.
1957
1958         */
1959         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
1960             "%*sCompiling trie using table compiler\n",
1961             (int)depth * 2 + 2, ""));
1962
1963         trie->trans = (reg_trie_trans *)
1964             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
1965                                   * trie->uniquecharcount + 1,
1966                                   sizeof(reg_trie_trans) );
1967         trie->states = (reg_trie_state *)
1968             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1969                                   sizeof(reg_trie_state) );
1970         next_alloc = trie->uniquecharcount + 1;
1971
1972
1973         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1974
1975             regnode *noper   = NEXTOPER( cur );
1976             const U8 *uc     = (U8*)STRING( noper );
1977             const U8 *e      = uc + STR_LEN( noper );
1978
1979             U32 state        = 1;         /* required init */
1980
1981             U16 charid       = 0;         /* sanity init */
1982             U32 accept_state = 0;         /* sanity init */
1983             U8 *scan         = (U8*)NULL; /* sanity init */
1984
1985             STRLEN foldlen   = 0;         /* required init */
1986             U32 wordlen      = 0;         /* required init */
1987             STRLEN skiplen   = 0;
1988             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1989
1990             if (OP(noper) == NOTHING) {
1991                 regnode *noper_next= regnext(noper);
1992                 if (noper_next != tail && OP(noper_next) == flags) {
1993                     noper = noper_next;
1994                     uc= (U8*)STRING(noper);
1995                     e= uc + STR_LEN(noper);
1996                 }
1997             }
1998
1999             if ( OP(noper) != NOTHING ) {
2000                 for ( ; uc < e ; uc += len ) {
2001
2002                     TRIE_READ_CHAR;
2003
2004                     if ( uvc < 256 ) {
2005                         charid = trie->charmap[ uvc ];
2006                     } else {
2007                         SV* const * const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
2008                         charid = svpp ? (U16)SvIV(*svpp) : 0;
2009                     }
2010                     if ( charid ) {
2011                         charid--;
2012                         if ( !trie->trans[ state + charid ].next ) {
2013                             trie->trans[ state + charid ].next = next_alloc;
2014                             trie->trans[ state ].check++;
2015                             prev_states[TRIE_NODENUM(next_alloc)]
2016                                     = TRIE_NODENUM(state);
2017                             next_alloc += trie->uniquecharcount;
2018                         }
2019                         state = trie->trans[ state + charid ].next;
2020                     } else {
2021                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
2022                     }
2023                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
2024                 }
2025             }
2026             accept_state = TRIE_NODENUM( state );
2027             TRIE_HANDLE_WORD(accept_state);
2028
2029         } /* end second pass */
2030
2031         /* and now dump it out before we compress it */
2032         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
2033                                                           revcharmap,
2034                                                           next_alloc, depth+1));
2035
2036         {
2037         /*
2038            * Inplace compress the table.*
2039
2040            For sparse data sets the table constructed by the trie algorithm will
2041            be mostly 0/FAIL transitions or to put it another way mostly empty.
2042            (Note that leaf nodes will not contain any transitions.)
2043
2044            This algorithm compresses the tables by eliminating most such
2045            transitions, at the cost of a modest bit of extra work during lookup:
2046
2047            - Each states[] entry contains a .base field which indicates the
2048            index in the state[] array wheres its transition data is stored.
2049
2050            - If .base is 0 there are no valid transitions from that node.
2051
2052            - If .base is nonzero then charid is added to it to find an entry in
2053            the trans array.
2054
2055            -If trans[states[state].base+charid].check!=state then the
2056            transition is taken to be a 0/Fail transition. Thus if there are fail
2057            transitions at the front of the node then the .base offset will point
2058            somewhere inside the previous nodes data (or maybe even into a node
2059            even earlier), but the .check field determines if the transition is
2060            valid.
2061
2062            XXX - wrong maybe?
2063            The following process inplace converts the table to the compressed
2064            table: We first do not compress the root node 1,and mark all its
2065            .check pointers as 1 and set its .base pointer as 1 as well. This
2066            allows us to do a DFA construction from the compressed table later,
2067            and ensures that any .base pointers we calculate later are greater
2068            than 0.
2069
2070            - We set 'pos' to indicate the first entry of the second node.
2071
2072            - We then iterate over the columns of the node, finding the first and
2073            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
2074            and set the .check pointers accordingly, and advance pos
2075            appropriately and repreat for the next node. Note that when we copy
2076            the next pointers we have to convert them from the original
2077            NODEIDX form to NODENUM form as the former is not valid post
2078            compression.
2079
2080            - If a node has no transitions used we mark its base as 0 and do not
2081            advance the pos pointer.
2082
2083            - If a node only has one transition we use a second pointer into the
2084            structure to fill in allocated fail transitions from other states.
2085            This pointer is independent of the main pointer and scans forward
2086            looking for null transitions that are allocated to a state. When it
2087            finds one it writes the single transition into the "hole".  If the
2088            pointer doesnt find one the single transition is appended as normal.
2089
2090            - Once compressed we can Renew/realloc the structures to release the
2091            excess space.
2092
2093            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
2094            specifically Fig 3.47 and the associated pseudocode.
2095
2096            demq
2097         */
2098         const U32 laststate = TRIE_NODENUM( next_alloc );
2099         U32 state, charid;
2100         U32 pos = 0, zp=0;
2101         trie->statecount = laststate;
2102
2103         for ( state = 1 ; state < laststate ; state++ ) {
2104             U8 flag = 0;
2105             const U32 stateidx = TRIE_NODEIDX( state );
2106             const U32 o_used = trie->trans[ stateidx ].check;
2107             U32 used = trie->trans[ stateidx ].check;
2108             trie->trans[ stateidx ].check = 0;
2109
2110             for ( charid = 0 ; used && charid < trie->uniquecharcount ; charid++ ) {
2111                 if ( flag || trie->trans[ stateidx + charid ].next ) {
2112                     if ( trie->trans[ stateidx + charid ].next ) {
2113                         if (o_used == 1) {
2114                             for ( ; zp < pos ; zp++ ) {
2115                                 if ( ! trie->trans[ zp ].next ) {
2116                                     break;
2117                                 }
2118                             }
2119                             trie->states[ state ].trans.base = zp + trie->uniquecharcount - charid ;
2120                             trie->trans[ zp ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2121                             trie->trans[ zp ].check = state;
2122                             if ( ++zp > pos ) pos = zp;
2123                             break;
2124                         }
2125                         used--;
2126                     }
2127                     if ( !flag ) {
2128                         flag = 1;
2129                         trie->states[ state ].trans.base = pos + trie->uniquecharcount - charid ;
2130                     }
2131                     trie->trans[ pos ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2132                     trie->trans[ pos ].check = state;
2133                     pos++;
2134                 }
2135             }
2136         }
2137         trie->lasttrans = pos + 1;
2138         trie->states = (reg_trie_state *)
2139             PerlMemShared_realloc( trie->states, laststate
2140                                    * sizeof(reg_trie_state) );
2141         DEBUG_TRIE_COMPILE_MORE_r(
2142                 PerlIO_printf( Perl_debug_log,
2143                     "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
2144                     (int)depth * 2 + 2,"",
2145                     (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1 ),
2146                     (IV)next_alloc,
2147                     (IV)pos,
2148                     ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
2149             );
2150
2151         } /* end table compress */
2152     }
2153     DEBUG_TRIE_COMPILE_MORE_r(
2154             PerlIO_printf(Perl_debug_log, "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
2155                 (int)depth * 2 + 2, "",
2156                 (UV)trie->statecount,
2157                 (UV)trie->lasttrans)
2158     );
2159     /* resize the trans array to remove unused space */
2160     trie->trans = (reg_trie_trans *)
2161         PerlMemShared_realloc( trie->trans, trie->lasttrans
2162                                * sizeof(reg_trie_trans) );
2163
2164     {   /* Modify the program and insert the new TRIE node */ 
2165         U8 nodetype =(U8)(flags & 0xFF);
2166         char *str=NULL;
2167         
2168 #ifdef DEBUGGING
2169         regnode *optimize = NULL;
2170 #ifdef RE_TRACK_PATTERN_OFFSETS
2171
2172         U32 mjd_offset = 0;
2173         U32 mjd_nodelen = 0;
2174 #endif /* RE_TRACK_PATTERN_OFFSETS */
2175 #endif /* DEBUGGING */
2176         /*
2177            This means we convert either the first branch or the first Exact,
2178            depending on whether the thing following (in 'last') is a branch
2179            or not and whther first is the startbranch (ie is it a sub part of
2180            the alternation or is it the whole thing.)
2181            Assuming its a sub part we convert the EXACT otherwise we convert
2182            the whole branch sequence, including the first.
2183          */
2184         /* Find the node we are going to overwrite */
2185         if ( first != startbranch || OP( last ) == BRANCH ) {
2186             /* branch sub-chain */
2187             NEXT_OFF( first ) = (U16)(last - first);
2188 #ifdef RE_TRACK_PATTERN_OFFSETS
2189             DEBUG_r({
2190                 mjd_offset= Node_Offset((convert));
2191                 mjd_nodelen= Node_Length((convert));
2192             });
2193 #endif
2194             /* whole branch chain */
2195         }
2196 #ifdef RE_TRACK_PATTERN_OFFSETS
2197         else {
2198             DEBUG_r({
2199                 const  regnode *nop = NEXTOPER( convert );
2200                 mjd_offset= Node_Offset((nop));
2201                 mjd_nodelen= Node_Length((nop));
2202             });
2203         }
2204         DEBUG_OPTIMISE_r(
2205             PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
2206                 (int)depth * 2 + 2, "",
2207                 (UV)mjd_offset, (UV)mjd_nodelen)
2208         );
2209 #endif
2210         /* But first we check to see if there is a common prefix we can 
2211            split out as an EXACT and put in front of the TRIE node.  */
2212         trie->startstate= 1;
2213         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
2214             U32 state;
2215             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
2216                 U32 ofs = 0;
2217                 I32 idx = -1;
2218                 U32 count = 0;
2219                 const U32 base = trie->states[ state ].trans.base;
2220
2221                 if ( trie->states[state].wordnum )
2222                         count = 1;
2223
2224                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2225                     if ( ( base + ofs >= trie->uniquecharcount ) &&
2226                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
2227                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
2228                     {
2229                         if ( ++count > 1 ) {
2230                             SV **tmp = av_fetch( revcharmap, ofs, 0);
2231                             const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
2232                             if ( state == 1 ) break;
2233                             if ( count == 2 ) {
2234                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
2235                                 DEBUG_OPTIMISE_r(
2236                                     PerlIO_printf(Perl_debug_log,
2237                                         "%*sNew Start State=%"UVuf" Class: [",
2238                                         (int)depth * 2 + 2, "",
2239                                         (UV)state));
2240                                 if (idx >= 0) {
2241                                     SV ** const tmp = av_fetch( revcharmap, idx, 0);
2242                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
2243
2244                                     TRIE_BITMAP_SET(trie,*ch);
2245                                     if ( folder )
2246                                         TRIE_BITMAP_SET(trie, folder[ *ch ]);
2247                                     DEBUG_OPTIMISE_r(
2248                                         PerlIO_printf(Perl_debug_log, "%s", (char*)ch)
2249                                     );
2250                                 }
2251                             }
2252                             TRIE_BITMAP_SET(trie,*ch);
2253                             if ( folder )
2254                                 TRIE_BITMAP_SET(trie,folder[ *ch ]);
2255                             DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
2256                         }
2257                         idx = ofs;
2258                     }
2259                 }
2260                 if ( count == 1 ) {
2261                     SV **tmp = av_fetch( revcharmap, idx, 0);
2262                     STRLEN len;
2263                     char *ch = SvPV( *tmp, len );
2264                     DEBUG_OPTIMISE_r({
2265                         SV *sv=sv_newmortal();
2266                         PerlIO_printf( Perl_debug_log,
2267                             "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
2268                             (int)depth * 2 + 2, "",
2269                             (UV)state, (UV)idx, 
2270                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6, 
2271                                 PL_colors[0], PL_colors[1],
2272                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2273                                 PERL_PV_ESCAPE_FIRSTCHAR 
2274                             )
2275                         );
2276                     });
2277                     if ( state==1 ) {
2278                         OP( convert ) = nodetype;
2279                         str=STRING(convert);
2280                         STR_LEN(convert)=0;
2281                     }
2282                     STR_LEN(convert) += len;
2283                     while (len--)
2284                         *str++ = *ch++;
2285                 } else {
2286 #ifdef DEBUGGING            
2287                     if (state>1)
2288                         DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
2289 #endif
2290                     break;
2291                 }
2292             }
2293             trie->prefixlen = (state-1);
2294             if (str) {
2295                 regnode *n = convert+NODE_SZ_STR(convert);
2296                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
2297                 trie->startstate = state;
2298                 trie->minlen -= (state - 1);
2299                 trie->maxlen -= (state - 1);
2300 #ifdef DEBUGGING
2301                /* At least the UNICOS C compiler choked on this
2302                 * being argument to DEBUG_r(), so let's just have
2303                 * it right here. */
2304                if (
2305 #ifdef PERL_EXT_RE_BUILD
2306                    1
2307 #else
2308                    DEBUG_r_TEST
2309 #endif
2310                    ) {
2311                    regnode *fix = convert;
2312                    U32 word = trie->wordcount;
2313                    mjd_nodelen++;
2314                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
2315                    while( ++fix < n ) {
2316                        Set_Node_Offset_Length(fix, 0, 0);
2317                    }
2318                    while (word--) {
2319                        SV ** const tmp = av_fetch( trie_words, word, 0 );
2320                        if (tmp) {
2321                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
2322                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
2323                            else
2324                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
2325                        }
2326                    }
2327                }
2328 #endif
2329                 if (trie->maxlen) {
2330                     convert = n;
2331                 } else {
2332                     NEXT_OFF(convert) = (U16)(tail - convert);
2333                     DEBUG_r(optimize= n);
2334                 }
2335             }
2336         }
2337         if (!jumper) 
2338             jumper = last; 
2339         if ( trie->maxlen ) {
2340             NEXT_OFF( convert ) = (U16)(tail - convert);
2341             ARG_SET( convert, data_slot );
2342             /* Store the offset to the first unabsorbed branch in 
2343                jump[0], which is otherwise unused by the jump logic. 
2344                We use this when dumping a trie and during optimisation. */
2345             if (trie->jump) 
2346                 trie->jump[0] = (U16)(nextbranch - convert);
2347             
2348             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
2349              *   and there is a bitmap
2350              *   and the first "jump target" node we found leaves enough room
2351              * then convert the TRIE node into a TRIEC node, with the bitmap
2352              * embedded inline in the opcode - this is hypothetically faster.
2353              */
2354             if ( !trie->states[trie->startstate].wordnum
2355                  && trie->bitmap
2356                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
2357             {
2358                 OP( convert ) = TRIEC;
2359                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
2360                 PerlMemShared_free(trie->bitmap);
2361                 trie->bitmap= NULL;
2362             } else 
2363                 OP( convert ) = TRIE;
2364
2365             /* store the type in the flags */
2366             convert->flags = nodetype;
2367             DEBUG_r({
2368             optimize = convert 
2369                       + NODE_STEP_REGNODE 
2370                       + regarglen[ OP( convert ) ];
2371             });
2372             /* XXX We really should free up the resource in trie now, 
2373                    as we won't use them - (which resources?) dmq */
2374         }
2375         /* needed for dumping*/
2376         DEBUG_r(if (optimize) {
2377             regnode *opt = convert;
2378
2379             while ( ++opt < optimize) {
2380                 Set_Node_Offset_Length(opt,0,0);
2381             }
2382             /* 
2383                 Try to clean up some of the debris left after the 
2384                 optimisation.
2385              */
2386             while( optimize < jumper ) {
2387                 mjd_nodelen += Node_Length((optimize));
2388                 OP( optimize ) = OPTIMIZED;
2389                 Set_Node_Offset_Length(optimize,0,0);
2390                 optimize++;
2391             }
2392             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
2393         });
2394     } /* end node insert */
2395
2396     /*  Finish populating the prev field of the wordinfo array.  Walk back
2397      *  from each accept state until we find another accept state, and if
2398      *  so, point the first word's .prev field at the second word. If the
2399      *  second already has a .prev field set, stop now. This will be the
2400      *  case either if we've already processed that word's accept state,
2401      *  or that state had multiple words, and the overspill words were
2402      *  already linked up earlier.
2403      */
2404     {
2405         U16 word;
2406         U32 state;
2407         U16 prev;
2408
2409         for (word=1; word <= trie->wordcount; word++) {
2410             prev = 0;
2411             if (trie->wordinfo[word].prev)
2412                 continue;
2413             state = trie->wordinfo[word].accept;
2414             while (state) {
2415                 state = prev_states[state];
2416                 if (!state)
2417                     break;
2418                 prev = trie->states[state].wordnum;
2419                 if (prev)
2420                     break;
2421             }
2422             trie->wordinfo[word].prev = prev;
2423         }
2424         Safefree(prev_states);
2425     }
2426
2427
2428     /* and now dump out the compressed format */
2429     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
2430
2431     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
2432 #ifdef DEBUGGING
2433     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
2434     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
2435 #else
2436     SvREFCNT_dec(revcharmap);
2437 #endif
2438     return trie->jump 
2439            ? MADE_JUMP_TRIE 
2440            : trie->startstate>1 
2441              ? MADE_EXACT_TRIE 
2442              : MADE_TRIE;
2443 }
2444
2445 STATIC void
2446 S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source,  regnode *stclass, U32 depth)
2447 {
2448 /* The Trie is constructed and compressed now so we can build a fail array if it's needed
2449
2450    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
2451    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
2452    ISBN 0-201-10088-6
2453
2454    We find the fail state for each state in the trie, this state is the longest proper
2455    suffix of the current state's 'word' that is also a proper prefix of another word in our
2456    trie. State 1 represents the word '' and is thus the default fail state. This allows
2457    the DFA not to have to restart after its tried and failed a word at a given point, it
2458    simply continues as though it had been matching the other word in the first place.
2459    Consider
2460       'abcdgu'=~/abcdefg|cdgu/
2461    When we get to 'd' we are still matching the first word, we would encounter 'g' which would
2462    fail, which would bring us to the state representing 'd' in the second word where we would
2463    try 'g' and succeed, proceeding to match 'cdgu'.
2464  */
2465  /* add a fail transition */
2466     const U32 trie_offset = ARG(source);
2467     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
2468     U32 *q;
2469     const U32 ucharcount = trie->uniquecharcount;
2470     const U32 numstates = trie->statecount;
2471     const U32 ubound = trie->lasttrans + ucharcount;
2472     U32 q_read = 0;
2473     U32 q_write = 0;
2474     U32 charid;
2475     U32 base = trie->states[ 1 ].trans.base;
2476     U32 *fail;
2477     reg_ac_data *aho;
2478     const U32 data_slot = add_data( pRExC_state, 1, "T" );
2479     GET_RE_DEBUG_FLAGS_DECL;
2480
2481     PERL_ARGS_ASSERT_MAKE_TRIE_FAILTABLE;
2482 #ifndef DEBUGGING
2483     PERL_UNUSED_ARG(depth);
2484 #endif
2485
2486
2487     ARG_SET( stclass, data_slot );
2488     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
2489     RExC_rxi->data->data[ data_slot ] = (void*)aho;
2490     aho->trie=trie_offset;
2491     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
2492     Copy( trie->states, aho->states, numstates, reg_trie_state );
2493     Newxz( q, numstates, U32);
2494     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
2495     aho->refcount = 1;
2496     fail = aho->fail;
2497     /* initialize fail[0..1] to be 1 so that we always have
2498        a valid final fail state */
2499     fail[ 0 ] = fail[ 1 ] = 1;
2500
2501     for ( charid = 0; charid < ucharcount ; charid++ ) {
2502         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
2503         if ( newstate ) {
2504             q[ q_write ] = newstate;
2505             /* set to point at the root */
2506             fail[ q[ q_write++ ] ]=1;
2507         }
2508     }
2509     while ( q_read < q_write) {
2510         const U32 cur = q[ q_read++ % numstates ];
2511         base = trie->states[ cur ].trans.base;
2512
2513         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
2514             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
2515             if (ch_state) {
2516                 U32 fail_state = cur;
2517                 U32 fail_base;
2518                 do {
2519                     fail_state = fail[ fail_state ];
2520                     fail_base = aho->states[ fail_state ].trans.base;
2521                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
2522
2523                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
2524                 fail[ ch_state ] = fail_state;
2525                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
2526                 {
2527                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
2528                 }
2529                 q[ q_write++ % numstates] = ch_state;
2530             }
2531         }
2532     }
2533     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
2534        when we fail in state 1, this allows us to use the
2535        charclass scan to find a valid start char. This is based on the principle
2536        that theres a good chance the string being searched contains lots of stuff
2537        that cant be a start char.
2538      */
2539     fail[ 0 ] = fail[ 1 ] = 0;
2540     DEBUG_TRIE_COMPILE_r({
2541         PerlIO_printf(Perl_debug_log,
2542                       "%*sStclass Failtable (%"UVuf" states): 0", 
2543                       (int)(depth * 2), "", (UV)numstates
2544         );
2545         for( q_read=1; q_read<numstates; q_read++ ) {
2546             PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
2547         }
2548         PerlIO_printf(Perl_debug_log, "\n");
2549     });
2550     Safefree(q);
2551     /*RExC_seen |= REG_SEEN_TRIEDFA;*/
2552 }
2553
2554
2555 /*
2556  * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2557  * These need to be revisited when a newer toolchain becomes available.
2558  */
2559 #if defined(__sparc64__) && defined(__GNUC__)
2560 #   if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2561 #       undef  SPARC64_GCC_WORKAROUND
2562 #       define SPARC64_GCC_WORKAROUND 1
2563 #   endif
2564 #endif
2565
2566 #define DEBUG_PEEP(str,scan,depth) \
2567     DEBUG_OPTIMISE_r({if (scan){ \
2568        SV * const mysv=sv_newmortal(); \
2569        regnode *Next = regnext(scan); \
2570        regprop(RExC_rx, mysv, scan); \
2571        PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
2572        (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
2573        Next ? (REG_NODE_NUM(Next)) : 0 ); \
2574    }});
2575
2576
2577 /* The below joins as many adjacent EXACTish nodes as possible into a single
2578  * one, and looks for problematic sequences of characters whose folds vs.
2579  * non-folds have sufficiently different lengths, that the optimizer would be
2580  * fooled into rejecting legitimate matches of them, and the trie construction
2581  * code can't cope with them.  The joining is only done if:
2582  * 1) there is room in the current conglomerated node to entirely contain the
2583  *    next one.
2584  * 2) they are the exact same node type
2585  *
2586  * The adjacent nodes actually may be separated by NOTHING kind nodes, and
2587  * these get optimized out
2588  *
2589  * If there are problematic code sequences, *min_subtract is set to the delta
2590  * that the minimum size of the node can be less than its actual size.  And,
2591  * the node type of the result is changed to reflect that it contains these
2592  * sequences.
2593  *
2594  * And *has_exactf_sharp_s is set to indicate whether or not the node is EXACTF
2595  * and contains LATIN SMALL LETTER SHARP S
2596  *
2597  * This is as good a place as any to discuss the design of handling these
2598  * problematic sequences.  It's been wrong in Perl for a very long time.  There
2599  * are three code points in Unicode whose folded lengths differ so much from
2600  * the un-folded lengths that it causes problems for the optimizer and trie
2601  * construction.  Why only these are problematic, and not others where lengths
2602  * also differ is something I (khw) do not understand.  New versions of Unicode
2603  * might add more such code points.  Hopefully the logic in fold_grind.t that
2604  * figures out what to test (in part by verifying that each size-combination
2605  * gets tested) will catch any that do come along, so they can be added to the
2606  * special handling below.  The chances of new ones are actually rather small,
2607  * as most, if not all, of the world's scripts that have casefolding have
2608  * already been encoded by Unicode.  Also, a number of Unicode's decisions were
2609  * made to allow compatibility with pre-existing standards, and almost all of
2610  * those have already been dealt with.  These would otherwise be the most
2611  * likely candidates for generating further tricky sequences.  In other words,
2612  * Unicode by itself is unlikely to add new ones unless it is for compatibility
2613  * with pre-existing standards, and there aren't many of those left.
2614  *
2615  * The previous designs for dealing with these involved assigning a special
2616  * node for them.  This approach doesn't work, as evidenced by this example:
2617  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
2618  * Both these fold to "sss", but if the pattern is parsed to create a node of
2619  * that would match just the \xDF, it won't be able to handle the case where a
2620  * successful match would have to cross the node's boundary.  The new approach
2621  * that hopefully generally solves the problem generates an EXACTFU_SS node
2622  * that is "sss".
2623  *
2624  * There are a number of components to the approach (a lot of work for just
2625  * three code points!):
2626  * 1)   This routine examines each EXACTFish node that could contain the
2627  *      problematic sequences.  It returns in *min_subtract how much to
2628  *      subtract from the the actual length of the string to get a real minimum
2629  *      for one that could match it.  This number is usually 0 except for the
2630  *      problematic sequences.  This delta is used by the caller to adjust the
2631  *      min length of the match, and the delta between min and max, so that the
2632  *      optimizer doesn't reject these possibilities based on size constraints.
2633  * 2)   These sequences are not currently correctly handled by the trie code
2634  *      either, so it changes the joined node type to ops that are not handled
2635  *      by trie's, those new ops being EXACTFU_SS and EXACTFU_TRICKYFOLD.
2636  * 3)   This is sufficient for the two Greek sequences (described below), but
2637  *      the one involving the Sharp s (\xDF) needs more.  The node type
2638  *      EXACTFU_SS is used for an EXACTFU node that contains at least one "ss"
2639  *      sequence in it.  For non-UTF-8 patterns and strings, this is the only
2640  *      case where there is a possible fold length change.  That means that a
2641  *      regular EXACTFU node without UTF-8 involvement doesn't have to concern
2642  *      itself with length changes, and so can be processed faster.  regexec.c
2643  *      takes advantage of this.  Generally, an EXACTFish node that is in UTF-8
2644  *      is pre-folded by regcomp.c.  This saves effort in regex matching.
2645  *      However, probably mostly for historical reasons, the pre-folding isn't
2646  *      done for non-UTF8 patterns (and it can't be for EXACTF and EXACTFL
2647  *      nodes, as what they fold to isn't known until runtime.)  The fold
2648  *      possibilities for the non-UTF8 patterns are quite simple, except for
2649  *      the sharp s.  All the ones that don't involve a UTF-8 target string
2650  *      are members of a fold-pair, and arrays are set up for all of them
2651  *      that quickly find the other member of the pair.  It might actually
2652  *      be faster to pre-fold these, but it isn't currently done, except for
2653  *      the sharp s.  Code elsewhere in this file makes sure that it gets
2654  *      folded to 'ss', even if the pattern isn't UTF-8.  This avoids the
2655  *      issues described in the next item.
2656  * 4)   A problem remains for the sharp s in EXACTF nodes.  Whether it matches
2657  *      'ss' or not is not knowable at compile time.  It will match iff the
2658  *      target string is in UTF-8, unlike the EXACTFU nodes, where it always
2659  *      matches; and the EXACTFL and EXACTFA nodes where it never does.  Thus
2660  *      it can't be folded to "ss" at compile time, unlike EXACTFU does as
2661  *      described in item 3).  An assumption that the optimizer part of
2662  *      regexec.c (probably unwittingly) makes is that a character in the
2663  *      pattern corresponds to at most a single character in the target string.
2664  *      (And I do mean character, and not byte here, unlike other parts of the
2665  *      documentation that have never been updated to account for multibyte
2666  *      Unicode.)  This assumption is wrong only in this case, as all other
2667  *      cases are either 1-1 folds when no UTF-8 is involved; or is true by
2668  *      virtue of having this file pre-fold UTF-8 patterns.   I'm
2669  *      reluctant to try to change this assumption, so instead the code punts.
2670  *      This routine examines EXACTF nodes for the sharp s, and returns a
2671  *      boolean indicating whether or not the node is an EXACTF node that
2672  *      contains a sharp s.  When it is true, the caller sets a flag that later
2673  *      causes the optimizer in this file to not set values for the floating
2674  *      and fixed string lengths, and thus avoids the optimizer code in
2675  *      regexec.c that makes the invalid assumption.  Thus, there is no
2676  *      optimization based on string lengths for EXACTF nodes that contain the
2677  *      sharp s.  This only happens for /id rules (which means the pattern
2678  *      isn't in UTF-8).
2679  */
2680
2681 #define JOIN_EXACT(scan,min_subtract,has_exactf_sharp_s, flags) \
2682     if (PL_regkind[OP(scan)] == EXACT) \
2683         join_exact(pRExC_state,(scan),(min_subtract),has_exactf_sharp_s, (flags),NULL,depth+1)
2684
2685 STATIC U32
2686 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, UV *min_subtract, bool *has_exactf_sharp_s, U32 flags,regnode *val, U32 depth) {
2687     /* Merge several consecutive EXACTish nodes into one. */
2688     regnode *n = regnext(scan);
2689     U32 stringok = 1;
2690     regnode *next = scan + NODE_SZ_STR(scan);
2691     U32 merged = 0;
2692     U32 stopnow = 0;
2693 #ifdef DEBUGGING
2694     regnode *stop = scan;
2695     GET_RE_DEBUG_FLAGS_DECL;
2696 #else
2697     PERL_UNUSED_ARG(depth);
2698 #endif
2699
2700     PERL_ARGS_ASSERT_JOIN_EXACT;
2701 #ifndef EXPERIMENTAL_INPLACESCAN
2702     PERL_UNUSED_ARG(flags);
2703     PERL_UNUSED_ARG(val);
2704 #endif
2705     DEBUG_PEEP("join",scan,depth);
2706
2707     /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
2708      * EXACT ones that are mergeable to the current one. */
2709     while (n
2710            && (PL_regkind[OP(n)] == NOTHING
2711                || (stringok && OP(n) == OP(scan)))
2712            && NEXT_OFF(n)
2713            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
2714     {
2715         
2716         if (OP(n) == TAIL || n > next)
2717             stringok = 0;
2718         if (PL_regkind[OP(n)] == NOTHING) {
2719             DEBUG_PEEP("skip:",n,depth);
2720             NEXT_OFF(scan) += NEXT_OFF(n);
2721             next = n + NODE_STEP_REGNODE;
2722 #ifdef DEBUGGING
2723             if (stringok)
2724                 stop = n;
2725 #endif
2726             n = regnext(n);
2727         }
2728         else if (stringok) {
2729             const unsigned int oldl = STR_LEN(scan);
2730             regnode * const nnext = regnext(n);
2731
2732             if (oldl + STR_LEN(n) > U8_MAX)
2733                 break;
2734             
2735             DEBUG_PEEP("merg",n,depth);
2736             merged++;
2737
2738             NEXT_OFF(scan) += NEXT_OFF(n);
2739             STR_LEN(scan) += STR_LEN(n);
2740             next = n + NODE_SZ_STR(n);
2741             /* Now we can overwrite *n : */
2742             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
2743 #ifdef DEBUGGING
2744             stop = next - 1;
2745 #endif
2746             n = nnext;
2747             if (stopnow) break;
2748         }
2749
2750 #ifdef EXPERIMENTAL_INPLACESCAN
2751         if (flags && !NEXT_OFF(n)) {
2752             DEBUG_PEEP("atch", val, depth);
2753             if (reg_off_by_arg[OP(n)]) {
2754                 ARG_SET(n, val - n);
2755             }
2756             else {
2757                 NEXT_OFF(n) = val - n;
2758             }
2759             stopnow = 1;
2760         }
2761 #endif
2762     }
2763
2764     *min_subtract = 0;
2765     *has_exactf_sharp_s = FALSE;
2766
2767     /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
2768      * can now analyze for sequences of problematic code points.  (Prior to
2769      * this final joining, sequences could have been split over boundaries, and
2770      * hence missed).  The sequences only happen in folding, hence for any
2771      * non-EXACT EXACTish node */
2772     if (OP(scan) != EXACT) {
2773         U8 *s;
2774         U8 * s0 = (U8*) STRING(scan);
2775         U8 * const s_end = s0 + STR_LEN(scan);
2776
2777         /* The below is perhaps overboard, but this allows us to save a test
2778          * each time through the loop at the expense of a mask.  This is
2779          * because on both EBCDIC and ASCII machines, 'S' and 's' differ by a
2780          * single bit.  On ASCII they are 32 apart; on EBCDIC, they are 64.
2781          * This uses an exclusive 'or' to find that bit and then inverts it to
2782          * form a mask, with just a single 0, in the bit position where 'S' and
2783          * 's' differ. */
2784         const U8 S_or_s_mask = (U8) ~ ('S' ^ 's');
2785         const U8 s_masked = 's' & S_or_s_mask;
2786
2787         /* One pass is made over the node's string looking for all the
2788          * possibilities.  to avoid some tests in the loop, there are two main
2789          * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
2790          * non-UTF-8 */
2791         if (UTF) {
2792
2793             /* There are two problematic Greek code points in Unicode
2794              * casefolding
2795              *
2796              * U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
2797              * U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
2798              *
2799              * which casefold to
2800              *
2801              * Unicode                      UTF-8
2802              *
2803              * U+03B9 U+0308 U+0301         0xCE 0xB9 0xCC 0x88 0xCC 0x81
2804              * U+03C5 U+0308 U+0301         0xCF 0x85 0xCC 0x88 0xCC 0x81
2805              *
2806              * This means that in case-insensitive matching (or "loose
2807              * matching", as Unicode calls it), an EXACTF of length six (the
2808              * UTF-8 encoded byte length of the above casefolded versions) can
2809              * match a target string of length two (the byte length of UTF-8
2810              * encoded U+0390 or U+03B0).  This would rather mess up the
2811              * minimum length computation.  (there are other code points that
2812              * also fold to these two sequences, but the delta is smaller)
2813              *
2814              * If these sequences are found, the minimum length is decreased by
2815              * four (six minus two).
2816              *
2817              * Similarly, 'ss' may match the single char and byte LATIN SMALL
2818              * LETTER SHARP S.  We decrease the min length by 1 for each
2819              * occurrence of 'ss' found */
2820
2821 #ifdef EBCDIC /* RD tunifold greek 0390 and 03B0 */
2822 #           define U390_first_byte 0xb4
2823             const U8 U390_tail[] = "\x68\xaf\x49\xaf\x42";
2824 #           define U3B0_first_byte 0xb5
2825             const U8 U3B0_tail[] = "\x46\xaf\x49\xaf\x42";
2826 #else
2827 #           define U390_first_byte 0xce
2828             const U8 U390_tail[] = "\xb9\xcc\x88\xcc\x81";
2829 #           define U3B0_first_byte 0xcf
2830             const U8 U3B0_tail[] = "\x85\xcc\x88\xcc\x81";
2831 #endif
2832             const U8 len = sizeof(U390_tail); /* (-1 for NUL; +1 for 1st byte;
2833                                                  yields a net of 0 */
2834             /* Examine the string for one of the problematic sequences */
2835             for (s = s0;
2836                  s < s_end - 1; /* Can stop 1 before the end, as minimum length
2837                                  * sequence we are looking for is 2 */
2838                  s += UTF8SKIP(s))
2839             {
2840
2841                 /* Look for the first byte in each problematic sequence */
2842                 switch (*s) {
2843                     /* We don't have to worry about other things that fold to
2844                      * 's' (such as the long s, U+017F), as all above-latin1
2845                      * code points have been pre-folded */
2846                     case 's':
2847                     case 'S':
2848
2849                         /* Current character is an 's' or 'S'.  If next one is
2850                          * as well, we have the dreaded sequence */
2851                         if (((*(s+1) & S_or_s_mask) == s_masked)
2852                             /* These two node types don't have special handling
2853                              * for 'ss' */
2854                             && OP(scan) != EXACTFL && OP(scan) != EXACTFA)
2855                         {
2856                             *min_subtract += 1;
2857                             OP(scan) = EXACTFU_SS;
2858                             s++;    /* No need to look at this character again */
2859                         }
2860                         break;
2861
2862                     case U390_first_byte:
2863                         if (s_end - s >= len
2864
2865                             /* The 1's are because are skipping comparing the
2866                              * first byte */
2867                             && memEQ(s + 1, U390_tail, len - 1))
2868                         {
2869                             goto greek_sequence;
2870                         }
2871                         break;
2872
2873                     case U3B0_first_byte:
2874                         if (! (s_end - s >= len
2875                                && memEQ(s + 1, U3B0_tail, len - 1)))
2876                         {
2877                             break;
2878                         }
2879                       greek_sequence:
2880                         *min_subtract += 4;
2881
2882                         /* This can't currently be handled by trie's, so change
2883                          * the node type to indicate this.  If EXACTFA and
2884                          * EXACTFL were ever to be handled by trie's, this
2885                          * would have to be changed.  If this node has already
2886                          * been changed to EXACTFU_SS in this loop, leave it as
2887                          * is.  (I (khw) think it doesn't matter in regexec.c
2888                          * for UTF patterns, but no need to change it */
2889                         if (OP(scan) == EXACTFU) {
2890                             OP(scan) = EXACTFU_TRICKYFOLD;
2891                         }
2892                         s += 6; /* We already know what this sequence is.  Skip
2893                                    the rest of it */
2894                         break;
2895                 }
2896             }
2897         }
2898         else if (OP(scan) != EXACTFL && OP(scan) != EXACTFA) {
2899
2900             /* Here, the pattern is not UTF-8.  We need to look only for the
2901              * 'ss' sequence, and in the EXACTF case, the sharp s, which can be
2902              * in the final position.  Otherwise we can stop looking 1 byte
2903              * earlier because have to find both the first and second 's' */
2904             const U8* upper = (OP(scan) == EXACTF) ? s_end : s_end -1;
2905
2906             for (s = s0; s < upper; s++) {
2907                 switch (*s) {
2908                     case 'S':
2909                     case 's':
2910                         if (s_end - s > 1
2911                             && ((*(s+1) & S_or_s_mask) == s_masked))
2912                         {
2913                             *min_subtract += 1;
2914
2915                             /* EXACTF nodes need to know that the minimum
2916                              * length changed so that a sharp s in the string
2917                              * can match this ss in the pattern, but they
2918                              * remain EXACTF nodes, as they are not trie'able,
2919                              * so don't have to invent a new node type to
2920                              * exclude them from the trie code */
2921                             if (OP(scan) != EXACTF) {
2922                                 OP(scan) = EXACTFU_SS;
2923                             }
2924                             s++;
2925                         }
2926                         break;
2927                     case LATIN_SMALL_LETTER_SHARP_S:
2928                         if (OP(scan) == EXACTF) {
2929                             *has_exactf_sharp_s = TRUE;
2930                         }
2931                         break;
2932                 }
2933             }
2934         }
2935     }
2936
2937 #ifdef DEBUGGING
2938     /* Allow dumping but overwriting the collection of skipped
2939      * ops and/or strings with fake optimized ops */
2940     n = scan + NODE_SZ_STR(scan);
2941     while (n <= stop) {
2942         OP(n) = OPTIMIZED;
2943         FLAGS(n) = 0;
2944         NEXT_OFF(n) = 0;
2945         n++;
2946     }
2947 #endif
2948     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
2949     return stopnow;
2950 }
2951
2952 /* REx optimizer.  Converts nodes into quicker variants "in place".
2953    Finds fixed substrings.  */
2954
2955 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
2956    to the position after last scanned or to NULL. */
2957
2958 #define INIT_AND_WITHP \
2959     assert(!and_withp); \
2960     Newx(and_withp,1,struct regnode_charclass_class); \
2961     SAVEFREEPV(and_withp)
2962
2963 /* this is a chain of data about sub patterns we are processing that
2964    need to be handled separately/specially in study_chunk. Its so
2965    we can simulate recursion without losing state.  */
2966 struct scan_frame;
2967 typedef struct scan_frame {
2968     regnode *last;  /* last node to process in this frame */
2969     regnode *next;  /* next node to process when last is reached */
2970     struct scan_frame *prev; /*previous frame*/
2971     I32 stop; /* what stopparen do we use */
2972 } scan_frame;
2973
2974
2975 #define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf)
2976
2977 #define CASE_SYNST_FNC(nAmE)                                       \
2978 case nAmE:                                                         \
2979     if (flags & SCF_DO_STCLASS_AND) {                              \
2980             for (value = 0; value < 256; value++)                  \
2981                 if (!is_ ## nAmE ## _cp(value))                       \
2982                     ANYOF_BITMAP_CLEAR(data->start_class, value);  \
2983     }                                                              \
2984     else {                                                         \
2985             for (value = 0; value < 256; value++)                  \
2986                 if (is_ ## nAmE ## _cp(value))                        \
2987                     ANYOF_BITMAP_SET(data->start_class, value);    \
2988     }                                                              \
2989     break;                                                         \
2990 case N ## nAmE:                                                    \
2991     if (flags & SCF_DO_STCLASS_AND) {                              \
2992             for (value = 0; value < 256; value++)                   \
2993                 if (is_ ## nAmE ## _cp(value))                         \
2994                     ANYOF_BITMAP_CLEAR(data->start_class, value);   \
2995     }                                                               \
2996     else {                                                          \
2997             for (value = 0; value < 256; value++)                   \
2998                 if (!is_ ## nAmE ## _cp(value))                        \
2999                     ANYOF_BITMAP_SET(data->start_class, value);     \
3000     }                                                               \
3001     break
3002
3003
3004
3005 STATIC I32
3006 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
3007                         I32 *minlenp, I32 *deltap,
3008                         regnode *last,
3009                         scan_data_t *data,
3010                         I32 stopparen,
3011                         U8* recursed,
3012                         struct regnode_charclass_class *and_withp,
3013                         U32 flags, U32 depth)
3014                         /* scanp: Start here (read-write). */
3015                         /* deltap: Write maxlen-minlen here. */
3016                         /* last: Stop before this one. */
3017                         /* data: string data about the pattern */
3018                         /* stopparen: treat close N as END */
3019                         /* recursed: which subroutines have we recursed into */
3020                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
3021 {
3022     dVAR;
3023     I32 min = 0, pars = 0, code;
3024     regnode *scan = *scanp, *next;
3025     I32 delta = 0;
3026     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
3027     int is_inf_internal = 0;            /* The studied chunk is infinite */
3028     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
3029     scan_data_t data_fake;
3030     SV *re_trie_maxbuff = NULL;
3031     regnode *first_non_open = scan;
3032     I32 stopmin = I32_MAX;
3033     scan_frame *frame = NULL;
3034     GET_RE_DEBUG_FLAGS_DECL;
3035
3036     PERL_ARGS_ASSERT_STUDY_CHUNK;
3037
3038 #ifdef DEBUGGING
3039     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
3040 #endif
3041
3042     if ( depth == 0 ) {
3043         while (first_non_open && OP(first_non_open) == OPEN)
3044             first_non_open=regnext(first_non_open);
3045     }
3046
3047
3048   fake_study_recurse:
3049     while ( scan && OP(scan) != END && scan < last ){
3050         UV min_subtract = 0;    /* How much to subtract from the minimum node
3051                                    length to get a real minimum (because the
3052                                    folded version may be shorter) */
3053         bool has_exactf_sharp_s = FALSE;
3054         /* Peephole optimizer: */
3055         DEBUG_STUDYDATA("Peep:", data,depth);
3056         DEBUG_PEEP("Peep",scan,depth);
3057
3058         /* Its not clear to khw or hv why this is done here, and not in the
3059          * clauses that deal with EXACT nodes.  khw's guess is that it's
3060          * because of a previous design */
3061         JOIN_EXACT(scan,&min_subtract, &has_exactf_sharp_s, 0);
3062
3063         /* Follow the next-chain of the current node and optimize
3064            away all the NOTHINGs from it.  */
3065         if (OP(scan) != CURLYX) {
3066             const int max = (reg_off_by_arg[OP(scan)]
3067                        ? I32_MAX
3068                        /* I32 may be smaller than U16 on CRAYs! */
3069                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
3070             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
3071             int noff;
3072             regnode *n = scan;
3073
3074             /* Skip NOTHING and LONGJMP. */
3075             while ((n = regnext(n))
3076                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
3077                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
3078                    && off + noff < max)
3079                 off += noff;
3080             if (reg_off_by_arg[OP(scan)])
3081                 ARG(scan) = off;
3082             else
3083                 NEXT_OFF(scan) = off;
3084         }
3085
3086
3087
3088         /* The principal pseudo-switch.  Cannot be a switch, since we
3089            look into several different things.  */
3090         if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
3091                    || OP(scan) == IFTHEN) {
3092             next = regnext(scan);
3093             code = OP(scan);
3094             /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
3095
3096             if (OP(next) == code || code == IFTHEN) {
3097                 /* NOTE - There is similar code to this block below for handling
3098                    TRIE nodes on a re-study.  If you change stuff here check there
3099                    too. */
3100                 I32 max1 = 0, min1 = I32_MAX, num = 0;
3101                 struct regnode_charclass_class accum;
3102                 regnode * const startbranch=scan;
3103
3104                 if (flags & SCF_DO_SUBSTR)
3105                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
3106                 if (flags & SCF_DO_STCLASS)
3107                     cl_init_zero(pRExC_state, &accum);
3108
3109                 while (OP(scan) == code) {
3110                     I32 deltanext, minnext, f = 0, fake;
3111                     struct regnode_charclass_class this_class;
3112
3113                     num++;
3114                     data_fake.flags = 0;
3115                     if (data) {
3116                         data_fake.whilem_c = data->whilem_c;
3117                         data_fake.last_closep = data->last_closep;
3118                     }
3119                     else
3120                         data_fake.last_closep = &fake;
3121
3122                     data_fake.pos_delta = delta;
3123                     next = regnext(scan);
3124                     scan = NEXTOPER(scan);
3125                     if (code != BRANCH)
3126                         scan = NEXTOPER(scan);
3127                     if (flags & SCF_DO_STCLASS) {
3128                         cl_init(pRExC_state, &this_class);
3129                         data_fake.start_class = &this_class;
3130                         f = SCF_DO_STCLASS_AND;
3131                     }
3132                     if (flags & SCF_WHILEM_VISITED_POS)
3133                         f |= SCF_WHILEM_VISITED_POS;
3134
3135                     /* we suppose the run is continuous, last=next...*/
3136                     minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
3137                                           next, &data_fake,
3138                                           stopparen, recursed, NULL, f,depth+1);
3139                     if (min1 > minnext)
3140                         min1 = minnext;
3141                     if (max1 < minnext + deltanext)
3142                         max1 = minnext + deltanext;
3143                     if (deltanext == I32_MAX)
3144                         is_inf = is_inf_internal = 1;
3145                     scan = next;
3146                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3147                         pars++;
3148                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
3149                         if ( stopmin > minnext) 
3150                             stopmin = min + min1;
3151                         flags &= ~SCF_DO_SUBSTR;
3152                         if (data)
3153                             data->flags |= SCF_SEEN_ACCEPT;
3154                     }
3155                     if (data) {
3156                         if (data_fake.flags & SF_HAS_EVAL)
3157                             data->flags |= SF_HAS_EVAL;
3158                         data->whilem_c = data_fake.whilem_c;
3159                     }
3160                     if (flags & SCF_DO_STCLASS)
3161                         cl_or(pRExC_state, &accum, &this_class);
3162                 }
3163                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
3164                     min1 = 0;
3165                 if (flags & SCF_DO_SUBSTR) {
3166                     data->pos_min += min1;
3167                     data->pos_delta += max1 - min1;
3168                     if (max1 != min1 || is_inf)
3169                         data->longest = &(data->longest_float);
3170                 }
3171                 min += min1;
3172                 delta += max1 - min1;
3173                 if (flags & SCF_DO_STCLASS_OR) {
3174                     cl_or(pRExC_state, data->start_class, &accum);
3175                     if (min1) {
3176                         cl_and(data->start_class, and_withp);
3177                         flags &= ~SCF_DO_STCLASS;
3178                     }
3179                 }
3180                 else if (flags & SCF_DO_STCLASS_AND) {
3181                     if (min1) {
3182                         cl_and(data->start_class, &accum);
3183                         flags &= ~SCF_DO_STCLASS;
3184                     }
3185                     else {
3186                         /* Switch to OR mode: cache the old value of
3187                          * data->start_class */
3188                         INIT_AND_WITHP;
3189                         StructCopy(data->start_class, and_withp,
3190                                    struct regnode_charclass_class);
3191                         flags &= ~SCF_DO_STCLASS_AND;
3192                         StructCopy(&accum, data->start_class,
3193                                    struct regnode_charclass_class);
3194                         flags |= SCF_DO_STCLASS_OR;
3195                         data->start_class->flags |= ANYOF_EOS;
3196                     }
3197                 }
3198
3199                 if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) == BRANCH ) {
3200                 /* demq.
3201
3202                    Assuming this was/is a branch we are dealing with: 'scan' now
3203                    points at the item that follows the branch sequence, whatever
3204                    it is. We now start at the beginning of the sequence and look
3205                    for subsequences of
3206
3207                    BRANCH->EXACT=>x1
3208                    BRANCH->EXACT=>x2
3209                    tail
3210
3211                    which would be constructed from a pattern like /A|LIST|OF|WORDS/
3212
3213                    If we can find such a subsequence we need to turn the first
3214                    element into a trie and then add the subsequent branch exact
3215                    strings to the trie.
3216
3217                    We have two cases
3218
3219                      1. patterns where the whole set of branches can be converted. 
3220
3221                      2. patterns where only a subset can be converted.
3222
3223                    In case 1 we can replace the whole set with a single regop
3224                    for the trie. In case 2 we need to keep the start and end
3225                    branches so
3226
3227                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
3228                      becomes BRANCH TRIE; BRANCH X;
3229
3230                   There is an additional case, that being where there is a 
3231                   common prefix, which gets split out into an EXACT like node
3232                   preceding the TRIE node.
3233
3234                   If x(1..n)==tail then we can do a simple trie, if not we make
3235                   a "jump" trie, such that when we match the appropriate word
3236                   we "jump" to the appropriate tail node. Essentially we turn
3237                   a nested if into a case structure of sorts.
3238
3239                 */
3240
3241                     int made=0;
3242                     if (!re_trie_maxbuff) {
3243                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
3244                         if (!SvIOK(re_trie_maxbuff))
3245                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
3246                     }
3247                     if ( SvIV(re_trie_maxbuff)>=0  ) {
3248                         regnode *cur;
3249                         regnode *first = (regnode *)NULL;
3250                         regnode *last = (regnode *)NULL;
3251                         regnode *tail = scan;
3252                         U8 trietype = 0;
3253                         U32 count=0;
3254
3255 #ifdef DEBUGGING
3256                         SV * const mysv = sv_newmortal();       /* for dumping */
3257 #endif
3258                         /* var tail is used because there may be a TAIL
3259                            regop in the way. Ie, the exacts will point to the
3260                            thing following the TAIL, but the last branch will
3261                            point at the TAIL. So we advance tail. If we
3262                            have nested (?:) we may have to move through several
3263                            tails.
3264                          */
3265
3266                         while ( OP( tail ) == TAIL ) {
3267                             /* this is the TAIL generated by (?:) */
3268                             tail = regnext( tail );
3269                         }
3270
3271                         
3272                         DEBUG_TRIE_COMPILE_r({
3273                             regprop(RExC_rx, mysv, tail );
3274                             PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
3275                                 (int)depth * 2 + 2, "", 
3276                                 "Looking for TRIE'able sequences. Tail node is: ", 
3277                                 SvPV_nolen_const( mysv )
3278                             );
3279                         });
3280                         
3281                         /*
3282
3283                             Step through the branches
3284                                 cur represents each branch,
3285                                 noper is the first thing to be matched as part of that branch
3286                                 noper_next is the regnext() of that node.
3287
3288                             We normally handle a case like this /FOO[xyz]|BAR[pqr]/
3289                             via a "jump trie" but we also support building with NOJUMPTRIE,
3290                             which restricts the trie logic to structures like /FOO|BAR/.
3291
3292                             If noper is a trieable nodetype then the branch is a possible optimization
3293                             target. If we are building under NOJUMPTRIE then we require that noper_next
3294                             is the same as scan (our current position in the regex program).
3295
3296                             Once we have two or more consecutive such branches we can create a
3297                             trie of the EXACT's contents and stitch it in place into the program.
3298
3299                             If the sequence represents all of the branches in the alternation we
3300                             replace the entire thing with a single TRIE node.
3301
3302                             Otherwise when it is a subsequence we need to stitch it in place and
3303                             replace only the relevant branches. This means the first branch has
3304                             to remain as it is used by the alternation logic, and its next pointer,
3305                             and needs to be repointed at the item on the branch chain following
3306                             the last branch we have optimized away.
3307
3308                             This could be either a BRANCH, in which case the subsequence is internal,
3309                             or it could be the item following the branch sequence in which case the
3310                             subsequence is at the end (which does not necessarily mean the first node
3311                             is the start of the alternation).
3312
3313                             TRIE_TYPE(X) is a define which maps the optype to a trietype.
3314
3315                                 optype          |  trietype
3316                                 ----------------+-----------
3317                                 NOTHING         | NOTHING
3318                                 EXACT           | EXACT
3319                                 EXACTFU         | EXACTFU
3320                                 EXACTFU_SS      | EXACTFU
3321                                 EXACTFU_TRICKYFOLD | EXACTFU
3322                                 EXACTFA         | 0
3323
3324
3325                         */
3326 #define TRIE_TYPE(X) ( ( NOTHING == (X) ) ? NOTHING :   \
3327                        ( EXACT == (X) )   ? EXACT :        \
3328                        ( EXACTFU == (X) || EXACTFU_SS == (X) || EXACTFU_TRICKYFOLD == (X) ) ? EXACTFU :        \
3329                        0 )
3330
3331                         /* dont use tail as the end marker for this traverse */
3332                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
3333                             regnode * const noper = NEXTOPER( cur );
3334                             U8 noper_type = OP( noper );
3335                             U8 noper_trietype = TRIE_TYPE( noper_type );
3336 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
3337                             regnode * const noper_next = regnext( noper );
3338                             U8 noper_next_type = (noper_next && noper_next != tail) ? OP(noper_next) : 0;
3339                             U8 noper_next_trietype = (noper_next && noper_next != tail) ? TRIE_TYPE( noper_next_type ) :0;
3340 #endif
3341
3342                             DEBUG_TRIE_COMPILE_r({
3343                                 regprop(RExC_rx, mysv, cur);
3344                                 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
3345                                    (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
3346
3347                                 regprop(RExC_rx, mysv, noper);
3348                                 PerlIO_printf( Perl_debug_log, " -> %s",
3349                                     SvPV_nolen_const(mysv));
3350
3351                                 if ( noper_next ) {
3352                                   regprop(RExC_rx, mysv, noper_next );
3353                                   PerlIO_printf( Perl_debug_log,"\t=> %s\t",
3354                                     SvPV_nolen_const(mysv));
3355                                 }
3356                                 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d,tt==%s,nt==%s,nnt==%s)\n",
3357                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
3358                                    PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype] 
3359                                 );
3360                             });
3361
3362                             /* Is noper a trieable nodetype that can be merged with the
3363                              * current trie (if there is one)? */
3364                             if ( noper_trietype
3365                                   &&
3366                                   (
3367                                         ( noper_trietype == NOTHING)
3368                                         || ( trietype == NOTHING )
3369                                         || ( trietype == noper_trietype )
3370                                   )
3371 #ifdef NOJUMPTRIE
3372                                   && noper_next == tail
3373 #endif
3374                                   && count < U16_MAX)
3375                             {
3376                                 /* Handle mergable triable node
3377                                  * Either we are the first node in a new trieable sequence,
3378                                  * in which case we do some bookkeeping, otherwise we update
3379                                  * the end pointer. */
3380                                 if ( !first ) {
3381                                     first = cur;
3382                                     if ( noper_trietype == NOTHING ) {
3383 #if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
3384                                         regnode * const noper_next = regnext( noper );
3385                                         U8 noper_next_type = (noper_next && noper_next!=tail) ? OP(noper_next) : 0;
3386                                         U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
3387 #endif
3388
3389                                         if ( noper_next_trietype ) {
3390                                             trietype = noper_next_trietype;
3391                                         } else if (noper_next_type)  {
3392                                             /* a NOTHING regop is 1 regop wide. We need at least two
3393                                              * for a trie so we can't merge this in */
3394                                             first = NULL;
3395                                         }
3396                                     } else {
3397                                         trietype = noper_trietype;
3398                                     }
3399                                 } else {
3400                                     if ( trietype == NOTHING )
3401                                         trietype = noper_trietype;
3402                                     last = cur;
3403                                 }
3404                                 if (first)
3405                                     count++;
3406                             } /* end handle mergable triable node */
3407                             else {
3408                                 /* handle unmergable node -
3409                                  * noper may either be a triable node which can not be tried
3410                                  * together with the current trie, or a non triable node */
3411                                 if ( last ) {
3412                                     /* If last is set and trietype is not NOTHING then we have found
3413                                      * at least two triable branch sequences in a row of a similar
3414                                      * trietype so we can turn them into a trie. If/when we
3415                                      * allow NOTHING to start a trie sequence this condition will be
3416                                      * required, and it isn't expensive so we leave it in for now. */
3417                                     if ( trietype != NOTHING )
3418                                         make_trie( pRExC_state,
3419                                                 startbranch, first, cur, tail, count,
3420                                                 trietype, depth+1 );
3421                                     last = NULL; /* note: we clear/update first, trietype etc below, so we dont do it here */
3422                                 }
3423                                 if ( noper_trietype
3424 #ifdef NOJUMPTRIE
3425                                      && noper_next == tail
3426 #endif
3427                                 ){
3428                                     /* noper is triable, so we can start a new trie sequence */
3429                                     count = 1;
3430                                     first = cur;
3431                                     trietype = noper_trietype;
3432                                 } else if (first) {
3433                                     /* if we already saw a first but the current node is not triable then we have
3434                                      * to reset the first information. */
3435                                     count = 0;
3436                                     first = NULL;
3437                                     trietype = 0;
3438                                 }
3439                             } /* end handle unmergable node */
3440                         } /* loop over branches */
3441                         DEBUG_TRIE_COMPILE_r({
3442                             regprop(RExC_rx, mysv, cur);
3443                             PerlIO_printf( Perl_debug_log,
3444                               "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
3445                               "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3446
3447                         });
3448                         if ( last ) {
3449                             if ( trietype != NOTHING ) {
3450                                 /* the last branch of the sequence was part of a trie,
3451                                  * so we have to construct it here outside of the loop
3452                                  */
3453                                 made= make_trie( pRExC_state, startbranch, first, scan, tail, count, trietype, depth+1 );
3454 #ifdef TRIE_STUDY_OPT
3455                                 if ( ((made == MADE_EXACT_TRIE &&
3456                                      startbranch == first)
3457                                      || ( first_non_open == first )) &&
3458                                      depth==0 ) {
3459                                     flags |= SCF_TRIE_RESTUDY;
3460                                     if ( startbranch == first
3461                                          && scan == tail )
3462                                     {
3463                                         RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
3464                                     }
3465                                 }
3466 #endif
3467                             } else {
3468                                 /* at this point we know whatever we have is a NOTHING sequence/branch
3469                                  * AND if 'startbranch' is 'first' then we can turn the whole thing into a NOTHING
3470                                  */
3471                                 if ( startbranch == first ) {
3472                                     regnode *opt;
3473                                     /* the entire thing is a NOTHING sequence, something like this:
3474                                      * (?:|) So we can turn it into a plain NOTHING op. */
3475                                     DEBUG_TRIE_COMPILE_r({
3476                                         regprop(RExC_rx, mysv, cur);
3477                                         PerlIO_printf( Perl_debug_log,
3478                                           "%*s- %s (%d) <NOTHING BRANCH SEQUENCE>\n", (int)depth * 2 + 2,
3479                                           "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3480
3481                                     });
3482                                     OP(startbranch)= NOTHING;
3483                                     NEXT_OFF(startbranch)= tail - startbranch;
3484                                     for ( opt= startbranch + 1; opt < tail ; opt++ )
3485                                         OP(opt)= OPTIMIZED;
3486                                 }
3487                             }
3488                         } /* end if ( last) */
3489                     } /* TRIE_MAXBUF is non zero */
3490                     
3491                 } /* do trie */
3492                 
3493             }
3494             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
3495                 scan = NEXTOPER(NEXTOPER(scan));
3496             } else                      /* single branch is optimized. */
3497                 scan = NEXTOPER(scan);
3498             continue;
3499         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
3500             scan_frame *newframe = NULL;
3501             I32 paren;
3502             regnode *start;
3503             regnode *end;
3504
3505             if (OP(scan) != SUSPEND) {
3506             /* set the pointer */
3507                 if (OP(scan) == GOSUB) {
3508                     paren = ARG(scan);
3509                     RExC_recurse[ARG2L(scan)] = scan;
3510                     start = RExC_open_parens[paren-1];
3511                     end   = RExC_close_parens[paren-1];
3512                 } else {
3513                     paren = 0;
3514                     start = RExC_rxi->program + 1;
3515                     end   = RExC_opend;
3516                 }
3517                 if (!recursed) {
3518                     Newxz(recursed, (((RExC_npar)>>3) +1), U8);
3519                     SAVEFREEPV(recursed);
3520                 }
3521                 if (!PAREN_TEST(recursed,paren+1)) {
3522                     PAREN_SET(recursed,paren+1);
3523                     Newx(newframe,1,scan_frame);
3524                 } else {
3525                     if (flags & SCF_DO_SUBSTR) {
3526                         SCAN_COMMIT(pRExC_state,data,minlenp);
3527                         data->longest = &(data->longest_float);
3528                     }
3529                     is_inf = is_inf_internal = 1;
3530                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3531                         cl_anything(pRExC_state, data->start_class);
3532                     flags &= ~SCF_DO_STCLASS;
3533                 }
3534             } else {
3535                 Newx(newframe,1,scan_frame);
3536                 paren = stopparen;
3537                 start = scan+2;
3538                 end = regnext(scan);
3539             }
3540             if (newframe) {
3541                 assert(start);
3542                 assert(end);
3543                 SAVEFREEPV(newframe);
3544                 newframe->next = regnext(scan);
3545                 newframe->last = last;
3546                 newframe->stop = stopparen;
3547                 newframe->prev = frame;
3548
3549                 frame = newframe;
3550                 scan =  start;
3551                 stopparen = paren;
3552                 last = end;
3553
3554                 continue;
3555             }
3556         }
3557         else if (OP(scan) == EXACT) {
3558             I32 l = STR_LEN(scan);
3559             UV uc;
3560             if (UTF) {
3561                 const U8 * const s = (U8*)STRING(scan);
3562                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
3563                 l = utf8_length(s, s + l);
3564             } else {
3565                 uc = *((U8*)STRING(scan));
3566             }
3567             min += l;
3568             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
3569                 /* The code below prefers earlier match for fixed
3570                    offset, later match for variable offset.  */
3571                 if (data->last_end == -1) { /* Update the start info. */
3572                     data->last_start_min = data->pos_min;
3573                     data->last_start_max = is_inf
3574                         ? I32_MAX : data->pos_min + data->pos_delta;
3575                 }
3576                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
3577                 if (UTF)
3578                     SvUTF8_on(data->last_found);
3579                 {
3580                     SV * const sv = data->last_found;
3581                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3582                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
3583                     if (mg && mg->mg_len >= 0)
3584                         mg->mg_len += utf8_length((U8*)STRING(scan),
3585                                                   (U8*)STRING(scan)+STR_LEN(scan));
3586                 }
3587                 data->last_end = data->pos_min + l;
3588                 data->pos_min += l; /* As in the first entry. */
3589                 data->flags &= ~SF_BEFORE_EOL;
3590             }
3591             if (flags & SCF_DO_STCLASS_AND) {
3592                 /* Check whether it is compatible with what we know already! */
3593                 int compat = 1;
3594
3595
3596                 /* If compatible, we or it in below.  It is compatible if is
3597                  * in the bitmp and either 1) its bit or its fold is set, or 2)
3598                  * it's for a locale.  Even if there isn't unicode semantics
3599                  * here, at runtime there may be because of matching against a
3600                  * utf8 string, so accept a possible false positive for
3601                  * latin1-range folds */
3602                 if (uc >= 0x100 ||
3603                     (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3604                     && !ANYOF_BITMAP_TEST(data->start_class, uc)
3605                     && (!(data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD)
3606                         || !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3607                     )
3608                 {
3609                     compat = 0;
3610                 }
3611                 ANYOF_CLASS_ZERO(data->start_class);
3612                 ANYOF_BITMAP_ZERO(data->start_class);
3613                 if (compat)
3614                     ANYOF_BITMAP_SET(data->start_class, uc);
3615                 else if (uc >= 0x100) {
3616                     int i;
3617
3618                     /* Some Unicode code points fold to the Latin1 range; as
3619                      * XXX temporary code, instead of figuring out if this is
3620                      * one, just assume it is and set all the start class bits
3621                      * that could be some such above 255 code point's fold
3622                      * which will generate fals positives.  As the code
3623                      * elsewhere that does compute the fold settles down, it
3624                      * can be extracted out and re-used here */
3625                     for (i = 0; i < 256; i++){
3626                         if (HAS_NONLATIN1_FOLD_CLOSURE(i)) {
3627                             ANYOF_BITMAP_SET(data->start_class, i);
3628                         }
3629                     }
3630                 }
3631                 data->start_class->flags &= ~ANYOF_EOS;
3632                 if (uc < 0x100)
3633                   data->start_class->flags &= ~ANYOF_UNICODE_ALL;
3634             }
3635             else if (flags & SCF_DO_STCLASS_OR) {
3636                 /* false positive possible if the class is case-folded */
3637                 if (uc < 0x100)
3638                     ANYOF_BITMAP_SET(data->start_class, uc);
3639                 else
3640                     data->start_class->flags |= ANYOF_UNICODE_ALL;
3641                 data->start_class->flags &= ~ANYOF_EOS;
3642                 cl_and(data->start_class, and_withp);
3643             }
3644             flags &= ~SCF_DO_STCLASS;
3645         }
3646         else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
3647             I32 l = STR_LEN(scan);
3648             UV uc = *((U8*)STRING(scan));
3649
3650             /* Search for fixed substrings supports EXACT only. */
3651             if (flags & SCF_DO_SUBSTR) {
3652                 assert(data);
3653                 SCAN_COMMIT(pRExC_state, data, minlenp);
3654             }
3655             if (UTF) {
3656                 const U8 * const s = (U8 *)STRING(scan);
3657                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
3658                 l = utf8_length(s, s + l);
3659             }
3660             else if (has_exactf_sharp_s) {
3661                 RExC_seen |= REG_SEEN_EXACTF_SHARP_S;
3662             }
3663             min += l - min_subtract;
3664             if (min < 0) {
3665                 min = 0;
3666             }
3667             delta += min_subtract;
3668             if (flags & SCF_DO_SUBSTR) {
3669                 data->pos_min += l - min_subtract;
3670                 if (data->pos_min < 0) {
3671                     data->pos_min = 0;
3672                 }
3673                 data->pos_delta += min_subtract;
3674                 if (min_subtract) {
3675                     data->longest = &(data->longest_float);
3676                 }
3677             }
3678             if (flags & SCF_DO_STCLASS_AND) {
3679                 /* Check whether it is compatible with what we know already! */
3680                 int compat = 1;
3681                 if (uc >= 0x100 ||
3682                  (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3683                   && !ANYOF_BITMAP_TEST(data->start_class, uc)
3684                   && !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3685                 {
3686                     compat = 0;
3687                 }
3688                 ANYOF_CLASS_ZERO(data->start_class);
3689                 ANYOF_BITMAP_ZERO(data->start_class);
3690                 if (compat) {
3691                     ANYOF_BITMAP_SET(data->start_class, uc);
3692                     data->start_class->flags &= ~ANYOF_EOS;
3693                     data->start_class->flags |= ANYOF_LOC_NONBITMAP_FOLD;
3694                     if (OP(scan) == EXACTFL) {
3695                         /* XXX This set is probably no longer necessary, and
3696                          * probably wrong as LOCALE now is on in the initial
3697                          * state */
3698                         data->start_class->flags |= ANYOF_LOCALE;
3699                     }
3700                     else {
3701
3702                         /* Also set the other member of the fold pair.  In case
3703                          * that unicode semantics is called for at runtime, use
3704                          * the full latin1 fold.  (Can't do this for locale,
3705                          * because not known until runtime) */
3706                         ANYOF_BITMAP_SET(data->start_class, PL_fold_latin1[uc]);
3707
3708                         /* All other (EXACTFL handled above) folds except under
3709                          * /iaa that include s, S, and sharp_s also may include
3710                          * the others */
3711                         if (OP(scan) != EXACTFA) {
3712                             if (uc == 's' || uc == 'S') {
3713                                 ANYOF_BITMAP_SET(data->start_class,
3714                                                  LATIN_SMALL_LETTER_SHARP_S);
3715                             }
3716                             else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3717                                 ANYOF_BITMAP_SET(data->start_class, 's');
3718                                 ANYOF_BITMAP_SET(data->start_class, 'S');
3719                             }
3720                         }
3721                     }
3722                 }
3723                 else if (uc >= 0x100) {
3724                     int i;
3725                     for (i = 0; i < 256; i++){
3726                         if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3727                             ANYOF_BITMAP_SET(data->start_class, i);
3728                         }
3729                     }
3730                 }
3731             }
3732             else if (flags & SCF_DO_STCLASS_OR) {
3733                 if (data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD) {
3734                     /* false positive possible if the class is case-folded.
3735                        Assume that the locale settings are the same... */
3736                     if (uc < 0x100) {
3737                         ANYOF_BITMAP_SET(data->start_class, uc);
3738                         if (OP(scan) != EXACTFL) {
3739
3740                             /* And set the other member of the fold pair, but
3741                              * can't do that in locale because not known until
3742                              * run-time */
3743                             ANYOF_BITMAP_SET(data->start_class,
3744                                              PL_fold_latin1[uc]);
3745
3746                             /* All folds except under /iaa that include s, S,
3747                              * and sharp_s also may include the others */
3748                             if (OP(scan) != EXACTFA) {
3749                                 if (uc == 's' || uc == 'S') {
3750                                     ANYOF_BITMAP_SET(data->start_class,
3751                                                    LATIN_SMALL_LETTER_SHARP_S);
3752                                 }
3753                                 else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3754                                     ANYOF_BITMAP_SET(data->start_class, 's');
3755                                     ANYOF_BITMAP_SET(data->start_class, 'S');
3756                                 }
3757                             }
3758                         }
3759                     }
3760                     data->start_class->flags &= ~ANYOF_EOS;
3761                 }
3762                 cl_and(data->start_class, and_withp);
3763             }
3764             flags &= ~SCF_DO_STCLASS;
3765         }
3766         else if (REGNODE_VARIES(OP(scan))) {
3767             I32 mincount, maxcount, minnext, deltanext, fl = 0;
3768             I32 f = flags, pos_before = 0;
3769             regnode * const oscan = scan;
3770             struct regnode_charclass_class this_class;
3771             struct regnode_charclass_class *oclass = NULL;
3772             I32 next_is_eval = 0;
3773
3774             switch (PL_regkind[OP(scan)]) {
3775             case WHILEM:                /* End of (?:...)* . */
3776                 scan = NEXTOPER(scan);
3777                 goto finish;
3778             case PLUS:
3779                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
3780                     next = NEXTOPER(scan);
3781                     if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
3782                         mincount = 1;
3783                         maxcount = REG_INFTY;
3784                         next = regnext(scan);
3785                         scan = NEXTOPER(scan);
3786                         goto do_curly;
3787                     }
3788                 }
3789                 if (flags & SCF_DO_SUBSTR)
3790                     data->pos_min++;
3791                 min++;
3792                 /* Fall through. */
3793             case STAR:
3794                 if (flags & SCF_DO_STCLASS) {
3795                     mincount = 0;
3796                     maxcount = REG_INFTY;
3797                     next = regnext(scan);
3798                     scan = NEXTOPER(scan);
3799                     goto do_curly;
3800                 }
3801                 is_inf = is_inf_internal = 1;
3802                 scan = regnext(scan);
3803                 if (flags & SCF_DO_SUBSTR) {
3804                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
3805                     data->longest = &(data->longest_float);
3806                 }
3807                 goto optimize_curly_tail;
3808             case CURLY:
3809                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
3810                     && (scan->flags == stopparen))
3811                 {
3812                     mincount = 1;
3813                     maxcount = 1;
3814                 } else {
3815                     mincount = ARG1(scan);
3816                     maxcount = ARG2(scan);
3817                 }
3818                 next = regnext(scan);
3819                 if (OP(scan) == CURLYX) {
3820                     I32 lp = (data ? *(data->last_closep) : 0);
3821                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
3822                 }
3823                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3824                 next_is_eval = (OP(scan) == EVAL);
3825               do_curly:
3826                 if (flags & SCF_DO_SUBSTR) {
3827                     if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
3828                     pos_before = data->pos_min;
3829                 }
3830                 if (data) {
3831                     fl = data->flags;
3832                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
3833                     if (is_inf)
3834                         data->flags |= SF_IS_INF;
3835                 }
3836                 if (flags & SCF_DO_STCLASS) {
3837                     cl_init(pRExC_state, &this_class);
3838                     oclass = data->start_class;
3839                     data->start_class = &this_class;
3840                     f |= SCF_DO_STCLASS_AND;
3841                     f &= ~SCF_DO_STCLASS_OR;
3842                 }
3843                 /* Exclude from super-linear cache processing any {n,m}
3844                    regops for which the combination of input pos and regex
3845                    pos is not enough information to determine if a match
3846                    will be possible.
3847
3848                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
3849                    regex pos at the \s*, the prospects for a match depend not
3850                    only on the input position but also on how many (bar\s*)
3851                    repeats into the {4,8} we are. */
3852                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
3853                     f &= ~SCF_WHILEM_VISITED_POS;
3854
3855                 /* This will finish on WHILEM, setting scan, or on NULL: */
3856                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, 
3857                                       last, data, stopparen, recursed, NULL,
3858                                       (mincount == 0
3859                                         ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
3860
3861                 if (flags & SCF_DO_STCLASS)
3862                     data->start_class = oclass;
3863                 if (mincount == 0 || minnext == 0) {
3864                     if (flags & SCF_DO_STCLASS_OR) {
3865                         cl_or(pRExC_state, data->start_class, &this_class);
3866                     }
3867                     else if (flags & SCF_DO_STCLASS_AND) {
3868                         /* Switch to OR mode: cache the old value of
3869                          * data->start_class */
3870                         INIT_AND_WITHP;
3871                         StructCopy(data->start_class, and_withp,
3872                                    struct regnode_charclass_class);
3873                         flags &= ~SCF_DO_STCLASS_AND;
3874                         StructCopy(&this_class, data->start_class,
3875                                    struct regnode_charclass_class);
3876                         flags |= SCF_DO_STCLASS_OR;
3877                         data->start_class->flags |= ANYOF_EOS;
3878                     }
3879                 } else {                /* Non-zero len */
3880                     if (flags & SCF_DO_STCLASS_OR) {
3881                         cl_or(pRExC_state, data->start_class, &this_class);
3882                         cl_and(data->start_class, and_withp);
3883                     }
3884                     else if (flags & SCF_DO_STCLASS_AND)
3885                         cl_and(data->start_class, &this_class);
3886                     flags &= ~SCF_DO_STCLASS;
3887                 }
3888                 if (!scan)              /* It was not CURLYX, but CURLY. */
3889                     scan = next;
3890                 if ( /* ? quantifier ok, except for (?{ ... }) */
3891                     (next_is_eval || !(mincount == 0 && maxcount == 1))
3892                     && (minnext == 0) && (deltanext == 0)
3893                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
3894                     && maxcount <= REG_INFTY/3) /* Complement check for big count */
3895                 {
3896                     ckWARNreg(RExC_parse,
3897                               "Quantifier unexpected on zero-length expression");
3898                 }
3899
3900                 min += minnext * mincount;
3901                 is_inf_internal |= ((maxcount == REG_INFTY
3902                                      && (minnext + deltanext) > 0)
3903                                     || deltanext == I32_MAX);
3904                 is_inf |= is_inf_internal;
3905                 delta += (minnext + deltanext) * maxcount - minnext * mincount;
3906
3907                 /* Try powerful optimization CURLYX => CURLYN. */
3908                 if (  OP(oscan) == CURLYX && data
3909                       && data->flags & SF_IN_PAR
3910                       && !(data->flags & SF_HAS_EVAL)
3911                       && !deltanext && minnext == 1 ) {
3912                     /* Try to optimize to CURLYN.  */
3913                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
3914                     regnode * const nxt1 = nxt;
3915 #ifdef DEBUGGING
3916                     regnode *nxt2;
3917 #endif
3918
3919                     /* Skip open. */
3920                     nxt = regnext(nxt);
3921                     if (!REGNODE_SIMPLE(OP(nxt))
3922                         && !(PL_regkind[OP(nxt)] == EXACT
3923                              && STR_LEN(nxt) == 1))
3924                         goto nogo;
3925 #ifdef DEBUGGING
3926                     nxt2 = nxt;
3927 #endif
3928                     nxt = regnext(nxt);
3929                     if (OP(nxt) != CLOSE)
3930                         goto nogo;
3931                     if (RExC_open_parens) {
3932                         RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3933                         RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
3934                     }
3935                     /* Now we know that nxt2 is the only contents: */
3936                     oscan->flags = (U8)ARG(nxt);
3937                     OP(oscan) = CURLYN;
3938                     OP(nxt1) = NOTHING; /* was OPEN. */
3939
3940 #ifdef DEBUGGING
3941                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3942                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
3943                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
3944                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
3945                     OP(nxt + 1) = OPTIMIZED; /* was count. */
3946                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
3947 #endif
3948                 }
3949               nogo:
3950
3951                 /* Try optimization CURLYX => CURLYM. */
3952                 if (  OP(oscan) == CURLYX && data
3953                       && !(data->flags & SF_HAS_PAR)
3954                       && !(data->flags & SF_HAS_EVAL)
3955                       && !deltanext     /* atom is fixed width */
3956                       && minnext != 0   /* CURLYM can't handle zero width */
3957                 ) {
3958                     /* XXXX How to optimize if data == 0? */
3959                     /* Optimize to a simpler form.  */
3960                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
3961                     regnode *nxt2;
3962
3963                     OP(oscan) = CURLYM;
3964                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
3965                             && (OP(nxt2) != WHILEM))
3966                         nxt = nxt2;
3967                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
3968                     /* Need to optimize away parenths. */
3969                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
3970                         /* Set the parenth number.  */
3971                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
3972
3973                         oscan->flags = (U8)ARG(nxt);
3974                         if (RExC_open_parens) {
3975                             RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3976                             RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
3977                         }
3978                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
3979                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
3980
3981 #ifdef DEBUGGING
3982                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3983                         OP(nxt + 1) = OPTIMIZED; /* was count. */
3984                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
3985                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
3986 #endif
3987 #if 0
3988                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
3989                             regnode *nnxt = regnext(nxt1);
3990                             if (nnxt == nxt) {
3991                                 if (reg_off_by_arg[OP(nxt1)])
3992                                     ARG_SET(nxt1, nxt2 - nxt1);
3993                                 else if (nxt2 - nxt1 < U16_MAX)
3994                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
3995                                 else
3996                                     OP(nxt) = NOTHING;  /* Cannot beautify */
3997                             }
3998                             nxt1 = nnxt;
3999                         }
4000 #endif
4001                         /* Optimize again: */
4002                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
4003                                     NULL, stopparen, recursed, NULL, 0,depth+1);
4004                     }
4005                     else
4006                         oscan->flags = 0;
4007                 }
4008                 else if ((OP(oscan) == CURLYX)
4009                          && (flags & SCF_WHILEM_VISITED_POS)
4010                          /* See the comment on a similar expression above.
4011                             However, this time it's not a subexpression
4012                             we care about, but the expression itself. */
4013                          && (maxcount == REG_INFTY)
4014                          && data && ++data->whilem_c < 16) {
4015                     /* This stays as CURLYX, we can put the count/of pair. */
4016                     /* Find WHILEM (as in regexec.c) */
4017                     regnode *nxt = oscan + NEXT_OFF(oscan);
4018
4019                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
4020                         nxt += ARG(nxt);
4021                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
4022                         | (RExC_whilem_seen << 4)); /* On WHILEM */
4023                 }
4024                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
4025                     pars++;
4026                 if (flags & SCF_DO_SUBSTR) {
4027                     SV *last_str = NULL;
4028                     int counted = mincount != 0;
4029
4030                     if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
4031 #if defined(SPARC64_GCC_WORKAROUND)
4032                         I32 b = 0;
4033                         STRLEN l = 0;
4034                         const char *s = NULL;
4035                         I32 old = 0;
4036
4037                         if (pos_before >= data->last_start_min)
4038                             b = pos_before;
4039                         else
4040                             b = data->last_start_min;
4041
4042                         l = 0;
4043                         s = SvPV_const(data->last_found, l);
4044                         old = b - data->last_start_min;
4045
4046 #else
4047                         I32 b = pos_before >= data->last_start_min
4048                             ? pos_before : data->last_start_min;
4049                         STRLEN l;
4050                         const char * const s = SvPV_const(data->last_found, l);
4051                         I32 old = b - data->last_start_min;
4052 #endif
4053
4054                         if (UTF)
4055                             old = utf8_hop((U8*)s, old) - (U8*)s;
4056                         l -= old;
4057                         /* Get the added string: */
4058                         last_str = newSVpvn_utf8(s  + old, l, UTF);
4059                         if (deltanext == 0 && pos_before == b) {
4060                             /* What was added is a constant string */
4061                             if (mincount > 1) {
4062                                 SvGROW(last_str, (mincount * l) + 1);
4063                                 repeatcpy(SvPVX(last_str) + l,
4064                                           SvPVX_const(last_str), l, mincount - 1);
4065                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
4066                                 /* Add additional parts. */
4067                                 SvCUR_set(data->last_found,
4068                                           SvCUR(data->last_found) - l);
4069                                 sv_catsv(data->last_found, last_str);
4070                                 {
4071                                     SV * sv = data->last_found;
4072                                     MAGIC *mg =
4073                                         SvUTF8(sv) && SvMAGICAL(sv) ?
4074                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
4075                                     if (mg && mg->mg_len >= 0)
4076                                         mg->mg_len += CHR_SVLEN(last_str) - l;
4077                                 }
4078                                 data->last_end += l * (mincount - 1);
4079                             }
4080                         } else {
4081                             /* start offset must point into the last copy */
4082                             data->last_start_min += minnext * (mincount - 1);
4083                             data->last_start_max += is_inf ? I32_MAX
4084                                 : (maxcount - 1) * (minnext + data->pos_delta);
4085                         }
4086                     }
4087                     /* It is counted once already... */
4088                     data->pos_min += minnext * (mincount - counted);
4089                     data->pos_delta += - counted * deltanext +
4090                         (minnext + deltanext) * maxcount - minnext * mincount;
4091                     if (mincount != maxcount) {
4092                          /* Cannot extend fixed substrings found inside
4093                             the group.  */
4094                         SCAN_COMMIT(pRExC_state,data,minlenp);
4095                         if (mincount && last_str) {
4096                             SV * const sv = data->last_found;
4097                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4098                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
4099
4100                             if (mg)
4101                                 mg->mg_len = -1;
4102                             sv_setsv(sv, last_str);
4103                             data->last_end = data->pos_min;
4104                             data->last_start_min =
4105                                 data->pos_min - CHR_SVLEN(last_str);
4106                             data->last_start_max = is_inf
4107                                 ? I32_MAX
4108                                 : data->pos_min + data->pos_delta
4109                                 - CHR_SVLEN(last_str);
4110                         }
4111                         data->longest = &(data->longest_float);
4112                     }
4113                     SvREFCNT_dec(last_str);
4114                 }
4115                 if (data && (fl & SF_HAS_EVAL))
4116                     data->flags |= SF_HAS_EVAL;
4117               optimize_curly_tail:
4118                 if (OP(oscan) != CURLYX) {
4119                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
4120                            && NEXT_OFF(next))
4121                         NEXT_OFF(oscan) += NEXT_OFF(next);
4122                 }
4123                 continue;
4124             default:                    /* REF, ANYOFV, and CLUMP only? */
4125                 if (flags & SCF_DO_SUBSTR) {
4126                     SCAN_COMMIT(pRExC_state,data,minlenp);      /* Cannot expect anything... */
4127                     data->longest = &(data->longest_float);
4128                 }
4129                 is_inf = is_inf_internal = 1;
4130                 if (flags & SCF_DO_STCLASS_OR)
4131                     cl_anything(pRExC_state, data->start_class);
4132                 flags &= ~SCF_DO_STCLASS;
4133                 break;
4134             }
4135         }
4136         else if (OP(scan) == LNBREAK) {
4137             if (flags & SCF_DO_STCLASS) {
4138                 int value = 0;
4139                 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
4140                 if (flags & SCF_DO_STCLASS_AND) {
4141                     for (value = 0; value < 256; value++)
4142                         if (!is_VERTWS_cp(value))
4143                             ANYOF_BITMAP_CLEAR(data->start_class, value);
4144                 }
4145                 else {
4146                     for (value = 0; value < 256; value++)
4147                         if (is_VERTWS_cp(value))
4148                             ANYOF_BITMAP_SET(data->start_class, value);
4149                 }
4150                 if (flags & SCF_DO_STCLASS_OR)
4151                     cl_and(data->start_class, and_withp);
4152                 flags &= ~SCF_DO_STCLASS;
4153             }
4154             min += 1;
4155             delta += 1;
4156             if (flags & SCF_DO_SUBSTR) {
4157                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
4158                 data->pos_min += 1;
4159                 data->pos_delta += 1;
4160                 data->longest = &(data->longest_float);
4161             }
4162         }
4163         else if (REGNODE_SIMPLE(OP(scan))) {
4164             int value = 0;
4165
4166             if (flags & SCF_DO_SUBSTR) {
4167                 SCAN_COMMIT(pRExC_state,data,minlenp);
4168                 data->pos_min++;
4169             }
4170             min++;
4171             if (flags & SCF_DO_STCLASS) {
4172                 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
4173
4174                 /* Some of the logic below assumes that switching
4175                    locale on will only add false positives. */
4176                 switch (PL_regkind[OP(scan)]) {
4177                 case SANY:
4178                 default:
4179                   do_default:
4180                     /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
4181                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4182                         cl_anything(pRExC_state, data->start_class);
4183                     break;
4184                 case REG_ANY:
4185                     if (OP(scan) == SANY)
4186                         goto do_default;
4187                     if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
4188                         value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
4189                                  || ANYOF_CLASS_TEST_ANY_SET(data->start_class));
4190                         cl_anything(pRExC_state, data->start_class);
4191                     }
4192                     if (flags & SCF_DO_STCLASS_AND || !value)
4193                         ANYOF_BITMAP_CLEAR(data->start_class,'\n');
4194                     break;
4195                 case ANYOF:
4196                     if (flags & SCF_DO_STCLASS_AND)
4197                         cl_and(data->start_class,
4198                                (struct regnode_charclass_class*)scan);
4199                     else
4200                         cl_or(pRExC_state, data->start_class,
4201                               (struct regnode_charclass_class*)scan);
4202                     break;
4203                 case ALNUM:
4204                     if (flags & SCF_DO_STCLASS_AND) {
4205                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
4206                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
4207                             if (OP(scan) == ALNUMU) {
4208                                 for (value = 0; value < 256; value++) {
4209                                     if (!isWORDCHAR_L1(value)) {
4210                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4211                                     }
4212                                 }
4213                             } else {
4214                                 for (value = 0; value < 256; value++) {
4215                                     if (!isALNUM(value)) {
4216                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4217                                     }
4218                                 }
4219                             }
4220                         }
4221                     }
4222                     else {
4223                         if (data->start_class->flags & ANYOF_LOCALE)
4224                             ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
4225
4226                         /* Even if under locale, set the bits for non-locale
4227                          * in case it isn't a true locale-node.  This will
4228                          * create false positives if it truly is locale */
4229                         if (OP(scan) == ALNUMU) {
4230                             for (value = 0; value < 256; value++) {
4231                                 if (isWORDCHAR_L1(value)) {
4232                                     ANYOF_BITMAP_SET(data->start_class, value);
4233                                 }
4234                             }
4235                         } else {
4236                             for (value = 0; value < 256; value++) {
4237                                 if (isALNUM(value)) {
4238                                     ANYOF_BITMAP_SET(data->start_class, value);
4239                                 }
4240                             }
4241                         }
4242                     }
4243                     break;
4244                 case NALNUM:
4245                     if (flags & SCF_DO_STCLASS_AND) {
4246                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
4247                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
4248                             if (OP(scan) == NALNUMU) {
4249                                 for (value = 0; value < 256; value++) {
4250                                     if (isWORDCHAR_L1(value)) {
4251                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4252                                     }
4253                                 }
4254                             } else {
4255                                 for (value = 0; value < 256; value++) {
4256                                     if (isALNUM(value)) {
4257                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4258                                     }
4259                                 }
4260                             }
4261                         }
4262                     }
4263                     else {
4264                         if (data->start_class->flags & ANYOF_LOCALE)
4265                             ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
4266
4267                         /* Even if under locale, set the bits for non-locale in
4268                          * case it isn't a true locale-node.  This will create
4269                          * false positives if it truly is locale */
4270                         if (OP(scan) == NALNUMU) {
4271                             for (value = 0; value < 256; value++) {
4272                                 if (! isWORDCHAR_L1(value)) {
4273                                     ANYOF_BITMAP_SET(data->start_class, value);
4274                                 }
4275                             }
4276                         } else {
4277                             for (value = 0; value < 256; value++) {
4278                                 if (! isALNUM(value)) {
4279                                     ANYOF_BITMAP_SET(data->start_class, value);
4280                                 }
4281                             }
4282                         }
4283                     }
4284                     break;
4285                 case SPACE:
4286                     if (flags & SCF_DO_STCLASS_AND) {
4287                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
4288                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
4289                             if (OP(scan) == SPACEU) {
4290                                 for (value = 0; value < 256; value++) {
4291                                     if (!isSPACE_L1(value)) {
4292                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4293                                     }
4294                                 }
4295                             } else {
4296                                 for (value = 0; value < 256; value++) {
4297                                     if (!isSPACE(value)) {
4298                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4299                                     }
4300                                 }
4301                             }
4302                         }
4303                     }
4304                     else {
4305                         if (data->start_class->flags & ANYOF_LOCALE) {
4306                             ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
4307                         }
4308                         if (OP(scan) == SPACEU) {
4309                             for (value = 0; value < 256; value++) {
4310                                 if (isSPACE_L1(value)) {
4311                                     ANYOF_BITMAP_SET(data->start_class, value);
4312                                 }
4313                             }
4314                         } else {
4315                             for (value = 0; value < 256; value++) {
4316                                 if (isSPACE(value)) {
4317                                     ANYOF_BITMAP_SET(data->start_class, value);
4318                                 }
4319                             }
4320                         }
4321                     }
4322                     break;
4323                 case NSPACE:
4324                     if (flags & SCF_DO_STCLASS_AND) {
4325                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
4326                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
4327                             if (OP(scan) == NSPACEU) {
4328                                 for (value = 0; value < 256; value++) {
4329                                     if (isSPACE_L1(value)) {
4330                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4331                                     }
4332                                 }
4333                             } else {
4334                                 for (value = 0; value < 256; value++) {
4335                                     if (isSPACE(value)) {
4336                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4337                                     }
4338                                 }
4339                             }
4340                         }
4341                     }
4342                     else {
4343                         if (data->start_class->flags & ANYOF_LOCALE)
4344                             ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
4345                         if (OP(scan) == NSPACEU) {
4346                             for (value = 0; value < 256; value++) {
4347                                 if (!isSPACE_L1(value)) {
4348                                     ANYOF_BITMAP_SET(data->start_class, value);
4349                                 }
4350                             }
4351                         }
4352                         else {
4353                             for (value = 0; value < 256; value++) {
4354                                 if (!isSPACE(value)) {
4355                                     ANYOF_BITMAP_SET(data->start_class, value);
4356                                 }
4357                             }
4358                         }
4359                     }
4360                     break;
4361                 case DIGIT:
4362                     if (flags & SCF_DO_STCLASS_AND) {
4363                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
4364                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
4365                             for (value = 0; value < 256; value++)
4366                                 if (!isDIGIT(value))
4367                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
4368                         }
4369                     }
4370                     else {
4371                         if (data->start_class->flags & ANYOF_LOCALE)
4372                             ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
4373                         for (value = 0; value < 256; value++)
4374                             if (isDIGIT(value))
4375                                 ANYOF_BITMAP_SET(data->start_class, value);
4376                     }
4377                     break;
4378                 case NDIGIT:
4379                     if (flags & SCF_DO_STCLASS_AND) {
4380                         if (!(data->start_class->flags & ANYOF_LOCALE))
4381                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
4382                         for (value = 0; value < 256; value++)
4383                             if (isDIGIT(value))
4384                                 ANYOF_BITMAP_CLEAR(data->start_class, value);
4385                     }
4386                     else {
4387                         if (data->start_class->flags & ANYOF_LOCALE)
4388                             ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
4389                         for (value = 0; value < 256; value++)
4390                             if (!isDIGIT(value))
4391                                 ANYOF_BITMAP_SET(data->start_class, value);
4392                     }
4393                     break;
4394                 CASE_SYNST_FNC(VERTWS);
4395                 CASE_SYNST_FNC(HORIZWS);
4396
4397                 }
4398                 if (flags & SCF_DO_STCLASS_OR)
4399                     cl_and(data->start_class, and_withp);
4400                 flags &= ~SCF_DO_STCLASS;
4401             }
4402         }
4403         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
4404             data->flags |= (OP(scan) == MEOL
4405                             ? SF_BEFORE_MEOL
4406                             : SF_BEFORE_SEOL);
4407             SCAN_COMMIT(pRExC_state, data, minlenp);
4408
4409         }
4410         else if (  PL_regkind[OP(scan)] == BRANCHJ
4411                  /* Lookbehind, or need to calculate parens/evals/stclass: */
4412                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
4413                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
4414             if ( OP(scan) == UNLESSM &&
4415                  scan->flags == 0 &&
4416                  OP(NEXTOPER(NEXTOPER(scan))) == NOTHING &&
4417                  OP(regnext(NEXTOPER(NEXTOPER(scan)))) == SUCCEED
4418             ) {
4419                 regnode *opt;
4420                 regnode *upto= regnext(scan);
4421                 DEBUG_PARSE_r({
4422                     SV * const mysv_val=sv_newmortal();
4423                     DEBUG_STUDYDATA("OPFAIL",data,depth);
4424
4425                     /*DEBUG_PARSE_MSG("opfail");*/
4426                     regprop(RExC_rx, mysv_val, upto);
4427                     PerlIO_printf(Perl_debug_log, "~ replace with OPFAIL pointed at %s (%"IVdf") offset %"IVdf"\n",
4428                                   SvPV_nolen_const(mysv_val),
4429                                   (IV)REG_NODE_NUM(upto),
4430                                   (IV)(upto - scan)
4431                     );
4432                 });
4433                 OP(scan) = OPFAIL;
4434                 NEXT_OFF(scan) = upto - scan;
4435                 for (opt= scan + 1; opt < upto ; opt++)
4436                     OP(opt) = OPTIMIZED;
4437                 scan= upto;
4438                 continue;
4439             }
4440             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY 
4441                 || OP(scan) == UNLESSM )
4442             {
4443                 /* Negative Lookahead/lookbehind
4444                    In this case we can't do fixed string optimisation.
4445                 */
4446
4447                 I32 deltanext, minnext, fake = 0;
4448                 regnode *nscan;
4449                 struct regnode_charclass_class intrnl;
4450                 int f = 0;
4451
4452                 data_fake.flags = 0;
4453                 if (data) {
4454                     data_fake.whilem_c = data->whilem_c;
4455                     data_fake.last_closep = data->last_closep;
4456                 }
4457                 else
4458                     data_fake.last_closep = &fake;
4459                 data_fake.pos_delta = delta;
4460                 if ( flags & SCF_DO_STCLASS && !scan->flags
4461                      && OP(scan) == IFMATCH ) { /* Lookahead */
4462                     cl_init(pRExC_state, &intrnl);
4463                     data_fake.start_class = &intrnl;
4464                     f |= SCF_DO_STCLASS_AND;
4465                 }
4466                 if (flags & SCF_WHILEM_VISITED_POS)
4467                     f |= SCF_WHILEM_VISITED_POS;
4468                 next = regnext(scan);
4469                 nscan = NEXTOPER(NEXTOPER(scan));
4470                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext, 
4471                     last, &data_fake, stopparen, recursed, NULL, f, depth+1);
4472                 if (scan->flags) {
4473                     if (deltanext) {
4474                         FAIL("Variable length lookbehind not implemented");
4475                     }
4476                     else if (minnext > (I32)U8_MAX) {
4477                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4478                     }
4479                     scan->flags = (U8)minnext;
4480                 }
4481                 if (data) {
4482                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4483                         pars++;
4484                     if (data_fake.flags & SF_HAS_EVAL)
4485                         data->flags |= SF_HAS_EVAL;
4486                     data->whilem_c = data_fake.whilem_c;
4487                 }
4488                 if (f & SCF_DO_STCLASS_AND) {
4489                     if (flags & SCF_DO_STCLASS_OR) {
4490                         /* OR before, AND after: ideally we would recurse with
4491                          * data_fake to get the AND applied by study of the
4492                          * remainder of the pattern, and then derecurse;
4493                          * *** HACK *** for now just treat as "no information".
4494                          * See [perl #56690].
4495                          */
4496                         cl_init(pRExC_state, data->start_class);
4497                     }  else {
4498                         /* AND before and after: combine and continue */
4499                         const int was = (data->start_class->flags & ANYOF_EOS);
4500
4501                         cl_and(data->start_class, &intrnl);
4502                         if (was)
4503                             data->start_class->flags |= ANYOF_EOS;
4504                     }
4505                 }
4506             }
4507 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
4508             else {
4509                 /* Positive Lookahead/lookbehind
4510                    In this case we can do fixed string optimisation,
4511                    but we must be careful about it. Note in the case of
4512                    lookbehind the positions will be offset by the minimum
4513                    length of the pattern, something we won't know about
4514                    until after the recurse.
4515                 */
4516                 I32 deltanext, fake = 0;
4517                 regnode *nscan;
4518                 struct regnode_charclass_class intrnl;
4519                 int f = 0;
4520                 /* We use SAVEFREEPV so that when the full compile 
4521                     is finished perl will clean up the allocated 
4522                     minlens when it's all done. This way we don't
4523                     have to worry about freeing them when we know
4524                     they wont be used, which would be a pain.
4525                  */
4526                 I32 *minnextp;
4527                 Newx( minnextp, 1, I32 );
4528                 SAVEFREEPV(minnextp);
4529
4530                 if (data) {
4531                     StructCopy(data, &data_fake, scan_data_t);
4532                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
4533                         f |= SCF_DO_SUBSTR;
4534                         if (scan->flags) 
4535                             SCAN_COMMIT(pRExC_state, &data_fake,minlenp);
4536                         data_fake.last_found=newSVsv(data->last_found);
4537                     }
4538                 }
4539                 else
4540                     data_fake.last_closep = &fake;
4541                 data_fake.flags = 0;
4542                 data_fake.pos_delta = delta;
4543                 if (is_inf)
4544                     data_fake.flags |= SF_IS_INF;
4545                 if ( flags & SCF_DO_STCLASS && !scan->flags
4546                      && OP(scan) == IFMATCH ) { /* Lookahead */
4547                     cl_init(pRExC_state, &intrnl);
4548                     data_fake.start_class = &intrnl;
4549                     f |= SCF_DO_STCLASS_AND;
4550                 }
4551                 if (flags & SCF_WHILEM_VISITED_POS)
4552                     f |= SCF_WHILEM_VISITED_POS;
4553                 next = regnext(scan);
4554                 nscan = NEXTOPER(NEXTOPER(scan));
4555
4556                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext, 
4557                     last, &data_fake, stopparen, recursed, NULL, f,depth+1);
4558                 if (scan->flags) {
4559                     if (deltanext) {
4560                         FAIL("Variable length lookbehind not implemented");
4561                     }
4562                     else if (*minnextp > (I32)U8_MAX) {
4563                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4564                     }
4565                     scan->flags = (U8)*minnextp;
4566                 }
4567
4568                 *minnextp += min;
4569
4570                 if (f & SCF_DO_STCLASS_AND) {
4571                     const int was = (data->start_class->flags & ANYOF_EOS);
4572
4573                     cl_and(data->start_class, &intrnl);
4574                     if (was)
4575                         data->start_class->flags |= ANYOF_EOS;
4576                 }
4577                 if (data) {
4578                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4579                         pars++;
4580                     if (data_fake.flags & SF_HAS_EVAL)
4581                         data->flags |= SF_HAS_EVAL;
4582                     data->whilem_c = data_fake.whilem_c;
4583                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
4584                         if (RExC_rx->minlen<*minnextp)
4585                             RExC_rx->minlen=*minnextp;
4586                         SCAN_COMMIT(pRExC_state, &data_fake, minnextp);
4587                         SvREFCNT_dec(data_fake.last_found);
4588                         
4589                         if ( data_fake.minlen_fixed != minlenp ) 
4590                         {
4591                             data->offset_fixed= data_fake.offset_fixed;
4592                             data->minlen_fixed= data_fake.minlen_fixed;
4593                             data->lookbehind_fixed+= scan->flags;
4594                         }
4595                         if ( data_fake.minlen_float != minlenp )
4596                         {
4597                             data->minlen_float= data_fake.minlen_float;
4598                             data->offset_float_min=data_fake.offset_float_min;
4599                             data->offset_float_max=data_fake.offset_float_max;
4600                             data->lookbehind_float+= scan->flags;
4601                         }
4602                     }
4603                 }
4604             }
4605 #endif
4606         }
4607         else if (OP(scan) == OPEN) {
4608             if (stopparen != (I32)ARG(scan))
4609                 pars++;
4610         }
4611         else if (OP(scan) == CLOSE) {
4612             if (stopparen == (I32)ARG(scan)) {
4613                 break;
4614             }
4615             if ((I32)ARG(scan) == is_par) {
4616                 next = regnext(scan);
4617
4618                 if ( next && (OP(next) != WHILEM) && next < last)
4619                     is_par = 0;         /* Disable optimization */
4620             }
4621             if (data)
4622                 *(data->last_closep) = ARG(scan);
4623         }
4624         else if (OP(scan) == EVAL) {
4625                 if (data)
4626                     data->flags |= SF_HAS_EVAL;
4627         }
4628         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
4629             if (flags & SCF_DO_SUBSTR) {
4630                 SCAN_COMMIT(pRExC_state,data,minlenp);
4631                 flags &= ~SCF_DO_SUBSTR;
4632             }
4633             if (data && OP(scan)==ACCEPT) {
4634                 data->flags |= SCF_SEEN_ACCEPT;
4635                 if (stopmin > min)
4636                     stopmin = min;
4637             }
4638         }
4639         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
4640         {
4641                 if (flags & SCF_DO_SUBSTR) {
4642                     SCAN_COMMIT(pRExC_state,data,minlenp);
4643                     data->longest = &(data->longest_float);
4644                 }
4645                 is_inf = is_inf_internal = 1;
4646                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4647                     cl_anything(pRExC_state, data->start_class);
4648                 flags &= ~SCF_DO_STCLASS;
4649         }
4650         else if (OP(scan) == GPOS) {
4651             if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) &&
4652                 !(delta || is_inf || (data && data->pos_delta))) 
4653             {
4654                 if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR))
4655                     RExC_rx->extflags |= RXf_ANCH_GPOS;
4656                 if (RExC_rx->gofs < (U32)min)
4657                     RExC_rx->gofs = min;
4658             } else {
4659                 RExC_rx->extflags |= RXf_GPOS_FLOAT;
4660                 RExC_rx->gofs = 0;
4661             }       
4662         }
4663 #ifdef TRIE_STUDY_OPT
4664 #ifdef FULL_TRIE_STUDY
4665         else if (PL_regkind[OP(scan)] == TRIE) {
4666             /* NOTE - There is similar code to this block above for handling
4667                BRANCH nodes on the initial study.  If you change stuff here
4668                check there too. */
4669             regnode *trie_node= scan;
4670             regnode *tail= regnext(scan);
4671             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4672             I32 max1 = 0, min1 = I32_MAX;
4673             struct regnode_charclass_class accum;
4674
4675             if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
4676                 SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
4677             if (flags & SCF_DO_STCLASS)
4678                 cl_init_zero(pRExC_state, &accum);
4679                 
4680             if (!trie->jump) {
4681                 min1= trie->minlen;
4682                 max1= trie->maxlen;
4683             } else {
4684                 const regnode *nextbranch= NULL;
4685                 U32 word;
4686                 
4687                 for ( word=1 ; word <= trie->wordcount ; word++) 
4688                 {
4689                     I32 deltanext=0, minnext=0, f = 0, fake;
4690                     struct regnode_charclass_class this_class;
4691                     
4692                     data_fake.flags = 0;
4693                     if (data) {
4694                         data_fake.whilem_c = data->whilem_c;
4695                         data_fake.last_closep = data->last_closep;
4696                     }
4697                     else
4698                         data_fake.last_closep = &fake;
4699                     data_fake.pos_delta = delta;
4700                     if (flags & SCF_DO_STCLASS) {
4701                         cl_init(pRExC_state, &this_class);
4702                         data_fake.start_class = &this_class;
4703                         f = SCF_DO_STCLASS_AND;
4704                     }
4705                     if (flags & SCF_WHILEM_VISITED_POS)
4706                         f |= SCF_WHILEM_VISITED_POS;
4707     
4708                     if (trie->jump[word]) {
4709                         if (!nextbranch)
4710                             nextbranch = trie_node + trie->jump[0];
4711                         scan= trie_node + trie->jump[word];
4712                         /* We go from the jump point to the branch that follows
4713                            it. Note this means we need the vestigal unused branches
4714                            even though they arent otherwise used.
4715                          */
4716                         minnext = study_chunk(pRExC_state, &scan, minlenp, 
4717                             &deltanext, (regnode *)nextbranch, &data_fake, 
4718                             stopparen, recursed, NULL, f,depth+1);
4719                     }
4720                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
4721                         nextbranch= regnext((regnode*)nextbranch);
4722                     
4723                     if (min1 > (I32)(minnext + trie->minlen))
4724                         min1 = minnext + trie->minlen;
4725                     if (max1 < (I32)(minnext + deltanext + trie->maxlen))
4726                         max1 = minnext + deltanext + trie->maxlen;
4727                     if (deltanext == I32_MAX)
4728                         is_inf = is_inf_internal = 1;
4729                     
4730                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4731                         pars++;
4732                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4733                         if ( stopmin > min + min1) 
4734                             stopmin = min + min1;
4735                         flags &= ~SCF_DO_SUBSTR;
4736                         if (data)
4737                             data->flags |= SCF_SEEN_ACCEPT;
4738                     }
4739                     if (data) {
4740                         if (data_fake.flags & SF_HAS_EVAL)
4741                             data->flags |= SF_HAS_EVAL;
4742                         data->whilem_c = data_fake.whilem_c;
4743                     }
4744                     if (flags & SCF_DO_STCLASS)
4745                         cl_or(pRExC_state, &accum, &this_class);
4746                 }
4747             }
4748             if (flags & SCF_DO_SUBSTR) {
4749                 data->pos_min += min1;
4750                 data->pos_delta += max1 - min1;
4751                 if (max1 != min1 || is_inf)
4752                     data->longest = &(data->longest_float);
4753             }
4754             min += min1;
4755             delta += max1 - min1;
4756             if (flags & SCF_DO_STCLASS_OR) {
4757                 cl_or(pRExC_state, data->start_class, &accum);
4758                 if (min1) {
4759                     cl_and(data->start_class, and_withp);
4760                     flags &= ~SCF_DO_STCLASS;
4761                 }
4762             }
4763             else if (flags & SCF_DO_STCLASS_AND) {
4764                 if (min1) {
4765                     cl_and(data->start_class, &accum);
4766                     flags &= ~SCF_DO_STCLASS;
4767                 }
4768                 else {
4769                     /* Switch to OR mode: cache the old value of
4770                      * data->start_class */
4771                     INIT_AND_WITHP;
4772                     StructCopy(data->start_class, and_withp,
4773                                struct regnode_charclass_class);
4774                     flags &= ~SCF_DO_STCLASS_AND;
4775                     StructCopy(&accum, data->start_class,
4776                                struct regnode_charclass_class);
4777                     flags |= SCF_DO_STCLASS_OR;
4778                     data->start_class->flags |= ANYOF_EOS;
4779                 }
4780             }
4781             scan= tail;
4782             continue;
4783         }
4784 #else
4785         else if (PL_regkind[OP(scan)] == TRIE) {
4786             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4787             U8*bang=NULL;
4788             
4789             min += trie->minlen;
4790             delta += (trie->maxlen - trie->minlen);
4791             flags &= ~SCF_DO_STCLASS; /* xxx */
4792             if (flags & SCF_DO_SUBSTR) {
4793                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
4794                 data->pos_min += trie->minlen;
4795                 data->pos_delta += (trie->maxlen - trie->minlen);
4796                 if (trie->maxlen != trie->minlen)
4797                     data->longest = &(data->longest_float);
4798             }
4799             if (trie->jump) /* no more substrings -- for now /grr*/
4800                 flags &= ~SCF_DO_SUBSTR; 
4801         }
4802 #endif /* old or new */
4803 #endif /* TRIE_STUDY_OPT */
4804
4805         /* Else: zero-length, ignore. */
4806         scan = regnext(scan);
4807     }
4808     if (frame) {
4809         last = frame->last;
4810         scan = frame->next;
4811         stopparen = frame->stop;
4812         frame = frame->prev;
4813         goto fake_study_recurse;
4814     }
4815
4816   finish:
4817     assert(!frame);
4818     DEBUG_STUDYDATA("pre-fin:",data,depth);
4819
4820     *scanp = scan;
4821     *deltap = is_inf_internal ? I32_MAX : delta;
4822     if (flags & SCF_DO_SUBSTR && is_inf)
4823         data->pos_delta = I32_MAX - data->pos_min;
4824     if (is_par > (I32)U8_MAX)
4825         is_par = 0;
4826     if (is_par && pars==1 && data) {
4827         data->flags |= SF_IN_PAR;
4828         data->flags &= ~SF_HAS_PAR;
4829     }
4830     else if (pars && data) {
4831         data->flags |= SF_HAS_PAR;
4832         data->flags &= ~SF_IN_PAR;
4833     }
4834     if (flags & SCF_DO_STCLASS_OR)
4835         cl_and(data->start_class, and_withp);
4836     if (flags & SCF_TRIE_RESTUDY)
4837         data->flags |=  SCF_TRIE_RESTUDY;
4838     
4839     DEBUG_STUDYDATA("post-fin:",data,depth);
4840     
4841     return min < stopmin ? min : stopmin;
4842 }
4843
4844 STATIC U32
4845 S_add_data(RExC_state_t *pRExC_state, U32 n, const char *s)
4846 {
4847     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
4848
4849     PERL_ARGS_ASSERT_ADD_DATA;
4850
4851     Renewc(RExC_rxi->data,
4852            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
4853            char, struct reg_data);
4854     if(count)
4855         Renew(RExC_rxi->data->what, count + n, U8);
4856     else
4857         Newx(RExC_rxi->data->what, n, U8);
4858     RExC_rxi->data->count = count + n;
4859     Copy(s, RExC_rxi->data->what + count, n, U8);
4860     return count;
4861 }
4862
4863 /*XXX: todo make this not included in a non debugging perl */
4864 #ifndef PERL_IN_XSUB_RE
4865 void
4866 Perl_reginitcolors(pTHX)
4867 {
4868     dVAR;
4869     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
4870     if (s) {
4871         char *t = savepv(s);
4872         int i = 0;
4873         PL_colors[0] = t;
4874         while (++i < 6) {
4875             t = strchr(t, '\t');
4876             if (t) {
4877                 *t = '\0';
4878                 PL_colors[i] = ++t;
4879             }
4880             else
4881                 PL_colors[i] = t = (char *)"";
4882         }
4883     } else {
4884         int i = 0;
4885         while (i < 6)
4886             PL_colors[i++] = (char *)"";
4887     }
4888     PL_colorset = 1;
4889 }
4890 #endif
4891
4892
4893 #ifdef TRIE_STUDY_OPT
4894 #define CHECK_RESTUDY_GOTO                                  \
4895         if (                                                \
4896               (data.flags & SCF_TRIE_RESTUDY)               \
4897               && ! restudied++                              \
4898         )     goto reStudy
4899 #else
4900 #define CHECK_RESTUDY_GOTO
4901 #endif        
4902
4903 /*
4904  * pregcomp - compile a regular expression into internal code
4905  *
4906  * Decides which engine's compiler to call based on the hint currently in
4907  * scope
4908  */
4909
4910 #ifndef PERL_IN_XSUB_RE 
4911
4912 /* return the currently in-scope regex engine (or the default if none)  */
4913
4914 regexp_engine const *
4915 Perl_current_re_engine(pTHX)
4916 {
4917     dVAR;
4918
4919     if (IN_PERL_COMPILETIME) {
4920         HV * const table = GvHV(PL_hintgv);
4921         SV **ptr;
4922
4923         if (!table)
4924             return &PL_core_reg_engine;
4925         ptr = hv_fetchs(table, "regcomp", FALSE);
4926         if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
4927             return &PL_core_reg_engine;
4928         return INT2PTR(regexp_engine*,SvIV(*ptr));
4929     }
4930     else {
4931         SV *ptr;
4932         if (!PL_curcop->cop_hints_hash)
4933             return &PL_core_reg_engine;
4934         ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
4935         if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
4936             return &PL_core_reg_engine;
4937         return INT2PTR(regexp_engine*,SvIV(ptr));
4938     }
4939 }
4940
4941
4942 REGEXP *
4943 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
4944 {
4945     dVAR;
4946     regexp_engine const *eng = current_re_engine();
4947     GET_RE_DEBUG_FLAGS_DECL;
4948
4949     PERL_ARGS_ASSERT_PREGCOMP;
4950
4951     /* Dispatch a request to compile a regexp to correct regexp engine. */
4952     DEBUG_COMPILE_r({
4953         PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
4954                         PTR2UV(eng));
4955     });
4956     return CALLREGCOMP_ENG(eng, pattern, flags);
4957 }
4958 #endif
4959
4960 /* public(ish) wrapper for Perl_re_op_compile that only takes an SV
4961  * pattern rather than a list of OPs */
4962
4963 REGEXP *
4964 Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
4965 {
4966     SV *pat = pattern; /* defeat constness! */
4967     PERL_ARGS_ASSERT_RE_COMPILE;
4968     return Perl_re_op_compile(aTHX_ &pat, 1, NULL, current_re_engine(),
4969                                 NULL, NULL, rx_flags, 0);
4970 }
4971
4972 /* see if there are any run-time code blocks in the pattern.
4973  * False positives are allowed */
4974
4975 static bool
4976 S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state, OP *expr,
4977                     U32 pm_flags, char *pat, STRLEN plen)
4978 {
4979     int n = 0;
4980     STRLEN s;
4981
4982     /* avoid infinitely recursing when we recompile the pattern parcelled up
4983      * as qr'...'. A single constant qr// string can't have have any
4984      * run-time component in it, and thus, no runtime code. (A non-qr
4985      * string, however, can, e.g. $x =~ '(?{})') */
4986     if  ((pm_flags & PMf_IS_QR) && expr && expr->op_type == OP_CONST)
4987         return 0;
4988
4989     for (s = 0; s < plen; s++) {
4990         if (n < pRExC_state->num_code_blocks
4991             && s == pRExC_state->code_blocks[n].start)
4992         {
4993             s = pRExC_state->code_blocks[n].end;
4994             n++;
4995             continue;
4996         }
4997         /* TODO ideally should handle [..], (#..), /#.../x to reduce false
4998          * positives here */
4999         if (pat[s] == '(' && pat[s+1] == '?' &&
5000             (pat[s+2] == '{' || (pat[s+2] == '?' && pat[s+3] == '{'))
5001         )
5002             return 1;
5003     }
5004     return 0;
5005 }
5006
5007 /* Handle run-time code blocks. We will already have compiled any direct
5008  * or indirect literal code blocks. Now, take the pattern 'pat' and make a
5009  * copy of it, but with any literal code blocks blanked out and
5010  * appropriate chars escaped; then feed it into
5011  *
5012  *    eval "qr'modified_pattern'"
5013  *
5014  * For example,
5015  *
5016  *       a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
5017  *
5018  * becomes
5019  *
5020  *    qr'a\\bc                       def\'ghi\\\\jkl(?{"this is runtime"})mno'
5021  *
5022  * After eval_sv()-ing that, grab any new code blocks from the returned qr
5023  * and merge them with any code blocks of the original regexp.
5024  *
5025  * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
5026  * instead, just save the qr and return FALSE; this tells our caller that
5027  * the original pattern needs upgrading to utf8.
5028  */
5029
5030 static bool
5031 S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
5032     char *pat, STRLEN plen)
5033 {
5034     SV *qr;
5035
5036     GET_RE_DEBUG_FLAGS_DECL;
5037
5038     if (pRExC_state->runtime_code_qr) {
5039         /* this is the second time we've been called; this should
5040          * only happen if the main pattern got upgraded to utf8
5041          * during compilation; re-use the qr we compiled first time
5042          * round (which should be utf8 too)
5043          */
5044         qr = pRExC_state->runtime_code_qr;
5045         pRExC_state->runtime_code_qr = NULL;
5046         assert(RExC_utf8 && SvUTF8(qr));
5047     }
5048     else {
5049         int n = 0;
5050         STRLEN s;
5051         char *p, *newpat;
5052         int newlen = plen + 6; /* allow for "qr''x\0" extra chars */
5053         SV *sv, *qr_ref;
5054         dSP;
5055
5056         /* determine how many extra chars we need for ' and \ escaping */
5057         for (s = 0; s < plen; s++) {
5058             if (pat[s] == '\'' || pat[s] == '\\')
5059                 newlen++;
5060         }
5061
5062         Newx(newpat, newlen, char);
5063         p = newpat;
5064         *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
5065
5066         for (s = 0; s < plen; s++) {
5067             if (n < pRExC_state->num_code_blocks
5068                 && s == pRExC_state->code_blocks[n].start)
5069             {
5070                 /* blank out literal code block */
5071                 assert(pat[s] == '(');
5072                 while (s <= pRExC_state->code_blocks[n].end) {
5073                     *p++ = ' ';
5074                     s++;
5075                 }
5076                 s--;
5077                 n++;
5078                 continue;
5079             }
5080             if (pat[s] == '\'' || pat[s] == '\\')
5081                 *p++ = '\\';
5082             *p++ = pat[s];
5083         }
5084         *p++ = '\'';
5085         if (pRExC_state->pm_flags & RXf_PMf_EXTENDED)
5086             *p++ = 'x';
5087         *p++ = '\0';
5088         DEBUG_COMPILE_r({
5089             PerlIO_printf(Perl_debug_log,
5090                 "%sre-parsing pattern for runtime code:%s %s\n",
5091                 PL_colors[4],PL_colors[5],newpat);
5092         });
5093
5094         sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
5095         Safefree(newpat);
5096
5097         ENTER;
5098         SAVETMPS;
5099         save_re_context();
5100         PUSHSTACKi(PERLSI_REQUIRE);
5101         /* this causes the toker to collapse \\ into \ when parsing
5102          * qr''; normally only q'' does this. It also alters hints
5103          * handling */
5104         PL_reg_state.re_reparsing = TRUE;
5105         eval_sv(sv, G_SCALAR);
5106         SvREFCNT_dec(sv);
5107         SPAGAIN;
5108         qr_ref = POPs;
5109         PUTBACK;
5110         if (SvTRUE(ERRSV))
5111             Perl_croak(aTHX_ "%s", SvPVx_nolen_const(ERRSV));
5112         assert(SvROK(qr_ref));
5113         qr = SvRV(qr_ref);
5114         assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
5115         /* the leaving below frees the tmp qr_ref.
5116          * Give qr a life of its own */
5117         SvREFCNT_inc(qr);
5118         POPSTACK;
5119         FREETMPS;
5120         LEAVE;
5121
5122     }
5123
5124     if (!RExC_utf8 && SvUTF8(qr)) {
5125         /* first time through; the pattern got upgraded; save the
5126          * qr for the next time through */
5127         assert(!pRExC_state->runtime_code_qr);
5128         pRExC_state->runtime_code_qr = qr;
5129         return 0;
5130     }
5131
5132
5133     /* extract any code blocks within the returned qr//  */
5134
5135
5136     /* merge the main (r1) and run-time (r2) code blocks into one */
5137     {
5138         RXi_GET_DECL(((struct regexp*)SvANY(qr)), r2);
5139         struct reg_code_block *new_block, *dst;
5140         RExC_state_t * const r1 = pRExC_state; /* convenient alias */
5141         int i1 = 0, i2 = 0;
5142
5143         if (!r2->num_code_blocks) /* we guessed wrong */
5144             return 1;
5145
5146         Newx(new_block,
5147             r1->num_code_blocks + r2->num_code_blocks,
5148             struct reg_code_block);
5149         dst = new_block;
5150
5151         while (    i1 < r1->num_code_blocks
5152                 || i2 < r2->num_code_blocks)
5153         {
5154             struct reg_code_block *src;
5155             bool is_qr = 0;
5156
5157             if (i1 == r1->num_code_blocks) {
5158                 src = &r2->code_blocks[i2++];
5159                 is_qr = 1;
5160             }
5161             else if (i2 == r2->num_code_blocks)
5162                 src = &r1->code_blocks[i1++];
5163             else if (  r1->code_blocks[i1].start
5164                      < r2->code_blocks[i2].start)
5165             {
5166                 src = &r1->code_blocks[i1++];
5167                 assert(src->end < r2->code_blocks[i2].start);
5168             }
5169             else {
5170                 assert(  r1->code_blocks[i1].start
5171                        > r2->code_blocks[i2].start);
5172                 src = &r2->code_blocks[i2++];
5173                 is_qr = 1;
5174                 assert(src->end < r1->code_blocks[i1].start);
5175             }
5176
5177             assert(pat[src->start] == '(');
5178             assert(pat[src->end]   == ')');
5179             dst->start      = src->start;
5180             dst->end        = src->end;
5181             dst->block      = src->block;
5182             dst->src_regex  = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
5183                                     : src->src_regex;
5184             dst++;
5185         }
5186         r1->num_code_blocks += r2->num_code_blocks;
5187         Safefree(r1->code_blocks);
5188         r1->code_blocks = new_block;
5189     }
5190
5191     SvREFCNT_dec(qr);
5192     return 1;
5193 }
5194
5195
5196 /*
5197  * Perl_re_op_compile - the perl internal RE engine's function to compile a
5198  * regular expression into internal code.
5199  * The pattern may be passed either as:
5200  *    a list of SVs (patternp plus pat_count)
5201  *    a list of OPs (expr)
5202  * If both are passed, the SV list is used, but the OP list indicates
5203  * which SVs are actually pre-compiled code blocks
5204  *
5205  * The SVs in the list have magic and qr overloading applied to them (and
5206  * the list may be modified in-place with replacement SVs in the latter
5207  * case).
5208  *
5209  * If the pattern hasn't changed from old_re, then old_re will be
5210  * returned.
5211  *
5212  * eng is the current engine. If that engine has an op_comp method, then
5213  * handle directly (i.e. we assume that op_comp was us); otherwise, just
5214  * do the initial concatenation of arguments and pass on to the external
5215  * engine.
5216  *
5217  * If is_bare_re is not null, set it to a boolean indicating whether the
5218  * arg list reduced (after overloading) to a single bare regex which has
5219  * been returned (i.e. /$qr/).
5220  *
5221  * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
5222  *
5223  * pm_flags contains the PMf_* flags, typically based on those from the
5224  * pm_flags field of the related PMOP. Currently we're only interested in
5225  * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL.
5226  *
5227  * We can't allocate space until we know how big the compiled form will be,
5228  * but we can't compile it (and thus know how big it is) until we've got a
5229  * place to put the code.  So we cheat:  we compile it twice, once with code
5230  * generation turned off and size counting turned on, and once "for real".
5231  * This also means that we don't allocate space until we are sure that the
5232  * thing really will compile successfully, and we never have to move the
5233  * code and thus invalidate pointers into it.  (Note that it has to be in
5234  * one piece because free() must be able to free it all.) [NB: not true in perl]
5235  *
5236  * Beware that the optimization-preparation code in here knows about some
5237  * of the structure of the compiled regexp.  [I'll say.]
5238  */
5239
5240 REGEXP *
5241 Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
5242                     OP *expr, const regexp_engine* eng, REGEXP *VOL old_re,
5243                      bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags)
5244 {
5245     dVAR;
5246     REGEXP *rx;
5247     struct regexp *r;
5248     register regexp_internal *ri;
5249     STRLEN plen;
5250     char  * VOL exp;
5251     char* xend;
5252     regnode *scan;
5253     I32 flags;
5254     I32 minlen = 0;
5255     U32 rx_flags;
5256     SV * VOL pat;
5257
5258     /* these are all flags - maybe they should be turned
5259      * into a single int with different bit masks */
5260     I32 sawlookahead = 0;
5261     I32 sawplus = 0;
5262     I32 sawopen = 0;
5263     bool used_setjump = FALSE;
5264     regex_charset initial_charset = get_regex_charset(orig_rx_flags);
5265     bool code_is_utf8 = 0;
5266     bool VOL recompile = 0;
5267     bool runtime_code = 0;
5268     U8 jump_ret = 0;
5269     dJMPENV;
5270     scan_data_t data;
5271     RExC_state_t RExC_state;
5272     RExC_state_t * const pRExC_state = &RExC_state;
5273 #ifdef TRIE_STUDY_OPT    
5274     int restudied;
5275     RExC_state_t copyRExC_state;
5276 #endif    
5277     GET_RE_DEBUG_FLAGS_DECL;
5278
5279     PERL_ARGS_ASSERT_RE_OP_COMPILE;
5280
5281     DEBUG_r(if (!PL_colorset) reginitcolors());
5282
5283 #ifndef PERL_IN_XSUB_RE
5284     /* Initialize these here instead of as-needed, as is quick and avoids
5285      * having to test them each time otherwise */
5286     if (! PL_AboveLatin1) {
5287         PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
5288         PL_ASCII = _new_invlist_C_array(ASCII_invlist);
5289         PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
5290
5291         PL_L1PosixAlnum = _new_invlist_C_array(L1PosixAlnum_invlist);
5292         PL_PosixAlnum = _new_invlist_C_array(PosixAlnum_invlist);
5293
5294         PL_L1PosixAlpha = _new_invlist_C_array(L1PosixAlpha_invlist);
5295         PL_PosixAlpha = _new_invlist_C_array(PosixAlpha_invlist);
5296
5297         PL_PosixBlank = _new_invlist_C_array(PosixBlank_invlist);
5298         PL_XPosixBlank = _new_invlist_C_array(XPosixBlank_invlist);
5299
5300         PL_L1Cased = _new_invlist_C_array(L1Cased_invlist);
5301
5302         PL_PosixCntrl = _new_invlist_C_array(PosixCntrl_invlist);
5303         PL_XPosixCntrl = _new_invlist_C_array(XPosixCntrl_invlist);
5304
5305         PL_PosixDigit = _new_invlist_C_array(PosixDigit_invlist);
5306
5307         PL_L1PosixGraph = _new_invlist_C_array(L1PosixGraph_invlist);
5308         PL_PosixGraph = _new_invlist_C_array(PosixGraph_invlist);
5309
5310         PL_L1PosixAlnum = _new_invlist_C_array(L1PosixAlnum_invlist);
5311         PL_PosixAlnum = _new_invlist_C_array(PosixAlnum_invlist);
5312
5313         PL_L1PosixLower = _new_invlist_C_array(L1PosixLower_invlist);
5314         PL_PosixLower = _new_invlist_C_array(PosixLower_invlist);
5315
5316         PL_L1PosixPrint = _new_invlist_C_array(L1PosixPrint_invlist);
5317         PL_PosixPrint = _new_invlist_C_array(PosixPrint_invlist);
5318
5319         PL_L1PosixPunct = _new_invlist_C_array(L1PosixPunct_invlist);
5320         PL_PosixPunct = _new_invlist_C_array(PosixPunct_invlist);
5321
5322         PL_PerlSpace = _new_invlist_C_array(PerlSpace_invlist);
5323         PL_XPerlSpace = _new_invlist_C_array(XPerlSpace_invlist);
5324
5325         PL_PosixSpace = _new_invlist_C_array(PosixSpace_invlist);
5326         PL_XPosixSpace = _new_invlist_C_array(XPosixSpace_invlist);
5327
5328         PL_L1PosixUpper = _new_invlist_C_array(L1PosixUpper_invlist);
5329         PL_PosixUpper = _new_invlist_C_array(PosixUpper_invlist);
5330
5331         PL_VertSpace = _new_invlist_C_array(VertSpace_invlist);
5332
5333         PL_PosixWord = _new_invlist_C_array(PosixWord_invlist);
5334         PL_L1PosixWord = _new_invlist_C_array(L1PosixWord_invlist);
5335
5336         PL_PosixXDigit = _new_invlist_C_array(PosixXDigit_invlist);
5337         PL_XPosixXDigit = _new_invlist_C_array(XPosixXDigit_invlist);
5338     }
5339 #endif
5340
5341     pRExC_state->code_blocks = NULL;
5342     pRExC_state->num_code_blocks = 0;
5343
5344     if (is_bare_re)
5345         *is_bare_re = FALSE;
5346
5347     if (expr && (expr->op_type == OP_LIST ||
5348                 (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
5349
5350         /* is the source UTF8, and how many code blocks are there? */
5351         OP *o;
5352         int ncode = 0;
5353
5354         for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
5355             if (o->op_type == OP_CONST && SvUTF8(cSVOPo_sv))
5356                 code_is_utf8 = 1;
5357             else if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
5358                 /* count of DO blocks */
5359                 ncode++;
5360         }
5361         if (ncode) {
5362             pRExC_state->num_code_blocks = ncode;
5363             Newx(pRExC_state->code_blocks, ncode, struct reg_code_block);
5364         }
5365     }
5366
5367     if (pat_count) {
5368         /* handle a list of SVs */
5369
5370         SV **svp;
5371
5372         /* apply magic and RE overloading to each arg */
5373         for (svp = patternp; svp < patternp + pat_count; svp++) {
5374             SV *rx = *svp;
5375             SvGETMAGIC(rx);
5376             if (SvROK(rx) && SvAMAGIC(rx)) {
5377                 SV *sv = AMG_CALLunary(rx, regexp_amg);
5378                 if (sv) {
5379                     if (SvROK(sv))
5380                         sv = SvRV(sv);
5381                     if (SvTYPE(sv) != SVt_REGEXP)
5382                         Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
5383                     *svp = sv;
5384                 }
5385             }
5386         }
5387
5388         if (pat_count > 1) {
5389             /* concat multiple args and find any code block indexes */
5390
5391             OP *o = NULL;
5392             int n = 0;
5393             bool utf8 = 0;
5394             STRLEN orig_patlen = 0;
5395
5396             if (pRExC_state->num_code_blocks) {
5397                 o = cLISTOPx(expr)->op_first;
5398                 assert(o->op_type == OP_PUSHMARK);
5399                 o = o->op_sibling;
5400             }
5401
5402             pat = newSVpvn("", 0);
5403             SAVEFREESV(pat);
5404
5405             /* determine if the pattern is going to be utf8 (needed
5406              * in advance to align code block indices correctly).
5407              * XXX This could fail to be detected for an arg with
5408              * overloading but not concat overloading; but the main effect
5409              * in this obscure case is to need a 'use re eval' for a
5410              * literal code block */
5411             for (svp = patternp; svp < patternp + pat_count; svp++) {
5412                 if (SvUTF8(*svp))
5413                     utf8 = 1;
5414             }
5415             if (utf8)
5416                 SvUTF8_on(pat);
5417
5418             for (svp = patternp; svp < patternp + pat_count; svp++) {
5419                 SV *sv, *msv = *svp;
5420                 SV *rx;
5421                 bool code = 0;
5422                 if (o) {
5423                     if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5424                         assert(n < pRExC_state->num_code_blocks);
5425                         pRExC_state->code_blocks[n].start = SvCUR(pat);
5426                         pRExC_state->code_blocks[n].block = o;
5427                         pRExC_state->code_blocks[n].src_regex = NULL;
5428                         n++;
5429                         code = 1;
5430                         o = o->op_sibling; /* skip CONST */
5431                         assert(o);
5432                     }
5433                     o = o->op_sibling;;
5434                 }
5435
5436                 if ((SvAMAGIC(pat) || SvAMAGIC(msv)) &&
5437                         (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
5438                 {
5439                     sv_setsv(pat, sv);
5440                     /* overloading involved: all bets are off over literal
5441                      * code. Pretend we haven't seen it */
5442                     pRExC_state->num_code_blocks -= n;
5443                     n = 0;
5444                     rx = NULL;
5445
5446                 }
5447                 else  {
5448                     while (SvAMAGIC(msv)
5449                             && (sv = AMG_CALLunary(msv, string_amg))
5450                             && sv != msv)
5451                     {
5452                         msv = sv;
5453                         SvGETMAGIC(msv);
5454                     }
5455                     if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
5456                         msv = SvRV(msv);
5457                     orig_patlen = SvCUR(pat);
5458                     sv_catsv_nomg(pat, msv);
5459                     rx = msv;
5460                     if (code)
5461                         pRExC_state->code_blocks[n-1].end = SvCUR(pat)-1;
5462                 }
5463
5464                 /* extract any code blocks within any embedded qr//'s */
5465                 if (rx && SvTYPE(rx) == SVt_REGEXP
5466                     && RX_ENGINE((REGEXP*)rx)->op_comp)
5467                 {
5468
5469                     RXi_GET_DECL(((struct regexp*)SvANY(rx)), ri);
5470                     if (ri->num_code_blocks) {
5471                         int i;
5472                         /* the presence of an embedded qr// with code means
5473                          * we should always recompile: the text of the
5474                          * qr// may not have changed, but it may be a
5475                          * different closure than last time */
5476                         recompile = 1;
5477                         Renew(pRExC_state->code_blocks,
5478                             pRExC_state->num_code_blocks + ri->num_code_blocks,
5479                             struct reg_code_block);
5480                         pRExC_state->num_code_blocks += ri->num_code_blocks;
5481                         for (i=0; i < ri->num_code_blocks; i++) {
5482                             struct reg_code_block *src, *dst;
5483                             STRLEN offset =  orig_patlen
5484                                 + ((struct regexp *)SvANY(rx))->pre_prefix;
5485                             assert(n < pRExC_state->num_code_blocks);
5486                             src = &ri->code_blocks[i];
5487                             dst = &pRExC_state->code_blocks[n];
5488                             dst->start      = src->start + offset;
5489                             dst->end        = src->end   + offset;
5490                             dst->block      = src->block;
5491                             dst->src_regex  = (REGEXP*) SvREFCNT_inc( (SV*)
5492                                                     src->src_regex
5493                                                         ? src->src_regex
5494                                                         : (REGEXP*)rx);
5495                             n++;
5496                         }
5497                     }
5498                 }
5499             }
5500             SvSETMAGIC(pat);
5501         }
5502         else {
5503             SV *sv;
5504             pat = *patternp;
5505             while (SvAMAGIC(pat)
5506                     && (sv = AMG_CALLunary(pat, string_amg))
5507                     && sv != pat)
5508             {
5509                 pat = sv;
5510                 SvGETMAGIC(pat);
5511             }
5512         }
5513
5514         /* handle bare regex: foo =~ $re */
5515         {
5516             SV *re = pat;
5517             if (SvROK(re))
5518                 re = SvRV(re);
5519             if (SvTYPE(re) == SVt_REGEXP) {
5520                 if (is_bare_re)
5521                     *is_bare_re = TRUE;
5522                 SvREFCNT_inc(re);
5523                 Safefree(pRExC_state->code_blocks);
5524                 return (REGEXP*)re;
5525             }
5526         }
5527     }
5528     else {
5529         /* not a list of SVs, so must be a list of OPs */
5530         assert(expr);
5531         if (expr->op_type == OP_LIST) {
5532             int i = -1;
5533             bool is_code = 0;
5534             OP *o;
5535
5536             pat = newSVpvn("", 0);
5537             SAVEFREESV(pat);
5538             if (code_is_utf8)
5539                 SvUTF8_on(pat);
5540
5541             /* given a list of CONSTs and DO blocks in expr, append all
5542              * the CONSTs to pat, and record the start and end of each
5543              * code block in code_blocks[] (each DO{} op is followed by an
5544              * OP_CONST containing the corresponding literal '(?{...})
5545              * text)
5546              */
5547             for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
5548                 if (o->op_type == OP_CONST) {
5549                     sv_catsv(pat, cSVOPo_sv);
5550                     if (is_code) {
5551                         pRExC_state->code_blocks[i].end = SvCUR(pat)-1;
5552                         is_code = 0;
5553                     }
5554                 }
5555                 else if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5556                     assert(i+1 < pRExC_state->num_code_blocks);
5557                     pRExC_state->code_blocks[++i].start = SvCUR(pat);
5558                     pRExC_state->code_blocks[i].block = o;
5559                     pRExC_state->code_blocks[i].src_regex = NULL;
5560                     is_code = 1;
5561                 }
5562             }
5563         }
5564         else {
5565             assert(expr->op_type == OP_CONST);
5566             pat = cSVOPx_sv(expr);
5567         }
5568     }
5569
5570     exp = SvPV_nomg(pat, plen);
5571
5572     if (!eng->op_comp) {
5573         if ((SvUTF8(pat) && IN_BYTES)
5574                 || SvGMAGICAL(pat) || SvAMAGIC(pat))
5575         {
5576             /* make a temporary copy; either to convert to bytes,
5577              * or to avoid repeating get-magic / overloaded stringify */
5578             pat = newSVpvn_flags(exp, plen, SVs_TEMP |
5579                                         (IN_BYTES ? 0 : SvUTF8(pat)));
5580         }
5581         Safefree(pRExC_state->code_blocks);
5582         return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
5583     }
5584
5585     /* ignore the utf8ness if the pattern is 0 length */
5586     RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
5587     RExC_uni_semantics = 0;
5588     RExC_contains_locale = 0;
5589     pRExC_state->runtime_code_qr = NULL;
5590
5591     /****************** LONG JUMP TARGET HERE***********************/
5592     /* Longjmp back to here if have to switch in midstream to utf8 */
5593     if (! RExC_orig_utf8) {
5594         JMPENV_PUSH(jump_ret);
5595         used_setjump = TRUE;
5596     }
5597
5598     if (jump_ret == 0) {    /* First time through */
5599         xend = exp + plen;
5600
5601         DEBUG_COMPILE_r({
5602             SV *dsv= sv_newmortal();
5603             RE_PV_QUOTED_DECL(s, RExC_utf8,
5604                 dsv, exp, plen, 60);
5605             PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
5606                            PL_colors[4],PL_colors[5],s);
5607         });
5608     }
5609     else {  /* longjumped back */
5610         U8 *src, *dst;
5611         int n=0;
5612         STRLEN s = 0, d = 0;
5613         bool do_end = 0;
5614
5615         /* If the cause for the longjmp was other than changing to utf8, pop
5616          * our own setjmp, and longjmp to the correct handler */
5617         if (jump_ret != UTF8_LONGJMP) {
5618             JMPENV_POP;
5619             JMPENV_JUMP(jump_ret);
5620         }
5621
5622         GET_RE_DEBUG_FLAGS;
5623
5624         /* It's possible to write a regexp in ascii that represents Unicode
5625         codepoints outside of the byte range, such as via \x{100}. If we
5626         detect such a sequence we have to convert the entire pattern to utf8
5627         and then recompile, as our sizing calculation will have been based
5628         on 1 byte == 1 character, but we will need to use utf8 to encode
5629         at least some part of the pattern, and therefore must convert the whole
5630         thing.
5631         -- dmq */
5632         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
5633             "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
5634
5635         /* upgrade pattern to UTF8, and if there are code blocks,
5636          * recalculate the indices.
5637          * This is essentially an unrolled Perl_bytes_to_utf8() */
5638
5639         src = (U8*)SvPV_nomg(pat, plen);
5640         Newx(dst, plen * 2 + 1, U8);
5641
5642         while (s < plen) {
5643             const UV uv = NATIVE_TO_ASCII(src[s]);
5644             if (UNI_IS_INVARIANT(uv))
5645                 dst[d]   = (U8)UTF_TO_NATIVE(uv);
5646             else {
5647                 dst[d++] = (U8)UTF8_EIGHT_BIT_HI(uv);
5648                 dst[d]   = (U8)UTF8_EIGHT_BIT_LO(uv);
5649             }
5650             if (n < pRExC_state->num_code_blocks) {
5651                 if (!do_end && pRExC_state->code_blocks[n].start == s) {
5652                     pRExC_state->code_blocks[n].start = d;
5653                     assert(dst[d] == '(');
5654                     do_end = 1;
5655                 }
5656                 else if (do_end && pRExC_state->code_blocks[n].end == s) {
5657                     pRExC_state->code_blocks[n].end = d;
5658                     assert(dst[d] == ')');
5659                     do_end = 0;
5660                     n++;
5661                 }
5662             }
5663             s++;
5664             d++;
5665         }
5666         dst[d] = '\0';
5667         plen = d;
5668         exp = (char*) dst;
5669         xend = exp + plen;
5670         SAVEFREEPV(exp);
5671         RExC_orig_utf8 = RExC_utf8 = 1;
5672     }
5673
5674     /* return old regex if pattern hasn't changed */
5675
5676     if (   old_re
5677         && !recompile
5678         && !!RX_UTF8(old_re) == !!RExC_utf8
5679         && RX_PRECOMP(old_re)
5680         && RX_PRELEN(old_re) == plen
5681         && memEQ(RX_PRECOMP(old_re), exp, plen))
5682     {
5683         /* with runtime code, always recompile */
5684         runtime_code = S_has_runtime_code(aTHX_ pRExC_state, expr, pm_flags,
5685                                             exp, plen);
5686         if (!runtime_code) {
5687             ReREFCNT_inc(old_re);
5688             if (used_setjump) {
5689                 JMPENV_POP;
5690             }
5691             Safefree(pRExC_state->code_blocks);
5692             return old_re;
5693         }
5694     }
5695     else if ((pm_flags & PMf_USE_RE_EVAL)
5696                 /* this second condition covers the non-regex literal case,
5697                  * i.e.  $foo =~ '(?{})'. */
5698                 || ( !PL_reg_state.re_reparsing && IN_PERL_COMPILETIME
5699                     && (PL_hints & HINT_RE_EVAL))
5700     )
5701         runtime_code = S_has_runtime_code(aTHX_ pRExC_state, expr, pm_flags,
5702                             exp, plen);
5703
5704 #ifdef TRIE_STUDY_OPT
5705     restudied = 0;
5706 #endif
5707
5708     rx_flags = orig_rx_flags;
5709
5710     if (initial_charset == REGEX_LOCALE_CHARSET) {
5711         RExC_contains_locale = 1;
5712     }
5713     else if (RExC_utf8 && initial_charset == REGEX_DEPENDS_CHARSET) {
5714
5715         /* Set to use unicode semantics if the pattern is in utf8 and has the
5716          * 'depends' charset specified, as it means unicode when utf8  */
5717         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
5718     }
5719
5720     RExC_precomp = exp;
5721     RExC_flags = rx_flags;
5722     RExC_pm_flags = pm_flags;
5723
5724     if (runtime_code) {
5725         if (PL_tainting && PL_tainted)
5726             Perl_croak(aTHX_ "Eval-group in insecure regular expression");
5727
5728         if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
5729             /* whoops, we have a non-utf8 pattern, whilst run-time code
5730              * got compiled as utf8. Try again with a utf8 pattern */
5731              JMPENV_JUMP(UTF8_LONGJMP);
5732         }
5733     }
5734     assert(!pRExC_state->runtime_code_qr);
5735
5736     RExC_sawback = 0;
5737
5738     RExC_seen = 0;
5739     RExC_in_lookbehind = 0;
5740     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
5741     RExC_extralen = 0;
5742     RExC_override_recoding = 0;
5743
5744     /* First pass: determine size, legality. */
5745     RExC_parse = exp;
5746     RExC_start = exp;
5747     RExC_end = xend;
5748     RExC_naughty = 0;
5749     RExC_npar = 1;
5750     RExC_nestroot = 0;
5751     RExC_size = 0L;
5752     RExC_emit = &PL_regdummy;
5753     RExC_whilem_seen = 0;
5754     RExC_open_parens = NULL;
5755     RExC_close_parens = NULL;
5756     RExC_opend = NULL;
5757     RExC_paren_names = NULL;
5758 #ifdef DEBUGGING
5759     RExC_paren_name_list = NULL;
5760 #endif
5761     RExC_recurse = NULL;
5762     RExC_recurse_count = 0;
5763     pRExC_state->code_index = 0;
5764
5765 #if 0 /* REGC() is (currently) a NOP at the first pass.
5766        * Clever compilers notice this and complain. --jhi */
5767     REGC((U8)REG_MAGIC, (char*)RExC_emit);
5768 #endif
5769     DEBUG_PARSE_r(
5770         PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n");
5771         RExC_lastnum=0;
5772         RExC_lastparse=NULL;
5773     );
5774     if (reg(pRExC_state, 0, &flags,1) == NULL) {
5775         RExC_precomp = NULL;
5776         Safefree(pRExC_state->code_blocks);
5777         return(NULL);
5778     }
5779
5780     /* Here, finished first pass.  Get rid of any added setjmp */
5781     if (used_setjump) {
5782         JMPENV_POP;
5783     }
5784
5785     DEBUG_PARSE_r({
5786         PerlIO_printf(Perl_debug_log, 
5787             "Required size %"IVdf" nodes\n"
5788             "Starting second pass (creation)\n", 
5789             (IV)RExC_size);
5790         RExC_lastnum=0; 
5791         RExC_lastparse=NULL; 
5792     });
5793
5794     /* The first pass could have found things that force Unicode semantics */
5795     if ((RExC_utf8 || RExC_uni_semantics)
5796          && get_regex_charset(rx_flags) == REGEX_DEPENDS_CHARSET)
5797     {
5798         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
5799     }
5800
5801     /* Small enough for pointer-storage convention?
5802        If extralen==0, this means that we will not need long jumps. */
5803     if (RExC_size >= 0x10000L && RExC_extralen)
5804         RExC_size += RExC_extralen;
5805     else
5806         RExC_extralen = 0;
5807     if (RExC_whilem_seen > 15)
5808         RExC_whilem_seen = 15;
5809
5810     /* Allocate space and zero-initialize. Note, the two step process 
5811        of zeroing when in debug mode, thus anything assigned has to 
5812        happen after that */
5813     rx = (REGEXP*) newSV_type(SVt_REGEXP);
5814     r = (struct regexp*)SvANY(rx);
5815     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
5816          char, regexp_internal);
5817     if ( r == NULL || ri == NULL )
5818         FAIL("Regexp out of space");
5819 #ifdef DEBUGGING
5820     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
5821     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char);
5822 #else 
5823     /* bulk initialize base fields with 0. */
5824     Zero(ri, sizeof(regexp_internal), char);        
5825 #endif
5826
5827     /* non-zero initialization begins here */
5828     RXi_SET( r, ri );
5829     r->engine= eng;
5830     r->extflags = rx_flags;
5831     if (pm_flags & PMf_IS_QR) {
5832         ri->code_blocks = pRExC_state->code_blocks;
5833         ri->num_code_blocks = pRExC_state->num_code_blocks;
5834     }
5835     else
5836         SAVEFREEPV(pRExC_state->code_blocks);
5837
5838     {
5839         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
5840         bool has_charset = (get_regex_charset(r->extflags) != REGEX_DEPENDS_CHARSET);
5841
5842         /* The caret is output if there are any defaults: if not all the STD
5843          * flags are set, or if no character set specifier is needed */
5844         bool has_default =
5845                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
5846                     || ! has_charset);
5847         bool has_runon = ((RExC_seen & REG_SEEN_RUN_ON_COMMENT)==REG_SEEN_RUN_ON_COMMENT);
5848         U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD)
5849                             >> RXf_PMf_STD_PMMOD_SHIFT);
5850         const char *fptr = STD_PAT_MODS;        /*"msix"*/
5851         char *p;
5852         /* Allocate for the worst case, which is all the std flags are turned
5853          * on.  If more precision is desired, we could do a population count of
5854          * the flags set.  This could be done with a small lookup table, or by
5855          * shifting, masking and adding, or even, when available, assembly
5856          * language for a machine-language population count.
5857          * We never output a minus, as all those are defaults, so are
5858          * covered by the caret */
5859         const STRLEN wraplen = plen + has_p + has_runon
5860             + has_default       /* If needs a caret */
5861
5862                 /* If needs a character set specifier */
5863             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
5864             + (sizeof(STD_PAT_MODS) - 1)
5865             + (sizeof("(?:)") - 1);
5866
5867         p = sv_grow(MUTABLE_SV(rx), wraplen + 1); /* +1 for the ending NUL */
5868         SvPOK_on(rx);
5869         if (RExC_utf8)
5870             SvFLAGS(rx) |= SVf_UTF8;
5871         *p++='('; *p++='?';
5872
5873         /* If a default, cover it using the caret */
5874         if (has_default) {
5875             *p++= DEFAULT_PAT_MOD;
5876         }
5877         if (has_charset) {
5878             STRLEN len;
5879             const char* const name = get_regex_charset_name(r->extflags, &len);
5880             Copy(name, p, len, char);
5881             p += len;
5882         }
5883         if (has_p)
5884             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
5885         {
5886             char ch;
5887             while((ch = *fptr++)) {
5888                 if(reganch & 1)
5889                     *p++ = ch;
5890                 reganch >>= 1;
5891             }
5892         }
5893
5894         *p++ = ':';
5895         Copy(RExC_precomp, p, plen, char);
5896         assert ((RX_WRAPPED(rx) - p) < 16);
5897         r->pre_prefix = p - RX_WRAPPED(rx);
5898         p += plen;
5899         if (has_runon)
5900             *p++ = '\n';
5901         *p++ = ')';
5902         *p = 0;
5903         SvCUR_set(rx, p - SvPVX_const(rx));
5904     }
5905
5906     r->intflags = 0;
5907     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
5908     
5909     if (RExC_seen & REG_SEEN_RECURSE) {
5910         Newxz(RExC_open_parens, RExC_npar,regnode *);
5911         SAVEFREEPV(RExC_open_parens);
5912         Newxz(RExC_close_parens,RExC_npar,regnode *);
5913         SAVEFREEPV(RExC_close_parens);
5914     }
5915
5916     /* Useful during FAIL. */
5917 #ifdef RE_TRACK_PATTERN_OFFSETS
5918     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
5919     DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
5920                           "%s %"UVuf" bytes for offset annotations.\n",
5921                           ri->u.offsets ? "Got" : "Couldn't get",
5922                           (UV)((2*RExC_size+1) * sizeof(U32))));
5923 #endif
5924     SetProgLen(ri,RExC_size);
5925     RExC_rx_sv = rx;
5926     RExC_rx = r;
5927     RExC_rxi = ri;
5928
5929     /* Second pass: emit code. */
5930     RExC_flags = rx_flags;      /* don't let top level (?i) bleed */
5931     RExC_pm_flags = pm_flags;
5932     RExC_parse = exp;
5933     RExC_end = xend;
5934     RExC_naughty = 0;
5935     RExC_npar = 1;
5936     RExC_emit_start = ri->program;
5937     RExC_emit = ri->program;
5938     RExC_emit_bound = ri->program + RExC_size + 1;
5939     pRExC_state->code_index = 0;
5940
5941     REGC((U8)REG_MAGIC, (char*) RExC_emit++);
5942     if (reg(pRExC_state, 0, &flags,1) == NULL) {
5943         ReREFCNT_dec(rx);   
5944         return(NULL);
5945     }
5946     /* XXXX To minimize changes to RE engine we always allocate
5947        3-units-long substrs field. */
5948     Newx(r->substrs, 1, struct reg_substr_data);
5949     if (RExC_recurse_count) {
5950         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
5951         SAVEFREEPV(RExC_recurse);
5952     }
5953
5954 reStudy:
5955     r->minlen = minlen = sawlookahead = sawplus = sawopen = 0;
5956     Zero(r->substrs, 1, struct reg_substr_data);
5957
5958 #ifdef TRIE_STUDY_OPT
5959     if (!restudied) {
5960         StructCopy(&zero_scan_data, &data, scan_data_t);
5961         copyRExC_state = RExC_state;
5962     } else {
5963         U32 seen=RExC_seen;
5964         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
5965         
5966         RExC_state = copyRExC_state;
5967         if (seen & REG_TOP_LEVEL_BRANCHES) 
5968             RExC_seen |= REG_TOP_LEVEL_BRANCHES;
5969         else
5970             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES;
5971         if (data.last_found) {
5972             SvREFCNT_dec(data.longest_fixed);
5973             SvREFCNT_dec(data.longest_float);
5974             SvREFCNT_dec(data.last_found);
5975         }
5976         StructCopy(&zero_scan_data, &data, scan_data_t);
5977     }
5978 #else
5979     StructCopy(&zero_scan_data, &data, scan_data_t);
5980 #endif    
5981
5982     /* Dig out information for optimizations. */
5983     r->extflags = RExC_flags; /* was pm_op */
5984     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
5985  
5986     if (UTF)
5987         SvUTF8_on(rx);  /* Unicode in it? */
5988     ri->regstclass = NULL;
5989     if (RExC_naughty >= 10)     /* Probably an expensive pattern. */
5990         r->intflags |= PREGf_NAUGHTY;
5991     scan = ri->program + 1;             /* First BRANCH. */
5992
5993     /* testing for BRANCH here tells us whether there is "must appear"
5994        data in the pattern. If there is then we can use it for optimisations */
5995     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /*  Only one top-level choice. */
5996         I32 fake;
5997         STRLEN longest_float_length, longest_fixed_length;
5998         struct regnode_charclass_class ch_class; /* pointed to by data */
5999         int stclass_flag;
6000         I32 last_close = 0; /* pointed to by data */
6001         regnode *first= scan;
6002         regnode *first_next= regnext(first);
6003         /*
6004          * Skip introductions and multiplicators >= 1
6005          * so that we can extract the 'meat' of the pattern that must 
6006          * match in the large if() sequence following.
6007          * NOTE that EXACT is NOT covered here, as it is normally
6008          * picked up by the optimiser separately. 
6009          *
6010          * This is unfortunate as the optimiser isnt handling lookahead
6011          * properly currently.
6012          *
6013          */
6014         while ((OP(first) == OPEN && (sawopen = 1)) ||
6015                /* An OR of *one* alternative - should not happen now. */
6016             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
6017             /* for now we can't handle lookbehind IFMATCH*/
6018             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
6019             (OP(first) == PLUS) ||
6020             (OP(first) == MINMOD) ||
6021                /* An {n,m} with n>0 */
6022             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
6023             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
6024         {
6025                 /* 
6026                  * the only op that could be a regnode is PLUS, all the rest
6027                  * will be regnode_1 or regnode_2.
6028                  *
6029                  */
6030                 if (OP(first) == PLUS)
6031                     sawplus = 1;
6032                 else
6033                     first += regarglen[OP(first)];
6034
6035                 first = NEXTOPER(first);
6036                 first_next= regnext(first);
6037         }
6038
6039         /* Starting-point info. */
6040       again:
6041         DEBUG_PEEP("first:",first,0);
6042         /* Ignore EXACT as we deal with it later. */
6043         if (PL_regkind[OP(first)] == EXACT) {
6044             if (OP(first) == EXACT)
6045                 NOOP;   /* Empty, get anchored substr later. */
6046             else
6047                 ri->regstclass = first;
6048         }
6049 #ifdef TRIE_STCLASS
6050         else if (PL_regkind[OP(first)] == TRIE &&
6051                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0) 
6052         {
6053             regnode *trie_op;
6054             /* this can happen only on restudy */
6055             if ( OP(first) == TRIE ) {
6056                 struct regnode_1 *trieop = (struct regnode_1 *)
6057                     PerlMemShared_calloc(1, sizeof(struct regnode_1));
6058                 StructCopy(first,trieop,struct regnode_1);
6059                 trie_op=(regnode *)trieop;
6060             } else {
6061                 struct regnode_charclass *trieop = (struct regnode_charclass *)
6062                     PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
6063                 StructCopy(first,trieop,struct regnode_charclass);
6064                 trie_op=(regnode *)trieop;
6065             }
6066             OP(trie_op)+=2;
6067             make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
6068             ri->regstclass = trie_op;
6069         }
6070 #endif
6071         else if (REGNODE_SIMPLE(OP(first)))
6072             ri->regstclass = first;
6073         else if (PL_regkind[OP(first)] == BOUND ||
6074                  PL_regkind[OP(first)] == NBOUND)
6075             ri->regstclass = first;
6076         else if (PL_regkind[OP(first)] == BOL) {
6077             r->extflags |= (OP(first) == MBOL
6078                            ? RXf_ANCH_MBOL
6079                            : (OP(first) == SBOL
6080                               ? RXf_ANCH_SBOL
6081                               : RXf_ANCH_BOL));
6082             first = NEXTOPER(first);
6083             goto again;
6084         }
6085         else if (OP(first) == GPOS) {
6086             r->extflags |= RXf_ANCH_GPOS;
6087             first = NEXTOPER(first);
6088             goto again;
6089         }
6090         else if ((!sawopen || !RExC_sawback) &&
6091             (OP(first) == STAR &&
6092             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
6093             !(r->extflags & RXf_ANCH) && !pRExC_state->num_code_blocks)
6094         {
6095             /* turn .* into ^.* with an implied $*=1 */
6096             const int type =
6097                 (OP(NEXTOPER(first)) == REG_ANY)
6098                     ? RXf_ANCH_MBOL
6099                     : RXf_ANCH_SBOL;
6100             r->extflags |= type;
6101             r->intflags |= PREGf_IMPLICIT;
6102             first = NEXTOPER(first);
6103             goto again;
6104         }
6105         if (sawplus && !sawlookahead && (!sawopen || !RExC_sawback)
6106             && !pRExC_state->num_code_blocks) /* May examine pos and $& */
6107             /* x+ must match at the 1st pos of run of x's */
6108             r->intflags |= PREGf_SKIP;
6109
6110         /* Scan is after the zeroth branch, first is atomic matcher. */
6111 #ifdef TRIE_STUDY_OPT
6112         DEBUG_PARSE_r(
6113             if (!restudied)
6114                 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
6115                               (IV)(first - scan + 1))
6116         );
6117 #else
6118         DEBUG_PARSE_r(
6119             PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
6120                 (IV)(first - scan + 1))
6121         );
6122 #endif
6123
6124
6125         /*
6126         * If there's something expensive in the r.e., find the
6127         * longest literal string that must appear and make it the
6128         * regmust.  Resolve ties in favor of later strings, since
6129         * the regstart check works with the beginning of the r.e.
6130         * and avoiding duplication strengthens checking.  Not a
6131         * strong reason, but sufficient in the absence of others.
6132         * [Now we resolve ties in favor of the earlier string if
6133         * it happens that c_offset_min has been invalidated, since the
6134         * earlier string may buy us something the later one won't.]
6135         */
6136
6137         data.longest_fixed = newSVpvs("");
6138         data.longest_float = newSVpvs("");
6139         data.last_found = newSVpvs("");
6140         data.longest = &(data.longest_fixed);
6141         first = scan;
6142         if (!ri->regstclass) {
6143             cl_init(pRExC_state, &ch_class);
6144             data.start_class = &ch_class;
6145             stclass_flag = SCF_DO_STCLASS_AND;
6146         } else                          /* XXXX Check for BOUND? */
6147             stclass_flag = 0;
6148         data.last_closep = &last_close;
6149         
6150         minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */
6151             &data, -1, NULL, NULL,
6152             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
6153
6154
6155         CHECK_RESTUDY_GOTO;
6156
6157
6158         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
6159              && data.last_start_min == 0 && data.last_end > 0
6160              && !RExC_seen_zerolen
6161              && !(RExC_seen & REG_SEEN_VERBARG)
6162              && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
6163             r->extflags |= RXf_CHECK_ALL;
6164         scan_commit(pRExC_state, &data,&minlen,0);
6165         SvREFCNT_dec(data.last_found);
6166
6167         /* Note that code very similar to this but for anchored string 
6168            follows immediately below, changes may need to be made to both. 
6169            Be careful. 
6170          */
6171         longest_float_length = CHR_SVLEN(data.longest_float);
6172         if (longest_float_length
6173             || (data.flags & SF_FL_BEFORE_EOL
6174                 && (!(data.flags & SF_FL_BEFORE_MEOL)
6175                     || (RExC_flags & RXf_PMf_MULTILINE)))) 
6176         {
6177             I32 t,ml;
6178
6179             /* See comments for join_exact for why REG_SEEN_EXACTF_SHARP_S */
6180             if ((RExC_seen & REG_SEEN_EXACTF_SHARP_S)
6181                 || (SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
6182                     && data.offset_fixed == data.offset_float_min
6183                     && SvCUR(data.longest_fixed) == SvCUR(data.longest_float)))
6184                     goto remove_float;          /* As in (a)+. */
6185
6186             /* copy the information about the longest float from the reg_scan_data
6187                over to the program. */
6188             if (SvUTF8(data.longest_float)) {
6189                 r->float_utf8 = data.longest_float;
6190                 r->float_substr = NULL;
6191             } else {
6192                 r->float_substr = data.longest_float;
6193                 r->float_utf8 = NULL;
6194             }
6195             /* float_end_shift is how many chars that must be matched that 
6196                follow this item. We calculate it ahead of time as once the
6197                lookbehind offset is added in we lose the ability to correctly
6198                calculate it.*/
6199             ml = data.minlen_float ? *(data.minlen_float) 
6200                                    : (I32)longest_float_length;
6201             r->float_end_shift = ml - data.offset_float_min
6202                 - longest_float_length + (SvTAIL(data.longest_float) != 0)
6203                 + data.lookbehind_float;
6204             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
6205             r->float_max_offset = data.offset_float_max;
6206             if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
6207                 r->float_max_offset -= data.lookbehind_float;
6208             
6209             t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
6210                        && (!(data.flags & SF_FL_BEFORE_MEOL)
6211                            || (RExC_flags & RXf_PMf_MULTILINE)));
6212             fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0);
6213         }
6214         else {
6215           remove_float:
6216             r->float_substr = r->float_utf8 = NULL;
6217             SvREFCNT_dec(data.longest_float);
6218             longest_float_length = 0;
6219         }
6220
6221         /* Note that code very similar to this but for floating string 
6222            is immediately above, changes may need to be made to both. 
6223            Be careful. 
6224          */
6225         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
6226
6227         /* See comments for join_exact for why REG_SEEN_EXACTF_SHARP_S */
6228         if (! (RExC_seen & REG_SEEN_EXACTF_SHARP_S)
6229             && (longest_fixed_length
6230                 || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
6231                     && (!(data.flags & SF_FIX_BEFORE_MEOL)
6232                         || (RExC_flags & RXf_PMf_MULTILINE)))) )
6233         {
6234             I32 t,ml;
6235
6236             /* copy the information about the longest fixed 
6237                from the reg_scan_data over to the program. */
6238             if (SvUTF8(data.longest_fixed)) {
6239                 r->anchored_utf8 = data.longest_fixed;
6240                 r->anchored_substr = NULL;
6241             } else {
6242                 r->anchored_substr = data.longest_fixed;
6243                 r->anchored_utf8 = NULL;
6244             }
6245             /* fixed_end_shift is how many chars that must be matched that 
6246                follow this item. We calculate it ahead of time as once the
6247                lookbehind offset is added in we lose the ability to correctly
6248                calculate it.*/
6249             ml = data.minlen_fixed ? *(data.minlen_fixed) 
6250                                    : (I32)longest_fixed_length;
6251             r->anchored_end_shift = ml - data.offset_fixed
6252                 - longest_fixed_length + (SvTAIL(data.longest_fixed) != 0)
6253                 + data.lookbehind_fixed;
6254             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
6255
6256             t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
6257                  && (!(data.flags & SF_FIX_BEFORE_MEOL)
6258                      || (RExC_flags & RXf_PMf_MULTILINE)));
6259             fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0);
6260         }
6261         else {
6262             r->anchored_substr = r->anchored_utf8 = NULL;
6263             SvREFCNT_dec(data.longest_fixed);
6264             longest_fixed_length = 0;
6265         }
6266         if (ri->regstclass
6267             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
6268             ri->regstclass = NULL;
6269
6270         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
6271             && stclass_flag
6272             && !(data.start_class->flags & ANYOF_EOS)
6273             && !cl_is_anything(data.start_class))
6274         {
6275             const U32 n = add_data(pRExC_state, 1, "f");
6276             data.start_class->flags |= ANYOF_IS_SYNTHETIC;
6277
6278             Newx(RExC_rxi->data->data[n], 1,
6279                 struct regnode_charclass_class);
6280             StructCopy(data.start_class,
6281                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
6282                        struct regnode_charclass_class);
6283             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
6284             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
6285             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
6286                       regprop(r, sv, (regnode*)data.start_class);
6287                       PerlIO_printf(Perl_debug_log,
6288                                     "synthetic stclass \"%s\".\n",
6289                                     SvPVX_const(sv));});
6290         }
6291
6292         /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
6293         if (longest_fixed_length > longest_float_length) {
6294             r->check_end_shift = r->anchored_end_shift;
6295             r->check_substr = r->anchored_substr;
6296             r->check_utf8 = r->anchored_utf8;
6297             r->check_offset_min = r->check_offset_max = r->anchored_offset;
6298             if (r->extflags & RXf_ANCH_SINGLE)
6299                 r->extflags |= RXf_NOSCAN;
6300         }
6301         else {
6302             r->check_end_shift = r->float_end_shift;
6303             r->check_substr = r->float_substr;
6304             r->check_utf8 = r->float_utf8;
6305             r->check_offset_min = r->float_min_offset;
6306             r->check_offset_max = r->float_max_offset;
6307         }
6308         /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
6309            This should be changed ASAP!  */
6310         if ((r->check_substr || r->check_utf8) && !(r->extflags & RXf_ANCH_GPOS)) {
6311             r->extflags |= RXf_USE_INTUIT;
6312             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
6313                 r->extflags |= RXf_INTUIT_TAIL;
6314         }
6315         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
6316         if ( (STRLEN)minlen < longest_float_length )
6317             minlen= longest_float_length;
6318         if ( (STRLEN)minlen < longest_fixed_length )
6319             minlen= longest_fixed_length;     
6320         */
6321     }
6322     else {
6323         /* Several toplevels. Best we can is to set minlen. */
6324         I32 fake;
6325         struct regnode_charclass_class ch_class;
6326         I32 last_close = 0;
6327
6328         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
6329
6330         scan = ri->program + 1;
6331         cl_init(pRExC_state, &ch_class);
6332         data.start_class = &ch_class;
6333         data.last_closep = &last_close;
6334
6335         
6336         minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
6337             &data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
6338         
6339         CHECK_RESTUDY_GOTO;
6340
6341         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
6342                 = r->float_substr = r->float_utf8 = NULL;
6343
6344         if (!(data.start_class->flags & ANYOF_EOS)
6345             && !cl_is_anything(data.start_class))
6346         {
6347             const U32 n = add_data(pRExC_state, 1, "f");
6348             data.start_class->flags |= ANYOF_IS_SYNTHETIC;
6349
6350             Newx(RExC_rxi->data->data[n], 1,
6351                 struct regnode_charclass_class);
6352             StructCopy(data.start_class,
6353                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
6354                        struct regnode_charclass_class);
6355             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
6356             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
6357             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
6358                       regprop(r, sv, (regnode*)data.start_class);
6359                       PerlIO_printf(Perl_debug_log,
6360                                     "synthetic stclass \"%s\".\n",
6361                                     SvPVX_const(sv));});
6362         }
6363     }
6364
6365     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
6366        the "real" pattern. */
6367     DEBUG_OPTIMISE_r({
6368         PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n",
6369                       (IV)minlen, (IV)r->minlen);
6370     });
6371     r->minlenret = minlen;
6372     if (r->minlen < minlen) 
6373         r->minlen = minlen;
6374     
6375     if (RExC_seen & REG_SEEN_GPOS)
6376         r->extflags |= RXf_GPOS_SEEN;
6377     if (RExC_seen & REG_SEEN_LOOKBEHIND)
6378         r->extflags |= RXf_LOOKBEHIND_SEEN;
6379     if (pRExC_state->num_code_blocks)
6380         r->extflags |= RXf_EVAL_SEEN;
6381     if (RExC_seen & REG_SEEN_CANY)
6382         r->extflags |= RXf_CANY_SEEN;
6383     if (RExC_seen & REG_SEEN_VERBARG)
6384         r->intflags |= PREGf_VERBARG_SEEN;
6385     if (RExC_seen & REG_SEEN_CUTGROUP)
6386         r->intflags |= PREGf_CUTGROUP_SEEN;
6387     if (pm_flags & PMf_USE_RE_EVAL)
6388         r->intflags |= PREGf_USE_RE_EVAL;
6389     if (RExC_paren_names)
6390         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
6391     else
6392         RXp_PAREN_NAMES(r) = NULL;
6393
6394 #ifdef STUPID_PATTERN_CHECKS            
6395     if (RX_PRELEN(rx) == 0)
6396         r->extflags |= RXf_NULL;
6397     if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
6398         /* XXX: this should happen BEFORE we compile */
6399         r->extflags |= (RXf_SKIPWHITE|RXf_WHITE); 
6400     else if (RX_PRELEN(rx) == 3 && memEQ("\\s+", RX_PRECOMP(rx), 3))
6401         r->extflags |= RXf_WHITE;
6402     else if (RX_PRELEN(rx) == 1 && RXp_PRECOMP(rx)[0] == '^')
6403         r->extflags |= RXf_START_ONLY;
6404 #else
6405     if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
6406             /* XXX: this should happen BEFORE we compile */
6407             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE); 
6408     else {
6409         regnode *first = ri->program + 1;
6410         U8 fop = OP(first);
6411
6412         if (PL_regkind[fop] == NOTHING && OP(NEXTOPER(first)) == END)
6413             r->extflags |= RXf_NULL;
6414         else if (PL_regkind[fop] == BOL && OP(NEXTOPER(first)) == END)
6415             r->extflags |= RXf_START_ONLY;
6416         else if (fop == PLUS && OP(NEXTOPER(first)) == SPACE
6417                              && OP(regnext(first)) == END)
6418             r->extflags |= RXf_WHITE;    
6419     }
6420 #endif
6421 #ifdef DEBUGGING
6422     if (RExC_paren_names) {
6423         ri->name_list_idx = add_data( pRExC_state, 1, "a" );
6424         ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list);
6425     } else
6426 #endif
6427         ri->name_list_idx = 0;
6428
6429     if (RExC_recurse_count) {
6430         for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
6431             const regnode *scan = RExC_recurse[RExC_recurse_count-1];
6432             ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
6433         }
6434     }
6435     Newxz(r->offs, RExC_npar, regexp_paren_pair);
6436     /* assume we don't need to swap parens around before we match */
6437
6438     DEBUG_DUMP_r({
6439         PerlIO_printf(Perl_debug_log,"Final program:\n");
6440         regdump(r);
6441     });
6442 #ifdef RE_TRACK_PATTERN_OFFSETS
6443     DEBUG_OFFSETS_r(if (ri->u.offsets) {
6444         const U32 len = ri->u.offsets[0];
6445         U32 i;
6446         GET_RE_DEBUG_FLAGS_DECL;
6447         PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
6448         for (i = 1; i <= len; i++) {
6449             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
6450                 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
6451                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
6452             }
6453         PerlIO_printf(Perl_debug_log, "\n");
6454     });
6455 #endif
6456     return rx;
6457 }
6458
6459
6460 SV*
6461 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
6462                     const U32 flags)
6463 {
6464     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
6465
6466     PERL_UNUSED_ARG(value);
6467
6468     if (flags & RXapif_FETCH) {
6469         return reg_named_buff_fetch(rx, key, flags);
6470     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
6471         Perl_croak_no_modify(aTHX);
6472         return NULL;
6473     } else if (flags & RXapif_EXISTS) {
6474         return reg_named_buff_exists(rx, key, flags)
6475             ? &PL_sv_yes
6476             : &PL_sv_no;
6477     } else if (flags & RXapif_REGNAMES) {
6478         return reg_named_buff_all(rx, flags);
6479     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
6480         return reg_named_buff_scalar(rx, flags);
6481     } else {
6482         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
6483         return NULL;
6484     }
6485 }
6486
6487 SV*
6488 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
6489                          const U32 flags)
6490 {
6491     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
6492     PERL_UNUSED_ARG(lastkey);
6493
6494     if (flags & RXapif_FIRSTKEY)
6495         return reg_named_buff_firstkey(rx, flags);
6496     else if (flags & RXapif_NEXTKEY)
6497         return reg_named_buff_nextkey(rx, flags);
6498     else {
6499         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter", (int)flags);
6500         return NULL;
6501     }
6502 }
6503
6504 SV*
6505 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
6506                           const U32 flags)
6507 {
6508     AV *retarray = NULL;
6509     SV *ret;
6510     struct regexp *const rx = (struct regexp *)SvANY(r);
6511
6512     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
6513
6514     if (flags & RXapif_ALL)
6515         retarray=newAV();
6516
6517     if (rx && RXp_PAREN_NAMES(rx)) {
6518         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
6519         if (he_str) {
6520             IV i;
6521             SV* sv_dat=HeVAL(he_str);
6522             I32 *nums=(I32*)SvPVX(sv_dat);
6523             for ( i=0; i<SvIVX(sv_dat); i++ ) {
6524                 if ((I32)(rx->nparens) >= nums[i]
6525                     && rx->offs[nums[i]].start != -1
6526                     && rx->offs[nums[i]].end != -1)
6527                 {
6528                     ret = newSVpvs("");
6529                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
6530                     if (!retarray)
6531                         return ret;
6532                 } else {
6533                     if (retarray)
6534                         ret = newSVsv(&PL_sv_undef);
6535                 }
6536                 if (retarray)
6537                     av_push(retarray, ret);
6538             }
6539             if (retarray)
6540                 return newRV_noinc(MUTABLE_SV(retarray));
6541         }
6542     }
6543     return NULL;
6544 }
6545
6546 bool
6547 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
6548                            const U32 flags)
6549 {
6550     struct regexp *const rx = (struct regexp *)SvANY(r);
6551
6552     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
6553
6554     if (rx && RXp_PAREN_NAMES(rx)) {
6555         if (flags & RXapif_ALL) {
6556             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
6557         } else {
6558             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
6559             if (sv) {
6560                 SvREFCNT_dec(sv);
6561                 return TRUE;
6562             } else {
6563                 return FALSE;
6564             }
6565         }
6566     } else {
6567         return FALSE;
6568     }
6569 }
6570
6571 SV*
6572 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
6573 {
6574     struct regexp *const rx = (struct regexp *)SvANY(r);
6575
6576     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
6577
6578     if ( rx && RXp_PAREN_NAMES(rx) ) {
6579         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
6580
6581         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
6582     } else {
6583         return FALSE;
6584     }
6585 }
6586
6587 SV*
6588 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
6589 {
6590     struct regexp *const rx = (struct regexp *)SvANY(r);
6591     GET_RE_DEBUG_FLAGS_DECL;
6592
6593     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
6594
6595     if (rx && RXp_PAREN_NAMES(rx)) {
6596         HV *hv = RXp_PAREN_NAMES(rx);
6597         HE *temphe;
6598         while ( (temphe = hv_iternext_flags(hv,0)) ) {
6599             IV i;
6600             IV parno = 0;
6601             SV* sv_dat = HeVAL(temphe);
6602             I32 *nums = (I32*)SvPVX(sv_dat);
6603             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
6604                 if ((I32)(rx->lastparen) >= nums[i] &&
6605                     rx->offs[nums[i]].start != -1 &&
6606                     rx->offs[nums[i]].end != -1)
6607                 {
6608                     parno = nums[i];
6609                     break;
6610                 }
6611             }
6612             if (parno || flags & RXapif_ALL) {
6613                 return newSVhek(HeKEY_hek(temphe));
6614             }
6615         }
6616     }
6617     return NULL;
6618 }
6619
6620 SV*
6621 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
6622 {
6623     SV *ret;
6624     AV *av;
6625     I32 length;
6626     struct regexp *const rx = (struct regexp *)SvANY(r);
6627
6628     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
6629
6630     if (rx && RXp_PAREN_NAMES(rx)) {
6631         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
6632             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
6633         } else if (flags & RXapif_ONE) {
6634             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
6635             av = MUTABLE_AV(SvRV(ret));
6636             length = av_len(av);
6637             SvREFCNT_dec(ret);
6638             return newSViv(length + 1);
6639         } else {
6640             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", (int)flags);
6641             return NULL;
6642         }
6643     }
6644     return &PL_sv_undef;
6645 }
6646
6647 SV*
6648 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
6649 {
6650     struct regexp *const rx = (struct regexp *)SvANY(r);
6651     AV *av = newAV();
6652
6653     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
6654
6655     if (rx && RXp_PAREN_NAMES(rx)) {
6656         HV *hv= RXp_PAREN_NAMES(rx);
6657         HE *temphe;
6658         (void)hv_iterinit(hv);
6659         while ( (temphe = hv_iternext_flags(hv,0)) ) {
6660             IV i;
6661             IV parno = 0;
6662             SV* sv_dat = HeVAL(temphe);
6663             I32 *nums = (I32*)SvPVX(sv_dat);
6664             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
6665                 if ((I32)(rx->lastparen) >= nums[i] &&
6666                     rx->offs[nums[i]].start != -1 &&
6667                     rx->offs[nums[i]].end != -1)
6668                 {
6669                     parno = nums[i];
6670                     break;
6671                 }
6672             }
6673             if (parno || flags & RXapif_ALL) {
6674                 av_push(av, newSVhek(HeKEY_hek(temphe)));
6675             }
6676         }
6677     }
6678
6679     return newRV_noinc(MUTABLE_SV(av));
6680 }
6681
6682 void
6683 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
6684                              SV * const sv)
6685 {
6686     struct regexp *const rx = (struct regexp *)SvANY(r);
6687     char *s = NULL;
6688     I32 i = 0;
6689     I32 s1, t1;
6690
6691     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
6692         
6693     if (!rx->subbeg) {
6694         sv_setsv(sv,&PL_sv_undef);
6695         return;
6696     } 
6697     else               
6698     if (paren == RX_BUFF_IDX_PREMATCH && rx->offs[0].start != -1) {
6699         /* $` */
6700         i = rx->offs[0].start;
6701         s = rx->subbeg;
6702     }
6703     else 
6704     if (paren == RX_BUFF_IDX_POSTMATCH && rx->offs[0].end != -1) {
6705         /* $' */
6706         s = rx->subbeg + rx->offs[0].end;
6707         i = rx->sublen - rx->offs[0].end;
6708     } 
6709     else
6710     if ( 0 <= paren && paren <= (I32)rx->nparens &&
6711         (s1 = rx->offs[paren].start) != -1 &&
6712         (t1 = rx->offs[paren].end) != -1)
6713     {
6714         /* $& $1 ... */
6715         i = t1 - s1;
6716         s = rx->subbeg + s1;
6717     } else {
6718         sv_setsv(sv,&PL_sv_undef);
6719         return;
6720     }          
6721     assert(rx->sublen >= (s - rx->subbeg) + i );
6722     if (i >= 0) {
6723         const int oldtainted = PL_tainted;
6724         TAINT_NOT;
6725         sv_setpvn(sv, s, i);
6726         PL_tainted = oldtainted;
6727         if ( (rx->extflags & RXf_CANY_SEEN)
6728             ? (RXp_MATCH_UTF8(rx)
6729                         && (!i || is_utf8_string((U8*)s, i)))
6730             : (RXp_MATCH_UTF8(rx)) )
6731         {
6732             SvUTF8_on(sv);
6733         }
6734         else
6735             SvUTF8_off(sv);
6736         if (PL_tainting) {
6737             if (RXp_MATCH_TAINTED(rx)) {
6738                 if (SvTYPE(sv) >= SVt_PVMG) {
6739                     MAGIC* const mg = SvMAGIC(sv);
6740                     MAGIC* mgt;
6741                     PL_tainted = 1;
6742                     SvMAGIC_set(sv, mg->mg_moremagic);
6743                     SvTAINT(sv);
6744                     if ((mgt = SvMAGIC(sv))) {
6745                         mg->mg_moremagic = mgt;
6746                         SvMAGIC_set(sv, mg);
6747                     }
6748                 } else {
6749                     PL_tainted = 1;
6750                     SvTAINT(sv);
6751                 }
6752             } else 
6753                 SvTAINTED_off(sv);
6754         }
6755     } else {
6756         sv_setsv(sv,&PL_sv_undef);
6757         return;
6758     }
6759 }
6760
6761 void
6762 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
6763                                                          SV const * const value)
6764 {
6765     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
6766
6767     PERL_UNUSED_ARG(rx);
6768     PERL_UNUSED_ARG(paren);
6769     PERL_UNUSED_ARG(value);
6770
6771     if (!PL_localizing)
6772         Perl_croak_no_modify(aTHX);
6773 }
6774
6775 I32
6776 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
6777                               const I32 paren)
6778 {
6779     struct regexp *const rx = (struct regexp *)SvANY(r);
6780     I32 i;
6781     I32 s1, t1;
6782
6783     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
6784
6785     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
6786         switch (paren) {
6787       /* $` / ${^PREMATCH} */
6788       case RX_BUFF_IDX_PREMATCH:
6789         if (rx->offs[0].start != -1) {
6790                         i = rx->offs[0].start;
6791                         if (i > 0) {
6792                                 s1 = 0;
6793                                 t1 = i;
6794                                 goto getlen;
6795                         }
6796             }
6797         return 0;
6798       /* $' / ${^POSTMATCH} */
6799       case RX_BUFF_IDX_POSTMATCH:
6800             if (rx->offs[0].end != -1) {
6801                         i = rx->sublen - rx->offs[0].end;
6802                         if (i > 0) {
6803                                 s1 = rx->offs[0].end;
6804                                 t1 = rx->sublen;
6805                                 goto getlen;
6806                         }
6807             }
6808         return 0;
6809       /* $& / ${^MATCH}, $1, $2, ... */
6810       default:
6811             if (paren <= (I32)rx->nparens &&
6812             (s1 = rx->offs[paren].start) != -1 &&
6813             (t1 = rx->offs[paren].end) != -1)
6814             {
6815             i = t1 - s1;
6816             goto getlen;
6817         } else {
6818             if (ckWARN(WARN_UNINITIALIZED))
6819                 report_uninit((const SV *)sv);
6820             return 0;
6821         }
6822     }
6823   getlen:
6824     if (i > 0 && RXp_MATCH_UTF8(rx)) {
6825         const char * const s = rx->subbeg + s1;
6826         const U8 *ep;
6827         STRLEN el;
6828
6829         i = t1 - s1;
6830         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
6831                         i = el;
6832     }
6833     return i;
6834 }
6835
6836 SV*
6837 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
6838 {
6839     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
6840         PERL_UNUSED_ARG(rx);
6841         if (0)
6842             return NULL;
6843         else
6844             return newSVpvs("Regexp");
6845 }
6846
6847 /* Scans the name of a named buffer from the pattern.
6848  * If flags is REG_RSN_RETURN_NULL returns null.
6849  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
6850  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
6851  * to the parsed name as looked up in the RExC_paren_names hash.
6852  * If there is an error throws a vFAIL().. type exception.
6853  */
6854
6855 #define REG_RSN_RETURN_NULL    0
6856 #define REG_RSN_RETURN_NAME    1
6857 #define REG_RSN_RETURN_DATA    2
6858
6859 STATIC SV*
6860 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
6861 {
6862     char *name_start = RExC_parse;
6863
6864     PERL_ARGS_ASSERT_REG_SCAN_NAME;
6865
6866     if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
6867          /* skip IDFIRST by using do...while */
6868         if (UTF)
6869             do {
6870                 RExC_parse += UTF8SKIP(RExC_parse);
6871             } while (isALNUM_utf8((U8*)RExC_parse));
6872         else
6873             do {
6874                 RExC_parse++;
6875             } while (isALNUM(*RExC_parse));
6876     } else {
6877         RExC_parse++; /* so the <- from the vFAIL is after the offending character */
6878         vFAIL("Group name must start with a non-digit word character");
6879     }
6880     if ( flags ) {
6881         SV* sv_name
6882             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
6883                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
6884         if ( flags == REG_RSN_RETURN_NAME)
6885             return sv_name;
6886         else if (flags==REG_RSN_RETURN_DATA) {
6887             HE *he_str = NULL;
6888             SV *sv_dat = NULL;
6889             if ( ! sv_name )      /* should not happen*/
6890                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
6891             if (RExC_paren_names)
6892                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
6893             if ( he_str )
6894                 sv_dat = HeVAL(he_str);
6895             if ( ! sv_dat )
6896                 vFAIL("Reference to nonexistent named group");
6897             return sv_dat;
6898         }
6899         else {
6900             Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
6901                        (unsigned long) flags);
6902         }
6903         assert(0); /* NOT REACHED */
6904     }
6905     return NULL;
6906 }
6907
6908 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
6909     int rem=(int)(RExC_end - RExC_parse);                       \
6910     int cut;                                                    \
6911     int num;                                                    \
6912     int iscut=0;                                                \
6913     if (rem>10) {                                               \
6914         rem=10;                                                 \
6915         iscut=1;                                                \
6916     }                                                           \
6917     cut=10-rem;                                                 \
6918     if (RExC_lastparse!=RExC_parse)                             \
6919         PerlIO_printf(Perl_debug_log," >%.*s%-*s",              \
6920             rem, RExC_parse,                                    \
6921             cut + 4,                                            \
6922             iscut ? "..." : "<"                                 \
6923         );                                                      \
6924     else                                                        \
6925         PerlIO_printf(Perl_debug_log,"%16s","");                \
6926                                                                 \
6927     if (SIZE_ONLY)                                              \
6928        num = RExC_size + 1;                                     \
6929     else                                                        \
6930        num=REG_NODE_NUM(RExC_emit);                             \
6931     if (RExC_lastnum!=num)                                      \
6932        PerlIO_printf(Perl_debug_log,"|%4d",num);                \
6933     else                                                        \
6934        PerlIO_printf(Perl_debug_log,"|%4s","");                 \
6935     PerlIO_printf(Perl_debug_log,"|%*s%-4s",                    \
6936         (int)((depth*2)), "",                                   \
6937         (funcname)                                              \
6938     );                                                          \
6939     RExC_lastnum=num;                                           \
6940     RExC_lastparse=RExC_parse;                                  \
6941 })
6942
6943
6944
6945 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
6946     DEBUG_PARSE_MSG((funcname));                            \
6947     PerlIO_printf(Perl_debug_log,"%4s","\n");               \
6948 })
6949 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({           \
6950     DEBUG_PARSE_MSG((funcname));                            \
6951     PerlIO_printf(Perl_debug_log,fmt "\n",args);               \
6952 })
6953
6954 /* This section of code defines the inversion list object and its methods.  The
6955  * interfaces are highly subject to change, so as much as possible is static to
6956  * this file.  An inversion list is here implemented as a malloc'd C UV array
6957  * with some added info that is placed as UVs at the beginning in a header
6958  * portion.  An inversion list for Unicode is an array of code points, sorted
6959  * by ordinal number.  The zeroth element is the first code point in the list.
6960  * The 1th element is the first element beyond that not in the list.  In other
6961  * words, the first range is
6962  *  invlist[0]..(invlist[1]-1)
6963  * The other ranges follow.  Thus every element whose index is divisible by two
6964  * marks the beginning of a range that is in the list, and every element not
6965  * divisible by two marks the beginning of a range not in the list.  A single
6966  * element inversion list that contains the single code point N generally
6967  * consists of two elements
6968  *  invlist[0] == N
6969  *  invlist[1] == N+1
6970  * (The exception is when N is the highest representable value on the
6971  * machine, in which case the list containing just it would be a single
6972  * element, itself.  By extension, if the last range in the list extends to
6973  * infinity, then the first element of that range will be in the inversion list
6974  * at a position that is divisible by two, and is the final element in the
6975  * list.)
6976  * Taking the complement (inverting) an inversion list is quite simple, if the
6977  * first element is 0, remove it; otherwise add a 0 element at the beginning.
6978  * This implementation reserves an element at the beginning of each inversion list
6979  * to contain 0 when the list contains 0, and contains 1 otherwise.  The actual
6980  * beginning of the list is either that element if 0, or the next one if 1.
6981  *
6982  * More about inversion lists can be found in "Unicode Demystified"
6983  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
6984  * More will be coming when functionality is added later.
6985  *
6986  * The inversion list data structure is currently implemented as an SV pointing
6987  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
6988  * array of UV whose memory management is automatically handled by the existing
6989  * facilities for SV's.
6990  *
6991  * Some of the methods should always be private to the implementation, and some
6992  * should eventually be made public */
6993
6994 #define INVLIST_LEN_OFFSET 0    /* Number of elements in the inversion list */
6995 #define INVLIST_ITER_OFFSET 1   /* Current iteration position */
6996
6997 /* This is a combination of a version and data structure type, so that one
6998  * being passed in can be validated to be an inversion list of the correct
6999  * vintage.  When the structure of the header is changed, a new random number
7000  * in the range 2**31-1 should be generated and the new() method changed to
7001  * insert that at this location.  Then, if an auxiliary program doesn't change
7002  * correspondingly, it will be discovered immediately */
7003 #define INVLIST_VERSION_ID_OFFSET 2
7004 #define INVLIST_VERSION_ID 1064334010
7005
7006 /* For safety, when adding new elements, remember to #undef them at the end of
7007  * the inversion list code section */
7008
7009 #define INVLIST_ZERO_OFFSET 3   /* 0 or 1; must be last element in header */
7010 /* The UV at position ZERO contains either 0 or 1.  If 0, the inversion list
7011  * contains the code point U+00000, and begins here.  If 1, the inversion list
7012  * doesn't contain U+0000, and it begins at the next UV in the array.
7013  * Inverting an inversion list consists of adding or removing the 0 at the
7014  * beginning of it.  By reserving a space for that 0, inversion can be made
7015  * very fast */
7016
7017 #define HEADER_LENGTH (INVLIST_ZERO_OFFSET + 1)
7018
7019 /* Internally things are UVs */
7020 #define TO_INTERNAL_SIZE(x) ((x + HEADER_LENGTH) * sizeof(UV))
7021 #define FROM_INTERNAL_SIZE(x) ((x / sizeof(UV)) - HEADER_LENGTH)
7022
7023 #define INVLIST_INITIAL_LEN 10
7024
7025 PERL_STATIC_INLINE UV*
7026 S__invlist_array_init(pTHX_ SV* const invlist, const bool will_have_0)
7027 {
7028     /* Returns a pointer to the first element in the inversion list's array.
7029      * This is called upon initialization of an inversion list.  Where the
7030      * array begins depends on whether the list has the code point U+0000
7031      * in it or not.  The other parameter tells it whether the code that
7032      * follows this call is about to put a 0 in the inversion list or not.
7033      * The first element is either the element with 0, if 0, or the next one,
7034      * if 1 */
7035
7036     UV* zero = get_invlist_zero_addr(invlist);
7037
7038     PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
7039
7040     /* Must be empty */
7041     assert(! *get_invlist_len_addr(invlist));
7042
7043     /* 1^1 = 0; 1^0 = 1 */
7044     *zero = 1 ^ will_have_0;
7045     return zero + *zero;
7046 }
7047
7048 PERL_STATIC_INLINE UV*
7049 S_invlist_array(pTHX_ SV* const invlist)
7050 {
7051     /* Returns the pointer to the inversion list's array.  Every time the
7052      * length changes, this needs to be called in case malloc or realloc moved
7053      * it */
7054
7055     PERL_ARGS_ASSERT_INVLIST_ARRAY;
7056
7057     /* Must not be empty.  If these fail, you probably didn't check for <len>
7058      * being non-zero before trying to get the array */
7059     assert(*get_invlist_len_addr(invlist));
7060     assert(*get_invlist_zero_addr(invlist) == 0
7061            || *get_invlist_zero_addr(invlist) == 1);
7062
7063     /* The array begins either at the element reserved for zero if the
7064      * list contains 0 (that element will be set to 0), or otherwise the next
7065      * element (in which case the reserved element will be set to 1). */
7066     return (UV *) (get_invlist_zero_addr(invlist)
7067                    + *get_invlist_zero_addr(invlist));
7068 }
7069
7070 PERL_STATIC_INLINE UV*
7071 S_get_invlist_len_addr(pTHX_ SV* invlist)
7072 {
7073     /* Return the address of the UV that contains the current number
7074      * of used elements in the inversion list */
7075
7076     PERL_ARGS_ASSERT_GET_INVLIST_LEN_ADDR;
7077
7078     return (UV *) (SvPVX(invlist) + (INVLIST_LEN_OFFSET * sizeof (UV)));
7079 }
7080
7081 PERL_STATIC_INLINE UV
7082 S_invlist_len(pTHX_ SV* const invlist)
7083 {
7084     /* Returns the current number of elements stored in the inversion list's
7085      * array */
7086
7087     PERL_ARGS_ASSERT_INVLIST_LEN;
7088
7089     return *get_invlist_len_addr(invlist);
7090 }
7091
7092 PERL_STATIC_INLINE void
7093 S_invlist_set_len(pTHX_ SV* const invlist, const UV len)
7094 {
7095     /* Sets the current number of elements stored in the inversion list */
7096
7097     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
7098
7099     *get_invlist_len_addr(invlist) = len;
7100
7101     assert(len <= SvLEN(invlist));
7102
7103     SvCUR_set(invlist, TO_INTERNAL_SIZE(len));
7104     /* If the list contains U+0000, that element is part of the header,
7105      * and should not be counted as part of the array.  It will contain
7106      * 0 in that case, and 1 otherwise.  So we could flop 0=>1, 1=>0 and
7107      * subtract:
7108      *  SvCUR_set(invlist,
7109      *            TO_INTERNAL_SIZE(len
7110      *                             - (*get_invlist_zero_addr(inv_list) ^ 1)));
7111      * But, this is only valid if len is not 0.  The consequences of not doing
7112      * this is that the memory allocation code may think that 1 more UV is
7113      * being used than actually is, and so might do an unnecessary grow.  That
7114      * seems worth not bothering to make this the precise amount.
7115      *
7116      * Note that when inverting, SvCUR shouldn't change */
7117 }
7118
7119 PERL_STATIC_INLINE UV
7120 S_invlist_max(pTHX_ SV* const invlist)
7121 {
7122     /* Returns the maximum number of elements storable in the inversion list's
7123      * array, without having to realloc() */
7124
7125     PERL_ARGS_ASSERT_INVLIST_MAX;
7126
7127     return FROM_INTERNAL_SIZE(SvLEN(invlist));
7128 }
7129
7130 PERL_STATIC_INLINE UV*
7131 S_get_invlist_zero_addr(pTHX_ SV* invlist)
7132 {
7133     /* Return the address of the UV that is reserved to hold 0 if the inversion
7134      * list contains 0.  This has to be the last element of the heading, as the
7135      * list proper starts with either it if 0, or the next element if not.
7136      * (But we force it to contain either 0 or 1) */
7137
7138     PERL_ARGS_ASSERT_GET_INVLIST_ZERO_ADDR;
7139
7140     return (UV *) (SvPVX(invlist) + (INVLIST_ZERO_OFFSET * sizeof (UV)));
7141 }
7142
7143 #ifndef PERL_IN_XSUB_RE
7144 SV*
7145 Perl__new_invlist(pTHX_ IV initial_size)
7146 {
7147
7148     /* Return a pointer to a newly constructed inversion list, with enough
7149      * space to store 'initial_size' elements.  If that number is negative, a
7150      * system default is used instead */
7151
7152     SV* new_list;
7153
7154     if (initial_size < 0) {
7155         initial_size = INVLIST_INITIAL_LEN;
7156     }
7157
7158     /* Allocate the initial space */
7159     new_list = newSV(TO_INTERNAL_SIZE(initial_size));
7160     invlist_set_len(new_list, 0);
7161
7162     /* Force iterinit() to be used to get iteration to work */
7163     *get_invlist_iter_addr(new_list) = UV_MAX;
7164
7165     /* This should force a segfault if a method doesn't initialize this
7166      * properly */
7167     *get_invlist_zero_addr(new_list) = UV_MAX;
7168
7169     *get_invlist_version_id_addr(new_list) = INVLIST_VERSION_ID;
7170 #if HEADER_LENGTH != 4
7171 #   error Need to regenerate VERSION_ID by running perl -E 'say int(rand 2**31-1)', and then changing the #if to the new length
7172 #endif
7173
7174     return new_list;
7175 }
7176 #endif
7177
7178 STATIC SV*
7179 S__new_invlist_C_array(pTHX_ UV* list)
7180 {
7181     /* Return a pointer to a newly constructed inversion list, initialized to
7182      * point to <list>, which has to be in the exact correct inversion list
7183      * form, including internal fields.  Thus this is a dangerous routine that
7184      * should not be used in the wrong hands */
7185
7186     SV* invlist = newSV_type(SVt_PV);
7187
7188     PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
7189
7190     SvPV_set(invlist, (char *) list);
7191     SvLEN_set(invlist, 0);  /* Means we own the contents, and the system
7192                                shouldn't touch it */
7193     SvCUR_set(invlist, TO_INTERNAL_SIZE(invlist_len(invlist)));
7194
7195     if (*get_invlist_version_id_addr(invlist) != INVLIST_VERSION_ID) {
7196         Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
7197     }
7198
7199     return invlist;
7200 }
7201
7202 STATIC void
7203 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
7204 {
7205     /* Grow the maximum size of an inversion list */
7206
7207     PERL_ARGS_ASSERT_INVLIST_EXTEND;
7208
7209     SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max));
7210 }
7211
7212 PERL_STATIC_INLINE void
7213 S_invlist_trim(pTHX_ SV* const invlist)
7214 {
7215     PERL_ARGS_ASSERT_INVLIST_TRIM;
7216
7217     /* Change the length of the inversion list to how many entries it currently
7218      * has */
7219
7220     SvPV_shrink_to_cur((SV *) invlist);
7221 }
7222
7223 /* An element is in an inversion list iff its index is even numbered: 0, 2, 4,
7224  * etc */
7225 #define ELEMENT_RANGE_MATCHES_INVLIST(i) (! ((i) & 1))
7226 #define PREV_RANGE_MATCHES_INVLIST(i) (! ELEMENT_RANGE_MATCHES_INVLIST(i))
7227
7228 #define _invlist_union_complement_2nd(a, b, output) _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
7229
7230 STATIC void
7231 S__append_range_to_invlist(pTHX_ SV* const invlist, const UV start, const UV end)
7232 {
7233    /* Subject to change or removal.  Append the range from 'start' to 'end' at
7234     * the end of the inversion list.  The range must be above any existing
7235     * ones. */
7236
7237     UV* array;
7238     UV max = invlist_max(invlist);
7239     UV len = invlist_len(invlist);
7240
7241     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
7242
7243     if (len == 0) { /* Empty lists must be initialized */
7244         array = _invlist_array_init(invlist, start == 0);
7245     }
7246     else {
7247         /* Here, the existing list is non-empty. The current max entry in the
7248          * list is generally the first value not in the set, except when the
7249          * set extends to the end of permissible values, in which case it is
7250          * the first entry in that final set, and so this call is an attempt to
7251          * append out-of-order */
7252
7253         UV final_element = len - 1;
7254         array = invlist_array(invlist);
7255         if (array[final_element] > start
7256             || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
7257         {
7258             Perl_croak(aTHX_ "panic: attempting to append to an inversion list, but wasn't at the end of the list, final=%"UVuf", start=%"UVuf", match=%c",
7259                        array[final_element], start,
7260                        ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
7261         }
7262
7263         /* Here, it is a legal append.  If the new range begins with the first
7264          * value not in the set, it is extending the set, so the new first
7265          * value not in the set is one greater than the newly extended range.
7266          * */
7267         if (array[final_element] == start) {
7268             if (end != UV_MAX) {
7269                 array[final_element] = end + 1;
7270             }
7271             else {
7272                 /* But if the end is the maximum representable on the machine,
7273                  * just let the range that this would extend to have no end */
7274                 invlist_set_len(invlist, len - 1);
7275             }
7276             return;
7277         }
7278     }
7279
7280     /* Here the new range doesn't extend any existing set.  Add it */
7281
7282     len += 2;   /* Includes an element each for the start and end of range */
7283
7284     /* If overflows the existing space, extend, which may cause the array to be
7285      * moved */
7286     if (max < len) {
7287         invlist_extend(invlist, len);
7288         invlist_set_len(invlist, len);  /* Have to set len here to avoid assert
7289                                            failure in invlist_array() */
7290         array = invlist_array(invlist);
7291     }
7292     else {
7293         invlist_set_len(invlist, len);
7294     }
7295
7296     /* The next item on the list starts the range, the one after that is
7297      * one past the new range.  */
7298     array[len - 2] = start;
7299     if (end != UV_MAX) {
7300         array[len - 1] = end + 1;
7301     }
7302     else {
7303         /* But if the end is the maximum representable on the machine, just let
7304          * the range have no end */
7305         invlist_set_len(invlist, len - 1);
7306     }
7307 }
7308
7309 #ifndef PERL_IN_XSUB_RE
7310
7311 STATIC IV
7312 S_invlist_search(pTHX_ SV* const invlist, const UV cp)
7313 {
7314     /* Searches the inversion list for the entry that contains the input code
7315      * point <cp>.  If <cp> is not in the list, -1 is returned.  Otherwise, the
7316      * return value is the index into the list's array of the range that
7317      * contains <cp> */
7318
7319     IV low = 0;
7320     IV high = invlist_len(invlist);
7321     const UV * const array = invlist_array(invlist);
7322
7323     PERL_ARGS_ASSERT_INVLIST_SEARCH;
7324
7325     /* If list is empty or the code point is before the first element, return
7326      * failure. */
7327     if (high == 0 || cp < array[0]) {
7328         return -1;
7329     }
7330
7331     /* Binary search.  What we are looking for is <i> such that
7332      *  array[i] <= cp < array[i+1]
7333      * The loop below converges on the i+1. */
7334     while (low < high) {
7335         IV mid = (low + high) / 2;
7336         if (array[mid] <= cp) {
7337             low = mid + 1;
7338
7339             /* We could do this extra test to exit the loop early.
7340             if (cp < array[low]) {
7341                 return mid;
7342             }
7343             */
7344         }
7345         else { /* cp < array[mid] */
7346             high = mid;
7347         }
7348     }
7349
7350     return high - 1;
7351 }
7352
7353 void
7354 Perl__invlist_populate_swatch(pTHX_ SV* const invlist, const UV start, const UV end, U8* swatch)
7355 {
7356     /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
7357      * but is used when the swash has an inversion list.  This makes this much
7358      * faster, as it uses a binary search instead of a linear one.  This is
7359      * intimately tied to that function, and perhaps should be in utf8.c,
7360      * except it is intimately tied to inversion lists as well.  It assumes
7361      * that <swatch> is all 0's on input */
7362
7363     UV current = start;
7364     const IV len = invlist_len(invlist);
7365     IV i;
7366     const UV * array;
7367
7368     PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
7369
7370     if (len == 0) { /* Empty inversion list */
7371         return;
7372     }
7373
7374     array = invlist_array(invlist);
7375
7376     /* Find which element it is */
7377     i = invlist_search(invlist, start);
7378
7379     /* We populate from <start> to <end> */
7380     while (current < end) {
7381         UV upper;
7382
7383         /* The inversion list gives the results for every possible code point
7384          * after the first one in the list.  Only those ranges whose index is
7385          * even are ones that the inversion list matches.  For the odd ones,
7386          * and if the initial code point is not in the list, we have to skip
7387          * forward to the next element */
7388         if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
7389             i++;
7390             if (i >= len) { /* Finished if beyond the end of the array */
7391                 return;
7392             }
7393             current = array[i];
7394             if (current >= end) {   /* Finished if beyond the end of what we
7395                                        are populating */
7396                 return;
7397             }
7398         }
7399         assert(current >= start);
7400
7401         /* The current range ends one below the next one, except don't go past
7402          * <end> */
7403         i++;
7404         upper = (i < len && array[i] < end) ? array[i] : end;
7405
7406         /* Here we are in a range that matches.  Populate a bit in the 3-bit U8
7407          * for each code point in it */
7408         for (; current < upper; current++) {
7409             const STRLEN offset = (STRLEN)(current - start);
7410             swatch[offset >> 3] |= 1 << (offset & 7);
7411         }
7412
7413         /* Quit if at the end of the list */
7414         if (i >= len) {
7415
7416             /* But first, have to deal with the highest possible code point on
7417              * the platform.  The previous code assumes that <end> is one
7418              * beyond where we want to populate, but that is impossible at the
7419              * platform's infinity, so have to handle it specially */
7420             if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
7421             {
7422                 const STRLEN offset = (STRLEN)(end - start);
7423                 swatch[offset >> 3] |= 1 << (offset & 7);
7424             }
7425             return;
7426         }
7427
7428         /* Advance to the next range, which will be for code points not in the
7429          * inversion list */
7430         current = array[i];
7431     }
7432
7433     return;
7434 }
7435
7436
7437 void
7438 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** output)
7439 {
7440     /* Take the union of two inversion lists and point <output> to it.  *output
7441      * should be defined upon input, and if it points to one of the two lists,
7442      * the reference count to that list will be decremented.  The first list,
7443      * <a>, may be NULL, in which case a copy of the second list is returned.
7444      * If <complement_b> is TRUE, the union is taken of the complement
7445      * (inversion) of <b> instead of b itself.
7446      *
7447      * The basis for this comes from "Unicode Demystified" Chapter 13 by
7448      * Richard Gillam, published by Addison-Wesley, and explained at some
7449      * length there.  The preface says to incorporate its examples into your
7450      * code at your own risk.
7451      *
7452      * The algorithm is like a merge sort.
7453      *
7454      * XXX A potential performance improvement is to keep track as we go along
7455      * if only one of the inputs contributes to the result, meaning the other
7456      * is a subset of that one.  In that case, we can skip the final copy and
7457      * return the larger of the input lists, but then outside code might need
7458      * to keep track of whether to free the input list or not */
7459
7460     UV* array_a;    /* a's array */
7461     UV* array_b;
7462     UV len_a;       /* length of a's array */
7463     UV len_b;
7464
7465     SV* u;                      /* the resulting union */
7466     UV* array_u;
7467     UV len_u;
7468
7469     UV i_a = 0;             /* current index into a's array */
7470     UV i_b = 0;
7471     UV i_u = 0;
7472
7473     /* running count, as explained in the algorithm source book; items are
7474      * stopped accumulating and are output when the count changes to/from 0.
7475      * The count is incremented when we start a range that's in the set, and
7476      * decremented when we start a range that's not in the set.  So its range
7477      * is 0 to 2.  Only when the count is zero is something not in the set.
7478      */
7479     UV count = 0;
7480
7481     PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
7482     assert(a != b);
7483
7484     /* If either one is empty, the union is the other one */
7485     if (a == NULL || ((len_a = invlist_len(a)) == 0)) {
7486         if (*output == a) {
7487             if (a != NULL) {
7488                 SvREFCNT_dec(a);
7489             }
7490         }
7491         if (*output != b) {
7492             *output = invlist_clone(b);
7493             if (complement_b) {
7494                 _invlist_invert(*output);
7495             }
7496         } /* else *output already = b; */
7497         return;
7498     }
7499     else if ((len_b = invlist_len(b)) == 0) {
7500         if (*output == b) {
7501             SvREFCNT_dec(b);
7502         }
7503
7504         /* The complement of an empty list is a list that has everything in it,
7505          * so the union with <a> includes everything too */
7506         if (complement_b) {
7507             if (a == *output) {
7508                 SvREFCNT_dec(a);
7509             }
7510             *output = _new_invlist(1);
7511             _append_range_to_invlist(*output, 0, UV_MAX);
7512         }
7513         else if (*output != a) {
7514             *output = invlist_clone(a);
7515         }
7516         /* else *output already = a; */
7517         return;
7518     }
7519
7520     /* Here both lists exist and are non-empty */
7521     array_a = invlist_array(a);
7522     array_b = invlist_array(b);
7523
7524     /* If are to take the union of 'a' with the complement of b, set it
7525      * up so are looking at b's complement. */
7526     if (complement_b) {
7527
7528         /* To complement, we invert: if the first element is 0, remove it.  To
7529          * do this, we just pretend the array starts one later, and clear the
7530          * flag as we don't have to do anything else later */
7531         if (array_b[0] == 0) {
7532             array_b++;
7533             len_b--;
7534             complement_b = FALSE;
7535         }
7536         else {
7537
7538             /* But if the first element is not zero, we unshift a 0 before the
7539              * array.  The data structure reserves a space for that 0 (which
7540              * should be a '1' right now), so physical shifting is unneeded,
7541              * but temporarily change that element to 0.  Before exiting the
7542              * routine, we must restore the element to '1' */
7543             array_b--;
7544             len_b++;
7545             array_b[0] = 0;
7546         }
7547     }
7548
7549     /* Size the union for the worst case: that the sets are completely
7550      * disjoint */
7551     u = _new_invlist(len_a + len_b);
7552
7553     /* Will contain U+0000 if either component does */
7554     array_u = _invlist_array_init(u, (len_a > 0 && array_a[0] == 0)
7555                                       || (len_b > 0 && array_b[0] == 0));
7556
7557     /* Go through each list item by item, stopping when exhausted one of
7558      * them */
7559     while (i_a < len_a && i_b < len_b) {
7560         UV cp;      /* The element to potentially add to the union's array */
7561         bool cp_in_set;   /* is it in the the input list's set or not */
7562
7563         /* We need to take one or the other of the two inputs for the union.
7564          * Since we are merging two sorted lists, we take the smaller of the
7565          * next items.  In case of a tie, we take the one that is in its set
7566          * first.  If we took one not in the set first, it would decrement the
7567          * count, possibly to 0 which would cause it to be output as ending the
7568          * range, and the next time through we would take the same number, and
7569          * output it again as beginning the next range.  By doing it the
7570          * opposite way, there is no possibility that the count will be
7571          * momentarily decremented to 0, and thus the two adjoining ranges will
7572          * be seamlessly merged.  (In a tie and both are in the set or both not
7573          * in the set, it doesn't matter which we take first.) */
7574         if (array_a[i_a] < array_b[i_b]
7575             || (array_a[i_a] == array_b[i_b]
7576                 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
7577         {
7578             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
7579             cp= array_a[i_a++];
7580         }
7581         else {
7582             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
7583             cp= array_b[i_b++];
7584         }
7585
7586         /* Here, have chosen which of the two inputs to look at.  Only output
7587          * if the running count changes to/from 0, which marks the
7588          * beginning/end of a range in that's in the set */
7589         if (cp_in_set) {
7590             if (count == 0) {
7591                 array_u[i_u++] = cp;
7592             }
7593             count++;
7594         }
7595         else {
7596             count--;
7597             if (count == 0) {
7598                 array_u[i_u++] = cp;
7599             }
7600         }
7601     }
7602
7603     /* Here, we are finished going through at least one of the lists, which
7604      * means there is something remaining in at most one.  We check if the list
7605      * that hasn't been exhausted is positioned such that we are in the middle
7606      * of a range in its set or not.  (i_a and i_b point to the element beyond
7607      * the one we care about.) If in the set, we decrement 'count'; if 0, there
7608      * is potentially more to output.
7609      * There are four cases:
7610      *  1) Both weren't in their sets, count is 0, and remains 0.  What's left
7611      *     in the union is entirely from the non-exhausted set.
7612      *  2) Both were in their sets, count is 2.  Nothing further should
7613      *     be output, as everything that remains will be in the exhausted
7614      *     list's set, hence in the union; decrementing to 1 but not 0 insures
7615      *     that
7616      *  3) the exhausted was in its set, non-exhausted isn't, count is 1.
7617      *     Nothing further should be output because the union includes
7618      *     everything from the exhausted set.  Not decrementing ensures that.
7619      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1;
7620      *     decrementing to 0 insures that we look at the remainder of the
7621      *     non-exhausted set */
7622     if ((i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
7623         || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
7624     {
7625         count--;
7626     }
7627
7628     /* The final length is what we've output so far, plus what else is about to
7629      * be output.  (If 'count' is non-zero, then the input list we exhausted
7630      * has everything remaining up to the machine's limit in its set, and hence
7631      * in the union, so there will be no further output. */
7632     len_u = i_u;
7633     if (count == 0) {
7634         /* At most one of the subexpressions will be non-zero */
7635         len_u += (len_a - i_a) + (len_b - i_b);
7636     }
7637
7638     /* Set result to final length, which can change the pointer to array_u, so
7639      * re-find it */
7640     if (len_u != invlist_len(u)) {
7641         invlist_set_len(u, len_u);
7642         invlist_trim(u);
7643         array_u = invlist_array(u);
7644     }
7645
7646     /* When 'count' is 0, the list that was exhausted (if one was shorter than
7647      * the other) ended with everything above it not in its set.  That means
7648      * that the remaining part of the union is precisely the same as the
7649      * non-exhausted list, so can just copy it unchanged.  (If both list were
7650      * exhausted at the same time, then the operations below will be both 0.)
7651      */
7652     if (count == 0) {
7653         IV copy_count; /* At most one will have a non-zero copy count */
7654         if ((copy_count = len_a - i_a) > 0) {
7655             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
7656         }
7657         else if ((copy_count = len_b - i_b) > 0) {
7658             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
7659         }
7660     }
7661
7662     /*  We may be removing a reference to one of the inputs */
7663     if (a == *output || b == *output) {
7664         SvREFCNT_dec(*output);
7665     }
7666
7667     /* If we've changed b, restore it */
7668     if (complement_b) {
7669         array_b[0] = 1;
7670     }
7671
7672     *output = u;
7673     return;
7674 }
7675
7676 void
7677 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** i)
7678 {
7679     /* Take the intersection of two inversion lists and point <i> to it.  *i
7680      * should be defined upon input, and if it points to one of the two lists,
7681      * the reference count to that list will be decremented.
7682      * If <complement_b> is TRUE, the result will be the intersection of <a>
7683      * and the complement (or inversion) of <b> instead of <b> directly.
7684      *
7685      * The basis for this comes from "Unicode Demystified" Chapter 13 by
7686      * Richard Gillam, published by Addison-Wesley, and explained at some
7687      * length there.  The preface says to incorporate its examples into your
7688      * code at your own risk.  In fact, it had bugs
7689      *
7690      * The algorithm is like a merge sort, and is essentially the same as the
7691      * union above
7692      */
7693
7694     UV* array_a;                /* a's array */
7695     UV* array_b;
7696     UV len_a;   /* length of a's array */
7697     UV len_b;
7698
7699     SV* r;                   /* the resulting intersection */
7700     UV* array_r;
7701     UV len_r;
7702
7703     UV i_a = 0;             /* current index into a's array */
7704     UV i_b = 0;
7705     UV i_r = 0;
7706
7707     /* running count, as explained in the algorithm source book; items are
7708      * stopped accumulating and are output when the count changes to/from 2.
7709      * The count is incremented when we start a range that's in the set, and
7710      * decremented when we start a range that's not in the set.  So its range
7711      * is 0 to 2.  Only when the count is 2 is something in the intersection.
7712      */
7713     UV count = 0;
7714
7715     PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
7716     assert(a != b);
7717
7718     /* Special case if either one is empty */
7719     len_a = invlist_len(a);
7720     if ((len_a == 0) || ((len_b = invlist_len(b)) == 0)) {
7721
7722         if (len_a != 0 && complement_b) {
7723
7724             /* Here, 'a' is not empty, therefore from the above 'if', 'b' must
7725              * be empty.  Here, also we are using 'b's complement, which hence
7726              * must be every possible code point.  Thus the intersection is
7727              * simply 'a'. */
7728             if (*i != a) {
7729                 *i = invlist_clone(a);
7730
7731                 if (*i == b) {
7732                     SvREFCNT_dec(b);
7733                 }
7734             }
7735             /* else *i is already 'a' */
7736             return;
7737         }
7738
7739         /* Here, 'a' or 'b' is empty and not using the complement of 'b'.  The
7740          * intersection must be empty */
7741         if (*i == a) {
7742             SvREFCNT_dec(a);
7743         }
7744         else if (*i == b) {
7745             SvREFCNT_dec(b);
7746         }
7747         *i = _new_invlist(0);
7748         return;
7749     }
7750
7751     /* Here both lists exist and are non-empty */
7752     array_a = invlist_array(a);
7753     array_b = invlist_array(b);
7754
7755     /* If are to take the intersection of 'a' with the complement of b, set it
7756      * up so are looking at b's complement. */
7757     if (complement_b) {
7758
7759         /* To complement, we invert: if the first element is 0, remove it.  To
7760          * do this, we just pretend the array starts one later, and clear the
7761          * flag as we don't have to do anything else later */
7762         if (array_b[0] == 0) {
7763             array_b++;
7764             len_b--;
7765             complement_b = FALSE;
7766         }
7767         else {
7768
7769             /* But if the first element is not zero, we unshift a 0 before the
7770              * array.  The data structure reserves a space for that 0 (which
7771              * should be a '1' right now), so physical shifting is unneeded,
7772              * but temporarily change that element to 0.  Before exiting the
7773              * routine, we must restore the element to '1' */
7774             array_b--;
7775             len_b++;
7776             array_b[0] = 0;
7777         }
7778     }
7779
7780     /* Size the intersection for the worst case: that the intersection ends up
7781      * fragmenting everything to be completely disjoint */
7782     r= _new_invlist(len_a + len_b);
7783
7784     /* Will contain U+0000 iff both components do */
7785     array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
7786                                      && len_b > 0 && array_b[0] == 0);
7787
7788     /* Go through each list item by item, stopping when exhausted one of
7789      * them */
7790     while (i_a < len_a && i_b < len_b) {
7791         UV cp;      /* The element to potentially add to the intersection's
7792                        array */
7793         bool cp_in_set; /* Is it in the input list's set or not */
7794
7795         /* We need to take one or the other of the two inputs for the
7796          * intersection.  Since we are merging two sorted lists, we take the
7797          * smaller of the next items.  In case of a tie, we take the one that
7798          * is not in its set first (a difference from the union algorithm).  If
7799          * we took one in the set first, it would increment the count, possibly
7800          * to 2 which would cause it to be output as starting a range in the
7801          * intersection, and the next time through we would take that same
7802          * number, and output it again as ending the set.  By doing it the
7803          * opposite of this, there is no possibility that the count will be
7804          * momentarily incremented to 2.  (In a tie and both are in the set or
7805          * both not in the set, it doesn't matter which we take first.) */
7806         if (array_a[i_a] < array_b[i_b]
7807             || (array_a[i_a] == array_b[i_b]
7808                 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
7809         {
7810             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
7811             cp= array_a[i_a++];
7812         }
7813         else {
7814             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
7815             cp= array_b[i_b++];
7816         }
7817
7818         /* Here, have chosen which of the two inputs to look at.  Only output
7819          * if the running count changes to/from 2, which marks the
7820          * beginning/end of a range that's in the intersection */
7821         if (cp_in_set) {
7822             count++;
7823             if (count == 2) {
7824                 array_r[i_r++] = cp;
7825             }
7826         }
7827         else {
7828             if (count == 2) {
7829                 array_r[i_r++] = cp;
7830             }
7831             count--;
7832         }
7833     }
7834
7835     /* Here, we are finished going through at least one of the lists, which
7836      * means there is something remaining in at most one.  We check if the list
7837      * that has been exhausted is positioned such that we are in the middle
7838      * of a range in its set or not.  (i_a and i_b point to elements 1 beyond
7839      * the ones we care about.)  There are four cases:
7840      *  1) Both weren't in their sets, count is 0, and remains 0.  There's
7841      *     nothing left in the intersection.
7842      *  2) Both were in their sets, count is 2 and perhaps is incremented to
7843      *     above 2.  What should be output is exactly that which is in the
7844      *     non-exhausted set, as everything it has is also in the intersection
7845      *     set, and everything it doesn't have can't be in the intersection
7846      *  3) The exhausted was in its set, non-exhausted isn't, count is 1, and
7847      *     gets incremented to 2.  Like the previous case, the intersection is
7848      *     everything that remains in the non-exhausted set.
7849      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1, and
7850      *     remains 1.  And the intersection has nothing more. */
7851     if ((i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
7852         || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
7853     {
7854         count++;
7855     }
7856
7857     /* The final length is what we've output so far plus what else is in the
7858      * intersection.  At most one of the subexpressions below will be non-zero */
7859     len_r = i_r;
7860     if (count >= 2) {
7861         len_r += (len_a - i_a) + (len_b - i_b);
7862     }
7863
7864     /* Set result to final length, which can change the pointer to array_r, so
7865      * re-find it */
7866     if (len_r != invlist_len(r)) {
7867         invlist_set_len(r, len_r);
7868         invlist_trim(r);
7869         array_r = invlist_array(r);
7870     }
7871
7872     /* Finish outputting any remaining */
7873     if (count >= 2) { /* At most one will have a non-zero copy count */
7874         IV copy_count;
7875         if ((copy_count = len_a - i_a) > 0) {
7876             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
7877         }
7878         else if ((copy_count = len_b - i_b) > 0) {
7879             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
7880         }
7881     }
7882
7883     /*  We may be removing a reference to one of the inputs */
7884     if (a == *i || b == *i) {
7885         SvREFCNT_dec(*i);
7886     }
7887
7888     /* If we've changed b, restore it */
7889     if (complement_b) {
7890         array_b[0] = 1;
7891     }
7892
7893     *i = r;
7894     return;
7895 }
7896
7897 SV*
7898 Perl__add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end)
7899 {
7900     /* Add the range from 'start' to 'end' inclusive to the inversion list's
7901      * set.  A pointer to the inversion list is returned.  This may actually be
7902      * a new list, in which case the passed in one has been destroyed.  The
7903      * passed in inversion list can be NULL, in which case a new one is created
7904      * with just the one range in it */
7905
7906     SV* range_invlist;
7907     UV len;
7908
7909     if (invlist == NULL) {
7910         invlist = _new_invlist(2);
7911         len = 0;
7912     }
7913     else {
7914         len = invlist_len(invlist);
7915     }
7916
7917     /* If comes after the final entry, can just append it to the end */
7918     if (len == 0
7919         || start >= invlist_array(invlist)
7920                                     [invlist_len(invlist) - 1])
7921     {
7922         _append_range_to_invlist(invlist, start, end);
7923         return invlist;
7924     }
7925
7926     /* Here, can't just append things, create and return a new inversion list
7927      * which is the union of this range and the existing inversion list */
7928     range_invlist = _new_invlist(2);
7929     _append_range_to_invlist(range_invlist, start, end);
7930
7931     _invlist_union(invlist, range_invlist, &invlist);
7932
7933     /* The temporary can be freed */
7934     SvREFCNT_dec(range_invlist);
7935
7936     return invlist;
7937 }
7938
7939 #endif
7940
7941 PERL_STATIC_INLINE SV*
7942 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
7943     return _add_range_to_invlist(invlist, cp, cp);
7944 }
7945
7946 #ifndef PERL_IN_XSUB_RE
7947 void
7948 Perl__invlist_invert(pTHX_ SV* const invlist)
7949 {
7950     /* Complement the input inversion list.  This adds a 0 if the list didn't
7951      * have a zero; removes it otherwise.  As described above, the data
7952      * structure is set up so that this is very efficient */
7953
7954     UV* len_pos = get_invlist_len_addr(invlist);
7955
7956     PERL_ARGS_ASSERT__INVLIST_INVERT;
7957
7958     /* The inverse of matching nothing is matching everything */
7959     if (*len_pos == 0) {
7960         _append_range_to_invlist(invlist, 0, UV_MAX);
7961         return;
7962     }
7963
7964     /* The exclusive or complents 0 to 1; and 1 to 0.  If the result is 1, the
7965      * zero element was a 0, so it is being removed, so the length decrements
7966      * by 1; and vice-versa.  SvCUR is unaffected */
7967     if (*get_invlist_zero_addr(invlist) ^= 1) {
7968         (*len_pos)--;
7969     }
7970     else {
7971         (*len_pos)++;
7972     }
7973 }
7974
7975 void
7976 Perl__invlist_invert_prop(pTHX_ SV* const invlist)
7977 {
7978     /* Complement the input inversion list (which must be a Unicode property,
7979      * all of which don't match above the Unicode maximum code point.)  And
7980      * Perl has chosen to not have the inversion match above that either.  This
7981      * adds a 0x110000 if the list didn't end with it, and removes it if it did
7982      */
7983
7984     UV len;
7985     UV* array;
7986
7987     PERL_ARGS_ASSERT__INVLIST_INVERT_PROP;
7988
7989     _invlist_invert(invlist);
7990
7991     len = invlist_len(invlist);
7992
7993     if (len != 0) { /* If empty do nothing */
7994         array = invlist_array(invlist);
7995         if (array[len - 1] != PERL_UNICODE_MAX + 1) {
7996             /* Add 0x110000.  First, grow if necessary */
7997             len++;
7998             if (invlist_max(invlist) < len) {
7999                 invlist_extend(invlist, len);
8000                 array = invlist_array(invlist);
8001             }
8002             invlist_set_len(invlist, len);
8003             array[len - 1] = PERL_UNICODE_MAX + 1;
8004         }
8005         else {  /* Remove the 0x110000 */
8006             invlist_set_len(invlist, len - 1);
8007         }
8008     }
8009
8010     return;
8011 }
8012 #endif
8013
8014 PERL_STATIC_INLINE SV*
8015 S_invlist_clone(pTHX_ SV* const invlist)
8016 {
8017
8018     /* Return a new inversion list that is a copy of the input one, which is
8019      * unchanged */
8020
8021     /* Need to allocate extra space to accommodate Perl's addition of a
8022      * trailing NUL to SvPV's, since it thinks they are always strings */
8023     SV* new_invlist = _new_invlist(invlist_len(invlist) + 1);
8024     STRLEN length = SvCUR(invlist);
8025
8026     PERL_ARGS_ASSERT_INVLIST_CLONE;
8027
8028     SvCUR_set(new_invlist, length); /* This isn't done automatically */
8029     Copy(SvPVX(invlist), SvPVX(new_invlist), length, char);
8030
8031     return new_invlist;
8032 }
8033
8034 PERL_STATIC_INLINE UV*
8035 S_get_invlist_iter_addr(pTHX_ SV* invlist)
8036 {
8037     /* Return the address of the UV that contains the current iteration
8038      * position */
8039
8040     PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
8041
8042     return (UV *) (SvPVX(invlist) + (INVLIST_ITER_OFFSET * sizeof (UV)));
8043 }
8044
8045 PERL_STATIC_INLINE UV*
8046 S_get_invlist_version_id_addr(pTHX_ SV* invlist)
8047 {
8048     /* Return the address of the UV that contains the version id. */
8049
8050     PERL_ARGS_ASSERT_GET_INVLIST_VERSION_ID_ADDR;
8051
8052     return (UV *) (SvPVX(invlist) + (INVLIST_VERSION_ID_OFFSET * sizeof (UV)));
8053 }
8054
8055 PERL_STATIC_INLINE void
8056 S_invlist_iterinit(pTHX_ SV* invlist)   /* Initialize iterator for invlist */
8057 {
8058     PERL_ARGS_ASSERT_INVLIST_ITERINIT;
8059
8060     *get_invlist_iter_addr(invlist) = 0;
8061 }
8062
8063 STATIC bool
8064 S_invlist_iternext(pTHX_ SV* invlist, UV* start, UV* end)
8065 {
8066     /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
8067      * This call sets in <*start> and <*end>, the next range in <invlist>.
8068      * Returns <TRUE> if successful and the next call will return the next
8069      * range; <FALSE> if was already at the end of the list.  If the latter,
8070      * <*start> and <*end> are unchanged, and the next call to this function
8071      * will start over at the beginning of the list */
8072
8073     UV* pos = get_invlist_iter_addr(invlist);
8074     UV len = invlist_len(invlist);
8075     UV *array;
8076
8077     PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
8078
8079     if (*pos >= len) {
8080         *pos = UV_MAX;  /* Force iternit() to be required next time */
8081         return FALSE;
8082     }
8083
8084     array = invlist_array(invlist);
8085
8086     *start = array[(*pos)++];
8087
8088     if (*pos >= len) {
8089         *end = UV_MAX;
8090     }
8091     else {
8092         *end = array[(*pos)++] - 1;
8093     }
8094
8095     return TRUE;
8096 }
8097
8098 PERL_STATIC_INLINE UV
8099 S_invlist_highest(pTHX_ SV* const invlist)
8100 {
8101     /* Returns the highest code point that matches an inversion list.  This API
8102      * has an ambiguity, as it returns 0 under either the highest is actually
8103      * 0, or if the list is empty.  If this distinction matters to you, check
8104      * for emptiness before calling this function */
8105
8106     UV len = invlist_len(invlist);
8107     UV *array;
8108
8109     PERL_ARGS_ASSERT_INVLIST_HIGHEST;
8110
8111     if (len == 0) {
8112         return 0;
8113     }
8114
8115     array = invlist_array(invlist);
8116
8117     /* The last element in the array in the inversion list always starts a
8118      * range that goes to infinity.  That range may be for code points that are
8119      * matched in the inversion list, or it may be for ones that aren't
8120      * matched.  In the latter case, the highest code point in the set is one
8121      * less than the beginning of this range; otherwise it is the final element
8122      * of this range: infinity */
8123     return (ELEMENT_RANGE_MATCHES_INVLIST(len - 1))
8124            ? UV_MAX
8125            : array[len - 1] - 1;
8126 }
8127
8128 #ifndef PERL_IN_XSUB_RE
8129 SV *
8130 Perl__invlist_contents(pTHX_ SV* const invlist)
8131 {
8132     /* Get the contents of an inversion list into a string SV so that they can
8133      * be printed out.  It uses the format traditionally done for debug tracing
8134      */
8135
8136     UV start, end;
8137     SV* output = newSVpvs("\n");
8138
8139     PERL_ARGS_ASSERT__INVLIST_CONTENTS;
8140
8141     invlist_iterinit(invlist);
8142     while (invlist_iternext(invlist, &start, &end)) {
8143         if (end == UV_MAX) {
8144             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\tINFINITY\n", start);
8145         }
8146         else if (end != start) {
8147             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\t%04"UVXf"\n",
8148                     start,       end);
8149         }
8150         else {
8151             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\n", start);
8152         }
8153     }
8154
8155     return output;
8156 }
8157 #endif
8158
8159 #if 0
8160 void
8161 S_invlist_dump(pTHX_ SV* const invlist, const char * const header)
8162 {
8163     /* Dumps out the ranges in an inversion list.  The string 'header'
8164      * if present is output on a line before the first range */
8165
8166     UV start, end;
8167
8168     if (header && strlen(header)) {
8169         PerlIO_printf(Perl_debug_log, "%s\n", header);
8170     }
8171     invlist_iterinit(invlist);
8172     while (invlist_iternext(invlist, &start, &end)) {
8173         if (end == UV_MAX) {
8174             PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. INFINITY\n", start);
8175         }
8176         else {
8177             PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. 0x%04"UVXf"\n", start, end);
8178         }
8179     }
8180 }
8181 #endif
8182
8183 #undef HEADER_LENGTH
8184 #undef INVLIST_INITIAL_LENGTH
8185 #undef TO_INTERNAL_SIZE
8186 #undef FROM_INTERNAL_SIZE
8187 #undef INVLIST_LEN_OFFSET
8188 #undef INVLIST_ZERO_OFFSET
8189 #undef INVLIST_ITER_OFFSET
8190 #undef INVLIST_VERSION_ID
8191
8192 /* End of inversion list object */
8193
8194 /*
8195  - reg - regular expression, i.e. main body or parenthesized thing
8196  *
8197  * Caller must absorb opening parenthesis.
8198  *
8199  * Combining parenthesis handling with the base level of regular expression
8200  * is a trifle forced, but the need to tie the tails of the branches to what
8201  * follows makes it hard to avoid.
8202  */
8203 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
8204 #ifdef DEBUGGING
8205 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
8206 #else
8207 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
8208 #endif
8209
8210 STATIC regnode *
8211 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
8212     /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
8213 {
8214     dVAR;
8215     register regnode *ret;              /* Will be the head of the group. */
8216     register regnode *br;
8217     register regnode *lastbr;
8218     register regnode *ender = NULL;
8219     register I32 parno = 0;
8220     I32 flags;
8221     U32 oregflags = RExC_flags;
8222     bool have_branch = 0;
8223     bool is_open = 0;
8224     I32 freeze_paren = 0;
8225     I32 after_freeze = 0;
8226
8227     /* for (?g), (?gc), and (?o) warnings; warning
8228        about (?c) will warn about (?g) -- japhy    */
8229
8230 #define WASTED_O  0x01
8231 #define WASTED_G  0x02
8232 #define WASTED_C  0x04
8233 #define WASTED_GC (0x02|0x04)
8234     I32 wastedflags = 0x00;
8235
8236     char * parse_start = RExC_parse; /* MJD */
8237     char * const oregcomp_parse = RExC_parse;
8238
8239     GET_RE_DEBUG_FLAGS_DECL;
8240
8241     PERL_ARGS_ASSERT_REG;
8242     DEBUG_PARSE("reg ");
8243
8244     *flagp = 0;                         /* Tentatively. */
8245
8246
8247     /* Make an OPEN node, if parenthesized. */
8248     if (paren) {
8249         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
8250             char *start_verb = RExC_parse;
8251             STRLEN verb_len = 0;
8252             char *start_arg = NULL;
8253             unsigned char op = 0;
8254             int argok = 1;
8255             int internal_argval = 0; /* internal_argval is only useful if !argok */
8256             while ( *RExC_parse && *RExC_parse != ')' ) {
8257                 if ( *RExC_parse == ':' ) {
8258                     start_arg = RExC_parse + 1;
8259                     break;
8260                 }
8261                 RExC_parse++;
8262             }
8263             ++start_verb;
8264             verb_len = RExC_parse - start_verb;
8265             if ( start_arg ) {
8266                 RExC_parse++;
8267                 while ( *RExC_parse && *RExC_parse != ')' ) 
8268                     RExC_parse++;
8269                 if ( *RExC_parse != ')' ) 
8270                     vFAIL("Unterminated verb pattern argument");
8271                 if ( RExC_parse == start_arg )
8272                     start_arg = NULL;
8273             } else {
8274                 if ( *RExC_parse != ')' )
8275                     vFAIL("Unterminated verb pattern");
8276             }
8277             
8278             switch ( *start_verb ) {
8279             case 'A':  /* (*ACCEPT) */
8280                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
8281                     op = ACCEPT;
8282                     internal_argval = RExC_nestroot;
8283                 }
8284                 break;
8285             case 'C':  /* (*COMMIT) */
8286                 if ( memEQs(start_verb,verb_len,"COMMIT") )
8287                     op = COMMIT;
8288                 break;
8289             case 'F':  /* (*FAIL) */
8290                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
8291                     op = OPFAIL;
8292                     argok = 0;
8293                 }
8294                 break;
8295             case ':':  /* (*:NAME) */
8296             case 'M':  /* (*MARK:NAME) */
8297                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
8298                     op = MARKPOINT;
8299                     argok = -1;
8300                 }
8301                 break;
8302             case 'P':  /* (*PRUNE) */
8303                 if ( memEQs(start_verb,verb_len,"PRUNE") )
8304                     op = PRUNE;
8305                 break;
8306             case 'S':   /* (*SKIP) */  
8307                 if ( memEQs(start_verb,verb_len,"SKIP") ) 
8308                     op = SKIP;
8309                 break;
8310             case 'T':  /* (*THEN) */
8311                 /* [19:06] <TimToady> :: is then */
8312                 if ( memEQs(start_verb,verb_len,"THEN") ) {
8313                     op = CUTGROUP;
8314                     RExC_seen |= REG_SEEN_CUTGROUP;
8315                 }
8316                 break;
8317             }
8318             if ( ! op ) {
8319                 RExC_parse++;
8320                 vFAIL3("Unknown verb pattern '%.*s'",
8321                     verb_len, start_verb);
8322             }
8323             if ( argok ) {
8324                 if ( start_arg && internal_argval ) {
8325                     vFAIL3("Verb pattern '%.*s' may not have an argument",
8326                         verb_len, start_verb); 
8327                 } else if ( argok < 0 && !start_arg ) {
8328                     vFAIL3("Verb pattern '%.*s' has a mandatory argument",
8329                         verb_len, start_verb);    
8330                 } else {
8331                     ret = reganode(pRExC_state, op, internal_argval);
8332                     if ( ! internal_argval && ! SIZE_ONLY ) {
8333                         if (start_arg) {
8334                             SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
8335                             ARG(ret) = add_data( pRExC_state, 1, "S" );
8336                             RExC_rxi->data->data[ARG(ret)]=(void*)sv;
8337                             ret->flags = 0;
8338                         } else {
8339                             ret->flags = 1; 
8340                         }
8341                     }               
8342                 }
8343                 if (!internal_argval)
8344                     RExC_seen |= REG_SEEN_VERBARG;
8345             } else if ( start_arg ) {
8346                 vFAIL3("Verb pattern '%.*s' may not have an argument",
8347                         verb_len, start_verb);    
8348             } else {
8349                 ret = reg_node(pRExC_state, op);
8350             }
8351             nextchar(pRExC_state);
8352             return ret;
8353         } else 
8354         if (*RExC_parse == '?') { /* (?...) */
8355             bool is_logical = 0;
8356             const char * const seqstart = RExC_parse;
8357             bool has_use_defaults = FALSE;
8358
8359             RExC_parse++;
8360             paren = *RExC_parse++;
8361             ret = NULL;                 /* For look-ahead/behind. */
8362             switch (paren) {
8363
8364             case 'P':   /* (?P...) variants for those used to PCRE/Python */
8365                 paren = *RExC_parse++;
8366                 if ( paren == '<')         /* (?P<...>) named capture */
8367                     goto named_capture;
8368                 else if (paren == '>') {   /* (?P>name) named recursion */
8369                     goto named_recursion;
8370                 }
8371                 else if (paren == '=') {   /* (?P=...)  named backref */
8372                     /* this pretty much dupes the code for \k<NAME> in regatom(), if
8373                        you change this make sure you change that */
8374                     char* name_start = RExC_parse;
8375                     U32 num = 0;
8376                     SV *sv_dat = reg_scan_name(pRExC_state,
8377                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8378                     if (RExC_parse == name_start || *RExC_parse != ')')
8379                         vFAIL2("Sequence %.3s... not terminated",parse_start);
8380
8381                     if (!SIZE_ONLY) {
8382                         num = add_data( pRExC_state, 1, "S" );
8383                         RExC_rxi->data->data[num]=(void*)sv_dat;
8384                         SvREFCNT_inc_simple_void(sv_dat);
8385                     }
8386                     RExC_sawback = 1;
8387                     ret = reganode(pRExC_state,
8388                                    ((! FOLD)
8389                                      ? NREF
8390                                      : (MORE_ASCII_RESTRICTED)
8391                                        ? NREFFA
8392                                        : (AT_LEAST_UNI_SEMANTICS)
8393                                          ? NREFFU
8394                                          : (LOC)
8395                                            ? NREFFL
8396                                            : NREFF),
8397                                     num);
8398                     *flagp |= HASWIDTH;
8399
8400                     Set_Node_Offset(ret, parse_start+1);
8401                     Set_Node_Cur_Length(ret); /* MJD */
8402
8403                     nextchar(pRExC_state);
8404                     return ret;
8405                 }
8406                 RExC_parse++;
8407                 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8408                 /*NOTREACHED*/
8409             case '<':           /* (?<...) */
8410                 if (*RExC_parse == '!')
8411                     paren = ',';
8412                 else if (*RExC_parse != '=') 
8413               named_capture:
8414                 {               /* (?<...>) */
8415                     char *name_start;
8416                     SV *svname;
8417                     paren= '>';
8418             case '\'':          /* (?'...') */
8419                     name_start= RExC_parse;
8420                     svname = reg_scan_name(pRExC_state,
8421                         SIZE_ONLY ?  /* reverse test from the others */
8422                         REG_RSN_RETURN_NAME : 
8423                         REG_RSN_RETURN_NULL);
8424                     if (RExC_parse == name_start) {
8425                         RExC_parse++;
8426                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8427                         /*NOTREACHED*/
8428                     }
8429                     if (*RExC_parse != paren)
8430                         vFAIL2("Sequence (?%c... not terminated",
8431                             paren=='>' ? '<' : paren);
8432                     if (SIZE_ONLY) {
8433                         HE *he_str;
8434                         SV *sv_dat = NULL;
8435                         if (!svname) /* shouldn't happen */
8436                             Perl_croak(aTHX_
8437                                 "panic: reg_scan_name returned NULL");
8438                         if (!RExC_paren_names) {
8439                             RExC_paren_names= newHV();
8440                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
8441 #ifdef DEBUGGING
8442                             RExC_paren_name_list= newAV();
8443                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
8444 #endif
8445                         }
8446                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
8447                         if ( he_str )
8448                             sv_dat = HeVAL(he_str);
8449                         if ( ! sv_dat ) {
8450                             /* croak baby croak */
8451                             Perl_croak(aTHX_
8452                                 "panic: paren_name hash element allocation failed");
8453                         } else if ( SvPOK(sv_dat) ) {
8454                             /* (?|...) can mean we have dupes so scan to check
8455                                its already been stored. Maybe a flag indicating
8456                                we are inside such a construct would be useful,
8457                                but the arrays are likely to be quite small, so
8458                                for now we punt -- dmq */
8459                             IV count = SvIV(sv_dat);
8460                             I32 *pv = (I32*)SvPVX(sv_dat);
8461                             IV i;
8462                             for ( i = 0 ; i < count ; i++ ) {
8463                                 if ( pv[i] == RExC_npar ) {
8464                                     count = 0;
8465                                     break;
8466                                 }
8467                             }
8468                             if ( count ) {
8469                                 pv = (I32*)SvGROW(sv_dat, SvCUR(sv_dat) + sizeof(I32)+1);
8470                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
8471                                 pv[count] = RExC_npar;
8472                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
8473                             }
8474                         } else {
8475                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
8476                             sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
8477                             SvIOK_on(sv_dat);
8478                             SvIV_set(sv_dat, 1);
8479                         }
8480 #ifdef DEBUGGING
8481                         /* Yes this does cause a memory leak in debugging Perls */
8482                         if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
8483                             SvREFCNT_dec(svname);
8484 #endif
8485
8486                         /*sv_dump(sv_dat);*/
8487                     }
8488                     nextchar(pRExC_state);
8489                     paren = 1;
8490                     goto capturing_parens;
8491                 }
8492                 RExC_seen |= REG_SEEN_LOOKBEHIND;
8493                 RExC_in_lookbehind++;
8494                 RExC_parse++;
8495             case '=':           /* (?=...) */
8496                 RExC_seen_zerolen++;
8497                 break;
8498             case '!':           /* (?!...) */
8499                 RExC_seen_zerolen++;
8500                 if (*RExC_parse == ')') {
8501                     ret=reg_node(pRExC_state, OPFAIL);
8502                     nextchar(pRExC_state);
8503                     return ret;
8504                 }
8505                 break;
8506             case '|':           /* (?|...) */
8507                 /* branch reset, behave like a (?:...) except that
8508                    buffers in alternations share the same numbers */
8509                 paren = ':'; 
8510                 after_freeze = freeze_paren = RExC_npar;
8511                 break;
8512             case ':':           /* (?:...) */
8513             case '>':           /* (?>...) */
8514                 break;
8515             case '$':           /* (?$...) */
8516             case '@':           /* (?@...) */
8517                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
8518                 break;
8519             case '#':           /* (?#...) */
8520                 while (*RExC_parse && *RExC_parse != ')')
8521                     RExC_parse++;
8522                 if (*RExC_parse != ')')
8523                     FAIL("Sequence (?#... not terminated");
8524                 nextchar(pRExC_state);
8525                 *flagp = TRYAGAIN;
8526                 return NULL;
8527             case '0' :           /* (?0) */
8528             case 'R' :           /* (?R) */
8529                 if (*RExC_parse != ')')
8530                     FAIL("Sequence (?R) not terminated");
8531                 ret = reg_node(pRExC_state, GOSTART);
8532                 *flagp |= POSTPONED;
8533                 nextchar(pRExC_state);
8534                 return ret;
8535                 /*notreached*/
8536             { /* named and numeric backreferences */
8537                 I32 num;
8538             case '&':            /* (?&NAME) */
8539                 parse_start = RExC_parse - 1;
8540               named_recursion:
8541                 {
8542                     SV *sv_dat = reg_scan_name(pRExC_state,
8543                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8544                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
8545                 }
8546                 goto gen_recurse_regop;
8547                 assert(0); /* NOT REACHED */
8548             case '+':
8549                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
8550                     RExC_parse++;
8551                     vFAIL("Illegal pattern");
8552                 }
8553                 goto parse_recursion;
8554                 /* NOT REACHED*/
8555             case '-': /* (?-1) */
8556                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
8557                     RExC_parse--; /* rewind to let it be handled later */
8558                     goto parse_flags;
8559                 } 
8560                 /*FALLTHROUGH */
8561             case '1': case '2': case '3': case '4': /* (?1) */
8562             case '5': case '6': case '7': case '8': case '9':
8563                 RExC_parse--;
8564               parse_recursion:
8565                 num = atoi(RExC_parse);
8566                 parse_start = RExC_parse - 1; /* MJD */
8567                 if (*RExC_parse == '-')
8568                     RExC_parse++;
8569                 while (isDIGIT(*RExC_parse))
8570                         RExC_parse++;
8571                 if (*RExC_parse!=')') 
8572                     vFAIL("Expecting close bracket");
8573
8574               gen_recurse_regop:
8575                 if ( paren == '-' ) {
8576                     /*
8577                     Diagram of capture buffer numbering.
8578                     Top line is the normal capture buffer numbers
8579                     Bottom line is the negative indexing as from
8580                     the X (the (?-2))
8581
8582                     +   1 2    3 4 5 X          6 7
8583                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
8584                     -   5 4    3 2 1 X          x x
8585
8586                     */
8587                     num = RExC_npar + num;
8588                     if (num < 1)  {
8589                         RExC_parse++;
8590                         vFAIL("Reference to nonexistent group");
8591                     }
8592                 } else if ( paren == '+' ) {
8593                     num = RExC_npar + num - 1;
8594                 }
8595
8596                 ret = reganode(pRExC_state, GOSUB, num);
8597                 if (!SIZE_ONLY) {
8598                     if (num > (I32)RExC_rx->nparens) {
8599                         RExC_parse++;
8600                         vFAIL("Reference to nonexistent group");
8601                     }
8602                     ARG2L_SET( ret, RExC_recurse_count++);
8603                     RExC_emit++;
8604                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
8605                         "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
8606                 } else {
8607                     RExC_size++;
8608                 }
8609                 RExC_seen |= REG_SEEN_RECURSE;
8610                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
8611                 Set_Node_Offset(ret, parse_start); /* MJD */
8612
8613                 *flagp |= POSTPONED;
8614                 nextchar(pRExC_state);
8615                 return ret;
8616             } /* named and numeric backreferences */
8617             assert(0); /* NOT REACHED */
8618
8619             case '?':           /* (??...) */
8620                 is_logical = 1;
8621                 if (*RExC_parse != '{') {
8622                     RExC_parse++;
8623                     vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8624                     /*NOTREACHED*/
8625                 }
8626                 *flagp |= POSTPONED;
8627                 paren = *RExC_parse++;
8628                 /* FALL THROUGH */
8629             case '{':           /* (?{...}) */
8630             {
8631                 U32 n = 0;
8632                 struct reg_code_block *cb;
8633
8634                 RExC_seen_zerolen++;
8635
8636                 if (   !pRExC_state->num_code_blocks
8637                     || pRExC_state->code_index >= pRExC_state->num_code_blocks
8638                     || pRExC_state->code_blocks[pRExC_state->code_index].start
8639                         != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
8640                             - RExC_start)
8641                 ) {
8642                     if (RExC_pm_flags & PMf_USE_RE_EVAL)
8643                         FAIL("panic: Sequence (?{...}): no code block found\n");
8644                     FAIL("Eval-group not allowed at runtime, use re 'eval'");
8645                 }
8646                 /* this is a pre-compiled code block (?{...}) */
8647                 cb = &pRExC_state->code_blocks[pRExC_state->code_index];
8648                 RExC_parse = RExC_start + cb->end;
8649                 if (!SIZE_ONLY) {
8650                     OP *o = cb->block;
8651                     if (cb->src_regex) {
8652                         n = add_data(pRExC_state, 2, "rl");
8653                         RExC_rxi->data->data[n] =
8654                             (void*)SvREFCNT_inc((SV*)cb->src_regex);
8655                         RExC_rxi->data->data[n+1] = (void*)o;
8656                     }
8657                     else {
8658                         n = add_data(pRExC_state, 1,
8659                                (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l");
8660                         RExC_rxi->data->data[n] = (void*)o;
8661                     }
8662                 }
8663                 pRExC_state->code_index++;
8664                 nextchar(pRExC_state);
8665
8666                 if (is_logical) {
8667                     regnode *eval;
8668                     ret = reg_node(pRExC_state, LOGICAL);
8669                     eval = reganode(pRExC_state, EVAL, n);
8670                     if (!SIZE_ONLY) {
8671                         ret->flags = 2;
8672                         /* for later propagation into (??{}) return value */
8673                         eval->flags = (U8) (RExC_flags & RXf_PMf_COMPILETIME);
8674                     }
8675                     REGTAIL(pRExC_state, ret, eval);
8676                     /* deal with the length of this later - MJD */
8677                     return ret;
8678                 }
8679                 ret = reganode(pRExC_state, EVAL, n);
8680                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
8681                 Set_Node_Offset(ret, parse_start);
8682                 return ret;
8683             }
8684             case '(':           /* (?(?{...})...) and (?(?=...)...) */
8685             {
8686                 int is_define= 0;
8687                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
8688                     if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
8689                         || RExC_parse[1] == '<'
8690                         || RExC_parse[1] == '{') { /* Lookahead or eval. */
8691                         I32 flag;
8692
8693                         ret = reg_node(pRExC_state, LOGICAL);
8694                         if (!SIZE_ONLY)
8695                             ret->flags = 1;
8696                         REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
8697                         goto insert_if;
8698                     }
8699                 }
8700                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
8701                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
8702                 {
8703                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
8704                     char *name_start= RExC_parse++;
8705                     U32 num = 0;
8706                     SV *sv_dat=reg_scan_name(pRExC_state,
8707                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8708                     if (RExC_parse == name_start || *RExC_parse != ch)
8709                         vFAIL2("Sequence (?(%c... not terminated",
8710                             (ch == '>' ? '<' : ch));
8711                     RExC_parse++;
8712                     if (!SIZE_ONLY) {
8713                         num = add_data( pRExC_state, 1, "S" );
8714                         RExC_rxi->data->data[num]=(void*)sv_dat;
8715                         SvREFCNT_inc_simple_void(sv_dat);
8716                     }
8717                     ret = reganode(pRExC_state,NGROUPP,num);
8718                     goto insert_if_check_paren;
8719                 }
8720                 else if (RExC_parse[0] == 'D' &&
8721                          RExC_parse[1] == 'E' &&
8722                          RExC_parse[2] == 'F' &&
8723                          RExC_parse[3] == 'I' &&
8724                          RExC_parse[4] == 'N' &&
8725                          RExC_parse[5] == 'E')
8726                 {
8727                     ret = reganode(pRExC_state,DEFINEP,0);
8728                     RExC_parse +=6 ;
8729                     is_define = 1;
8730                     goto insert_if_check_paren;
8731                 }
8732                 else if (RExC_parse[0] == 'R') {
8733                     RExC_parse++;
8734                     parno = 0;
8735                     if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
8736                         parno = atoi(RExC_parse++);
8737                         while (isDIGIT(*RExC_parse))
8738                             RExC_parse++;
8739                     } else if (RExC_parse[0] == '&') {
8740                         SV *sv_dat;
8741                         RExC_parse++;
8742                         sv_dat = reg_scan_name(pRExC_state,
8743                             SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8744                         parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
8745                     }
8746                     ret = reganode(pRExC_state,INSUBP,parno); 
8747                     goto insert_if_check_paren;
8748                 }
8749                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
8750                     /* (?(1)...) */
8751                     char c;
8752                     parno = atoi(RExC_parse++);
8753
8754                     while (isDIGIT(*RExC_parse))
8755                         RExC_parse++;
8756                     ret = reganode(pRExC_state, GROUPP, parno);
8757
8758                  insert_if_check_paren:
8759                     if ((c = *nextchar(pRExC_state)) != ')')
8760                         vFAIL("Switch condition not recognized");
8761                   insert_if:
8762                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
8763                     br = regbranch(pRExC_state, &flags, 1,depth+1);
8764                     if (br == NULL)
8765                         br = reganode(pRExC_state, LONGJMP, 0);
8766                     else
8767                         REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
8768                     c = *nextchar(pRExC_state);
8769                     if (flags&HASWIDTH)
8770                         *flagp |= HASWIDTH;
8771                     if (c == '|') {
8772                         if (is_define) 
8773                             vFAIL("(?(DEFINE)....) does not allow branches");
8774                         lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
8775                         regbranch(pRExC_state, &flags, 1,depth+1);
8776                         REGTAIL(pRExC_state, ret, lastbr);
8777                         if (flags&HASWIDTH)
8778                             *flagp |= HASWIDTH;
8779                         c = *nextchar(pRExC_state);
8780                     }
8781                     else
8782                         lastbr = NULL;
8783                     if (c != ')')
8784                         vFAIL("Switch (?(condition)... contains too many branches");
8785                     ender = reg_node(pRExC_state, TAIL);
8786                     REGTAIL(pRExC_state, br, ender);
8787                     if (lastbr) {
8788                         REGTAIL(pRExC_state, lastbr, ender);
8789                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
8790                     }
8791                     else
8792                         REGTAIL(pRExC_state, ret, ender);
8793                     RExC_size++; /* XXX WHY do we need this?!!
8794                                     For large programs it seems to be required
8795                                     but I can't figure out why. -- dmq*/
8796                     return ret;
8797                 }
8798                 else {
8799                     vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
8800                 }
8801             }
8802             case 0:
8803                 RExC_parse--; /* for vFAIL to print correctly */
8804                 vFAIL("Sequence (? incomplete");
8805                 break;
8806             case DEFAULT_PAT_MOD:   /* Use default flags with the exceptions
8807                                        that follow */
8808                 has_use_defaults = TRUE;
8809                 STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
8810                 set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
8811                                                 ? REGEX_UNICODE_CHARSET
8812                                                 : REGEX_DEPENDS_CHARSET);
8813                 goto parse_flags;
8814             default:
8815                 --RExC_parse;
8816                 parse_flags:      /* (?i) */  
8817             {
8818                 U32 posflags = 0, negflags = 0;
8819                 U32 *flagsp = &posflags;
8820                 char has_charset_modifier = '\0';
8821                 regex_charset cs = get_regex_charset(RExC_flags);
8822                 if (cs == REGEX_DEPENDS_CHARSET
8823                     && (RExC_utf8 || RExC_uni_semantics))
8824                 {
8825                     cs = REGEX_UNICODE_CHARSET;
8826                 }
8827
8828                 while (*RExC_parse) {
8829                     /* && strchr("iogcmsx", *RExC_parse) */
8830                     /* (?g), (?gc) and (?o) are useless here
8831                        and must be globally applied -- japhy */
8832                     switch (*RExC_parse) {
8833                     CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
8834                     case LOCALE_PAT_MOD:
8835                         if (has_charset_modifier) {
8836                             goto excess_modifier;
8837                         }
8838                         else if (flagsp == &negflags) {
8839                             goto neg_modifier;
8840                         }
8841                         cs = REGEX_LOCALE_CHARSET;
8842                         has_charset_modifier = LOCALE_PAT_MOD;
8843                         RExC_contains_locale = 1;
8844                         break;
8845                     case UNICODE_PAT_MOD:
8846                         if (has_charset_modifier) {
8847                             goto excess_modifier;
8848                         }
8849                         else if (flagsp == &negflags) {
8850                             goto neg_modifier;
8851                         }
8852                         cs = REGEX_UNICODE_CHARSET;
8853                         has_charset_modifier = UNICODE_PAT_MOD;
8854                         break;
8855                     case ASCII_RESTRICT_PAT_MOD:
8856                         if (flagsp == &negflags) {
8857                             goto neg_modifier;
8858                         }
8859                         if (has_charset_modifier) {
8860                             if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
8861                                 goto excess_modifier;
8862                             }
8863                             /* Doubled modifier implies more restricted */
8864                             cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
8865                         }
8866                         else {
8867                             cs = REGEX_ASCII_RESTRICTED_CHARSET;
8868                         }
8869                         has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
8870                         break;
8871                     case DEPENDS_PAT_MOD:
8872                         if (has_use_defaults) {
8873                             goto fail_modifiers;
8874                         }
8875                         else if (flagsp == &negflags) {
8876                             goto neg_modifier;
8877                         }
8878                         else if (has_charset_modifier) {
8879                             goto excess_modifier;
8880                         }
8881
8882                         /* The dual charset means unicode semantics if the
8883                          * pattern (or target, not known until runtime) are
8884                          * utf8, or something in the pattern indicates unicode
8885                          * semantics */
8886                         cs = (RExC_utf8 || RExC_uni_semantics)
8887                              ? REGEX_UNICODE_CHARSET
8888                              : REGEX_DEPENDS_CHARSET;
8889                         has_charset_modifier = DEPENDS_PAT_MOD;
8890                         break;
8891                     excess_modifier:
8892                         RExC_parse++;
8893                         if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
8894                             vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
8895                         }
8896                         else if (has_charset_modifier == *(RExC_parse - 1)) {
8897                             vFAIL2("Regexp modifier \"%c\" may not appear twice", *(RExC_parse - 1));
8898                         }
8899                         else {
8900                             vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
8901                         }
8902                         /*NOTREACHED*/
8903                     neg_modifier:
8904                         RExC_parse++;
8905                         vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", *(RExC_parse - 1));
8906                         /*NOTREACHED*/
8907                     case ONCE_PAT_MOD: /* 'o' */
8908                     case GLOBAL_PAT_MOD: /* 'g' */
8909                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
8910                             const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
8911                             if (! (wastedflags & wflagbit) ) {
8912                                 wastedflags |= wflagbit;
8913                                 vWARN5(
8914                                     RExC_parse + 1,
8915                                     "Useless (%s%c) - %suse /%c modifier",
8916                                     flagsp == &negflags ? "?-" : "?",
8917                                     *RExC_parse,
8918                                     flagsp == &negflags ? "don't " : "",
8919                                     *RExC_parse
8920                                 );
8921                             }
8922                         }
8923                         break;
8924                         
8925                     case CONTINUE_PAT_MOD: /* 'c' */
8926                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
8927                             if (! (wastedflags & WASTED_C) ) {
8928                                 wastedflags |= WASTED_GC;
8929                                 vWARN3(
8930                                     RExC_parse + 1,
8931                                     "Useless (%sc) - %suse /gc modifier",
8932                                     flagsp == &negflags ? "?-" : "?",
8933                                     flagsp == &negflags ? "don't " : ""
8934                                 );
8935                             }
8936                         }
8937                         break;
8938                     case KEEPCOPY_PAT_MOD: /* 'p' */
8939                         if (flagsp == &negflags) {
8940                             if (SIZE_ONLY)
8941                                 ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
8942                         } else {
8943                             *flagsp |= RXf_PMf_KEEPCOPY;
8944                         }
8945                         break;
8946                     case '-':
8947                         /* A flag is a default iff it is following a minus, so
8948                          * if there is a minus, it means will be trying to
8949                          * re-specify a default which is an error */
8950                         if (has_use_defaults || flagsp == &negflags) {
8951             fail_modifiers:
8952                             RExC_parse++;
8953                             vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8954                             /*NOTREACHED*/
8955                         }
8956                         flagsp = &negflags;
8957                         wastedflags = 0;  /* reset so (?g-c) warns twice */
8958                         break;
8959                     case ':':
8960                         paren = ':';
8961                         /*FALLTHROUGH*/
8962                     case ')':
8963                         RExC_flags |= posflags;
8964                         RExC_flags &= ~negflags;
8965                         set_regex_charset(&RExC_flags, cs);
8966                         if (paren != ':') {
8967                             oregflags |= posflags;
8968                             oregflags &= ~negflags;
8969                             set_regex_charset(&oregflags, cs);
8970                         }
8971                         nextchar(pRExC_state);
8972                         if (paren != ':') {
8973                             *flagp = TRYAGAIN;
8974                             return NULL;
8975                         } else {
8976                             ret = NULL;
8977                             goto parse_rest;
8978                         }
8979                         /*NOTREACHED*/
8980                     default:
8981                         RExC_parse++;
8982                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8983                         /*NOTREACHED*/
8984                     }                           
8985                     ++RExC_parse;
8986                 }
8987             }} /* one for the default block, one for the switch */
8988         }
8989         else {                  /* (...) */
8990           capturing_parens:
8991             parno = RExC_npar;
8992             RExC_npar++;
8993             
8994             ret = reganode(pRExC_state, OPEN, parno);
8995             if (!SIZE_ONLY ){
8996                 if (!RExC_nestroot) 
8997                     RExC_nestroot = parno;
8998                 if (RExC_seen & REG_SEEN_RECURSE
8999                     && !RExC_open_parens[parno-1])
9000                 {
9001                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
9002                         "Setting open paren #%"IVdf" to %d\n", 
9003                         (IV)parno, REG_NODE_NUM(ret)));
9004                     RExC_open_parens[parno-1]= ret;
9005                 }
9006             }
9007             Set_Node_Length(ret, 1); /* MJD */
9008             Set_Node_Offset(ret, RExC_parse); /* MJD */
9009             is_open = 1;
9010         }
9011     }
9012     else                        /* ! paren */
9013         ret = NULL;
9014    
9015    parse_rest:
9016     /* Pick up the branches, linking them together. */
9017     parse_start = RExC_parse;   /* MJD */
9018     br = regbranch(pRExC_state, &flags, 1,depth+1);
9019
9020     /*     branch_len = (paren != 0); */
9021
9022     if (br == NULL)
9023         return(NULL);
9024     if (*RExC_parse == '|') {
9025         if (!SIZE_ONLY && RExC_extralen) {
9026             reginsert(pRExC_state, BRANCHJ, br, depth+1);
9027         }
9028         else {                  /* MJD */
9029             reginsert(pRExC_state, BRANCH, br, depth+1);
9030             Set_Node_Length(br, paren != 0);
9031             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
9032         }
9033         have_branch = 1;
9034         if (SIZE_ONLY)
9035             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
9036     }
9037     else if (paren == ':') {
9038         *flagp |= flags&SIMPLE;
9039     }
9040     if (is_open) {                              /* Starts with OPEN. */
9041         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
9042     }
9043     else if (paren != '?')              /* Not Conditional */
9044         ret = br;
9045     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
9046     lastbr = br;
9047     while (*RExC_parse == '|') {
9048         if (!SIZE_ONLY && RExC_extralen) {
9049             ender = reganode(pRExC_state, LONGJMP,0);
9050             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
9051         }
9052         if (SIZE_ONLY)
9053             RExC_extralen += 2;         /* Account for LONGJMP. */
9054         nextchar(pRExC_state);
9055         if (freeze_paren) {
9056             if (RExC_npar > after_freeze)
9057                 after_freeze = RExC_npar;
9058             RExC_npar = freeze_paren;       
9059         }
9060         br = regbranch(pRExC_state, &flags, 0, depth+1);
9061
9062         if (br == NULL)
9063             return(NULL);
9064         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
9065         lastbr = br;
9066         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
9067     }
9068
9069     if (have_branch || paren != ':') {
9070         /* Make a closing node, and hook it on the end. */
9071         switch (paren) {
9072         case ':':
9073             ender = reg_node(pRExC_state, TAIL);
9074             break;
9075         case 1:
9076             ender = reganode(pRExC_state, CLOSE, parno);
9077             if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
9078                 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
9079                         "Setting close paren #%"IVdf" to %d\n", 
9080                         (IV)parno, REG_NODE_NUM(ender)));
9081                 RExC_close_parens[parno-1]= ender;
9082                 if (RExC_nestroot == parno) 
9083                     RExC_nestroot = 0;
9084             }       
9085             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
9086             Set_Node_Length(ender,1); /* MJD */
9087             break;
9088         case '<':
9089         case ',':
9090         case '=':
9091         case '!':
9092             *flagp &= ~HASWIDTH;
9093             /* FALL THROUGH */
9094         case '>':
9095             ender = reg_node(pRExC_state, SUCCEED);
9096             break;
9097         case 0:
9098             ender = reg_node(pRExC_state, END);
9099             if (!SIZE_ONLY) {
9100                 assert(!RExC_opend); /* there can only be one! */
9101                 RExC_opend = ender;
9102             }
9103             break;
9104         }
9105         DEBUG_PARSE_r(if (!SIZE_ONLY) {
9106             SV * const mysv_val1=sv_newmortal();
9107             SV * const mysv_val2=sv_newmortal();
9108             DEBUG_PARSE_MSG("lsbr");
9109             regprop(RExC_rx, mysv_val1, lastbr);
9110             regprop(RExC_rx, mysv_val2, ender);
9111             PerlIO_printf(Perl_debug_log, "~ tying lastbr %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
9112                           SvPV_nolen_const(mysv_val1),
9113                           (IV)REG_NODE_NUM(lastbr),
9114                           SvPV_nolen_const(mysv_val2),
9115                           (IV)REG_NODE_NUM(ender),
9116                           (IV)(ender - lastbr)
9117             );
9118         });
9119         REGTAIL(pRExC_state, lastbr, ender);
9120
9121         if (have_branch && !SIZE_ONLY) {
9122             char is_nothing= 1;
9123             if (depth==1)
9124                 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
9125
9126             /* Hook the tails of the branches to the closing node. */
9127             for (br = ret; br; br = regnext(br)) {
9128                 const U8 op = PL_regkind[OP(br)];
9129                 if (op == BRANCH) {
9130                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
9131                     if (OP(NEXTOPER(br)) != NOTHING || regnext(NEXTOPER(br)) != ender)
9132                         is_nothing= 0;
9133                 }
9134                 else if (op == BRANCHJ) {
9135                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
9136                     /* for now we always disable this optimisation * /
9137                     if (OP(NEXTOPER(NEXTOPER(br))) != NOTHING || regnext(NEXTOPER(NEXTOPER(br))) != ender)
9138                     */
9139                         is_nothing= 0;
9140                 }
9141             }
9142             if (is_nothing) {
9143                 br= PL_regkind[OP(ret)] != BRANCH ? regnext(ret) : ret;
9144                 DEBUG_PARSE_r(if (!SIZE_ONLY) {
9145                     SV * const mysv_val1=sv_newmortal();
9146                     SV * const mysv_val2=sv_newmortal();
9147                     DEBUG_PARSE_MSG("NADA");
9148                     regprop(RExC_rx, mysv_val1, ret);
9149                     regprop(RExC_rx, mysv_val2, ender);
9150                     PerlIO_printf(Perl_debug_log, "~ converting ret %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
9151                                   SvPV_nolen_const(mysv_val1),
9152                                   (IV)REG_NODE_NUM(ret),
9153                                   SvPV_nolen_const(mysv_val2),
9154                                   (IV)REG_NODE_NUM(ender),
9155                                   (IV)(ender - ret)
9156                     );
9157                 });
9158                 OP(br)= NOTHING;
9159                 if (OP(ender) == TAIL) {
9160                     NEXT_OFF(br)= 0;
9161                     RExC_emit= br + 1;
9162                 } else {
9163                     regnode *opt;
9164                     for ( opt= br + 1; opt < ender ; opt++ )
9165                         OP(opt)= OPTIMIZED;
9166                     NEXT_OFF(br)= ender - br;
9167                 }
9168             }
9169         }
9170     }
9171
9172     {
9173         const char *p;
9174         static const char parens[] = "=!<,>";
9175
9176         if (paren && (p = strchr(parens, paren))) {
9177             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
9178             int flag = (p - parens) > 1;
9179
9180             if (paren == '>')
9181                 node = SUSPEND, flag = 0;
9182             reginsert(pRExC_state, node,ret, depth+1);
9183             Set_Node_Cur_Length(ret);
9184             Set_Node_Offset(ret, parse_start + 1);
9185             ret->flags = flag;
9186             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
9187         }
9188     }
9189
9190     /* Check for proper termination. */
9191     if (paren) {
9192         RExC_flags = oregflags;
9193         if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
9194             RExC_parse = oregcomp_parse;
9195             vFAIL("Unmatched (");
9196         }
9197     }
9198     else if (!paren && RExC_parse < RExC_end) {
9199         if (*RExC_parse == ')') {
9200             RExC_parse++;
9201             vFAIL("Unmatched )");
9202         }
9203         else
9204             FAIL("Junk on end of regexp");      /* "Can't happen". */
9205         assert(0); /* NOTREACHED */
9206     }
9207
9208     if (RExC_in_lookbehind) {
9209         RExC_in_lookbehind--;
9210     }
9211     if (after_freeze > RExC_npar)
9212         RExC_npar = after_freeze;
9213     return(ret);
9214 }
9215
9216 /*
9217  - regbranch - one alternative of an | operator
9218  *
9219  * Implements the concatenation operator.
9220  */
9221 STATIC regnode *
9222 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
9223 {
9224     dVAR;
9225     register regnode *ret;
9226     register regnode *chain = NULL;
9227     register regnode *latest;
9228     I32 flags = 0, c = 0;
9229     GET_RE_DEBUG_FLAGS_DECL;
9230
9231     PERL_ARGS_ASSERT_REGBRANCH;
9232
9233     DEBUG_PARSE("brnc");
9234
9235     if (first)
9236         ret = NULL;
9237     else {
9238         if (!SIZE_ONLY && RExC_extralen)
9239             ret = reganode(pRExC_state, BRANCHJ,0);
9240         else {
9241             ret = reg_node(pRExC_state, BRANCH);
9242             Set_Node_Length(ret, 1);
9243         }
9244     }
9245
9246     if (!first && SIZE_ONLY)
9247         RExC_extralen += 1;                     /* BRANCHJ */
9248
9249     *flagp = WORST;                     /* Tentatively. */
9250
9251     RExC_parse--;
9252     nextchar(pRExC_state);
9253     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
9254         flags &= ~TRYAGAIN;
9255         latest = regpiece(pRExC_state, &flags,depth+1);
9256         if (latest == NULL) {
9257             if (flags & TRYAGAIN)
9258                 continue;
9259             return(NULL);
9260         }
9261         else if (ret == NULL)
9262             ret = latest;
9263         *flagp |= flags&(HASWIDTH|POSTPONED);
9264         if (chain == NULL)      /* First piece. */
9265             *flagp |= flags&SPSTART;
9266         else {
9267             RExC_naughty++;
9268             REGTAIL(pRExC_state, chain, latest);
9269         }
9270         chain = latest;
9271         c++;
9272     }
9273     if (chain == NULL) {        /* Loop ran zero times. */
9274         chain = reg_node(pRExC_state, NOTHING);
9275         if (ret == NULL)
9276             ret = chain;
9277     }
9278     if (c == 1) {
9279         *flagp |= flags&SIMPLE;
9280     }
9281
9282     return ret;
9283 }
9284
9285 /*
9286  - regpiece - something followed by possible [*+?]
9287  *
9288  * Note that the branching code sequences used for ? and the general cases
9289  * of * and + are somewhat optimized:  they use the same NOTHING node as
9290  * both the endmarker for their branch list and the body of the last branch.
9291  * It might seem that this node could be dispensed with entirely, but the
9292  * endmarker role is not redundant.
9293  */
9294 STATIC regnode *
9295 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
9296 {
9297     dVAR;
9298     register regnode *ret;
9299     register char op;
9300     register char *next;
9301     I32 flags;
9302     const char * const origparse = RExC_parse;
9303     I32 min;
9304     I32 max = REG_INFTY;
9305 #ifdef RE_TRACK_PATTERN_OFFSETS
9306     char *parse_start;
9307 #endif
9308     const char *maxpos = NULL;
9309     GET_RE_DEBUG_FLAGS_DECL;
9310
9311     PERL_ARGS_ASSERT_REGPIECE;
9312
9313     DEBUG_PARSE("piec");
9314
9315     ret = regatom(pRExC_state, &flags,depth+1);
9316     if (ret == NULL) {
9317         if (flags & TRYAGAIN)
9318             *flagp |= TRYAGAIN;
9319         return(NULL);
9320     }
9321
9322     op = *RExC_parse;
9323
9324     if (op == '{' && regcurly(RExC_parse)) {
9325         maxpos = NULL;
9326 #ifdef RE_TRACK_PATTERN_OFFSETS
9327         parse_start = RExC_parse; /* MJD */
9328 #endif
9329         next = RExC_parse + 1;
9330         while (isDIGIT(*next) || *next == ',') {
9331             if (*next == ',') {
9332                 if (maxpos)
9333                     break;
9334                 else
9335                     maxpos = next;
9336             }
9337             next++;
9338         }
9339         if (*next == '}') {             /* got one */
9340             if (!maxpos)
9341                 maxpos = next;
9342             RExC_parse++;
9343             min = atoi(RExC_parse);
9344             if (*maxpos == ',')
9345                 maxpos++;
9346             else
9347                 maxpos = RExC_parse;
9348             max = atoi(maxpos);
9349             if (!max && *maxpos != '0')
9350                 max = REG_INFTY;                /* meaning "infinity" */
9351             else if (max >= REG_INFTY)
9352                 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
9353             RExC_parse = next;
9354             nextchar(pRExC_state);
9355
9356         do_curly:
9357             if ((flags&SIMPLE)) {
9358                 RExC_naughty += 2 + RExC_naughty / 2;
9359                 reginsert(pRExC_state, CURLY, ret, depth+1);
9360                 Set_Node_Offset(ret, parse_start+1); /* MJD */
9361                 Set_Node_Cur_Length(ret);
9362             }
9363             else {
9364                 regnode * const w = reg_node(pRExC_state, WHILEM);
9365
9366                 w->flags = 0;
9367                 REGTAIL(pRExC_state, ret, w);
9368                 if (!SIZE_ONLY && RExC_extralen) {
9369                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
9370                     reginsert(pRExC_state, NOTHING,ret, depth+1);
9371                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
9372                 }
9373                 reginsert(pRExC_state, CURLYX,ret, depth+1);
9374                                 /* MJD hk */
9375                 Set_Node_Offset(ret, parse_start+1);
9376                 Set_Node_Length(ret,
9377                                 op == '{' ? (RExC_parse - parse_start) : 1);
9378
9379                 if (!SIZE_ONLY && RExC_extralen)
9380                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
9381                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
9382                 if (SIZE_ONLY)
9383                     RExC_whilem_seen++, RExC_extralen += 3;
9384                 RExC_naughty += 4 + RExC_naughty;       /* compound interest */
9385             }
9386             ret->flags = 0;
9387
9388             if (min > 0)
9389                 *flagp = WORST;
9390             if (max > 0)
9391                 *flagp |= HASWIDTH;
9392             if (max < min)
9393                 vFAIL("Can't do {n,m} with n > m");
9394             if (!SIZE_ONLY) {
9395                 ARG1_SET(ret, (U16)min);
9396                 ARG2_SET(ret, (U16)max);
9397             }
9398
9399             goto nest_check;
9400         }
9401     }
9402
9403     if (!ISMULT1(op)) {
9404         *flagp = flags;
9405         return(ret);
9406     }
9407
9408 #if 0                           /* Now runtime fix should be reliable. */
9409
9410     /* if this is reinstated, don't forget to put this back into perldiag:
9411
9412             =item Regexp *+ operand could be empty at {#} in regex m/%s/
9413
9414            (F) The part of the regexp subject to either the * or + quantifier
9415            could match an empty string. The {#} shows in the regular
9416            expression about where the problem was discovered.
9417
9418     */
9419
9420     if (!(flags&HASWIDTH) && op != '?')
9421       vFAIL("Regexp *+ operand could be empty");
9422 #endif
9423
9424 #ifdef RE_TRACK_PATTERN_OFFSETS
9425     parse_start = RExC_parse;
9426 #endif
9427     nextchar(pRExC_state);
9428
9429     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
9430
9431     if (op == '*' && (flags&SIMPLE)) {
9432         reginsert(pRExC_state, STAR, ret, depth+1);
9433         ret->flags = 0;
9434         RExC_naughty += 4;
9435     }
9436     else if (op == '*') {
9437         min = 0;
9438         goto do_curly;
9439     }
9440     else if (op == '+' && (flags&SIMPLE)) {
9441         reginsert(pRExC_state, PLUS, ret, depth+1);
9442         ret->flags = 0;
9443         RExC_naughty += 3;
9444     }
9445     else if (op == '+') {
9446         min = 1;
9447         goto do_curly;
9448     }
9449     else if (op == '?') {
9450         min = 0; max = 1;
9451         goto do_curly;
9452     }
9453   nest_check:
9454     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
9455         ckWARN3reg(RExC_parse,
9456                    "%.*s matches null string many times",
9457                    (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
9458                    origparse);
9459     }
9460
9461     if (RExC_parse < RExC_end && *RExC_parse == '?') {
9462         nextchar(pRExC_state);
9463         reginsert(pRExC_state, MINMOD, ret, depth+1);
9464         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
9465     }
9466 #ifndef REG_ALLOW_MINMOD_SUSPEND
9467     else
9468 #endif
9469     if (RExC_parse < RExC_end && *RExC_parse == '+') {
9470         regnode *ender;
9471         nextchar(pRExC_state);
9472         ender = reg_node(pRExC_state, SUCCEED);
9473         REGTAIL(pRExC_state, ret, ender);
9474         reginsert(pRExC_state, SUSPEND, ret, depth+1);
9475         ret->flags = 0;
9476         ender = reg_node(pRExC_state, TAIL);
9477         REGTAIL(pRExC_state, ret, ender);
9478         /*ret= ender;*/
9479     }
9480
9481     if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
9482         RExC_parse++;
9483         vFAIL("Nested quantifiers");
9484     }
9485
9486     return(ret);
9487 }
9488
9489
9490 /* reg_namedseq(pRExC_state,UVp, UV depth)
9491    
9492    This is expected to be called by a parser routine that has 
9493    recognized '\N' and needs to handle the rest. RExC_parse is
9494    expected to point at the first char following the N at the time
9495    of the call.
9496
9497    The \N may be inside (indicated by valuep not being NULL) or outside a
9498    character class.
9499
9500    \N may begin either a named sequence, or if outside a character class, mean
9501    to match a non-newline.  For non single-quoted regexes, the tokenizer has
9502    attempted to decide which, and in the case of a named sequence converted it
9503    into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...},
9504    where c1... are the characters in the sequence.  For single-quoted regexes,
9505    the tokenizer passes the \N sequence through unchanged; this code will not
9506    attempt to determine this nor expand those.  The net effect is that if the
9507    beginning of the passed-in pattern isn't '{U+' or there is no '}', it
9508    signals that this \N occurrence means to match a non-newline.
9509    
9510    Only the \N{U+...} form should occur in a character class, for the same
9511    reason that '.' inside a character class means to just match a period: it
9512    just doesn't make sense.
9513    
9514    If valuep is non-null then it is assumed that we are parsing inside 
9515    of a charclass definition and the first codepoint in the resolved
9516    string is returned via *valuep and the routine will return NULL. 
9517    In this mode if a multichar string is returned from the charnames 
9518    handler, a warning will be issued, and only the first char in the 
9519    sequence will be examined. If the string returned is zero length
9520    then the value of *valuep is undefined and NON-NULL will 
9521    be returned to indicate failure. (This will NOT be a valid pointer 
9522    to a regnode.)
9523    
9524    If valuep is null then it is assumed that we are parsing normal text and a
9525    new EXACT node is inserted into the program containing the resolved string,
9526    and a pointer to the new node is returned.  But if the string is zero length
9527    a NOTHING node is emitted instead.
9528
9529    On success RExC_parse is set to the char following the endbrace.
9530    Parsing failures will generate a fatal error via vFAIL(...)
9531  */
9532 STATIC regnode *
9533 S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep, I32 *flagp, U32 depth)
9534 {
9535     char * endbrace;    /* '}' following the name */
9536     regnode *ret = NULL;
9537     char* p;
9538
9539     GET_RE_DEBUG_FLAGS_DECL;
9540  
9541     PERL_ARGS_ASSERT_REG_NAMEDSEQ;
9542
9543     GET_RE_DEBUG_FLAGS;
9544
9545     /* The [^\n] meaning of \N ignores spaces and comments under the /x
9546      * modifier.  The other meaning does not */
9547     p = (RExC_flags & RXf_PMf_EXTENDED)
9548         ? regwhite( pRExC_state, RExC_parse )
9549         : RExC_parse;
9550    
9551     /* Disambiguate between \N meaning a named character versus \N meaning
9552      * [^\n].  The former is assumed when it can't be the latter. */
9553     if (*p != '{' || regcurly(p)) {
9554         RExC_parse = p;
9555         if (valuep) {
9556             /* no bare \N in a charclass */
9557             vFAIL("\\N in a character class must be a named character: \\N{...}");
9558         }
9559         nextchar(pRExC_state);
9560         ret = reg_node(pRExC_state, REG_ANY);
9561         *flagp |= HASWIDTH|SIMPLE;
9562         RExC_naughty++;
9563         RExC_parse--;
9564         Set_Node_Length(ret, 1); /* MJD */
9565         return ret;
9566     }
9567
9568     /* Here, we have decided it should be a named sequence */
9569
9570     /* The test above made sure that the next real character is a '{', but
9571      * under the /x modifier, it could be separated by space (or a comment and
9572      * \n) and this is not allowed (for consistency with \x{...} and the
9573      * tokenizer handling of \N{NAME}). */
9574     if (*RExC_parse != '{') {
9575         vFAIL("Missing braces on \\N{}");
9576     }
9577
9578     RExC_parse++;       /* Skip past the '{' */
9579
9580     if (! (endbrace = strchr(RExC_parse, '}')) /* no trailing brace */
9581         || ! (endbrace == RExC_parse            /* nothing between the {} */
9582               || (endbrace - RExC_parse >= 2    /* U+ (bad hex is checked below */
9583                   && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg) */
9584     {
9585         if (endbrace) RExC_parse = endbrace;    /* position msg's '<--HERE' */
9586         vFAIL("\\N{NAME} must be resolved by the lexer");
9587     }
9588
9589     if (endbrace == RExC_parse) {   /* empty: \N{} */
9590         if (! valuep) {
9591             RExC_parse = endbrace + 1;  
9592             return reg_node(pRExC_state,NOTHING);
9593         }
9594
9595         if (SIZE_ONLY) {
9596             ckWARNreg(RExC_parse,
9597                     "Ignoring zero length \\N{} in character class"
9598             );
9599             RExC_parse = endbrace + 1;  
9600         }
9601         *valuep = 0;
9602         return (regnode *) &RExC_parse; /* Invalid regnode pointer */
9603     }
9604
9605     REQUIRE_UTF8;       /* named sequences imply Unicode semantics */
9606     RExC_parse += 2;    /* Skip past the 'U+' */
9607
9608     if (valuep) {   /* In a bracketed char class */
9609         /* We only pay attention to the first char of 
9610         multichar strings being returned. I kinda wonder
9611         if this makes sense as it does change the behaviour
9612         from earlier versions, OTOH that behaviour was broken
9613         as well. XXX Solution is to recharacterize as
9614         [rest-of-class]|multi1|multi2... */
9615
9616         STRLEN length_of_hex;
9617         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
9618             | PERL_SCAN_DISALLOW_PREFIX
9619             | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
9620     
9621         char * endchar = RExC_parse + strcspn(RExC_parse, ".}");
9622         if (endchar < endbrace) {
9623             ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
9624         }
9625
9626         length_of_hex = (STRLEN)(endchar - RExC_parse);
9627         *valuep = grok_hex(RExC_parse, &length_of_hex, &flags, NULL);
9628
9629         /* The tokenizer should have guaranteed validity, but it's possible to
9630          * bypass it by using single quoting, so check */
9631         if (length_of_hex == 0
9632             || length_of_hex != (STRLEN)(endchar - RExC_parse) )
9633         {
9634             RExC_parse += length_of_hex;        /* Includes all the valid */
9635             RExC_parse += (RExC_orig_utf8)      /* point to after 1st invalid */
9636                             ? UTF8SKIP(RExC_parse)
9637                             : 1;
9638             /* Guard against malformed utf8 */
9639             if (RExC_parse >= endchar) RExC_parse = endchar;
9640             vFAIL("Invalid hexadecimal number in \\N{U+...}");
9641         }    
9642
9643         RExC_parse = endbrace + 1;
9644         if (endchar == endbrace) return NULL;
9645
9646         ret = (regnode *) &RExC_parse;  /* Invalid regnode pointer */
9647     }
9648     else {      /* Not a char class */
9649
9650         /* What is done here is to convert this to a sub-pattern of the form
9651          * (?:\x{char1}\x{char2}...)
9652          * and then call reg recursively.  That way, it retains its atomicness,
9653          * while not having to worry about special handling that some code
9654          * points may have.  toke.c has converted the original Unicode values
9655          * to native, so that we can just pass on the hex values unchanged.  We
9656          * do have to set a flag to keep recoding from happening in the
9657          * recursion */
9658
9659         SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP);
9660         STRLEN len;
9661         char *endchar;      /* Points to '.' or '}' ending cur char in the input
9662                                stream */
9663         char *orig_end = RExC_end;
9664
9665         while (RExC_parse < endbrace) {
9666
9667             /* Code points are separated by dots.  If none, there is only one
9668              * code point, and is terminated by the brace */
9669             endchar = RExC_parse + strcspn(RExC_parse, ".}");
9670
9671             /* Convert to notation the rest of the code understands */
9672             sv_catpv(substitute_parse, "\\x{");
9673             sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
9674             sv_catpv(substitute_parse, "}");
9675
9676             /* Point to the beginning of the next character in the sequence. */
9677             RExC_parse = endchar + 1;
9678         }
9679         sv_catpv(substitute_parse, ")");
9680
9681         RExC_parse = SvPV(substitute_parse, len);
9682
9683         /* Don't allow empty number */
9684         if (len < 8) {
9685             vFAIL("Invalid hexadecimal number in \\N{U+...}");
9686         }
9687         RExC_end = RExC_parse + len;
9688
9689         /* The values are Unicode, and therefore not subject to recoding */
9690         RExC_override_recoding = 1;
9691
9692         ret = reg(pRExC_state, 1, flagp, depth+1);
9693
9694         RExC_parse = endbrace;
9695         RExC_end = orig_end;
9696         RExC_override_recoding = 0;
9697
9698         nextchar(pRExC_state);
9699     }
9700
9701     return ret;
9702 }
9703
9704
9705 /*
9706  * reg_recode
9707  *
9708  * It returns the code point in utf8 for the value in *encp.
9709  *    value: a code value in the source encoding
9710  *    encp:  a pointer to an Encode object
9711  *
9712  * If the result from Encode is not a single character,
9713  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
9714  */
9715 STATIC UV
9716 S_reg_recode(pTHX_ const char value, SV **encp)
9717 {
9718     STRLEN numlen = 1;
9719     SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP);
9720     const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
9721     const STRLEN newlen = SvCUR(sv);
9722     UV uv = UNICODE_REPLACEMENT;
9723
9724     PERL_ARGS_ASSERT_REG_RECODE;
9725
9726     if (newlen)
9727         uv = SvUTF8(sv)
9728              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
9729              : *(U8*)s;
9730
9731     if (!newlen || numlen != newlen) {
9732         uv = UNICODE_REPLACEMENT;
9733         *encp = NULL;
9734     }
9735     return uv;
9736 }
9737
9738
9739 /*
9740  - regatom - the lowest level
9741
9742    Try to identify anything special at the start of the pattern. If there
9743    is, then handle it as required. This may involve generating a single regop,
9744    such as for an assertion; or it may involve recursing, such as to
9745    handle a () structure.
9746
9747    If the string doesn't start with something special then we gobble up
9748    as much literal text as we can.
9749
9750    Once we have been able to handle whatever type of thing started the
9751    sequence, we return.
9752
9753    Note: we have to be careful with escapes, as they can be both literal
9754    and special, and in the case of \10 and friends, context determines which.
9755
9756    A summary of the code structure is:
9757
9758    switch (first_byte) {
9759         cases for each special:
9760             handle this special;
9761             break;
9762         case '\\':
9763             switch (2nd byte) {
9764                 cases for each unambiguous special:
9765                     handle this special;
9766                     break;
9767                 cases for each ambigous special/literal:
9768                     disambiguate;
9769                     if (special)  handle here
9770                     else goto defchar;
9771                 default: // unambiguously literal:
9772                     goto defchar;
9773             }
9774         default:  // is a literal char
9775             // FALL THROUGH
9776         defchar:
9777             create EXACTish node for literal;
9778             while (more input and node isn't full) {
9779                 switch (input_byte) {
9780                    cases for each special;
9781                        make sure parse pointer is set so that the next call to
9782                            regatom will see this special first
9783                        goto loopdone; // EXACTish node terminated by prev. char
9784                    default:
9785                        append char to EXACTISH node;
9786                 }
9787                 get next input byte;
9788             }
9789         loopdone:
9790    }
9791    return the generated node;
9792
9793    Specifically there are two separate switches for handling
9794    escape sequences, with the one for handling literal escapes requiring
9795    a dummy entry for all of the special escapes that are actually handled
9796    by the other.
9797 */
9798
9799 STATIC regnode *
9800 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
9801 {
9802     dVAR;
9803     register regnode *ret = NULL;
9804     I32 flags;
9805     char *parse_start = RExC_parse;
9806     U8 op;
9807     GET_RE_DEBUG_FLAGS_DECL;
9808     DEBUG_PARSE("atom");
9809     *flagp = WORST;             /* Tentatively. */
9810
9811     PERL_ARGS_ASSERT_REGATOM;
9812
9813 tryagain:
9814     switch ((U8)*RExC_parse) {
9815     case '^':
9816         RExC_seen_zerolen++;
9817         nextchar(pRExC_state);
9818         if (RExC_flags & RXf_PMf_MULTILINE)
9819             ret = reg_node(pRExC_state, MBOL);
9820         else if (RExC_flags & RXf_PMf_SINGLELINE)
9821             ret = reg_node(pRExC_state, SBOL);
9822         else
9823             ret = reg_node(pRExC_state, BOL);
9824         Set_Node_Length(ret, 1); /* MJD */
9825         break;
9826     case '$':
9827         nextchar(pRExC_state);
9828         if (*RExC_parse)
9829             RExC_seen_zerolen++;
9830         if (RExC_flags & RXf_PMf_MULTILINE)
9831             ret = reg_node(pRExC_state, MEOL);
9832         else if (RExC_flags & RXf_PMf_SINGLELINE)
9833             ret = reg_node(pRExC_state, SEOL);
9834         else
9835             ret = reg_node(pRExC_state, EOL);
9836         Set_Node_Length(ret, 1); /* MJD */
9837         break;
9838     case '.':
9839         nextchar(pRExC_state);
9840         if (RExC_flags & RXf_PMf_SINGLELINE)
9841             ret = reg_node(pRExC_state, SANY);
9842         else
9843             ret = reg_node(pRExC_state, REG_ANY);
9844         *flagp |= HASWIDTH|SIMPLE;
9845         RExC_naughty++;
9846         Set_Node_Length(ret, 1); /* MJD */
9847         break;
9848     case '[':
9849     {
9850         char * const oregcomp_parse = ++RExC_parse;
9851         ret = regclass(pRExC_state,depth+1);
9852         if (*RExC_parse != ']') {
9853             RExC_parse = oregcomp_parse;
9854             vFAIL("Unmatched [");
9855         }
9856         nextchar(pRExC_state);
9857         *flagp |= HASWIDTH|SIMPLE;
9858         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
9859         break;
9860     }
9861     case '(':
9862         nextchar(pRExC_state);
9863         ret = reg(pRExC_state, 1, &flags,depth+1);
9864         if (ret == NULL) {
9865                 if (flags & TRYAGAIN) {
9866                     if (RExC_parse == RExC_end) {
9867                          /* Make parent create an empty node if needed. */
9868                         *flagp |= TRYAGAIN;
9869                         return(NULL);
9870                     }
9871                     goto tryagain;
9872                 }
9873                 return(NULL);
9874         }
9875         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
9876         break;
9877     case '|':
9878     case ')':
9879         if (flags & TRYAGAIN) {
9880             *flagp |= TRYAGAIN;
9881             return NULL;
9882         }
9883         vFAIL("Internal urp");
9884                                 /* Supposed to be caught earlier. */
9885         break;
9886     case '?':
9887     case '+':
9888     case '*':
9889         RExC_parse++;
9890         vFAIL("Quantifier follows nothing");
9891         break;
9892     case '\\':
9893         /* Special Escapes
9894
9895            This switch handles escape sequences that resolve to some kind
9896            of special regop and not to literal text. Escape sequnces that
9897            resolve to literal text are handled below in the switch marked
9898            "Literal Escapes".
9899
9900            Every entry in this switch *must* have a corresponding entry
9901            in the literal escape switch. However, the opposite is not
9902            required, as the default for this switch is to jump to the
9903            literal text handling code.
9904         */
9905         switch ((U8)*++RExC_parse) {
9906         /* Special Escapes */
9907         case 'A':
9908             RExC_seen_zerolen++;
9909             ret = reg_node(pRExC_state, SBOL);
9910             *flagp |= SIMPLE;
9911             goto finish_meta_pat;
9912         case 'G':
9913             ret = reg_node(pRExC_state, GPOS);
9914             RExC_seen |= REG_SEEN_GPOS;
9915             *flagp |= SIMPLE;
9916             goto finish_meta_pat;
9917         case 'K':
9918             RExC_seen_zerolen++;
9919             ret = reg_node(pRExC_state, KEEPS);
9920             *flagp |= SIMPLE;
9921             /* XXX:dmq : disabling in-place substitution seems to
9922              * be necessary here to avoid cases of memory corruption, as
9923              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
9924              */
9925             RExC_seen |= REG_SEEN_LOOKBEHIND;
9926             goto finish_meta_pat;
9927         case 'Z':
9928             ret = reg_node(pRExC_state, SEOL);
9929             *flagp |= SIMPLE;
9930             RExC_seen_zerolen++;                /* Do not optimize RE away */
9931             goto finish_meta_pat;
9932         case 'z':
9933             ret = reg_node(pRExC_state, EOS);
9934             *flagp |= SIMPLE;
9935             RExC_seen_zerolen++;                /* Do not optimize RE away */
9936             goto finish_meta_pat;
9937         case 'C':
9938             ret = reg_node(pRExC_state, CANY);
9939             RExC_seen |= REG_SEEN_CANY;
9940             *flagp |= HASWIDTH|SIMPLE;
9941             goto finish_meta_pat;
9942         case 'X':
9943             ret = reg_node(pRExC_state, CLUMP);
9944             *flagp |= HASWIDTH;
9945             goto finish_meta_pat;
9946         case 'w':
9947             op = ALNUM + get_regex_charset(RExC_flags);
9948             if (op > ALNUMA) {  /* /aa is same as /a */
9949                 op = ALNUMA;
9950             }
9951             ret = reg_node(pRExC_state, op);
9952             *flagp |= HASWIDTH|SIMPLE;
9953             goto finish_meta_pat;
9954         case 'W':
9955             op = NALNUM + get_regex_charset(RExC_flags);
9956             if (op > NALNUMA) { /* /aa is same as /a */
9957                 op = NALNUMA;
9958             }
9959             ret = reg_node(pRExC_state, op);
9960             *flagp |= HASWIDTH|SIMPLE;
9961             goto finish_meta_pat;
9962         case 'b':
9963             RExC_seen_zerolen++;
9964             RExC_seen |= REG_SEEN_LOOKBEHIND;
9965             op = BOUND + get_regex_charset(RExC_flags);
9966             if (op > BOUNDA) {  /* /aa is same as /a */
9967                 op = BOUNDA;
9968             }
9969             ret = reg_node(pRExC_state, op);
9970             FLAGS(ret) = get_regex_charset(RExC_flags);
9971             *flagp |= SIMPLE;
9972             goto finish_meta_pat;
9973         case 'B':
9974             RExC_seen_zerolen++;
9975             RExC_seen |= REG_SEEN_LOOKBEHIND;
9976             op = NBOUND + get_regex_charset(RExC_flags);
9977             if (op > NBOUNDA) { /* /aa is same as /a */
9978                 op = NBOUNDA;
9979             }
9980             ret = reg_node(pRExC_state, op);
9981             FLAGS(ret) = get_regex_charset(RExC_flags);
9982             *flagp |= SIMPLE;
9983             goto finish_meta_pat;
9984         case 's':
9985             op = SPACE + get_regex_charset(RExC_flags);
9986             if (op > SPACEA) {  /* /aa is same as /a */
9987                 op = SPACEA;
9988             }
9989             ret = reg_node(pRExC_state, op);
9990             *flagp |= HASWIDTH|SIMPLE;
9991             goto finish_meta_pat;
9992         case 'S':
9993             op = NSPACE + get_regex_charset(RExC_flags);
9994             if (op > NSPACEA) { /* /aa is same as /a */
9995                 op = NSPACEA;
9996             }
9997             ret = reg_node(pRExC_state, op);
9998             *flagp |= HASWIDTH|SIMPLE;
9999             goto finish_meta_pat;
10000         case 'D':
10001             op = NDIGIT;
10002             goto join_D_and_d;
10003         case 'd':
10004             op = DIGIT;
10005         join_D_and_d:
10006             {
10007                 U8 offset = get_regex_charset(RExC_flags);
10008                 if (offset == REGEX_UNICODE_CHARSET) {
10009                     offset = REGEX_DEPENDS_CHARSET;
10010                 }
10011                 else if (offset == REGEX_ASCII_MORE_RESTRICTED_CHARSET) {
10012                     offset = REGEX_ASCII_RESTRICTED_CHARSET;
10013                 }
10014                 op += offset;
10015             }
10016             ret = reg_node(pRExC_state, op);
10017             *flagp |= HASWIDTH|SIMPLE;
10018             goto finish_meta_pat;
10019         case 'R':
10020             ret = reg_node(pRExC_state, LNBREAK);
10021             *flagp |= HASWIDTH|SIMPLE;
10022             goto finish_meta_pat;
10023         case 'h':
10024             ret = reg_node(pRExC_state, HORIZWS);
10025             *flagp |= HASWIDTH|SIMPLE;
10026             goto finish_meta_pat;
10027         case 'H':
10028             ret = reg_node(pRExC_state, NHORIZWS);
10029             *flagp |= HASWIDTH|SIMPLE;
10030             goto finish_meta_pat;
10031         case 'v':
10032             ret = reg_node(pRExC_state, VERTWS);
10033             *flagp |= HASWIDTH|SIMPLE;
10034             goto finish_meta_pat;
10035         case 'V':
10036             ret = reg_node(pRExC_state, NVERTWS);
10037             *flagp |= HASWIDTH|SIMPLE;
10038          finish_meta_pat:           
10039             nextchar(pRExC_state);
10040             Set_Node_Length(ret, 2); /* MJD */
10041             break;          
10042         case 'p':
10043         case 'P':
10044             {
10045                 char* const oldregxend = RExC_end;
10046 #ifdef DEBUGGING
10047                 char* parse_start = RExC_parse - 2;
10048 #endif
10049
10050                 if (RExC_parse[1] == '{') {
10051                   /* a lovely hack--pretend we saw [\pX] instead */
10052                     RExC_end = strchr(RExC_parse, '}');
10053                     if (!RExC_end) {
10054                         const U8 c = (U8)*RExC_parse;
10055                         RExC_parse += 2;
10056                         RExC_end = oldregxend;
10057                         vFAIL2("Missing right brace on \\%c{}", c);
10058                     }
10059                     RExC_end++;
10060                 }
10061                 else {
10062                     RExC_end = RExC_parse + 2;
10063                     if (RExC_end > oldregxend)
10064                         RExC_end = oldregxend;
10065                 }
10066                 RExC_parse--;
10067
10068                 ret = regclass(pRExC_state,depth+1);
10069
10070                 RExC_end = oldregxend;
10071                 RExC_parse--;
10072
10073                 Set_Node_Offset(ret, parse_start + 2);
10074                 Set_Node_Cur_Length(ret);
10075                 nextchar(pRExC_state);
10076                 *flagp |= HASWIDTH|SIMPLE;
10077             }
10078             break;
10079         case 'N': 
10080             /* Handle \N and \N{NAME} here and not below because it can be
10081             multicharacter. join_exact() will join them up later on. 
10082             Also this makes sure that things like /\N{BLAH}+/ and 
10083             \N{BLAH} being multi char Just Happen. dmq*/
10084             ++RExC_parse;
10085             ret= reg_namedseq(pRExC_state, NULL, flagp, depth);
10086             break;
10087         case 'k':    /* Handle \k<NAME> and \k'NAME' */
10088         parse_named_seq:
10089         {   
10090             char ch= RExC_parse[1];         
10091             if (ch != '<' && ch != '\'' && ch != '{') {
10092                 RExC_parse++;
10093                 vFAIL2("Sequence %.2s... not terminated",parse_start);
10094             } else {
10095                 /* this pretty much dupes the code for (?P=...) in reg(), if
10096                    you change this make sure you change that */
10097                 char* name_start = (RExC_parse += 2);
10098                 U32 num = 0;
10099                 SV *sv_dat = reg_scan_name(pRExC_state,
10100                     SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
10101                 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
10102                 if (RExC_parse == name_start || *RExC_parse != ch)
10103                     vFAIL2("Sequence %.3s... not terminated",parse_start);
10104
10105                 if (!SIZE_ONLY) {
10106                     num = add_data( pRExC_state, 1, "S" );
10107                     RExC_rxi->data->data[num]=(void*)sv_dat;
10108                     SvREFCNT_inc_simple_void(sv_dat);
10109                 }
10110
10111                 RExC_sawback = 1;
10112                 ret = reganode(pRExC_state,
10113                                ((! FOLD)
10114                                  ? NREF
10115                                  : (MORE_ASCII_RESTRICTED)
10116                                    ? NREFFA
10117                                    : (AT_LEAST_UNI_SEMANTICS)
10118                                      ? NREFFU
10119                                      : (LOC)
10120                                        ? NREFFL
10121                                        : NREFF),
10122                                 num);
10123                 *flagp |= HASWIDTH;
10124
10125                 /* override incorrect value set in reganode MJD */
10126                 Set_Node_Offset(ret, parse_start+1);
10127                 Set_Node_Cur_Length(ret); /* MJD */
10128                 nextchar(pRExC_state);
10129
10130             }
10131             break;
10132         }
10133         case 'g': 
10134         case '1': case '2': case '3': case '4':
10135         case '5': case '6': case '7': case '8': case '9':
10136             {
10137                 I32 num;
10138                 bool isg = *RExC_parse == 'g';
10139                 bool isrel = 0; 
10140                 bool hasbrace = 0;
10141                 if (isg) {
10142                     RExC_parse++;
10143                     if (*RExC_parse == '{') {
10144                         RExC_parse++;
10145                         hasbrace = 1;
10146                     }
10147                     if (*RExC_parse == '-') {
10148                         RExC_parse++;
10149                         isrel = 1;
10150                     }
10151                     if (hasbrace && !isDIGIT(*RExC_parse)) {
10152                         if (isrel) RExC_parse--;
10153                         RExC_parse -= 2;                            
10154                         goto parse_named_seq;
10155                 }   }
10156                 num = atoi(RExC_parse);
10157                 if (isg && num == 0)
10158                     vFAIL("Reference to invalid group 0");
10159                 if (isrel) {
10160                     num = RExC_npar - num;
10161                     if (num < 1)
10162                         vFAIL("Reference to nonexistent or unclosed group");
10163                 }
10164                 if (!isg && num > 9 && num >= RExC_npar)
10165                     /* Probably a character specified in octal, e.g. \35 */
10166                     goto defchar;
10167                 else {
10168                     char * const parse_start = RExC_parse - 1; /* MJD */
10169                     while (isDIGIT(*RExC_parse))
10170                         RExC_parse++;
10171                     if (parse_start == RExC_parse - 1) 
10172                         vFAIL("Unterminated \\g... pattern");
10173                     if (hasbrace) {
10174                         if (*RExC_parse != '}') 
10175                             vFAIL("Unterminated \\g{...} pattern");
10176                         RExC_parse++;
10177                     }    
10178                     if (!SIZE_ONLY) {
10179                         if (num > (I32)RExC_rx->nparens)
10180                             vFAIL("Reference to nonexistent group");
10181                     }
10182                     RExC_sawback = 1;
10183                     ret = reganode(pRExC_state,
10184                                    ((! FOLD)
10185                                      ? REF
10186                                      : (MORE_ASCII_RESTRICTED)
10187                                        ? REFFA
10188                                        : (AT_LEAST_UNI_SEMANTICS)
10189                                          ? REFFU
10190                                          : (LOC)
10191                                            ? REFFL
10192                                            : REFF),
10193                                     num);
10194                     *flagp |= HASWIDTH;
10195
10196                     /* override incorrect value set in reganode MJD */
10197                     Set_Node_Offset(ret, parse_start+1);
10198                     Set_Node_Cur_Length(ret); /* MJD */
10199                     RExC_parse--;
10200                     nextchar(pRExC_state);
10201                 }
10202             }
10203             break;
10204         case '\0':
10205             if (RExC_parse >= RExC_end)
10206                 FAIL("Trailing \\");
10207             /* FALL THROUGH */
10208         default:
10209             /* Do not generate "unrecognized" warnings here, we fall
10210                back into the quick-grab loop below */
10211             parse_start--;
10212             goto defchar;
10213         }
10214         break;
10215
10216     case '#':
10217         if (RExC_flags & RXf_PMf_EXTENDED) {
10218             if ( reg_skipcomment( pRExC_state ) )
10219                 goto tryagain;
10220         }
10221         /* FALL THROUGH */
10222
10223     default:
10224
10225             parse_start = RExC_parse - 1;
10226
10227             RExC_parse++;
10228
10229         defchar: {
10230             register STRLEN len;
10231             register UV ender;
10232             register char *p;
10233             char *s;
10234             STRLEN foldlen;
10235             U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
10236             U8 node_type;
10237
10238             /* Is this a LATIN LOWER CASE SHARP S in an EXACTFU node?  If so,
10239              * it is folded to 'ss' even if not utf8 */
10240             bool is_exactfu_sharp_s;
10241
10242             ender = 0;
10243             if (! FOLD) {
10244                 node_type = EXACT;
10245             }
10246             else {
10247                 node_type = get_regex_charset(RExC_flags);
10248                 if (node_type >= REGEX_ASCII_RESTRICTED_CHARSET) {
10249                     node_type--; /* /a is same as /u, and map /aa's offset to
10250                                     what /a's would have been, so there is no
10251                                     hole */
10252                 }
10253                 node_type += EXACTF;
10254             }
10255             ret = reg_node(pRExC_state, node_type);
10256             s = STRING(ret);
10257
10258             /* XXX The node can hold up to 255 bytes, yet this only goes to
10259              * 127.  I (khw) do not know why.  Keeping it somewhat less than
10260              * 255 allows us to not have to worry about overflow due to
10261              * converting to utf8 and fold expansion, but that value is
10262              * 255-UTF8_MAXBYTES_CASE.  join_exact() may join adjacent nodes
10263              * split up by this limit into a single one using the real max of
10264              * 255.  Even at 127, this breaks under rare circumstances.  If
10265              * folding, we do not want to split a node at a character that is a
10266              * non-final in a multi-char fold, as an input string could just
10267              * happen to want to match across the node boundary.  The join
10268              * would solve that problem if the join actually happens.  But a
10269              * series of more than two nodes in a row each of 127 would cause
10270              * the first join to succeed to get to 254, but then there wouldn't
10271              * be room for the next one, which could at be one of those split
10272              * multi-char folds.  I don't know of any fool-proof solution.  One
10273              * could back off to end with only a code point that isn't such a
10274              * non-final, but it is possible for there not to be any in the
10275              * entire node. */
10276             for (len = 0, p = RExC_parse - 1;
10277                  len < 127 && p < RExC_end;
10278                  len++)
10279             {
10280                 char * const oldp = p;
10281
10282                 if (RExC_flags & RXf_PMf_EXTENDED)
10283                     p = regwhite( pRExC_state, p );
10284                 switch ((U8)*p) {
10285                 case '^':
10286                 case '$':
10287                 case '.':
10288                 case '[':
10289                 case '(':
10290                 case ')':
10291                 case '|':
10292                     goto loopdone;
10293                 case '\\':
10294                     /* Literal Escapes Switch
10295
10296                        This switch is meant to handle escape sequences that
10297                        resolve to a literal character.
10298
10299                        Every escape sequence that represents something
10300                        else, like an assertion or a char class, is handled
10301                        in the switch marked 'Special Escapes' above in this
10302                        routine, but also has an entry here as anything that
10303                        isn't explicitly mentioned here will be treated as
10304                        an unescaped equivalent literal.
10305                     */
10306
10307                     switch ((U8)*++p) {
10308                     /* These are all the special escapes. */
10309                     case 'A':             /* Start assertion */
10310                     case 'b': case 'B':   /* Word-boundary assertion*/
10311                     case 'C':             /* Single char !DANGEROUS! */
10312                     case 'd': case 'D':   /* digit class */
10313                     case 'g': case 'G':   /* generic-backref, pos assertion */
10314                     case 'h': case 'H':   /* HORIZWS */
10315                     case 'k': case 'K':   /* named backref, keep marker */
10316                     case 'N':             /* named char sequence */
10317                     case 'p': case 'P':   /* Unicode property */
10318                               case 'R':   /* LNBREAK */
10319                     case 's': case 'S':   /* space class */
10320                     case 'v': case 'V':   /* VERTWS */
10321                     case 'w': case 'W':   /* word class */
10322                     case 'X':             /* eXtended Unicode "combining character sequence" */
10323                     case 'z': case 'Z':   /* End of line/string assertion */
10324                         --p;
10325                         goto loopdone;
10326
10327                     /* Anything after here is an escape that resolves to a
10328                        literal. (Except digits, which may or may not)
10329                      */
10330                     case 'n':
10331                         ender = '\n';
10332                         p++;
10333                         break;
10334                     case 'r':
10335                         ender = '\r';
10336                         p++;
10337                         break;
10338                     case 't':
10339                         ender = '\t';
10340                         p++;
10341                         break;
10342                     case 'f':
10343                         ender = '\f';
10344                         p++;
10345                         break;
10346                     case 'e':
10347                           ender = ASCII_TO_NATIVE('\033');
10348                         p++;
10349                         break;
10350                     case 'a':
10351                           ender = ASCII_TO_NATIVE('\007');
10352                         p++;
10353                         break;
10354                     case 'o':
10355                         {
10356                             STRLEN brace_len = len;
10357                             UV result;
10358                             const char* error_msg;
10359
10360                             bool valid = grok_bslash_o(p,
10361                                                        &result,
10362                                                        &brace_len,
10363                                                        &error_msg,
10364                                                        1);
10365                             p += brace_len;
10366                             if (! valid) {
10367                                 RExC_parse = p; /* going to die anyway; point
10368                                                    to exact spot of failure */
10369                                 vFAIL(error_msg);
10370                             }
10371                             else
10372                             {
10373                                 ender = result;
10374                             }
10375                             if (PL_encoding && ender < 0x100) {
10376                                 goto recode_encoding;
10377                             }
10378                             if (ender > 0xff) {
10379                                 REQUIRE_UTF8;
10380                             }
10381                             break;
10382                         }
10383                     case 'x':
10384                         {
10385                             STRLEN brace_len = len;
10386                             UV result;
10387                             const char* error_msg;
10388
10389                             bool valid = grok_bslash_x(p,
10390                                                        &result,
10391                                                        &brace_len,
10392                                                        &error_msg,
10393                                                        1);
10394                             p += brace_len;
10395                             if (! valid) {
10396                                 RExC_parse = p; /* going to die anyway; point
10397                                                    to exact spot of failure */
10398                                 vFAIL(error_msg);
10399                             }
10400                             else {
10401                                 ender = result;
10402                             }
10403                             if (PL_encoding && ender < 0x100) {
10404                                 goto recode_encoding;
10405                             }
10406                             if (ender > 0xff) {
10407                                 REQUIRE_UTF8;
10408                             }
10409                             break;
10410                         }
10411                     case 'c':
10412                         p++;
10413                         ender = grok_bslash_c(*p++, UTF, SIZE_ONLY);
10414                         break;
10415                     case '0': case '1': case '2': case '3':case '4':
10416                     case '5': case '6': case '7':
10417                         if (*p == '0' ||
10418                             (isDIGIT(p[1]) && atoi(p) >= RExC_npar))
10419                         {
10420                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
10421                             STRLEN numlen = 3;
10422                             ender = grok_oct(p, &numlen, &flags, NULL);
10423                             if (ender > 0xff) {
10424                                 REQUIRE_UTF8;
10425                             }
10426                             p += numlen;
10427                         }
10428                         else {
10429                             --p;
10430                             goto loopdone;
10431                         }
10432                         if (PL_encoding && ender < 0x100)
10433                             goto recode_encoding;
10434                         break;
10435                     recode_encoding:
10436                         if (! RExC_override_recoding) {
10437                             SV* enc = PL_encoding;
10438                             ender = reg_recode((const char)(U8)ender, &enc);
10439                             if (!enc && SIZE_ONLY)
10440                                 ckWARNreg(p, "Invalid escape in the specified encoding");
10441                             REQUIRE_UTF8;
10442                         }
10443                         break;
10444                     case '\0':
10445                         if (p >= RExC_end)
10446                             FAIL("Trailing \\");
10447                         /* FALL THROUGH */
10448                     default:
10449                         if (!SIZE_ONLY&& isALNUMC(*p)) {
10450                             ckWARN2reg(p + 1, "Unrecognized escape \\%.1s passed through", p);
10451                         }
10452                         goto normal_default;
10453                     }
10454                     break;
10455                 case '{':
10456                     /* Currently we don't warn when the lbrace is at the start
10457                      * of a construct.  This catches it in the middle of a
10458                      * literal string, or when its the first thing after
10459                      * something like "\b" */
10460                     if (! SIZE_ONLY
10461                         && (len || (p > RExC_start && isALPHA_A(*(p -1)))))
10462                     {
10463                         ckWARNregdep(p + 1, "Unescaped left brace in regex is deprecated, passed through");
10464                     }
10465                     /*FALLTHROUGH*/
10466                 default:
10467                   normal_default:
10468                     if (UTF8_IS_START(*p) && UTF) {
10469                         STRLEN numlen;
10470                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
10471                                                &numlen, UTF8_ALLOW_DEFAULT);
10472                         p += numlen;
10473                     }
10474                     else
10475                         ender = (U8) *p++;
10476                     break;
10477                 } /* End of switch on the literal */
10478
10479                 is_exactfu_sharp_s = (node_type == EXACTFU
10480                                       && ender == LATIN_SMALL_LETTER_SHARP_S);
10481                 if ( RExC_flags & RXf_PMf_EXTENDED)
10482                     p = regwhite( pRExC_state, p );
10483                 if ((UTF && FOLD) || is_exactfu_sharp_s) {
10484                     /* Prime the casefolded buffer.  Locale rules, which apply
10485                      * only to code points < 256, aren't known until execution,
10486                      * so for them, just output the original character using
10487                      * utf8.  If we start to fold non-UTF patterns, be sure to
10488                      * update join_exact() */
10489                     if (LOC && ender < 256) {
10490                         if (UNI_IS_INVARIANT(ender)) {
10491                             *tmpbuf = (U8) ender;
10492                             foldlen = 1;
10493                         } else {
10494                             *tmpbuf = UTF8_TWO_BYTE_HI(ender);
10495                             *(tmpbuf + 1) = UTF8_TWO_BYTE_LO(ender);
10496                             foldlen = 2;
10497                         }
10498                     }
10499                     else if (isASCII(ender)) {  /* Note: Here can't also be LOC
10500                                                  */
10501                         ender = toLOWER(ender);
10502                         *tmpbuf = (U8) ender;
10503                         foldlen = 1;
10504                     }
10505                     else if (! MORE_ASCII_RESTRICTED && ! LOC) {
10506
10507                         /* Locale and /aa require more selectivity about the
10508                          * fold, so are handled below.  Otherwise, here, just
10509                          * use the fold */
10510                         ender = toFOLD_uni(ender, tmpbuf, &foldlen);
10511                     }
10512                     else {
10513                         /* Under locale rules or /aa we are not to mix,
10514                          * respectively, ords < 256 or ASCII with non-.  So
10515                          * reject folds that mix them, using only the
10516                          * non-folded code point.  So do the fold to a
10517                          * temporary, and inspect each character in it. */
10518                         U8 trialbuf[UTF8_MAXBYTES_CASE+1];
10519                         U8* s = trialbuf;
10520                         UV tmpender = toFOLD_uni(ender, trialbuf, &foldlen);
10521                         U8* e = s + foldlen;
10522                         bool fold_ok = TRUE;
10523
10524                         while (s < e) {
10525                             if (isASCII(*s)
10526                                 || (LOC && (UTF8_IS_INVARIANT(*s)
10527                                            || UTF8_IS_DOWNGRADEABLE_START(*s))))
10528                             {
10529                                 fold_ok = FALSE;
10530                                 break;
10531                             }
10532                             s += UTF8SKIP(s);
10533                         }
10534                         if (fold_ok) {
10535                             Copy(trialbuf, tmpbuf, foldlen, U8);
10536                             ender = tmpender;
10537                         }
10538                         else {
10539                             uvuni_to_utf8(tmpbuf, ender);
10540                             foldlen = UNISKIP(ender);
10541                         }
10542                     }
10543                 }
10544                 if (p < RExC_end && ISMULT2(p)) { /* Back off on ?+*. */
10545                     if (len)
10546                         p = oldp;
10547                     else if (UTF || is_exactfu_sharp_s) {
10548                          if (FOLD) {
10549                               /* Emit all the Unicode characters. */
10550                               STRLEN numlen;
10551                               for (foldbuf = tmpbuf;
10552                                    foldlen;
10553                                    foldlen -= numlen) {
10554
10555                                    /* tmpbuf has been constructed by us, so we
10556                                     * know it is valid utf8 */
10557                                    ender = valid_utf8_to_uvchr(foldbuf, &numlen);
10558                                    if (numlen > 0) {
10559                                         const STRLEN unilen = reguni(pRExC_state, ender, s);
10560                                         s       += unilen;
10561                                         len     += unilen;
10562                                         /* In EBCDIC the numlen
10563                                          * and unilen can differ. */
10564                                         foldbuf += numlen;
10565                                         if (numlen >= foldlen)
10566                                              break;
10567                                    }
10568                                    else
10569                                         break; /* "Can't happen." */
10570                               }
10571                          }
10572                          else {
10573                               const STRLEN unilen = reguni(pRExC_state, ender, s);
10574                               if (unilen > 0) {
10575                                    s   += unilen;
10576                                    len += unilen;
10577                               }
10578                          }
10579                     }
10580                     else {
10581                         len++;
10582                         REGC((char)ender, s++);
10583                     }
10584                     break;
10585                 }
10586                 if (UTF || is_exactfu_sharp_s) {
10587                      if (FOLD) {
10588                           /* Emit all the Unicode characters. */
10589                           STRLEN numlen;
10590                           for (foldbuf = tmpbuf;
10591                                foldlen;
10592                                foldlen -= numlen) {
10593                                ender = valid_utf8_to_uvchr(foldbuf, &numlen);
10594                                if (numlen > 0) {
10595                                     const STRLEN unilen = reguni(pRExC_state, ender, s);
10596                                     len     += unilen;
10597                                     s       += unilen;
10598                                     /* In EBCDIC the numlen
10599                                      * and unilen can differ. */
10600                                     foldbuf += numlen;
10601                                     if (numlen >= foldlen)
10602                                          break;
10603                                }
10604                                else
10605                                     break;
10606                           }
10607                      }
10608                      else {
10609                           const STRLEN unilen = reguni(pRExC_state, ender, s);
10610                           if (unilen > 0) {
10611                                s   += unilen;
10612                                len += unilen;
10613                           }
10614                      }
10615                      len--;
10616                 }
10617                 else {
10618                     REGC((char)ender, s++);
10619                 }
10620             }
10621         loopdone:   /* Jumped to when encounters something that shouldn't be in
10622                        the node */
10623             RExC_parse = p - 1;
10624             Set_Node_Cur_Length(ret); /* MJD */
10625             nextchar(pRExC_state);
10626             {
10627                 /* len is STRLEN which is unsigned, need to copy to signed */
10628                 IV iv = len;
10629                 if (iv < 0)
10630                     vFAIL("Internal disaster");
10631             }
10632             if (len > 0)
10633                 *flagp |= HASWIDTH;
10634             if (len == 1 && UNI_IS_INVARIANT(ender))
10635                 *flagp |= SIMPLE;
10636
10637             if (SIZE_ONLY)
10638                 RExC_size += STR_SZ(len);
10639             else {
10640                 STR_LEN(ret) = len;
10641                 RExC_emit += STR_SZ(len);
10642             }
10643         }
10644         break;
10645     }
10646
10647     return(ret);
10648 }
10649
10650 STATIC char *
10651 S_regwhite( RExC_state_t *pRExC_state, char *p )
10652 {
10653     const char *e = RExC_end;
10654
10655     PERL_ARGS_ASSERT_REGWHITE;
10656
10657     while (p < e) {
10658         if (isSPACE(*p))
10659             ++p;
10660         else if (*p == '#') {
10661             bool ended = 0;
10662             do {
10663                 if (*p++ == '\n') {
10664                     ended = 1;
10665                     break;
10666                 }
10667             } while (p < e);
10668             if (!ended)
10669                 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
10670         }
10671         else
10672             break;
10673     }
10674     return p;
10675 }
10676
10677 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
10678    Character classes ([:foo:]) can also be negated ([:^foo:]).
10679    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
10680    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
10681    but trigger failures because they are currently unimplemented. */
10682
10683 #define POSIXCC_DONE(c)   ((c) == ':')
10684 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
10685 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
10686
10687 STATIC I32
10688 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
10689 {
10690     dVAR;
10691     I32 namedclass = OOB_NAMEDCLASS;
10692
10693     PERL_ARGS_ASSERT_REGPPOSIXCC;
10694
10695     if (value == '[' && RExC_parse + 1 < RExC_end &&
10696         /* I smell either [: or [= or [. -- POSIX has been here, right? */
10697         POSIXCC(UCHARAT(RExC_parse))) {
10698         const char c = UCHARAT(RExC_parse);
10699         char* const s = RExC_parse++;
10700
10701         while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
10702             RExC_parse++;
10703         if (RExC_parse == RExC_end)
10704             /* Grandfather lone [:, [=, [. */
10705             RExC_parse = s;
10706         else {
10707             const char* const t = RExC_parse++; /* skip over the c */
10708             assert(*t == c);
10709
10710             if (UCHARAT(RExC_parse) == ']') {
10711                 const char *posixcc = s + 1;
10712                 RExC_parse++; /* skip over the ending ] */
10713
10714                 if (*s == ':') {
10715                     const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
10716                     const I32 skip = t - posixcc;
10717
10718                     /* Initially switch on the length of the name.  */
10719                     switch (skip) {
10720                     case 4:
10721                         if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
10722                             namedclass = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
10723                         break;
10724                     case 5:
10725                         /* Names all of length 5.  */
10726                         /* alnum alpha ascii blank cntrl digit graph lower
10727                            print punct space upper  */
10728                         /* Offset 4 gives the best switch position.  */
10729                         switch (posixcc[4]) {
10730                         case 'a':
10731                             if (memEQ(posixcc, "alph", 4)) /* alpha */
10732                                 namedclass = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
10733                             break;
10734                         case 'e':
10735                             if (memEQ(posixcc, "spac", 4)) /* space */
10736                                 namedclass = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
10737                             break;
10738                         case 'h':
10739                             if (memEQ(posixcc, "grap", 4)) /* graph */
10740                                 namedclass = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
10741                             break;
10742                         case 'i':
10743                             if (memEQ(posixcc, "asci", 4)) /* ascii */
10744                                 namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII;
10745                             break;
10746                         case 'k':
10747                             if (memEQ(posixcc, "blan", 4)) /* blank */
10748                                 namedclass = complement ? ANYOF_NBLANK : ANYOF_BLANK;
10749                             break;
10750                         case 'l':
10751                             if (memEQ(posixcc, "cntr", 4)) /* cntrl */
10752                                 namedclass = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
10753                             break;
10754                         case 'm':
10755                             if (memEQ(posixcc, "alnu", 4)) /* alnum */
10756                                 namedclass = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
10757                             break;
10758                         case 'r':
10759                             if (memEQ(posixcc, "lowe", 4)) /* lower */
10760                                 namedclass = complement ? ANYOF_NLOWER : ANYOF_LOWER;
10761                             else if (memEQ(posixcc, "uppe", 4)) /* upper */
10762                                 namedclass = complement ? ANYOF_NUPPER : ANYOF_UPPER;
10763                             break;
10764                         case 't':
10765                             if (memEQ(posixcc, "digi", 4)) /* digit */
10766                                 namedclass = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
10767                             else if (memEQ(posixcc, "prin", 4)) /* print */
10768                                 namedclass = complement ? ANYOF_NPRINT : ANYOF_PRINT;
10769                             else if (memEQ(posixcc, "punc", 4)) /* punct */
10770                                 namedclass = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
10771                             break;
10772                         }
10773                         break;
10774                     case 6:
10775                         if (memEQ(posixcc, "xdigit", 6))
10776                             namedclass = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
10777                         break;
10778                     }
10779
10780                     if (namedclass == OOB_NAMEDCLASS)
10781                         Simple_vFAIL3("POSIX class [:%.*s:] unknown",
10782                                       t - s - 1, s + 1);
10783                     assert (posixcc[skip] == ':');
10784                     assert (posixcc[skip+1] == ']');
10785                 } else if (!SIZE_ONLY) {
10786                     /* [[=foo=]] and [[.foo.]] are still future. */
10787
10788                     /* adjust RExC_parse so the warning shows after
10789                        the class closes */
10790                     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
10791                         RExC_parse++;
10792                     Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
10793                 }
10794             } else {
10795                 /* Maternal grandfather:
10796                  * "[:" ending in ":" but not in ":]" */
10797                 RExC_parse = s;
10798             }
10799         }
10800     }
10801
10802     return namedclass;
10803 }
10804
10805 STATIC void
10806 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
10807 {
10808     dVAR;
10809
10810     PERL_ARGS_ASSERT_CHECKPOSIXCC;
10811
10812     if (POSIXCC(UCHARAT(RExC_parse))) {
10813         const char *s = RExC_parse;
10814         const char  c = *s++;
10815
10816         while (isALNUM(*s))
10817             s++;
10818         if (*s && c == *s && s[1] == ']') {
10819             ckWARN3reg(s+2,
10820                        "POSIX syntax [%c %c] belongs inside character classes",
10821                        c, c);
10822
10823             /* [[=foo=]] and [[.foo.]] are still future. */
10824             if (POSIXCC_NOTYET(c)) {
10825                 /* adjust RExC_parse so the error shows after
10826                    the class closes */
10827                 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
10828                     NOOP;
10829                 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
10830             }
10831         }
10832     }
10833 }
10834
10835 /* Generate the code to add a full posix character <class> to the bracketed
10836  * character class given by <node>.  (<node> is needed only under locale rules)
10837  * destlist     is the inversion list for non-locale rules that this class is
10838  *              to be added to
10839  * sourcelist   is the ASCII-range inversion list to add under /a rules
10840  * Xsourcelist  is the full Unicode range list to use otherwise. */
10841 #define DO_POSIX(node, class, destlist, sourcelist, Xsourcelist)           \
10842     if (LOC) {                                                             \
10843         SV* scratch_list = NULL;                                           \
10844                                                                            \
10845         /* Set this class in the node for runtime matching */              \
10846         ANYOF_CLASS_SET(node, class);                                      \
10847                                                                            \
10848         /* For above Latin1 code points, we use the full Unicode range */  \
10849         _invlist_intersection(PL_AboveLatin1,                              \
10850                               Xsourcelist,                                 \
10851                               &scratch_list);                              \
10852         /* And set the output to it, adding instead if there already is an \
10853          * output.  Checking if <destlist> is NULL first saves an extra    \
10854          * clone.  Its reference count will be decremented at the next     \
10855          * union, etc, or if this is the only instance, at the end of the  \
10856          * routine */                                                      \
10857         if (! destlist) {                                                  \
10858             destlist = scratch_list;                                       \
10859         }                                                                  \
10860         else {                                                             \
10861             _invlist_union(destlist, scratch_list, &destlist);             \
10862             SvREFCNT_dec(scratch_list);                                    \
10863         }                                                                  \
10864     }                                                                      \
10865     else {                                                                 \
10866         /* For non-locale, just add it to any existing list */             \
10867         _invlist_union(destlist,                                           \
10868                        (AT_LEAST_ASCII_RESTRICTED)                         \
10869                            ? sourcelist                                    \
10870                            : Xsourcelist,                                  \
10871                        &destlist);                                         \
10872     }
10873
10874 /* Like DO_POSIX, but matches the complement of <sourcelist> and <Xsourcelist>.
10875  */
10876 #define DO_N_POSIX(node, class, destlist, sourcelist, Xsourcelist)         \
10877     if (LOC) {                                                             \
10878         SV* scratch_list = NULL;                                           \
10879         ANYOF_CLASS_SET(node, class);                                      \
10880         _invlist_subtract(PL_AboveLatin1, Xsourcelist, &scratch_list);     \
10881         if (! destlist) {                                                  \
10882             destlist = scratch_list;                                       \
10883         }                                                                  \
10884         else {                                                             \
10885             _invlist_union(destlist, scratch_list, &destlist);             \
10886             SvREFCNT_dec(scratch_list);                                    \
10887         }                                                                  \
10888     }                                                                      \
10889     else {                                                                 \
10890         _invlist_union_complement_2nd(destlist,                            \
10891                                     (AT_LEAST_ASCII_RESTRICTED)            \
10892                                         ? sourcelist                       \
10893                                         : Xsourcelist,                     \
10894                                     &destlist);                            \
10895         /* Under /d, everything in the upper half of the Latin1 range      \
10896          * matches this complement */                                      \
10897         if (DEPENDS_SEMANTICS) {                                           \
10898             ANYOF_FLAGS(node) |= ANYOF_NON_UTF8_LATIN1_ALL;                \
10899         }                                                                  \
10900     }
10901
10902 /* Generate the code to add a posix character <class> to the bracketed
10903  * character class given by <node>.  (<node> is needed only under locale rules)
10904  * destlist       is the inversion list for non-locale rules that this class is
10905  *                to be added to
10906  * sourcelist     is the ASCII-range inversion list to add under /a rules
10907  * l1_sourcelist  is the Latin1 range list to use otherwise.
10908  * Xpropertyname  is the name to add to <run_time_list> of the property to
10909  *                specify the code points above Latin1 that will have to be
10910  *                determined at run-time
10911  * run_time_list  is a SV* that contains text names of properties that are to
10912  *                be computed at run time.  This concatenates <Xpropertyname>
10913  *                to it, apppropriately
10914  * This is essentially DO_POSIX, but we know only the Latin1 values at compile
10915  * time */
10916 #define DO_POSIX_LATIN1_ONLY_KNOWN(node, class, destlist, sourcelist,      \
10917                               l1_sourcelist, Xpropertyname, run_time_list) \
10918         /* First, resolve whether to use the ASCII-only list or the L1     \
10919          * list */                                                         \
10920         DO_POSIX_LATIN1_ONLY_KNOWN_L1_RESOLVED(node, class, destlist,      \
10921                 ((AT_LEAST_ASCII_RESTRICTED) ? sourcelist : l1_sourcelist),\
10922                 Xpropertyname, run_time_list)
10923
10924 #define DO_POSIX_LATIN1_ONLY_KNOWN_L1_RESOLVED(node, class, destlist, sourcelist, \
10925                 Xpropertyname, run_time_list)                              \
10926     /* If not /a matching, there are going to be code points we will have  \
10927      * to defer to runtime to look-up */                                   \
10928     if (! AT_LEAST_ASCII_RESTRICTED) {                                     \
10929         Perl_sv_catpvf(aTHX_ run_time_list, "+utf8::%s\n", Xpropertyname); \
10930     }                                                                      \
10931     if (LOC) {                                                             \
10932         ANYOF_CLASS_SET(node, class);                                      \
10933     }                                                                      \
10934     else {                                                                 \
10935         _invlist_union(destlist, sourcelist, &destlist);                   \
10936     }
10937
10938 /* Like DO_POSIX_LATIN1_ONLY_KNOWN, but for the complement.  A combination of
10939  * this and DO_N_POSIX.  Sets <matches_above_unicode> only if it can; unchanged
10940  * otherwise */
10941 #define DO_N_POSIX_LATIN1_ONLY_KNOWN(node, class, destlist, sourcelist,    \
10942        l1_sourcelist, Xpropertyname, run_time_list, matches_above_unicode) \
10943     if (AT_LEAST_ASCII_RESTRICTED) {                                       \
10944         _invlist_union_complement_2nd(destlist, sourcelist, &destlist);    \
10945     }                                                                      \
10946     else {                                                                 \
10947         Perl_sv_catpvf(aTHX_ run_time_list, "!utf8::%s\n", Xpropertyname); \
10948         matches_above_unicode = TRUE;                                      \
10949         if (LOC) {                                                         \
10950             ANYOF_CLASS_SET(node, namedclass);                             \
10951         }                                                                  \
10952         else {                                                             \
10953             SV* scratch_list = NULL;                                       \
10954             _invlist_subtract(PL_Latin1, l1_sourcelist, &scratch_list);    \
10955             if (! destlist) {                                              \
10956                 destlist = scratch_list;                                   \
10957             }                                                              \
10958             else {                                                         \
10959                 _invlist_union(destlist, scratch_list, &destlist);         \
10960                 SvREFCNT_dec(scratch_list);                                \
10961             }                                                              \
10962             if (DEPENDS_SEMANTICS) {                                       \
10963                 ANYOF_FLAGS(node) |= ANYOF_NON_UTF8_LATIN1_ALL;            \
10964             }                                                              \
10965         }                                                                  \
10966     }
10967
10968 STATIC void
10969 S_add_alternate(pTHX_ AV** alternate_ptr, U8* string, STRLEN len)
10970 {
10971     /* Adds input 'string' with length 'len' to the ANYOF node's unicode
10972      * alternate list, pointed to by 'alternate_ptr'.  This is an array of
10973      * the multi-character folds of characters in the node */
10974     SV *sv;
10975
10976     PERL_ARGS_ASSERT_ADD_ALTERNATE;
10977
10978     if (! *alternate_ptr) {
10979         *alternate_ptr = newAV();
10980     }
10981     sv = newSVpvn_utf8((char*)string, len, TRUE);
10982     av_push(*alternate_ptr, sv);
10983     return;
10984 }
10985
10986 /*
10987    parse a class specification and produce either an ANYOF node that
10988    matches the pattern or perhaps will be optimized into an EXACTish node
10989    instead. The node contains a bit map for the first 256 characters, with the
10990    corresponding bit set if that character is in the list.  For characters
10991    above 255, a range list is used */
10992
10993 STATIC regnode *
10994 S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
10995 {
10996     dVAR;
10997     register UV nextvalue;
10998     register IV prevvalue = OOB_UNICODE;
10999     register IV range = 0;
11000     UV value = 0; /* XXX:dmq: needs to be referenceable (unfortunately) */
11001     register regnode *ret;
11002     STRLEN numlen;
11003     IV namedclass = OOB_NAMEDCLASS;
11004     char *rangebegin = NULL;
11005     bool need_class = 0;
11006     bool allow_full_fold = TRUE;   /* Assume wants multi-char folding */
11007     SV *listsv = NULL;
11008     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
11009                                       than just initialized.  */
11010     SV* properties = NULL;    /* Code points that match \p{} \P{} */
11011     SV* posixes = NULL;     /* Code points that match classes like, [:word:],
11012                                extended beyond the Latin1 range */
11013     UV element_count = 0;   /* Number of distinct elements in the class.
11014                                Optimizations may be possible if this is tiny */
11015     UV n;
11016
11017     /* Certain named classes have equivalents that can appear outside a
11018      * character class, e.g. \w.  These flags are set for these classes.  The
11019      * first flag indicates the op depends on the character set modifier, like
11020      * /d, /u....  The second is for those that don't have this dependency. */
11021     bool has_special_charset_op = FALSE;
11022     bool has_special_non_charset_op = FALSE;
11023
11024     /* Unicode properties are stored in a swash; this holds the current one
11025      * being parsed.  If this swash is the only above-latin1 component of the
11026      * character class, an optimization is to pass it directly on to the
11027      * execution engine.  Otherwise, it is set to NULL to indicate that there
11028      * are other things in the class that have to be dealt with at execution
11029      * time */
11030     SV* swash = NULL;           /* Code points that match \p{} \P{} */
11031
11032     /* Set if a component of this character class is user-defined; just passed
11033      * on to the engine */
11034     bool has_user_defined_property = FALSE;
11035
11036     /* inversion list of code points this node matches only when the target
11037      * string is in UTF-8.  (Because is under /d) */
11038     SV* depends_list = NULL;
11039
11040     /* inversion list of code points this node matches.  For much of the
11041      * function, it includes only those that match regardless of the utf8ness
11042      * of the target string */
11043     SV* cp_list = NULL;
11044
11045     /* List of multi-character folds that are matched by this node */
11046     AV* unicode_alternate  = NULL;
11047 #ifdef EBCDIC
11048     /* In a range, counts how many 0-2 of the ends of it came from literals,
11049      * not escapes.  Thus we can tell if 'A' was input vs \x{C1} */
11050     UV literal_endpoint = 0;
11051 #endif
11052     UV stored = 0;  /* how many chars stored in the bitmap */
11053     bool invert = FALSE;    /* Is this class to be complemented */
11054
11055     /* Is there any thing like \W or [:^digit:] that matches above the legal
11056      * Unicode range? */
11057     bool runtime_posix_matches_above_Unicode = FALSE;
11058
11059     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
11060         case we need to change the emitted regop to an EXACT. */
11061     const char * orig_parse = RExC_parse;
11062     GET_RE_DEBUG_FLAGS_DECL;
11063
11064     PERL_ARGS_ASSERT_REGCLASS;
11065 #ifndef DEBUGGING
11066     PERL_UNUSED_ARG(depth);
11067 #endif
11068
11069     DEBUG_PARSE("clas");
11070
11071     /* Assume we are going to generate an ANYOF node. */
11072     ret = reganode(pRExC_state, ANYOF, 0);
11073
11074
11075     if (!SIZE_ONLY) {
11076         ANYOF_FLAGS(ret) = 0;
11077     }
11078
11079     if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
11080         RExC_naughty++;
11081         RExC_parse++;
11082         invert = TRUE;
11083
11084         /* We have decided to not allow multi-char folds in inverted character
11085          * classes, due to the confusion that can happen, especially with
11086          * classes that are designed for a non-Unicode world:  You have the
11087          * peculiar case that:
11088             "s s" =~ /^[^\xDF]+$/i => Y
11089             "ss"  =~ /^[^\xDF]+$/i => N
11090          *
11091          * See [perl #89750] */
11092         allow_full_fold = FALSE;
11093     }
11094
11095     if (SIZE_ONLY) {
11096         RExC_size += ANYOF_SKIP;
11097         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
11098     }
11099     else {
11100         RExC_emit += ANYOF_SKIP;
11101         if (LOC) {
11102             ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
11103         }
11104         ANYOF_BITMAP_ZERO(ret);
11105         listsv = newSVpvs("# comment\n");
11106         initial_listsv_len = SvCUR(listsv);
11107     }
11108
11109     nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
11110
11111     if (!SIZE_ONLY && POSIXCC(nextvalue))
11112         checkposixcc(pRExC_state);
11113
11114     /* allow 1st char to be ] (allowing it to be - is dealt with later) */
11115     if (UCHARAT(RExC_parse) == ']')
11116         goto charclassloop;
11117
11118 parseit:
11119     while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
11120
11121     charclassloop:
11122
11123         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
11124
11125         if (!range) {
11126             rangebegin = RExC_parse;
11127             element_count++;
11128         }
11129         if (UTF) {
11130             value = utf8n_to_uvchr((U8*)RExC_parse,
11131                                    RExC_end - RExC_parse,
11132                                    &numlen, UTF8_ALLOW_DEFAULT);
11133             RExC_parse += numlen;
11134         }
11135         else
11136             value = UCHARAT(RExC_parse++);
11137
11138         nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
11139         if (value == '[' && POSIXCC(nextvalue))
11140             namedclass = regpposixcc(pRExC_state, value);
11141         else if (value == '\\') {
11142             if (UTF) {
11143                 value = utf8n_to_uvchr((U8*)RExC_parse,
11144                                    RExC_end - RExC_parse,
11145                                    &numlen, UTF8_ALLOW_DEFAULT);
11146                 RExC_parse += numlen;
11147             }
11148             else
11149                 value = UCHARAT(RExC_parse++);
11150             /* Some compilers cannot handle switching on 64-bit integer
11151              * values, therefore value cannot be an UV.  Yes, this will
11152              * be a problem later if we want switch on Unicode.
11153              * A similar issue a little bit later when switching on
11154              * namedclass. --jhi */
11155             switch ((I32)value) {
11156             case 'w':   namedclass = ANYOF_ALNUM;       break;
11157             case 'W':   namedclass = ANYOF_NALNUM;      break;
11158             case 's':   namedclass = ANYOF_SPACE;       break;
11159             case 'S':   namedclass = ANYOF_NSPACE;      break;
11160             case 'd':   namedclass = ANYOF_DIGIT;       break;
11161             case 'D':   namedclass = ANYOF_NDIGIT;      break;
11162             case 'v':   namedclass = ANYOF_VERTWS;      break;
11163             case 'V':   namedclass = ANYOF_NVERTWS;     break;
11164             case 'h':   namedclass = ANYOF_HORIZWS;     break;
11165             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
11166             case 'N':  /* Handle \N{NAME} in class */
11167                 {
11168                     /* We only pay attention to the first char of 
11169                     multichar strings being returned. I kinda wonder
11170                     if this makes sense as it does change the behaviour
11171                     from earlier versions, OTOH that behaviour was broken
11172                     as well. */
11173                     UV v; /* value is register so we cant & it /grrr */
11174                     if (reg_namedseq(pRExC_state, &v, NULL, depth)) {
11175                         goto parseit;
11176                     }
11177                     value= v; 
11178                 }
11179                 break;
11180             case 'p':
11181             case 'P':
11182                 {
11183                 char *e;
11184                 if (RExC_parse >= RExC_end)
11185                     vFAIL2("Empty \\%c{}", (U8)value);
11186                 if (*RExC_parse == '{') {
11187                     const U8 c = (U8)value;
11188                     e = strchr(RExC_parse++, '}');
11189                     if (!e)
11190                         vFAIL2("Missing right brace on \\%c{}", c);
11191                     while (isSPACE(UCHARAT(RExC_parse)))
11192                         RExC_parse++;
11193                     if (e == RExC_parse)
11194                         vFAIL2("Empty \\%c{}", c);
11195                     n = e - RExC_parse;
11196                     while (isSPACE(UCHARAT(RExC_parse + n - 1)))
11197                         n--;
11198                 }
11199                 else {
11200                     e = RExC_parse;
11201                     n = 1;
11202                 }
11203                 if (!SIZE_ONLY) {
11204                     SV** invlistsvp;
11205                     SV* invlist;
11206                     char* name;
11207
11208                     if (UCHARAT(RExC_parse) == '^') {
11209                          RExC_parse++;
11210                          n--;
11211                          value = value == 'p' ? 'P' : 'p'; /* toggle */
11212                          while (isSPACE(UCHARAT(RExC_parse))) {
11213                               RExC_parse++;
11214                               n--;
11215                          }
11216                     }
11217                     /* Try to get the definition of the property into
11218                      * <invlist>.  If /i is in effect, the effective property
11219                      * will have its name be <__NAME_i>.  The design is
11220                      * discussed in commit
11221                      * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
11222                     Newx(name, n + sizeof("_i__\n"), char);
11223
11224                     sprintf(name, "%s%.*s%s\n",
11225                                     (FOLD) ? "__" : "",
11226                                     (int)n,
11227                                     RExC_parse,
11228                                     (FOLD) ? "_i" : ""
11229                     );
11230
11231                     /* Look up the property name, and get its swash and
11232                      * inversion list, if the property is found  */
11233                     if (swash) {
11234                         SvREFCNT_dec(swash);
11235                     }
11236                     swash = _core_swash_init("utf8", name, &PL_sv_undef,
11237                                              1, /* binary */
11238                                              0, /* not tr/// */
11239                                              TRUE, /* this routine will handle
11240                                                       undefined properties */
11241                                              NULL, FALSE /* No inversion list */
11242                                             );
11243                     if (   ! swash
11244                         || ! SvROK(swash)
11245                         || ! SvTYPE(SvRV(swash)) == SVt_PVHV
11246                         || ! (invlistsvp =
11247                                 hv_fetchs(MUTABLE_HV(SvRV(swash)),
11248                                 "INVLIST", FALSE))
11249                         || ! (invlist = *invlistsvp))
11250                     {
11251                         if (swash) {
11252                             SvREFCNT_dec(swash);
11253                             swash = NULL;
11254                         }
11255
11256                         /* Here didn't find it.  It could be a user-defined
11257                          * property that will be available at run-time.  Add it
11258                          * to the list to look up then */
11259                         Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s\n",
11260                                         (value == 'p' ? '+' : '!'),
11261                                         name);
11262                         has_user_defined_property = TRUE;
11263
11264                         /* We don't know yet, so have to assume that the
11265                          * property could match something in the Latin1 range,
11266                          * hence something that isn't utf8 */
11267                         ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
11268                     }
11269                     else {
11270
11271                         /* Here, did get the swash and its inversion list.  If
11272                          * the swash is from a user-defined property, then this
11273                          * whole character class should be regarded as such */
11274                         has_user_defined_property =
11275                                                 _is_swash_user_defined(swash);
11276
11277                         /* Invert if asking for the complement */
11278                         if (value == 'P') {
11279                             _invlist_union_complement_2nd(properties,
11280                                                           invlist,
11281                                                           &properties);
11282
11283                             /* The swash can't be used as-is, because we've
11284                              * inverted things; delay removing it to here after
11285                              * have copied its invlist above */
11286                             SvREFCNT_dec(swash);
11287                             swash = NULL;
11288                         }
11289                         else {
11290                             _invlist_union(properties, invlist, &properties);
11291                         }
11292                     }
11293                     Safefree(name);
11294                 }
11295                 RExC_parse = e + 1;
11296                 namedclass = ANYOF_MAX;  /* no official name, but it's named */
11297
11298                 /* \p means they want Unicode semantics */
11299                 RExC_uni_semantics = 1;
11300                 }
11301                 break;
11302             case 'n':   value = '\n';                   break;
11303             case 'r':   value = '\r';                   break;
11304             case 't':   value = '\t';                   break;
11305             case 'f':   value = '\f';                   break;
11306             case 'b':   value = '\b';                   break;
11307             case 'e':   value = ASCII_TO_NATIVE('\033');break;
11308             case 'a':   value = ASCII_TO_NATIVE('\007');break;
11309             case 'o':
11310                 RExC_parse--;   /* function expects to be pointed at the 'o' */
11311                 {
11312                     const char* error_msg;
11313                     bool valid = grok_bslash_o(RExC_parse,
11314                                                &value,
11315                                                &numlen,
11316                                                &error_msg,
11317                                                SIZE_ONLY);
11318                     RExC_parse += numlen;
11319                     if (! valid) {
11320                         vFAIL(error_msg);
11321                     }
11322                 }
11323                 if (PL_encoding && value < 0x100) {
11324                     goto recode_encoding;
11325                 }
11326                 break;
11327             case 'x':
11328                 RExC_parse--;   /* function expects to be pointed at the 'x' */
11329                 {
11330                     const char* error_msg;
11331                     bool valid = grok_bslash_x(RExC_parse,
11332                                                &value,
11333                                                &numlen,
11334                                                &error_msg,
11335                                                1);
11336                     RExC_parse += numlen;
11337                     if (! valid) {
11338                         vFAIL(error_msg);
11339                     }
11340                 }
11341                 if (PL_encoding && value < 0x100)
11342                     goto recode_encoding;
11343                 break;
11344             case 'c':
11345                 value = grok_bslash_c(*RExC_parse++, UTF, SIZE_ONLY);
11346                 break;
11347             case '0': case '1': case '2': case '3': case '4':
11348             case '5': case '6': case '7':
11349                 {
11350                     /* Take 1-3 octal digits */
11351                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
11352                     numlen = 3;
11353                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
11354                     RExC_parse += numlen;
11355                     if (PL_encoding && value < 0x100)
11356                         goto recode_encoding;
11357                     break;
11358                 }
11359             recode_encoding:
11360                 if (! RExC_override_recoding) {
11361                     SV* enc = PL_encoding;
11362                     value = reg_recode((const char)(U8)value, &enc);
11363                     if (!enc && SIZE_ONLY)
11364                         ckWARNreg(RExC_parse,
11365                                   "Invalid escape in the specified encoding");
11366                     break;
11367                 }
11368             default:
11369                 /* Allow \_ to not give an error */
11370                 if (!SIZE_ONLY && isALNUM(value) && value != '_') {
11371                     ckWARN2reg(RExC_parse,
11372                                "Unrecognized escape \\%c in character class passed through",
11373                                (int)value);
11374                 }
11375                 break;
11376             }
11377         } /* end of \blah */
11378 #ifdef EBCDIC
11379         else
11380             literal_endpoint++;
11381 #endif
11382
11383             /* What matches in a locale is not known until runtime.  This
11384              * includes what the Posix classes (like \w, [:space:]) match.
11385              * Room must be reserved (one time per class) to store such
11386              * classes, either if Perl is compiled so that locale nodes always
11387              * should have this space, or if there is such class info to be
11388              * stored.  The space will contain a bit for each named class that
11389              * is to be matched against.  This isn't needed for \p{} and
11390              * pseudo-classes, as they are not affected by locale, and hence
11391              * are dealt with separately */
11392             if (LOC
11393                 && ! need_class
11394                 && (ANYOF_LOCALE == ANYOF_CLASS
11395                     || (namedclass > OOB_NAMEDCLASS && namedclass < ANYOF_MAX)))
11396             {
11397                 need_class = 1;
11398                 if (SIZE_ONLY) {
11399                     RExC_size += ANYOF_CLASS_SKIP - ANYOF_SKIP;
11400                 }
11401                 else {
11402                     RExC_emit += ANYOF_CLASS_SKIP - ANYOF_SKIP;
11403                     ANYOF_CLASS_ZERO(ret);
11404                 }
11405                 ANYOF_FLAGS(ret) |= ANYOF_CLASS;
11406             }
11407
11408         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
11409
11410             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
11411              * literal, as is the character that began the false range, i.e.
11412              * the 'a' in the examples */
11413             if (range) {
11414                 if (!SIZE_ONLY) {
11415                     const int w =
11416                         RExC_parse >= rangebegin ?
11417                         RExC_parse - rangebegin : 0;
11418                     ckWARN4reg(RExC_parse,
11419                                "False [] range \"%*.*s\"",
11420                                w, w, rangebegin);
11421                     cp_list = add_cp_to_invlist(cp_list, '-');
11422                     cp_list = add_cp_to_invlist(cp_list, prevvalue);
11423                 }
11424
11425                 range = 0; /* this was not a true range */
11426                 element_count += 2; /* So counts for three values */
11427             }
11428
11429             if (SIZE_ONLY) {
11430
11431                 /* In the first pass, do a little extra work so below can
11432                  * possibly optimize the whole node to one of the nodes that
11433                  * correspond to the classes given below */
11434
11435                 /* The optimization will only take place if there is a single
11436                  * element in the class, so can skip if there is more than one
11437                  */
11438                 if (element_count == 1) {
11439
11440                 /* Possible truncation here but in some 64-bit environments
11441                  * the compiler gets heartburn about switch on 64-bit values.
11442                  * A similar issue a little earlier when switching on value.
11443                  * --jhi */
11444                     switch ((I32)namedclass) {
11445                         case ANYOF_ALNUM:
11446                         case ANYOF_NALNUM:
11447                         case ANYOF_DIGIT:
11448                         case ANYOF_NDIGIT:
11449                         case ANYOF_SPACE:
11450                         case ANYOF_NSPACE:
11451                             has_special_charset_op = TRUE;
11452                             break;
11453
11454                         case ANYOF_HORIZWS:
11455                         case ANYOF_NHORIZWS:
11456                         case ANYOF_VERTWS:
11457                         case ANYOF_NVERTWS:
11458                             has_special_non_charset_op = TRUE;
11459                             break;
11460                     }
11461                 }
11462             }
11463             else {
11464                 switch ((I32)namedclass) {
11465
11466                 case ANYOF_ALNUMC: /* C's alnum, in contrast to \w */
11467                     DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
11468                         PL_PosixAlnum, PL_L1PosixAlnum, "XPosixAlnum", listsv);
11469                     break;
11470                 case ANYOF_NALNUMC:
11471                     DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
11472                         PL_PosixAlnum, PL_L1PosixAlnum, "XPosixAlnum", listsv,
11473                         runtime_posix_matches_above_Unicode);
11474                     break;
11475                 case ANYOF_ALPHA:
11476                     DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
11477                         PL_PosixAlpha, PL_L1PosixAlpha, "XPosixAlpha", listsv);
11478                     break;
11479                 case ANYOF_NALPHA:
11480                     DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
11481                         PL_PosixAlpha, PL_L1PosixAlpha, "XPosixAlpha", listsv,
11482                         runtime_posix_matches_above_Unicode);
11483                     break;
11484                 case ANYOF_ASCII:
11485                     if (LOC) {
11486                         ANYOF_CLASS_SET(ret, namedclass);
11487                     }
11488                     else {
11489                         _invlist_union(posixes, PL_ASCII, &posixes);
11490                     }
11491                     break;
11492                 case ANYOF_NASCII:
11493                     if (LOC) {
11494                         ANYOF_CLASS_SET(ret, namedclass);
11495                     }
11496                     else {
11497                         _invlist_union_complement_2nd(posixes,
11498                                                     PL_ASCII, &posixes);
11499                         if (DEPENDS_SEMANTICS) {
11500                             ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL;
11501                         }
11502                     }
11503                     break;
11504                 case ANYOF_BLANK:
11505                     DO_POSIX(ret, namedclass, posixes,
11506                                             PL_PosixBlank, PL_XPosixBlank);
11507                     break;
11508                 case ANYOF_NBLANK:
11509                     DO_N_POSIX(ret, namedclass, posixes,
11510                                             PL_PosixBlank, PL_XPosixBlank);
11511                     break;
11512                 case ANYOF_CNTRL:
11513                     DO_POSIX(ret, namedclass, posixes,
11514                                             PL_PosixCntrl, PL_XPosixCntrl);
11515                     break;
11516                 case ANYOF_NCNTRL:
11517                     DO_N_POSIX(ret, namedclass, posixes,
11518                                             PL_PosixCntrl, PL_XPosixCntrl);
11519                     break;
11520                 case ANYOF_DIGIT:
11521                     /* There are no digits in the Latin1 range outside of
11522                      * ASCII, so call the macro that doesn't have to resolve
11523                      * them */
11524                     DO_POSIX_LATIN1_ONLY_KNOWN_L1_RESOLVED(ret, namedclass, posixes,
11525                         PL_PosixDigit, "XPosixDigit", listsv);
11526                     has_special_charset_op = TRUE;
11527                     break;
11528                 case ANYOF_NDIGIT:
11529                     DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
11530                         PL_PosixDigit, PL_PosixDigit, "XPosixDigit", listsv,
11531                         runtime_posix_matches_above_Unicode);
11532                     has_special_charset_op = TRUE;
11533                     break;
11534                 case ANYOF_GRAPH:
11535                     DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
11536                         PL_PosixGraph, PL_L1PosixGraph, "XPosixGraph", listsv);
11537                     break;
11538                 case ANYOF_NGRAPH:
11539                     DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
11540                         PL_PosixGraph, PL_L1PosixGraph, "XPosixGraph", listsv,
11541                         runtime_posix_matches_above_Unicode);
11542                     break;
11543                 case ANYOF_HORIZWS:
11544                     /* For these, we use the cp_list, as /d doesn't make a
11545                      * difference in what these match.  There would be problems
11546                      * if these characters had folds other than themselves, as
11547                      * cp_list is subject to folding.  It turns out that \h
11548                      * is just a synonym for XPosixBlank */
11549                     _invlist_union(cp_list, PL_XPosixBlank, &cp_list);
11550                     has_special_non_charset_op = TRUE;
11551                     break;
11552                 case ANYOF_NHORIZWS:
11553                     _invlist_union_complement_2nd(cp_list,
11554                                                  PL_XPosixBlank, &cp_list);
11555                     has_special_non_charset_op = TRUE;
11556                     break;
11557                 case ANYOF_LOWER:
11558                 case ANYOF_NLOWER:
11559                 {   /* These require special handling, as they differ under
11560                        folding, matching Cased there (which in the ASCII range
11561                        is the same as Alpha */
11562
11563                     SV* ascii_source;
11564                     SV* l1_source;
11565                     const char *Xname;
11566
11567                     if (FOLD && ! LOC) {
11568                         ascii_source = PL_PosixAlpha;
11569                         l1_source = PL_L1Cased;
11570                         Xname = "Cased";
11571                     }
11572                     else {
11573                         ascii_source = PL_PosixLower;
11574                         l1_source = PL_L1PosixLower;
11575                         Xname = "XPosixLower";
11576                     }
11577                     if (namedclass == ANYOF_LOWER) {
11578                         DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
11579                                     ascii_source, l1_source, Xname, listsv);
11580                     }
11581                     else {
11582                         DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass,
11583                             posixes, ascii_source, l1_source, Xname, listsv,
11584                             runtime_posix_matches_above_Unicode);
11585                     }
11586                     break;
11587                 }
11588                 case ANYOF_PRINT:
11589                     DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
11590                         PL_PosixPrint, PL_L1PosixPrint, "XPosixPrint", listsv);
11591                     break;
11592                 case ANYOF_NPRINT:
11593                     DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
11594                         PL_PosixPrint, PL_L1PosixPrint, "XPosixPrint", listsv,
11595                         runtime_posix_matches_above_Unicode);
11596                     break;
11597                 case ANYOF_PUNCT:
11598                     DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
11599                         PL_PosixPunct, PL_L1PosixPunct, "XPosixPunct", listsv);
11600                     break;
11601                 case ANYOF_NPUNCT:
11602                     DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
11603                         PL_PosixPunct, PL_L1PosixPunct, "XPosixPunct", listsv,
11604                         runtime_posix_matches_above_Unicode);
11605                     break;
11606                 case ANYOF_PSXSPC:
11607                     DO_POSIX(ret, namedclass, posixes,
11608                                             PL_PosixSpace, PL_XPosixSpace);
11609                     break;
11610                 case ANYOF_NPSXSPC:
11611                     DO_N_POSIX(ret, namedclass, posixes,
11612                                             PL_PosixSpace, PL_XPosixSpace);
11613                     break;
11614                 case ANYOF_SPACE:
11615                     DO_POSIX(ret, namedclass, posixes,
11616                                             PL_PerlSpace, PL_XPerlSpace);
11617                     has_special_charset_op = TRUE;
11618                     break;
11619                 case ANYOF_NSPACE:
11620                     DO_N_POSIX(ret, namedclass, posixes,
11621                                             PL_PerlSpace, PL_XPerlSpace);
11622                     has_special_charset_op = TRUE;
11623                     break;
11624                 case ANYOF_UPPER:   /* Same as LOWER, above */
11625                 case ANYOF_NUPPER:
11626                 {
11627                     SV* ascii_source;
11628                     SV* l1_source;
11629                     const char *Xname;
11630
11631                     if (FOLD && ! LOC) {
11632                         ascii_source = PL_PosixAlpha;
11633                         l1_source = PL_L1Cased;
11634                         Xname = "Cased";
11635                     }
11636                     else {
11637                         ascii_source = PL_PosixUpper;
11638                         l1_source = PL_L1PosixUpper;
11639                         Xname = "XPosixUpper";
11640                     }
11641                     if (namedclass == ANYOF_UPPER) {
11642                         DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
11643                                     ascii_source, l1_source, Xname, listsv);
11644                     }
11645                     else {
11646                         DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass,
11647                         posixes, ascii_source, l1_source, Xname, listsv,
11648                         runtime_posix_matches_above_Unicode);
11649                     }
11650                     break;
11651                 }
11652                 case ANYOF_ALNUM:   /* Really is 'Word' */
11653                     DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
11654                             PL_PosixWord, PL_L1PosixWord, "XPosixWord", listsv);
11655                     has_special_charset_op = TRUE;
11656                     break;
11657                 case ANYOF_NALNUM:
11658                     DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, posixes,
11659                             PL_PosixWord, PL_L1PosixWord, "XPosixWord", listsv,
11660                             runtime_posix_matches_above_Unicode);
11661                     has_special_charset_op = TRUE;
11662                     break;
11663                 case ANYOF_VERTWS:
11664                     /* For these, we use the cp_list, as /d doesn't make a
11665                      * difference in what these match.  There would be problems
11666                      * if these characters had folds other than themselves, as
11667                      * cp_list is subject to folding */
11668                     _invlist_union(cp_list, PL_VertSpace, &cp_list);
11669                     has_special_non_charset_op = TRUE;
11670                     break;
11671                 case ANYOF_NVERTWS:
11672                     _invlist_union_complement_2nd(cp_list,
11673                                                     PL_VertSpace, &cp_list);
11674                     has_special_non_charset_op = TRUE;
11675                     break;
11676                 case ANYOF_XDIGIT:
11677                     DO_POSIX(ret, namedclass, posixes,
11678                                             PL_PosixXDigit, PL_XPosixXDigit);
11679                     break;
11680                 case ANYOF_NXDIGIT:
11681                     DO_N_POSIX(ret, namedclass, posixes,
11682                                             PL_PosixXDigit, PL_XPosixXDigit);
11683                     break;
11684                 case ANYOF_MAX:
11685                     /* this is to handle \p and \P */
11686                     break;
11687                 default:
11688                     vFAIL("Invalid [::] class");
11689                     break;
11690                 }
11691
11692                 continue;
11693             }
11694         } /* end of namedclass \blah */
11695
11696         if (range) {
11697             if (prevvalue > (IV)value) /* b-a */ {
11698                 const int w = RExC_parse - rangebegin;
11699                 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
11700                 range = 0; /* not a valid range */
11701             }
11702         }
11703         else {
11704             prevvalue = value; /* save the beginning of the range */
11705             if (RExC_parse+1 < RExC_end
11706                 && *RExC_parse == '-'
11707                 && RExC_parse[1] != ']')
11708             {
11709                 RExC_parse++;
11710
11711                 /* a bad range like \w-, [:word:]- ? */
11712                 if (namedclass > OOB_NAMEDCLASS) {
11713                     if (ckWARN(WARN_REGEXP)) {
11714                         const int w =
11715                             RExC_parse >= rangebegin ?
11716                             RExC_parse - rangebegin : 0;
11717                         vWARN4(RExC_parse,
11718                                "False [] range \"%*.*s\"",
11719                                w, w, rangebegin);
11720                     }
11721                     if (!SIZE_ONLY)
11722                         cp_list = add_cp_to_invlist(cp_list, '-');
11723                 } else
11724                     range = 1;  /* yeah, it's a range! */
11725                 continue;       /* but do it the next time */
11726             }
11727         }
11728
11729         /* non-Latin1 code point implies unicode semantics.  Must be set in
11730          * pass1 so is there for the whole of pass 2 */
11731         if (value > 255) {
11732             RExC_uni_semantics = 1;
11733         }
11734
11735         /* now is the next time */
11736         if (!SIZE_ONLY) {
11737 #ifndef EBCDIC
11738             cp_list = _add_range_to_invlist(cp_list, prevvalue, value);
11739 #else
11740             UV* this_range = _new_invlist(1);
11741             _append_range_to_invlist(this_range, prevvalue, value);
11742
11743             /* In EBCDIC, the ranges 'A-Z' and 'a-z' are each not contiguous.
11744              * If this range was specified using something like 'i-j', we want
11745              * to include only the 'i' and the 'j', and not anything in
11746              * between, so exclude non-ASCII, non-alphabetics from it.
11747              * However, if the range was specified with something like
11748              * [\x89-\x91] or [\x89-j], all code points within it should be
11749              * included.  literal_endpoint==2 means both ends of the range used
11750              * a literal character, not \x{foo} */
11751             if (literal_endpoint == 2
11752                 && (prevvalue >= 'a' && value <= 'z')
11753                     || (prevvalue >= 'A' && value <= 'Z'))
11754             {
11755                 _invlist_intersection(this_range, PL_ASCII, &this_range, );
11756                 _invlist_intersection(this_range, PL_Alpha, &this_range, );
11757             }
11758             _invlist_union(cp_list, this_range, &cp_list);
11759             literal_endpoint = 0;
11760 #endif
11761         }
11762
11763         range = 0; /* this range (if it was one) is done now */
11764     }
11765
11766     /* [\w] can be optimized into \w, but not if there is anything else in the
11767      * brackets (except for an initial '^' which indictes omplementing).  We
11768      * also can optimize the common special case /[0-9]/ into /\d/a */
11769     if (element_count == 1 &&
11770         (has_special_charset_op
11771          || has_special_non_charset_op
11772          || (prevvalue == '0' && value == '9')))
11773     {
11774         U8 op;
11775         const char * cur_parse = RExC_parse;
11776
11777         if (has_special_charset_op) {
11778             U8 offset = get_regex_charset(RExC_flags);
11779
11780             /* /aa is the same as /a for these */
11781             if (offset == REGEX_ASCII_MORE_RESTRICTED_CHARSET) {
11782                 offset = REGEX_ASCII_RESTRICTED_CHARSET;
11783             }
11784             switch ((I32)namedclass) {
11785                 case ANYOF_NALNUM:
11786                     invert = ! invert;
11787                     /* FALLTHROUGH */
11788                 case ANYOF_ALNUM:
11789                     op = ALNUM;
11790                     break;
11791                 case ANYOF_NSPACE:
11792                     invert = ! invert;
11793                     /* FALLTHROUGH */
11794                 case ANYOF_SPACE:
11795                     op = SPACE;
11796                     break;
11797                 case ANYOF_NDIGIT:
11798                     invert = ! invert;
11799                     /* FALLTHROUGH */
11800                 case ANYOF_DIGIT:
11801                     op = DIGIT;
11802
11803                     /* There is no DIGITU */
11804                     if (offset == REGEX_UNICODE_CHARSET) {
11805                         offset = REGEX_DEPENDS_CHARSET;
11806                     }
11807                     break;
11808                 default:
11809                     Perl_croak(aTHX_ "panic: Named character class %"IVdf" is not expected to have a non-[...] version", namedclass);
11810             }
11811
11812             /* The number of varieties of each of these is the same, hence, so
11813              * is the delta between the normal and complemented nodes */
11814             if (invert) {
11815                 offset += NALNUM - ALNUM;
11816             }
11817
11818             op += offset;
11819         }
11820         else if (has_special_non_charset_op) {
11821             switch ((I32)namedclass) {
11822                 case ANYOF_NHORIZWS:
11823                     invert = ! invert;
11824                     /* FALLTHROUGH */
11825                 case ANYOF_HORIZWS:
11826                     op = HORIZWS;
11827                     break;
11828                 case ANYOF_NVERTWS:
11829                     invert = ! invert;
11830                     /* FALLTHROUGH */
11831                 case ANYOF_VERTWS:
11832                     op = VERTWS;
11833                     break;
11834                 default:
11835                     Perl_croak(aTHX_ "panic: Named character class %"IVdf" is not expected to have a non-[...] version", namedclass);
11836             }
11837
11838             /* The complement version of each of these nodes is adjacently next
11839              * */
11840             if (invert) {
11841                 op++;
11842             }
11843         }
11844         else {  /* The remaining possibility is [0-9] */
11845             op = (invert) ? NDIGITA : DIGITA;
11846         }
11847
11848         /* Throw away this ANYOF regnode, and emit the calculated one, which
11849          * should correspond to the beginning, not current, state of the parse
11850          */
11851         RExC_parse = (char *)orig_parse;
11852         RExC_emit = (regnode *)orig_emit;
11853         ret = reg_node(pRExC_state, op);
11854         RExC_parse = (char *) cur_parse;
11855
11856         SvREFCNT_dec(listsv);
11857         return ret;
11858     }
11859
11860     if (SIZE_ONLY)
11861         return ret;
11862     /****** !SIZE_ONLY AFTER HERE *********/
11863
11864     /* If folding, we calculate all characters that could fold to or from the
11865      * ones already on the list */
11866     if (FOLD && cp_list) {
11867         UV start, end;  /* End points of code point ranges */
11868
11869         SV* fold_intersection = NULL;
11870
11871         /* In the Latin1 range, the characters that can be folded-to or -from
11872          * are precisely the alphabetic characters.  If the highest code point
11873          * is within Latin1, we can use the compiled-in list, and not have to
11874          * go out to disk. */
11875         if (invlist_highest(cp_list) < 256) {
11876             _invlist_intersection(PL_L1PosixAlpha, cp_list, &fold_intersection);
11877         }
11878         else {
11879
11880             /* This is a list of all the characters that participate in folds
11881              * (except marks, etc in multi-char folds */
11882             if (! PL_utf8_foldable) {
11883                 SV* swash = swash_init("utf8", "Cased", &PL_sv_undef, 1, 0);
11884                 PL_utf8_foldable = _swash_to_invlist(swash);
11885                 SvREFCNT_dec(swash);
11886             }
11887
11888             /* This is a hash that for a particular fold gives all characters
11889              * that are involved in it */
11890             if (! PL_utf8_foldclosures) {
11891
11892                 /* If we were unable to find any folds, then we likely won't be
11893                  * able to find the closures.  So just create an empty list.
11894                  * Folding will effectively be restricted to the non-Unicode
11895                  * rules hard-coded into Perl.  (This case happens legitimately
11896                  * during compilation of Perl itself before the Unicode tables
11897                  * are generated) */
11898                 if (invlist_len(PL_utf8_foldable) == 0) {
11899                     PL_utf8_foldclosures = newHV();
11900                 }
11901                 else {
11902                     /* If the folds haven't been read in, call a fold function
11903                      * to force that */
11904                     if (! PL_utf8_tofold) {
11905                         U8 dummy[UTF8_MAXBYTES+1];
11906                         STRLEN dummy_len;
11907
11908                         /* This particular string is above \xff in both UTF-8
11909                          * and UTFEBCDIC */
11910                         to_utf8_fold((U8*) "\xC8\x80", dummy, &dummy_len);
11911                         assert(PL_utf8_tofold); /* Verify that worked */
11912                     }
11913                     PL_utf8_foldclosures =
11914                                         _swash_inversion_hash(PL_utf8_tofold);
11915                 }
11916             }
11917
11918             /* Only the characters in this class that participate in folds need
11919              * be checked.  Get the intersection of this class and all the
11920              * possible characters that are foldable.  This can quickly narrow
11921              * down a large class */
11922             _invlist_intersection(PL_utf8_foldable, cp_list,
11923                                   &fold_intersection);
11924         }
11925
11926         /* Now look at the foldable characters in this class individually */
11927         invlist_iterinit(fold_intersection);
11928         while (invlist_iternext(fold_intersection, &start, &end)) {
11929             UV j;
11930
11931             /* Locale folding for Latin1 characters is deferred until runtime */
11932             if (LOC && start < 256) {
11933                 start = 256;
11934             }
11935
11936             /* Look at every character in the range */
11937             for (j = start; j <= end; j++) {
11938
11939                 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
11940                 STRLEN foldlen;
11941                 UV f;
11942
11943                 if (j < 256) {
11944
11945                     /* We have the latin1 folding rules hard-coded here so that
11946                      * an innocent-looking character class, like /[ks]/i won't
11947                      * have to go out to disk to find the possible matches.
11948                      * XXX It would be better to generate these via regen, in
11949                      * case a new version of the Unicode standard adds new
11950                      * mappings, though that is not really likely, and may be
11951                      * caught by the default: case of the switch below. */
11952
11953                     if (PL_fold_latin1[j] != j) {
11954
11955                         /* ASCII is always matched; non-ASCII is matched only
11956                          * under Unicode rules */
11957                         if (isASCII(j) || AT_LEAST_UNI_SEMANTICS) {
11958                             cp_list =
11959                                 add_cp_to_invlist(cp_list, PL_fold_latin1[j]);
11960                         }
11961                         else {
11962                             depends_list =
11963                                 add_cp_to_invlist(depends_list, PL_fold_latin1[j]);
11964                         }
11965                     }
11966
11967                     if (HAS_NONLATIN1_FOLD_CLOSURE(j)
11968                         && (! isASCII(j) || ! MORE_ASCII_RESTRICTED))
11969                     {
11970                         /* Certain Latin1 characters have matches outside
11971                          * Latin1, or are multi-character.  To get here, 'j' is
11972                          * one of those characters.   None of these matches is
11973                          * valid for ASCII characters under /aa, which is why
11974                          * the 'if' just above excludes those.  The matches
11975                          * fall into three categories:
11976                          * 1) They are singly folded-to or -from an above 255
11977                          *    character, e.g., LATIN SMALL LETTER Y WITH
11978                          *    DIAERESIS and LATIN CAPITAL LETTER Y WITH
11979                          *    DIAERESIS;
11980                          * 2) They are part of a multi-char fold with another
11981                          *    latin1 character; only LATIN SMALL LETTER
11982                          *    SHARP S => "ss" fits this;
11983                          * 3) They are part of a multi-char fold with a
11984                          *    character outside of Latin1, such as various
11985                          *    ligatures.
11986                         * We aren't dealing fully with multi-char folds, except
11987                         * we do deal with the pattern containing a character
11988                         * that has a multi-char fold (not so much the inverse).
11989                         * For types 1) and 3), the matches only happen when the
11990                         * target string is utf8; that's not true for 2), and we
11991                         * set a flag for it.
11992                         *
11993                         * The code below adds the single fold closures for 'j'
11994                         * to the inversion list. */
11995                         switch (j) {
11996                             case 'k':
11997                             case 'K':
11998                                 /* KELVIN SIGN */
11999                                 cp_list =
12000                                     add_cp_to_invlist(cp_list, 0x212A);
12001                                 break;
12002                             case 's':
12003                             case 'S':
12004                                 /* LATIN SMALL LETTER LONG S */
12005                                 cp_list =
12006                                     add_cp_to_invlist(cp_list, 0x017F);
12007                                 break;
12008                             case MICRO_SIGN:
12009                                 cp_list = add_cp_to_invlist(cp_list,
12010                                                     GREEK_SMALL_LETTER_MU);
12011                                 cp_list = add_cp_to_invlist(cp_list,
12012                                                     GREEK_CAPITAL_LETTER_MU);
12013                                 break;
12014                             case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
12015                             case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
12016                                 /* ANGSTROM SIGN */
12017                                 cp_list =
12018                                         add_cp_to_invlist(cp_list, 0x212B);
12019                                 break;
12020                             case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
12021                                 cp_list = add_cp_to_invlist(cp_list,
12022                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
12023                                 break;
12024                             case LATIN_SMALL_LETTER_SHARP_S:
12025                                 cp_list = add_cp_to_invlist(cp_list,
12026                                                 LATIN_CAPITAL_LETTER_SHARP_S);
12027
12028                                 /* Under /a, /d, and /u, this can match the two
12029                                  * chars "ss" */
12030                                 if (! MORE_ASCII_RESTRICTED) {
12031                                     add_alternate(&unicode_alternate,
12032                                                   (U8 *) "ss", 2);
12033
12034                                     /* And under /u or /a, it can match even if
12035                                      * the target is not utf8 */
12036                                     if (AT_LEAST_UNI_SEMANTICS) {
12037                                         ANYOF_FLAGS(ret) |=
12038                                                     ANYOF_NONBITMAP_NON_UTF8;
12039                                     }
12040                                 }
12041                                 break;
12042                             case 'F': case 'f':
12043                             case 'I': case 'i':
12044                             case 'L': case 'l':
12045                             case 'T': case 't':
12046                             case 'A': case 'a':
12047                             case 'H': case 'h':
12048                             case 'J': case 'j':
12049                             case 'N': case 'n':
12050                             case 'W': case 'w':
12051                             case 'Y': case 'y':
12052                                 /* These all are targets of multi-character
12053                                  * folds from code points that require UTF8 to
12054                                  * express, so they can't match unless the
12055                                  * target string is in UTF-8, so no action here
12056                                  * is necessary, as regexec.c properly handles
12057                                  * the general case for UTF-8 matching */
12058                                 break;
12059                             default:
12060                                 /* Use deprecated warning to increase the
12061                                  * chances of this being output */
12062                                 ckWARN2regdep(RExC_parse, "Perl folding rules are not up-to-date for 0x%"UVXf"; please use the perlbug utility to report;", j);
12063                                 break;
12064                         }
12065                     }
12066                     continue;
12067                 }
12068
12069                 /* Here is an above Latin1 character.  We don't have the rules
12070                  * hard-coded for it.  First, get its fold */
12071                 f = _to_uni_fold_flags(j, foldbuf, &foldlen,
12072                                     ((allow_full_fold) ? FOLD_FLAGS_FULL : 0)
12073                                     | ((LOC)
12074                                         ? FOLD_FLAGS_LOCALE
12075                                         : (MORE_ASCII_RESTRICTED)
12076                                             ? FOLD_FLAGS_NOMIX_ASCII
12077                                             : 0));
12078
12079                 if (foldlen > (STRLEN)UNISKIP(f)) {
12080
12081                     /* Any multicharacter foldings (disallowed in lookbehind
12082                      * patterns) require the following transform: [ABCDEF] ->
12083                      * (?:[ABCabcDEFd]|pq|rst) where E folds into "pq" and F
12084                      * folds into "rst", all other characters fold to single
12085                      * characters.  We save away these multicharacter foldings,
12086                      * to be later saved as part of the additional "s" data. */
12087                     if (! RExC_in_lookbehind) {
12088                         U8* loc = foldbuf;
12089                         U8* e = foldbuf + foldlen;
12090
12091                         /* If any of the folded characters of this are in the
12092                          * Latin1 range, tell the regex engine that this can
12093                          * match a non-utf8 target string.  */
12094                         while (loc < e) {
12095                             if (UTF8_IS_INVARIANT(*loc)
12096                                 || UTF8_IS_DOWNGRADEABLE_START(*loc))
12097                             {
12098                                 ANYOF_FLAGS(ret)
12099                                         |= ANYOF_NONBITMAP_NON_UTF8;
12100                                 break;
12101                             }
12102                             loc += UTF8SKIP(loc);
12103                         }
12104
12105                         add_alternate(&unicode_alternate, foldbuf, foldlen);
12106                     }
12107                 }
12108                 else {
12109                     /* Single character fold of above Latin1.  Add everything
12110                      * in its fold closure to the list that this node should
12111                      * match */
12112                     SV** listp;
12113
12114                     /* The fold closures data structure is a hash with the keys
12115                      * being every character that is folded to, like 'k', and
12116                      * the values each an array of everything that folds to its
12117                      * key.  e.g. [ 'k', 'K', KELVIN_SIGN ] */
12118                     if ((listp = hv_fetch(PL_utf8_foldclosures,
12119                                     (char *) foldbuf, foldlen, FALSE)))
12120                     {
12121                         AV* list = (AV*) *listp;
12122                         IV k;
12123                         for (k = 0; k <= av_len(list); k++) {
12124                             SV** c_p = av_fetch(list, k, FALSE);
12125                             UV c;
12126                             if (c_p == NULL) {
12127                                 Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
12128                             }
12129                             c = SvUV(*c_p);
12130
12131                             /* /aa doesn't allow folds between ASCII and non-;
12132                              * /l doesn't allow them between above and below
12133                              * 256 */
12134                             if ((MORE_ASCII_RESTRICTED && (isASCII(c) != isASCII(j)))
12135                                 || (LOC && ((c < 256) != (j < 256))))
12136                             {
12137                                 continue;
12138                             }
12139
12140                             /* Folds involving non-ascii Latin1 characters
12141                              * under /d are added to a separate list */
12142                             if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS)
12143                             {
12144                                 cp_list = add_cp_to_invlist(cp_list, c);
12145                             }
12146                             else {
12147                                 depends_list = add_cp_to_invlist(depends_list, c);
12148                             }
12149                         }
12150                     }
12151                 }
12152             }
12153         }
12154         SvREFCNT_dec(fold_intersection);
12155     }
12156
12157     /* And combine the result (if any) with any inversion list from posix
12158      * classes.  The lists are kept separate up to now because we don't want to
12159      * fold the classes */
12160     if (posixes) {
12161         if (AT_LEAST_UNI_SEMANTICS) {
12162             if (cp_list) {
12163                 _invlist_union(cp_list, posixes, &cp_list);
12164                 SvREFCNT_dec(posixes);
12165             }
12166             else {
12167                 cp_list = posixes;
12168             }
12169         }
12170         else {
12171
12172             /* Under /d, we put into a separate list the Latin1 things that
12173              * match only when the target string is utf8 */
12174             SV* nonascii_but_latin1_properties = NULL;
12175             _invlist_intersection(posixes, PL_Latin1,
12176                                   &nonascii_but_latin1_properties);
12177             _invlist_subtract(nonascii_but_latin1_properties, PL_ASCII,
12178                               &nonascii_but_latin1_properties);
12179             _invlist_subtract(posixes, nonascii_but_latin1_properties,
12180                               &posixes);
12181             if (cp_list) {
12182                 _invlist_union(cp_list, posixes, &cp_list);
12183                 SvREFCNT_dec(posixes);
12184             }
12185             else {
12186                 cp_list = posixes;
12187             }
12188
12189             if (depends_list) {
12190                 _invlist_union(depends_list, nonascii_but_latin1_properties,
12191                                &depends_list);
12192                 SvREFCNT_dec(nonascii_but_latin1_properties);
12193             }
12194             else {
12195                 depends_list = nonascii_but_latin1_properties;
12196             }
12197         }
12198     }
12199
12200     /* And combine the result (if any) with any inversion list from properties.
12201      * The lists are kept separate up to now so that we can distinguish the two
12202      * in regards to matching above-Unicode.  A run-time warning is generated
12203      * if a Unicode property is matched against a non-Unicode code point. But,
12204      * we allow user-defined properties to match anything, without any warning,
12205      * and we also suppress the warning if there is a portion of the character
12206      * class that isn't a Unicode property, and which matches above Unicode, \W
12207      * or [\x{110000}] for example.
12208      * (Note that in this case, unlike the Posix one above, there is no
12209      * <depends_list>, because having a Unicode property forces Unicode
12210      * semantics */
12211     if (properties) {
12212         bool warn_super = ! has_user_defined_property;
12213         if (cp_list) {
12214
12215             /* If it matters to the final outcome, see if a non-property
12216              * component of the class matches above Unicode.  If so, the
12217              * warning gets suppressed.  This is true even if just a single
12218              * such code point is specified, as though not strictly correct if
12219              * another such code point is matched against, the fact that they
12220              * are using above-Unicode code points indicates they should know
12221              * the issues involved */
12222             if (warn_super) {
12223                 bool non_prop_matches_above_Unicode =
12224                             runtime_posix_matches_above_Unicode
12225                             | (invlist_highest(cp_list) > PERL_UNICODE_MAX);
12226                 if (invert) {
12227                     non_prop_matches_above_Unicode =
12228                                             !  non_prop_matches_above_Unicode;
12229                 }
12230                 warn_super = ! non_prop_matches_above_Unicode;
12231             }
12232
12233             _invlist_union(properties, cp_list, &cp_list);
12234             SvREFCNT_dec(properties);
12235         }
12236         else {
12237             cp_list = properties;
12238         }
12239
12240         if (warn_super) {
12241             ANYOF_FLAGS(ret) |= ANYOF_WARN_SUPER;
12242         }
12243     }
12244
12245     /* Here, we have calculated what code points should be in the character
12246      * class.
12247      *
12248      * Now we can see about various optimizations.  Fold calculation (which we
12249      * did above) needs to take place before inversion.  Otherwise /[^k]/i
12250      * would invert to include K, which under /i would match k, which it
12251      * shouldn't. */
12252
12253     /* Optimize inverted simple patterns (e.g. [^a-z]).  Note that we haven't
12254      * set the FOLD flag yet, so this does optimize those.  It doesn't
12255      * optimize locale.  Doing so perhaps could be done as long as there is
12256      * nothing like \w in it; some thought also would have to be given to the
12257      * interaction with above 0x100 chars */
12258     if (invert
12259         && ! LOC
12260         && ! depends_list
12261         && ! unicode_alternate
12262         && SvCUR(listsv) == initial_listsv_len)
12263     {
12264         _invlist_invert(cp_list);
12265
12266         /* Any swash can't be used as-is, because we've inverted things */
12267         if (swash) {
12268             SvREFCNT_dec(swash);
12269             swash = NULL;
12270         }
12271
12272         /* Clear the invert flag since have just done it here */
12273         invert = FALSE;
12274     }
12275
12276     /* Here, <cp_list> contains all the code points we can determine at
12277      * compile time that match under all conditions.  Go through it, and
12278      * for things that belong in the bitmap, put them there, and delete from
12279      * <cp_list> */
12280     if (cp_list) {
12281
12282         /* This gets set if we actually need to modify things */
12283         bool change_invlist = FALSE;
12284
12285         UV start, end;
12286
12287         /* Start looking through <cp_list> */
12288         invlist_iterinit(cp_list);
12289         while (invlist_iternext(cp_list, &start, &end)) {
12290             UV high;
12291             int i;
12292
12293             /* Quit if are above what we should change */
12294             if (start > 255) {
12295                 break;
12296             }
12297
12298             change_invlist = TRUE;
12299
12300             /* Set all the bits in the range, up to the max that we are doing */
12301             high = (end < 255) ? end : 255;
12302             for (i = start; i <= (int) high; i++) {
12303                 if (! ANYOF_BITMAP_TEST(ret, i)) {
12304                     ANYOF_BITMAP_SET(ret, i);
12305                     stored++;
12306                     prevvalue = value;
12307                     value = i;
12308                 }
12309             }
12310         }
12311
12312         /* Done with loop; remove any code points that are in the bitmap from
12313          * <cp_list> */
12314         if (change_invlist) {
12315             _invlist_subtract(cp_list, PL_Latin1, &cp_list);
12316         }
12317
12318         /* If have completely emptied it, remove it completely */
12319         if (invlist_len(cp_list) == 0) {
12320             SvREFCNT_dec(cp_list);
12321             cp_list = NULL;
12322         }
12323     }
12324
12325     if (invert) {
12326         ANYOF_FLAGS(ret) |= ANYOF_INVERT;
12327     }
12328
12329     /* Combine the two lists into one. */
12330     if (depends_list) {
12331         if (cp_list) {
12332             _invlist_union(cp_list, depends_list, &cp_list);
12333             SvREFCNT_dec(depends_list);
12334         }
12335         else {
12336             cp_list = depends_list;
12337         }
12338     }
12339
12340     /* Folding in the bitmap is taken care of above, but not for locale (for
12341      * which we have to wait to see what folding is in effect at runtime), and
12342      * for some things not in the bitmap (only the upper latin folds in this
12343      * case, as all other single-char folding has been set above).  Set
12344      * run-time fold flag for these */
12345     if (FOLD && (LOC
12346                 || (DEPENDS_SEMANTICS
12347                     && cp_list
12348                     && ! (ANYOF_FLAGS(ret) & ANYOF_NONBITMAP_NON_UTF8))
12349                 || unicode_alternate))
12350     {
12351         ANYOF_FLAGS(ret) |= ANYOF_LOC_NONBITMAP_FOLD;
12352     }
12353
12354     /* A single character class can be "optimized" into an EXACTish node.
12355      * Note that since we don't currently count how many characters there are
12356      * outside the bitmap, we are XXX missing optimization possibilities for
12357      * them.  This optimization can't happen unless this is a truly single
12358      * character class, which means that it can't be an inversion into a
12359      * many-character class, and there must be no possibility of there being
12360      * things outside the bitmap.  'stored' (only) for locales doesn't include
12361      * \w, etc, so have to make a special test that they aren't present
12362      *
12363      * Similarly A 2-character class of the very special form like [bB] can be
12364      * optimized into an EXACTFish node, but only for non-locales, and for
12365      * characters which only have the two folds; so things like 'fF' and 'Ii'
12366      * wouldn't work because they are part of the fold of 'LATIN SMALL LIGATURE
12367      * FI'. */
12368     if (! cp_list
12369         && ! unicode_alternate
12370         && SvCUR(listsv) == initial_listsv_len
12371         && ! (ANYOF_FLAGS(ret) & (ANYOF_INVERT|ANYOF_UNICODE_ALL))
12372         && (((stored == 1 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
12373                               || (! ANYOF_CLASS_TEST_ANY_SET(ret)))))
12374             || (stored == 2 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
12375                                  && (! _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value))
12376                                  /* If the latest code point has a fold whose
12377                                   * bit is set, it must be the only other one */
12378                                 && ((prevvalue = PL_fold_latin1[value]) != (IV)value)
12379                                  && ANYOF_BITMAP_TEST(ret, prevvalue)))))
12380     {
12381         /* Note that the information needed to decide to do this optimization
12382          * is not currently available until the 2nd pass, and that the actually
12383          * used EXACTish node takes less space than the calculated ANYOF node,
12384          * and hence the amount of space calculated in the first pass is larger
12385          * than actually used, so this optimization doesn't gain us any space.
12386          * But an EXACT node is faster than an ANYOF node, and can be combined
12387          * with any adjacent EXACT nodes later by the optimizer for further
12388          * gains.  The speed of executing an EXACTF is similar to an ANYOF
12389          * node, so the optimization advantage comes from the ability to join
12390          * it to adjacent EXACT nodes */
12391
12392         const char * cur_parse= RExC_parse;
12393         U8 op;
12394         RExC_emit = (regnode *)orig_emit;
12395         RExC_parse = (char *)orig_parse;
12396
12397         if (stored == 1) {
12398
12399             /* A locale node with one point can be folded; all the other cases
12400              * with folding will have two points, since we calculate them above
12401              */
12402             if (ANYOF_FLAGS(ret) & ANYOF_LOC_NONBITMAP_FOLD) {
12403                  op = EXACTFL;
12404             }
12405             else {
12406                 op = EXACT;
12407             }
12408         }
12409         else {   /* else 2 chars in the bit map: the folds of each other */
12410
12411             /* Use the folded value, which for the cases where we get here,
12412              * is just the lower case of the current one (which may resolve to
12413              * itself, or to the other one */
12414             value = toLOWER_LATIN1(value);
12415
12416             /* To join adjacent nodes, they must be the exact EXACTish type.
12417              * Try to use the most likely type, by using EXACTFA if possible,
12418              * then EXACTFU if the regex calls for it, or is required because
12419              * the character is non-ASCII.  (If <value> is ASCII, its fold is
12420              * also ASCII for the cases where we get here.) */
12421             if (MORE_ASCII_RESTRICTED && isASCII(value)) {
12422                 op = EXACTFA;
12423             }
12424             else if (AT_LEAST_UNI_SEMANTICS || !isASCII(value)) {
12425                 op = EXACTFU;
12426             }
12427             else {    /* Otherwise, more likely to be EXACTF type */
12428                 op = EXACTF;
12429             }
12430         }
12431
12432         ret = reg_node(pRExC_state, op);
12433         RExC_parse = (char *)cur_parse;
12434         if (UTF && ! NATIVE_IS_INVARIANT(value)) {
12435             *STRING(ret)= UTF8_EIGHT_BIT_HI((U8) value);
12436             *(STRING(ret) + 1)= UTF8_EIGHT_BIT_LO((U8) value);
12437             STR_LEN(ret)= 2;
12438             RExC_emit += STR_SZ(2);
12439         }
12440         else {
12441             *STRING(ret)= (char)value;
12442             STR_LEN(ret)= 1;
12443             RExC_emit += STR_SZ(1);
12444         }
12445         SvREFCNT_dec(listsv);
12446         return ret;
12447     }
12448
12449     /* If there is a swash and more than one element, we can't use the swash in
12450      * the optimization below. */
12451     if (swash && element_count > 1) {
12452         SvREFCNT_dec(swash);
12453         swash = NULL;
12454     }
12455     if (! cp_list
12456         && SvCUR(listsv) == initial_listsv_len
12457         && ! unicode_alternate)
12458     {
12459         ARG_SET(ret, ANYOF_NONBITMAP_EMPTY);
12460         SvREFCNT_dec(listsv);
12461         SvREFCNT_dec(unicode_alternate);
12462     }
12463     else {
12464         /* av[0] stores the character class description in its textual form:
12465          *       used later (regexec.c:Perl_regclass_swash()) to initialize the
12466          *       appropriate swash, and is also useful for dumping the regnode.
12467          * av[1] if NULL, is a placeholder to later contain the swash computed
12468          *       from av[0].  But if no further computation need be done, the
12469          *       swash is stored there now.
12470          * av[2] stores the multicharacter foldings, used later in
12471          *       regexec.c:S_reginclass().
12472          * av[3] stores the cp_list inversion list for use in addition or
12473          *       instead of av[0]; used only if av[1] is NULL
12474          * av[4] is set if any component of the class is from a user-defined
12475          *       property; used only if av[1] is NULL */
12476         AV * const av = newAV();
12477         SV *rv;
12478
12479         av_store(av, 0, (SvCUR(listsv) == initial_listsv_len)
12480                         ? &PL_sv_undef
12481                         : listsv);
12482         if (swash) {
12483             av_store(av, 1, swash);
12484             SvREFCNT_dec(cp_list);
12485         }
12486         else {
12487             av_store(av, 1, NULL);
12488             if (cp_list) {
12489                 av_store(av, 3, cp_list);
12490                 av_store(av, 4, newSVuv(has_user_defined_property));
12491             }
12492         }
12493
12494         /* Store any computed multi-char folds only if we are allowing
12495          * them */
12496         if (allow_full_fold) {
12497             av_store(av, 2, MUTABLE_SV(unicode_alternate));
12498             if (unicode_alternate) { /* This node is variable length */
12499                 OP(ret) = ANYOFV;
12500             }
12501         }
12502         else {
12503             av_store(av, 2, NULL);
12504         }
12505         rv = newRV_noinc(MUTABLE_SV(av));
12506         n = add_data(pRExC_state, 1, "s");
12507         RExC_rxi->data->data[n] = (void*)rv;
12508         ARG_SET(ret, n);
12509     }
12510     return ret;
12511 }
12512
12513
12514 /* reg_skipcomment()
12515
12516    Absorbs an /x style # comments from the input stream.
12517    Returns true if there is more text remaining in the stream.
12518    Will set the REG_SEEN_RUN_ON_COMMENT flag if the comment
12519    terminates the pattern without including a newline.
12520
12521    Note its the callers responsibility to ensure that we are
12522    actually in /x mode
12523
12524 */
12525
12526 STATIC bool
12527 S_reg_skipcomment(pTHX_ RExC_state_t *pRExC_state)
12528 {
12529     bool ended = 0;
12530
12531     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
12532
12533     while (RExC_parse < RExC_end)
12534         if (*RExC_parse++ == '\n') {
12535             ended = 1;
12536             break;
12537         }
12538     if (!ended) {
12539         /* we ran off the end of the pattern without ending
12540            the comment, so we have to add an \n when wrapping */
12541         RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
12542         return 0;
12543     } else
12544         return 1;
12545 }
12546
12547 /* nextchar()
12548
12549    Advances the parse position, and optionally absorbs
12550    "whitespace" from the inputstream.
12551
12552    Without /x "whitespace" means (?#...) style comments only,
12553    with /x this means (?#...) and # comments and whitespace proper.
12554
12555    Returns the RExC_parse point from BEFORE the scan occurs.
12556
12557    This is the /x friendly way of saying RExC_parse++.
12558 */
12559
12560 STATIC char*
12561 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
12562 {
12563     char* const retval = RExC_parse++;
12564
12565     PERL_ARGS_ASSERT_NEXTCHAR;
12566
12567     for (;;) {
12568         if (RExC_end - RExC_parse >= 3
12569             && *RExC_parse == '('
12570             && RExC_parse[1] == '?'
12571             && RExC_parse[2] == '#')
12572         {
12573             while (*RExC_parse != ')') {
12574                 if (RExC_parse == RExC_end)
12575                     FAIL("Sequence (?#... not terminated");
12576                 RExC_parse++;
12577             }
12578             RExC_parse++;
12579             continue;
12580         }
12581         if (RExC_flags & RXf_PMf_EXTENDED) {
12582             if (isSPACE(*RExC_parse)) {
12583                 RExC_parse++;
12584                 continue;
12585             }
12586             else if (*RExC_parse == '#') {
12587                 if ( reg_skipcomment( pRExC_state ) )
12588                     continue;
12589             }
12590         }
12591         return retval;
12592     }
12593 }
12594
12595 /*
12596 - reg_node - emit a node
12597 */
12598 STATIC regnode *                        /* Location. */
12599 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
12600 {
12601     dVAR;
12602     register regnode *ptr;
12603     regnode * const ret = RExC_emit;
12604     GET_RE_DEBUG_FLAGS_DECL;
12605
12606     PERL_ARGS_ASSERT_REG_NODE;
12607
12608     if (SIZE_ONLY) {
12609         SIZE_ALIGN(RExC_size);
12610         RExC_size += 1;
12611         return(ret);
12612     }
12613     if (RExC_emit >= RExC_emit_bound)
12614         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
12615                    op, RExC_emit, RExC_emit_bound);
12616
12617     NODE_ALIGN_FILL(ret);
12618     ptr = ret;
12619     FILL_ADVANCE_NODE(ptr, op);
12620 #ifdef RE_TRACK_PATTERN_OFFSETS
12621     if (RExC_offsets) {         /* MJD */
12622         MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n", 
12623               "reg_node", __LINE__, 
12624               PL_reg_name[op],
12625               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] 
12626                 ? "Overwriting end of array!\n" : "OK",
12627               (UV)(RExC_emit - RExC_emit_start),
12628               (UV)(RExC_parse - RExC_start),
12629               (UV)RExC_offsets[0])); 
12630         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
12631     }
12632 #endif
12633     RExC_emit = ptr;
12634     return(ret);
12635 }
12636
12637 /*
12638 - reganode - emit a node with an argument
12639 */
12640 STATIC regnode *                        /* Location. */
12641 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
12642 {
12643     dVAR;
12644     register regnode *ptr;
12645     regnode * const ret = RExC_emit;
12646     GET_RE_DEBUG_FLAGS_DECL;
12647
12648     PERL_ARGS_ASSERT_REGANODE;
12649
12650     if (SIZE_ONLY) {
12651         SIZE_ALIGN(RExC_size);
12652         RExC_size += 2;
12653         /* 
12654            We can't do this:
12655            
12656            assert(2==regarglen[op]+1); 
12657
12658            Anything larger than this has to allocate the extra amount.
12659            If we changed this to be:
12660            
12661            RExC_size += (1 + regarglen[op]);
12662            
12663            then it wouldn't matter. Its not clear what side effect
12664            might come from that so its not done so far.
12665            -- dmq
12666         */
12667         return(ret);
12668     }
12669     if (RExC_emit >= RExC_emit_bound)
12670         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
12671                    op, RExC_emit, RExC_emit_bound);
12672
12673     NODE_ALIGN_FILL(ret);
12674     ptr = ret;
12675     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
12676 #ifdef RE_TRACK_PATTERN_OFFSETS
12677     if (RExC_offsets) {         /* MJD */
12678         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
12679               "reganode",
12680               __LINE__,
12681               PL_reg_name[op],
12682               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? 
12683               "Overwriting end of array!\n" : "OK",
12684               (UV)(RExC_emit - RExC_emit_start),
12685               (UV)(RExC_parse - RExC_start),
12686               (UV)RExC_offsets[0])); 
12687         Set_Cur_Node_Offset;
12688     }
12689 #endif            
12690     RExC_emit = ptr;
12691     return(ret);
12692 }
12693
12694 /*
12695 - reguni - emit (if appropriate) a Unicode character
12696 */
12697 STATIC STRLEN
12698 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
12699 {
12700     dVAR;
12701
12702     PERL_ARGS_ASSERT_REGUNI;
12703
12704     return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
12705 }
12706
12707 /*
12708 - reginsert - insert an operator in front of already-emitted operand
12709 *
12710 * Means relocating the operand.
12711 */
12712 STATIC void
12713 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
12714 {
12715     dVAR;
12716     register regnode *src;
12717     register regnode *dst;
12718     register regnode *place;
12719     const int offset = regarglen[(U8)op];
12720     const int size = NODE_STEP_REGNODE + offset;
12721     GET_RE_DEBUG_FLAGS_DECL;
12722
12723     PERL_ARGS_ASSERT_REGINSERT;
12724     PERL_UNUSED_ARG(depth);
12725 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
12726     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
12727     if (SIZE_ONLY) {
12728         RExC_size += size;
12729         return;
12730     }
12731
12732     src = RExC_emit;
12733     RExC_emit += size;
12734     dst = RExC_emit;
12735     if (RExC_open_parens) {
12736         int paren;
12737         /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
12738         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
12739             if ( RExC_open_parens[paren] >= opnd ) {
12740                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
12741                 RExC_open_parens[paren] += size;
12742             } else {
12743                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
12744             }
12745             if ( RExC_close_parens[paren] >= opnd ) {
12746                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
12747                 RExC_close_parens[paren] += size;
12748             } else {
12749                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
12750             }
12751         }
12752     }
12753
12754     while (src > opnd) {
12755         StructCopy(--src, --dst, regnode);
12756 #ifdef RE_TRACK_PATTERN_OFFSETS
12757         if (RExC_offsets) {     /* MJD 20010112 */
12758             MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
12759                   "reg_insert",
12760                   __LINE__,
12761                   PL_reg_name[op],
12762                   (UV)(dst - RExC_emit_start) > RExC_offsets[0] 
12763                     ? "Overwriting end of array!\n" : "OK",
12764                   (UV)(src - RExC_emit_start),
12765                   (UV)(dst - RExC_emit_start),
12766                   (UV)RExC_offsets[0])); 
12767             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
12768             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
12769         }
12770 #endif
12771     }
12772     
12773
12774     place = opnd;               /* Op node, where operand used to be. */
12775 #ifdef RE_TRACK_PATTERN_OFFSETS
12776     if (RExC_offsets) {         /* MJD */
12777         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
12778               "reginsert",
12779               __LINE__,
12780               PL_reg_name[op],
12781               (UV)(place - RExC_emit_start) > RExC_offsets[0] 
12782               ? "Overwriting end of array!\n" : "OK",
12783               (UV)(place - RExC_emit_start),
12784               (UV)(RExC_parse - RExC_start),
12785               (UV)RExC_offsets[0]));
12786         Set_Node_Offset(place, RExC_parse);
12787         Set_Node_Length(place, 1);
12788     }
12789 #endif    
12790     src = NEXTOPER(place);
12791     FILL_ADVANCE_NODE(place, op);
12792     Zero(src, offset, regnode);
12793 }
12794
12795 /*
12796 - regtail - set the next-pointer at the end of a node chain of p to val.
12797 - SEE ALSO: regtail_study
12798 */
12799 /* TODO: All three parms should be const */
12800 STATIC void
12801 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
12802 {
12803     dVAR;
12804     register regnode *scan;
12805     GET_RE_DEBUG_FLAGS_DECL;
12806
12807     PERL_ARGS_ASSERT_REGTAIL;
12808 #ifndef DEBUGGING
12809     PERL_UNUSED_ARG(depth);
12810 #endif
12811
12812     if (SIZE_ONLY)
12813         return;
12814
12815     /* Find last node. */
12816     scan = p;
12817     for (;;) {
12818         regnode * const temp = regnext(scan);
12819         DEBUG_PARSE_r({
12820             SV * const mysv=sv_newmortal();
12821             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
12822             regprop(RExC_rx, mysv, scan);
12823             PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
12824                 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
12825                     (temp == NULL ? "->" : ""),
12826                     (temp == NULL ? PL_reg_name[OP(val)] : "")
12827             );
12828         });
12829         if (temp == NULL)
12830             break;
12831         scan = temp;
12832     }
12833
12834     if (reg_off_by_arg[OP(scan)]) {
12835         ARG_SET(scan, val - scan);
12836     }
12837     else {
12838         NEXT_OFF(scan) = val - scan;
12839     }
12840 }
12841
12842 #ifdef DEBUGGING
12843 /*
12844 - regtail_study - set the next-pointer at the end of a node chain of p to val.
12845 - Look for optimizable sequences at the same time.
12846 - currently only looks for EXACT chains.
12847
12848 This is experimental code. The idea is to use this routine to perform 
12849 in place optimizations on branches and groups as they are constructed,
12850 with the long term intention of removing optimization from study_chunk so
12851 that it is purely analytical.
12852
12853 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
12854 to control which is which.
12855
12856 */
12857 /* TODO: All four parms should be const */
12858
12859 STATIC U8
12860 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
12861 {
12862     dVAR;
12863     register regnode *scan;
12864     U8 exact = PSEUDO;
12865 #ifdef EXPERIMENTAL_INPLACESCAN
12866     I32 min = 0;
12867 #endif
12868     GET_RE_DEBUG_FLAGS_DECL;
12869
12870     PERL_ARGS_ASSERT_REGTAIL_STUDY;
12871
12872
12873     if (SIZE_ONLY)
12874         return exact;
12875
12876     /* Find last node. */
12877
12878     scan = p;
12879     for (;;) {
12880         regnode * const temp = regnext(scan);
12881 #ifdef EXPERIMENTAL_INPLACESCAN
12882         if (PL_regkind[OP(scan)] == EXACT) {
12883             bool has_exactf_sharp_s;    /* Unexamined in this routine */
12884             if (join_exact(pRExC_state,scan,&min, &has_exactf_sharp_s, 1,val,depth+1))
12885                 return EXACT;
12886         }
12887 #endif
12888         if ( exact ) {
12889             switch (OP(scan)) {
12890                 case EXACT:
12891                 case EXACTF:
12892                 case EXACTFA:
12893                 case EXACTFU:
12894                 case EXACTFU_SS:
12895                 case EXACTFU_TRICKYFOLD:
12896                 case EXACTFL:
12897                         if( exact == PSEUDO )
12898                             exact= OP(scan);
12899                         else if ( exact != OP(scan) )
12900                             exact= 0;
12901                 case NOTHING:
12902                     break;
12903                 default:
12904                     exact= 0;
12905             }
12906         }
12907         DEBUG_PARSE_r({
12908             SV * const mysv=sv_newmortal();
12909             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
12910             regprop(RExC_rx, mysv, scan);
12911             PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
12912                 SvPV_nolen_const(mysv),
12913                 REG_NODE_NUM(scan),
12914                 PL_reg_name[exact]);
12915         });
12916         if (temp == NULL)
12917             break;
12918         scan = temp;
12919     }
12920     DEBUG_PARSE_r({
12921         SV * const mysv_val=sv_newmortal();
12922         DEBUG_PARSE_MSG("");
12923         regprop(RExC_rx, mysv_val, val);
12924         PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
12925                       SvPV_nolen_const(mysv_val),
12926                       (IV)REG_NODE_NUM(val),
12927                       (IV)(val - scan)
12928         );
12929     });
12930     if (reg_off_by_arg[OP(scan)]) {
12931         ARG_SET(scan, val - scan);
12932     }
12933     else {
12934         NEXT_OFF(scan) = val - scan;
12935     }
12936
12937     return exact;
12938 }
12939 #endif
12940
12941 /*
12942  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
12943  */
12944 #ifdef DEBUGGING
12945 static void 
12946 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
12947 {
12948     int bit;
12949     int set=0;
12950     regex_charset cs;
12951
12952     for (bit=0; bit<32; bit++) {
12953         if (flags & (1<<bit)) {
12954             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
12955                 continue;
12956             }
12957             if (!set++ && lead) 
12958                 PerlIO_printf(Perl_debug_log, "%s",lead);
12959             PerlIO_printf(Perl_debug_log, "%s ",PL_reg_extflags_name[bit]);
12960         }               
12961     }      
12962     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
12963             if (!set++ && lead) {
12964                 PerlIO_printf(Perl_debug_log, "%s",lead);
12965             }
12966             switch (cs) {
12967                 case REGEX_UNICODE_CHARSET:
12968                     PerlIO_printf(Perl_debug_log, "UNICODE");
12969                     break;
12970                 case REGEX_LOCALE_CHARSET:
12971                     PerlIO_printf(Perl_debug_log, "LOCALE");
12972                     break;
12973                 case REGEX_ASCII_RESTRICTED_CHARSET:
12974                     PerlIO_printf(Perl_debug_log, "ASCII-RESTRICTED");
12975                     break;
12976                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
12977                     PerlIO_printf(Perl_debug_log, "ASCII-MORE_RESTRICTED");
12978                     break;
12979                 default:
12980                     PerlIO_printf(Perl_debug_log, "UNKNOWN CHARACTER SET");
12981                     break;
12982             }
12983     }
12984     if (lead)  {
12985         if (set) 
12986             PerlIO_printf(Perl_debug_log, "\n");
12987         else 
12988             PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
12989     }            
12990 }   
12991 #endif
12992
12993 void
12994 Perl_regdump(pTHX_ const regexp *r)
12995 {
12996 #ifdef DEBUGGING
12997     dVAR;
12998     SV * const sv = sv_newmortal();
12999     SV *dsv= sv_newmortal();
13000     RXi_GET_DECL(r,ri);
13001     GET_RE_DEBUG_FLAGS_DECL;
13002
13003     PERL_ARGS_ASSERT_REGDUMP;
13004
13005     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
13006
13007     /* Header fields of interest. */
13008     if (r->anchored_substr) {
13009         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr), 
13010             RE_SV_DUMPLEN(r->anchored_substr), 30);
13011         PerlIO_printf(Perl_debug_log,
13012                       "anchored %s%s at %"IVdf" ",
13013                       s, RE_SV_TAIL(r->anchored_substr),
13014                       (IV)r->anchored_offset);
13015     } else if (r->anchored_utf8) {
13016         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8), 
13017             RE_SV_DUMPLEN(r->anchored_utf8), 30);
13018         PerlIO_printf(Perl_debug_log,
13019                       "anchored utf8 %s%s at %"IVdf" ",
13020                       s, RE_SV_TAIL(r->anchored_utf8),
13021                       (IV)r->anchored_offset);
13022     }                 
13023     if (r->float_substr) {
13024         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr), 
13025             RE_SV_DUMPLEN(r->float_substr), 30);
13026         PerlIO_printf(Perl_debug_log,
13027                       "floating %s%s at %"IVdf"..%"UVuf" ",
13028                       s, RE_SV_TAIL(r->float_substr),
13029                       (IV)r->float_min_offset, (UV)r->float_max_offset);
13030     } else if (r->float_utf8) {
13031         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8), 
13032             RE_SV_DUMPLEN(r->float_utf8), 30);
13033         PerlIO_printf(Perl_debug_log,
13034                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
13035                       s, RE_SV_TAIL(r->float_utf8),
13036                       (IV)r->float_min_offset, (UV)r->float_max_offset);
13037     }
13038     if (r->check_substr || r->check_utf8)
13039         PerlIO_printf(Perl_debug_log,
13040                       (const char *)
13041                       (r->check_substr == r->float_substr
13042                        && r->check_utf8 == r->float_utf8
13043                        ? "(checking floating" : "(checking anchored"));
13044     if (r->extflags & RXf_NOSCAN)
13045         PerlIO_printf(Perl_debug_log, " noscan");
13046     if (r->extflags & RXf_CHECK_ALL)
13047         PerlIO_printf(Perl_debug_log, " isall");
13048     if (r->check_substr || r->check_utf8)
13049         PerlIO_printf(Perl_debug_log, ") ");
13050
13051     if (ri->regstclass) {
13052         regprop(r, sv, ri->regstclass);
13053         PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
13054     }
13055     if (r->extflags & RXf_ANCH) {
13056         PerlIO_printf(Perl_debug_log, "anchored");
13057         if (r->extflags & RXf_ANCH_BOL)
13058             PerlIO_printf(Perl_debug_log, "(BOL)");
13059         if (r->extflags & RXf_ANCH_MBOL)
13060             PerlIO_printf(Perl_debug_log, "(MBOL)");
13061         if (r->extflags & RXf_ANCH_SBOL)
13062             PerlIO_printf(Perl_debug_log, "(SBOL)");
13063         if (r->extflags & RXf_ANCH_GPOS)
13064             PerlIO_printf(Perl_debug_log, "(GPOS)");
13065         PerlIO_putc(Perl_debug_log, ' ');
13066     }
13067     if (r->extflags & RXf_GPOS_SEEN)
13068         PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
13069     if (r->intflags & PREGf_SKIP)
13070         PerlIO_printf(Perl_debug_log, "plus ");
13071     if (r->intflags & PREGf_IMPLICIT)
13072         PerlIO_printf(Perl_debug_log, "implicit ");
13073     PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
13074     if (r->extflags & RXf_EVAL_SEEN)
13075         PerlIO_printf(Perl_debug_log, "with eval ");
13076     PerlIO_printf(Perl_debug_log, "\n");
13077     DEBUG_FLAGS_r(regdump_extflags("r->extflags: ",r->extflags));            
13078 #else
13079     PERL_ARGS_ASSERT_REGDUMP;
13080     PERL_UNUSED_CONTEXT;
13081     PERL_UNUSED_ARG(r);
13082 #endif  /* DEBUGGING */
13083 }
13084
13085 /*
13086 - regprop - printable representation of opcode
13087 */
13088 #define EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags) \
13089 STMT_START { \
13090         if (do_sep) {                           \
13091             Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]); \
13092             if (flags & ANYOF_INVERT)           \
13093                 /*make sure the invert info is in each */ \
13094                 sv_catpvs(sv, "^");             \
13095             do_sep = 0;                         \
13096         }                                       \
13097 } STMT_END
13098
13099 void
13100 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
13101 {
13102 #ifdef DEBUGGING
13103     dVAR;
13104     register int k;
13105     RXi_GET_DECL(prog,progi);
13106     GET_RE_DEBUG_FLAGS_DECL;
13107     
13108     PERL_ARGS_ASSERT_REGPROP;
13109
13110     sv_setpvs(sv, "");
13111
13112     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
13113         /* It would be nice to FAIL() here, but this may be called from
13114            regexec.c, and it would be hard to supply pRExC_state. */
13115         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
13116     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
13117
13118     k = PL_regkind[OP(o)];
13119
13120     if (k == EXACT) {
13121         sv_catpvs(sv, " ");
13122         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT) 
13123          * is a crude hack but it may be the best for now since 
13124          * we have no flag "this EXACTish node was UTF-8" 
13125          * --jhi */
13126         pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
13127                   PERL_PV_ESCAPE_UNI_DETECT |
13128                   PERL_PV_ESCAPE_NONASCII   |
13129                   PERL_PV_PRETTY_ELLIPSES   |
13130                   PERL_PV_PRETTY_LTGT       |
13131                   PERL_PV_PRETTY_NOCLEAR
13132                   );
13133     } else if (k == TRIE) {
13134         /* print the details of the trie in dumpuntil instead, as
13135          * progi->data isn't available here */
13136         const char op = OP(o);
13137         const U32 n = ARG(o);
13138         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
13139                (reg_ac_data *)progi->data->data[n] :
13140                NULL;
13141         const reg_trie_data * const trie
13142             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
13143         
13144         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
13145         DEBUG_TRIE_COMPILE_r(
13146             Perl_sv_catpvf(aTHX_ sv,
13147                 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
13148                 (UV)trie->startstate,
13149                 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
13150                 (UV)trie->wordcount,
13151                 (UV)trie->minlen,
13152                 (UV)trie->maxlen,
13153                 (UV)TRIE_CHARCOUNT(trie),
13154                 (UV)trie->uniquecharcount
13155             )
13156         );
13157         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
13158             int i;
13159             int rangestart = -1;
13160             U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
13161             sv_catpvs(sv, "[");
13162             for (i = 0; i <= 256; i++) {
13163                 if (i < 256 && BITMAP_TEST(bitmap,i)) {
13164                     if (rangestart == -1)
13165                         rangestart = i;
13166                 } else if (rangestart != -1) {
13167                     if (i <= rangestart + 3)
13168                         for (; rangestart < i; rangestart++)
13169                             put_byte(sv, rangestart);
13170                     else {
13171                         put_byte(sv, rangestart);
13172                         sv_catpvs(sv, "-");
13173                         put_byte(sv, i - 1);
13174                     }
13175                     rangestart = -1;
13176                 }
13177             }
13178             sv_catpvs(sv, "]");
13179         } 
13180          
13181     } else if (k == CURLY) {
13182         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
13183             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
13184         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
13185     }
13186     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
13187         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
13188     else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
13189         Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
13190         if ( RXp_PAREN_NAMES(prog) ) {
13191             if ( k != REF || (OP(o) < NREF)) {
13192                 AV *list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
13193                 SV **name= av_fetch(list, ARG(o), 0 );
13194                 if (name)
13195                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
13196             }       
13197             else {
13198                 AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]);
13199                 SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]);
13200                 I32 *nums=(I32*)SvPVX(sv_dat);
13201                 SV **name= av_fetch(list, nums[0], 0 );
13202                 I32 n;
13203                 if (name) {
13204                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
13205                         Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
13206                                     (n ? "," : ""), (IV)nums[n]);
13207                     }
13208                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
13209                 }
13210             }
13211         }            
13212     } else if (k == GOSUB) 
13213         Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
13214     else if (k == VERB) {
13215         if (!o->flags) 
13216             Perl_sv_catpvf(aTHX_ sv, ":%"SVf, 
13217                            SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
13218     } else if (k == LOGICAL)
13219         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);     /* 2: embedded, otherwise 1 */
13220     else if (k == ANYOF) {
13221         int i, rangestart = -1;
13222         const U8 flags = ANYOF_FLAGS(o);
13223         int do_sep = 0;
13224
13225         /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
13226         static const char * const anyofs[] = {
13227             "\\w",
13228             "\\W",
13229             "\\s",
13230             "\\S",
13231             "\\d",
13232             "\\D",
13233             "[:alnum:]",
13234             "[:^alnum:]",
13235             "[:alpha:]",
13236             "[:^alpha:]",
13237             "[:ascii:]",
13238             "[:^ascii:]",
13239             "[:cntrl:]",
13240             "[:^cntrl:]",
13241             "[:graph:]",
13242             "[:^graph:]",
13243             "[:lower:]",
13244             "[:^lower:]",
13245             "[:print:]",
13246             "[:^print:]",
13247             "[:punct:]",
13248             "[:^punct:]",
13249             "[:upper:]",
13250             "[:^upper:]",
13251             "[:xdigit:]",
13252             "[:^xdigit:]",
13253             "[:space:]",
13254             "[:^space:]",
13255             "[:blank:]",
13256             "[:^blank:]"
13257         };
13258
13259         if (flags & ANYOF_LOCALE)
13260             sv_catpvs(sv, "{loc}");
13261         if (flags & ANYOF_LOC_NONBITMAP_FOLD)
13262             sv_catpvs(sv, "{i}");
13263         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
13264         if (flags & ANYOF_INVERT)
13265             sv_catpvs(sv, "^");
13266
13267         /* output what the standard cp 0-255 bitmap matches */
13268         for (i = 0; i <= 256; i++) {
13269             if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
13270                 if (rangestart == -1)
13271                     rangestart = i;
13272             } else if (rangestart != -1) {
13273                 if (i <= rangestart + 3)
13274                     for (; rangestart < i; rangestart++)
13275                         put_byte(sv, rangestart);
13276                 else {
13277                     put_byte(sv, rangestart);
13278                     sv_catpvs(sv, "-");
13279                     put_byte(sv, i - 1);
13280                 }
13281                 do_sep = 1;
13282                 rangestart = -1;
13283             }
13284         }
13285         
13286         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
13287         /* output any special charclass tests (used entirely under use locale) */
13288         if (ANYOF_CLASS_TEST_ANY_SET(o))
13289             for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
13290                 if (ANYOF_CLASS_TEST(o,i)) {
13291                     sv_catpv(sv, anyofs[i]);
13292                     do_sep = 1;
13293                 }
13294         
13295         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
13296         
13297         if (flags & ANYOF_NON_UTF8_LATIN1_ALL) {
13298             sv_catpvs(sv, "{non-utf8-latin1-all}");
13299         }
13300
13301         /* output information about the unicode matching */
13302         if (flags & ANYOF_UNICODE_ALL)
13303             sv_catpvs(sv, "{unicode_all}");
13304         else if (ANYOF_NONBITMAP(o))
13305             sv_catpvs(sv, "{unicode}");
13306         if (flags & ANYOF_NONBITMAP_NON_UTF8)
13307             sv_catpvs(sv, "{outside bitmap}");
13308
13309         if (ANYOF_NONBITMAP(o)) {
13310             SV *lv; /* Set if there is something outside the bit map */
13311             SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
13312             bool byte_output = FALSE;   /* If something in the bitmap has been
13313                                            output */
13314
13315             if (lv && lv != &PL_sv_undef) {
13316                 if (sw) {
13317                     U8 s[UTF8_MAXBYTES_CASE+1];
13318
13319                     for (i = 0; i <= 256; i++) { /* Look at chars in bitmap */
13320                         uvchr_to_utf8(s, i);
13321
13322                         if (i < 256
13323                             && ! ANYOF_BITMAP_TEST(o, i)    /* Don't duplicate
13324                                                                things already
13325                                                                output as part
13326                                                                of the bitmap */
13327                             && swash_fetch(sw, s, TRUE))
13328                         {
13329                             if (rangestart == -1)
13330                                 rangestart = i;
13331                         } else if (rangestart != -1) {
13332                             byte_output = TRUE;
13333                             if (i <= rangestart + 3)
13334                                 for (; rangestart < i; rangestart++) {
13335                                     put_byte(sv, rangestart);
13336                                 }
13337                             else {
13338                                 put_byte(sv, rangestart);
13339                                 sv_catpvs(sv, "-");
13340                                 put_byte(sv, i-1);
13341                             }
13342                             rangestart = -1;
13343                         }
13344                     }
13345                 }
13346
13347                 {
13348                     char *s = savesvpv(lv);
13349                     char * const origs = s;
13350
13351                     while (*s && *s != '\n')
13352                         s++;
13353
13354                     if (*s == '\n') {
13355                         const char * const t = ++s;
13356
13357                         if (byte_output) {
13358                             sv_catpvs(sv, " ");
13359                         }
13360
13361                         while (*s) {
13362                             if (*s == '\n') {
13363
13364                                 /* Truncate very long output */
13365                                 if (s - origs > 256) {
13366                                     Perl_sv_catpvf(aTHX_ sv,
13367                                                    "%.*s...",
13368                                                    (int) (s - origs - 1),
13369                                                    t);
13370                                     goto out_dump;
13371                                 }
13372                                 *s = ' ';
13373                             }
13374                             else if (*s == '\t') {
13375                                 *s = '-';
13376                             }
13377                             s++;
13378                         }
13379                         if (s[-1] == ' ')
13380                             s[-1] = 0;
13381
13382                         sv_catpv(sv, t);
13383                     }
13384
13385                 out_dump:
13386
13387                     Safefree(origs);
13388                 }
13389                 SvREFCNT_dec(lv);
13390             }
13391         }
13392
13393         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
13394     }
13395     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
13396         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
13397 #else
13398     PERL_UNUSED_CONTEXT;
13399     PERL_UNUSED_ARG(sv);
13400     PERL_UNUSED_ARG(o);
13401     PERL_UNUSED_ARG(prog);
13402 #endif  /* DEBUGGING */
13403 }
13404
13405 SV *
13406 Perl_re_intuit_string(pTHX_ REGEXP * const r)
13407 {                               /* Assume that RE_INTUIT is set */
13408     dVAR;
13409     struct regexp *const prog = (struct regexp *)SvANY(r);
13410     GET_RE_DEBUG_FLAGS_DECL;
13411
13412     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
13413     PERL_UNUSED_CONTEXT;
13414
13415     DEBUG_COMPILE_r(
13416         {
13417             const char * const s = SvPV_nolen_const(prog->check_substr
13418                       ? prog->check_substr : prog->check_utf8);
13419
13420             if (!PL_colorset) reginitcolors();
13421             PerlIO_printf(Perl_debug_log,
13422                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
13423                       PL_colors[4],
13424                       prog->check_substr ? "" : "utf8 ",
13425                       PL_colors[5],PL_colors[0],
13426                       s,
13427                       PL_colors[1],
13428                       (strlen(s) > 60 ? "..." : ""));
13429         } );
13430
13431     return prog->check_substr ? prog->check_substr : prog->check_utf8;
13432 }
13433
13434 /* 
13435    pregfree() 
13436    
13437    handles refcounting and freeing the perl core regexp structure. When 
13438    it is necessary to actually free the structure the first thing it 
13439    does is call the 'free' method of the regexp_engine associated to
13440    the regexp, allowing the handling of the void *pprivate; member 
13441    first. (This routine is not overridable by extensions, which is why 
13442    the extensions free is called first.)
13443    
13444    See regdupe and regdupe_internal if you change anything here. 
13445 */
13446 #ifndef PERL_IN_XSUB_RE
13447 void
13448 Perl_pregfree(pTHX_ REGEXP *r)
13449 {
13450     SvREFCNT_dec(r);
13451 }
13452
13453 void
13454 Perl_pregfree2(pTHX_ REGEXP *rx)
13455 {
13456     dVAR;
13457     struct regexp *const r = (struct regexp *)SvANY(rx);
13458     GET_RE_DEBUG_FLAGS_DECL;
13459
13460     PERL_ARGS_ASSERT_PREGFREE2;
13461
13462     if (r->mother_re) {
13463         ReREFCNT_dec(r->mother_re);
13464     } else {
13465         CALLREGFREE_PVT(rx); /* free the private data */
13466         SvREFCNT_dec(RXp_PAREN_NAMES(r));
13467     }        
13468     if (r->substrs) {
13469         SvREFCNT_dec(r->anchored_substr);
13470         SvREFCNT_dec(r->anchored_utf8);
13471         SvREFCNT_dec(r->float_substr);
13472         SvREFCNT_dec(r->float_utf8);
13473         Safefree(r->substrs);
13474     }
13475     RX_MATCH_COPY_FREE(rx);
13476 #ifdef PERL_OLD_COPY_ON_WRITE
13477     SvREFCNT_dec(r->saved_copy);
13478 #endif
13479     Safefree(r->offs);
13480     SvREFCNT_dec(r->qr_anoncv);
13481 }
13482
13483 /*  reg_temp_copy()
13484     
13485     This is a hacky workaround to the structural issue of match results
13486     being stored in the regexp structure which is in turn stored in
13487     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
13488     could be PL_curpm in multiple contexts, and could require multiple
13489     result sets being associated with the pattern simultaneously, such
13490     as when doing a recursive match with (??{$qr})
13491     
13492     The solution is to make a lightweight copy of the regexp structure 
13493     when a qr// is returned from the code executed by (??{$qr}) this
13494     lightweight copy doesn't actually own any of its data except for
13495     the starp/end and the actual regexp structure itself. 
13496     
13497 */    
13498     
13499     
13500 REGEXP *
13501 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
13502 {
13503     struct regexp *ret;
13504     struct regexp *const r = (struct regexp *)SvANY(rx);
13505
13506     PERL_ARGS_ASSERT_REG_TEMP_COPY;
13507
13508     if (!ret_x)
13509         ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
13510     ret = (struct regexp *)SvANY(ret_x);
13511     
13512     (void)ReREFCNT_inc(rx);
13513     /* We can take advantage of the existing "copied buffer" mechanism in SVs
13514        by pointing directly at the buffer, but flagging that the allocated
13515        space in the copy is zero. As we've just done a struct copy, it's now
13516        a case of zero-ing that, rather than copying the current length.  */
13517     SvPV_set(ret_x, RX_WRAPPED(rx));
13518     SvFLAGS(ret_x) |= SvFLAGS(rx) & (SVf_POK|SVp_POK|SVf_UTF8);
13519     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
13520            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
13521     SvLEN_set(ret_x, 0);
13522     SvSTASH_set(ret_x, NULL);
13523     SvMAGIC_set(ret_x, NULL);
13524     if (r->offs) {
13525         const I32 npar = r->nparens+1;
13526         Newx(ret->offs, npar, regexp_paren_pair);
13527         Copy(r->offs, ret->offs, npar, regexp_paren_pair);
13528     }
13529     if (r->substrs) {
13530         Newx(ret->substrs, 1, struct reg_substr_data);
13531         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
13532
13533         SvREFCNT_inc_void(ret->anchored_substr);
13534         SvREFCNT_inc_void(ret->anchored_utf8);
13535         SvREFCNT_inc_void(ret->float_substr);
13536         SvREFCNT_inc_void(ret->float_utf8);
13537
13538         /* check_substr and check_utf8, if non-NULL, point to either their
13539            anchored or float namesakes, and don't hold a second reference.  */
13540     }
13541     RX_MATCH_COPIED_off(ret_x);
13542 #ifdef PERL_OLD_COPY_ON_WRITE
13543     ret->saved_copy = NULL;
13544 #endif
13545     ret->mother_re = rx;
13546     SvREFCNT_inc_void(ret->qr_anoncv);
13547     
13548     return ret_x;
13549 }
13550 #endif
13551
13552 /* regfree_internal() 
13553
13554    Free the private data in a regexp. This is overloadable by 
13555    extensions. Perl takes care of the regexp structure in pregfree(), 
13556    this covers the *pprivate pointer which technically perl doesn't 
13557    know about, however of course we have to handle the 
13558    regexp_internal structure when no extension is in use. 
13559    
13560    Note this is called before freeing anything in the regexp 
13561    structure. 
13562  */
13563  
13564 void
13565 Perl_regfree_internal(pTHX_ REGEXP * const rx)
13566 {
13567     dVAR;
13568     struct regexp *const r = (struct regexp *)SvANY(rx);
13569     RXi_GET_DECL(r,ri);
13570     GET_RE_DEBUG_FLAGS_DECL;
13571
13572     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
13573
13574     DEBUG_COMPILE_r({
13575         if (!PL_colorset)
13576             reginitcolors();
13577         {
13578             SV *dsv= sv_newmortal();
13579             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
13580                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
13581             PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n", 
13582                 PL_colors[4],PL_colors[5],s);
13583         }
13584     });
13585 #ifdef RE_TRACK_PATTERN_OFFSETS
13586     if (ri->u.offsets)
13587         Safefree(ri->u.offsets);             /* 20010421 MJD */
13588 #endif
13589     if (ri->code_blocks) {
13590         int n;
13591         for (n = 0; n < ri->num_code_blocks; n++)
13592             SvREFCNT_dec(ri->code_blocks[n].src_regex);
13593         Safefree(ri->code_blocks);
13594     }
13595
13596     if (ri->data) {
13597         int n = ri->data->count;
13598
13599         while (--n >= 0) {
13600           /* If you add a ->what type here, update the comment in regcomp.h */
13601             switch (ri->data->what[n]) {
13602             case 'a':
13603             case 'r':
13604             case 's':
13605             case 'S':
13606             case 'u':
13607                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
13608                 break;
13609             case 'f':
13610                 Safefree(ri->data->data[n]);
13611                 break;
13612             case 'l':
13613             case 'L':
13614                 break;
13615             case 'T':           
13616                 { /* Aho Corasick add-on structure for a trie node.
13617                      Used in stclass optimization only */
13618                     U32 refcount;
13619                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
13620                     OP_REFCNT_LOCK;
13621                     refcount = --aho->refcount;
13622                     OP_REFCNT_UNLOCK;
13623                     if ( !refcount ) {
13624                         PerlMemShared_free(aho->states);
13625                         PerlMemShared_free(aho->fail);
13626                          /* do this last!!!! */
13627                         PerlMemShared_free(ri->data->data[n]);
13628                         PerlMemShared_free(ri->regstclass);
13629                     }
13630                 }
13631                 break;
13632             case 't':
13633                 {
13634                     /* trie structure. */
13635                     U32 refcount;
13636                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
13637                     OP_REFCNT_LOCK;
13638                     refcount = --trie->refcount;
13639                     OP_REFCNT_UNLOCK;
13640                     if ( !refcount ) {
13641                         PerlMemShared_free(trie->charmap);
13642                         PerlMemShared_free(trie->states);
13643                         PerlMemShared_free(trie->trans);
13644                         if (trie->bitmap)
13645                             PerlMemShared_free(trie->bitmap);
13646                         if (trie->jump)
13647                             PerlMemShared_free(trie->jump);
13648                         PerlMemShared_free(trie->wordinfo);
13649                         /* do this last!!!! */
13650                         PerlMemShared_free(ri->data->data[n]);
13651                     }
13652                 }
13653                 break;
13654             default:
13655                 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
13656             }
13657         }
13658         Safefree(ri->data->what);
13659         Safefree(ri->data);
13660     }
13661
13662     Safefree(ri);
13663 }
13664
13665 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
13666 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
13667 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
13668
13669 /* 
13670    re_dup - duplicate a regexp. 
13671    
13672    This routine is expected to clone a given regexp structure. It is only
13673    compiled under USE_ITHREADS.
13674
13675    After all of the core data stored in struct regexp is duplicated
13676    the regexp_engine.dupe method is used to copy any private data
13677    stored in the *pprivate pointer. This allows extensions to handle
13678    any duplication it needs to do.
13679
13680    See pregfree() and regfree_internal() if you change anything here. 
13681 */
13682 #if defined(USE_ITHREADS)
13683 #ifndef PERL_IN_XSUB_RE
13684 void
13685 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
13686 {
13687     dVAR;
13688     I32 npar;
13689     const struct regexp *r = (const struct regexp *)SvANY(sstr);
13690     struct regexp *ret = (struct regexp *)SvANY(dstr);
13691     
13692     PERL_ARGS_ASSERT_RE_DUP_GUTS;
13693
13694     npar = r->nparens+1;
13695     Newx(ret->offs, npar, regexp_paren_pair);
13696     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
13697     if(ret->swap) {
13698         /* no need to copy these */
13699         Newx(ret->swap, npar, regexp_paren_pair);
13700     }
13701
13702     if (ret->substrs) {
13703         /* Do it this way to avoid reading from *r after the StructCopy().
13704            That way, if any of the sv_dup_inc()s dislodge *r from the L1
13705            cache, it doesn't matter.  */
13706         const bool anchored = r->check_substr
13707             ? r->check_substr == r->anchored_substr
13708             : r->check_utf8 == r->anchored_utf8;
13709         Newx(ret->substrs, 1, struct reg_substr_data);
13710         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
13711
13712         ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
13713         ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
13714         ret->float_substr = sv_dup_inc(ret->float_substr, param);
13715         ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
13716
13717         /* check_substr and check_utf8, if non-NULL, point to either their
13718            anchored or float namesakes, and don't hold a second reference.  */
13719
13720         if (ret->check_substr) {
13721             if (anchored) {
13722                 assert(r->check_utf8 == r->anchored_utf8);
13723                 ret->check_substr = ret->anchored_substr;
13724                 ret->check_utf8 = ret->anchored_utf8;
13725             } else {
13726                 assert(r->check_substr == r->float_substr);
13727                 assert(r->check_utf8 == r->float_utf8);
13728                 ret->check_substr = ret->float_substr;
13729                 ret->check_utf8 = ret->float_utf8;
13730             }
13731         } else if (ret->check_utf8) {
13732             if (anchored) {
13733                 ret->check_utf8 = ret->anchored_utf8;
13734             } else {
13735                 ret->check_utf8 = ret->float_utf8;
13736             }
13737         }
13738     }
13739
13740     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
13741     ret->qr_anoncv = MUTABLE_CV(sv_dup_inc((const SV *)ret->qr_anoncv, param));
13742
13743     if (ret->pprivate)
13744         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
13745
13746     if (RX_MATCH_COPIED(dstr))
13747         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
13748     else
13749         ret->subbeg = NULL;
13750 #ifdef PERL_OLD_COPY_ON_WRITE
13751     ret->saved_copy = NULL;
13752 #endif
13753
13754     if (ret->mother_re) {
13755         if (SvPVX_const(dstr) == SvPVX_const(ret->mother_re)) {
13756             /* Our storage points directly to our mother regexp, but that's
13757                1: a buffer in a different thread
13758                2: something we no longer hold a reference on
13759                so we need to copy it locally.  */
13760             /* Note we need to use SvCUR(), rather than
13761                SvLEN(), on our mother_re, because it, in
13762                turn, may well be pointing to its own mother_re.  */
13763             SvPV_set(dstr, SAVEPVN(SvPVX_const(ret->mother_re),
13764                                    SvCUR(ret->mother_re)+1));
13765             SvLEN_set(dstr, SvCUR(ret->mother_re)+1);
13766         }
13767         ret->mother_re      = NULL;
13768     }
13769     ret->gofs = 0;
13770 }
13771 #endif /* PERL_IN_XSUB_RE */
13772
13773 /*
13774    regdupe_internal()
13775    
13776    This is the internal complement to regdupe() which is used to copy
13777    the structure pointed to by the *pprivate pointer in the regexp.
13778    This is the core version of the extension overridable cloning hook.
13779    The regexp structure being duplicated will be copied by perl prior
13780    to this and will be provided as the regexp *r argument, however 
13781    with the /old/ structures pprivate pointer value. Thus this routine
13782    may override any copying normally done by perl.
13783    
13784    It returns a pointer to the new regexp_internal structure.
13785 */
13786
13787 void *
13788 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
13789 {
13790     dVAR;
13791     struct regexp *const r = (struct regexp *)SvANY(rx);
13792     regexp_internal *reti;
13793     int len;
13794     RXi_GET_DECL(r,ri);
13795
13796     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
13797     
13798     len = ProgLen(ri);
13799     
13800     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), char, regexp_internal);
13801     Copy(ri->program, reti->program, len+1, regnode);
13802
13803     reti->num_code_blocks = ri->num_code_blocks;
13804     if (ri->code_blocks) {
13805         int n;
13806         Newxc(reti->code_blocks, ri->num_code_blocks, struct reg_code_block,
13807                 struct reg_code_block);
13808         Copy(ri->code_blocks, reti->code_blocks, ri->num_code_blocks,
13809                 struct reg_code_block);
13810         for (n = 0; n < ri->num_code_blocks; n++)
13811              reti->code_blocks[n].src_regex = (REGEXP*)
13812                     sv_dup_inc((SV*)(ri->code_blocks[n].src_regex), param);
13813     }
13814     else
13815         reti->code_blocks = NULL;
13816
13817     reti->regstclass = NULL;
13818
13819     if (ri->data) {
13820         struct reg_data *d;
13821         const int count = ri->data->count;
13822         int i;
13823
13824         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
13825                 char, struct reg_data);
13826         Newx(d->what, count, U8);
13827
13828         d->count = count;
13829         for (i = 0; i < count; i++) {
13830             d->what[i] = ri->data->what[i];
13831             switch (d->what[i]) {
13832                 /* see also regcomp.h and regfree_internal() */
13833             case 'a': /* actually an AV, but the dup function is identical.  */
13834             case 'r':
13835             case 's':
13836             case 'S':
13837             case 'u': /* actually an HV, but the dup function is identical.  */
13838                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
13839                 break;
13840             case 'f':
13841                 /* This is cheating. */
13842                 Newx(d->data[i], 1, struct regnode_charclass_class);
13843                 StructCopy(ri->data->data[i], d->data[i],
13844                             struct regnode_charclass_class);
13845                 reti->regstclass = (regnode*)d->data[i];
13846                 break;
13847             case 'T':
13848                 /* Trie stclasses are readonly and can thus be shared
13849                  * without duplication. We free the stclass in pregfree
13850                  * when the corresponding reg_ac_data struct is freed.
13851                  */
13852                 reti->regstclass= ri->regstclass;
13853                 /* Fall through */
13854             case 't':
13855                 OP_REFCNT_LOCK;
13856                 ((reg_trie_data*)ri->data->data[i])->refcount++;
13857                 OP_REFCNT_UNLOCK;
13858                 /* Fall through */
13859             case 'l':
13860             case 'L':
13861                 d->data[i] = ri->data->data[i];
13862                 break;
13863             default:
13864                 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
13865             }
13866         }
13867
13868         reti->data = d;
13869     }
13870     else
13871         reti->data = NULL;
13872
13873     reti->name_list_idx = ri->name_list_idx;
13874
13875 #ifdef RE_TRACK_PATTERN_OFFSETS
13876     if (ri->u.offsets) {
13877         Newx(reti->u.offsets, 2*len+1, U32);
13878         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
13879     }
13880 #else
13881     SetProgLen(reti,len);
13882 #endif
13883
13884     return (void*)reti;
13885 }
13886
13887 #endif    /* USE_ITHREADS */
13888
13889 #ifndef PERL_IN_XSUB_RE
13890
13891 /*
13892  - regnext - dig the "next" pointer out of a node
13893  */
13894 regnode *
13895 Perl_regnext(pTHX_ register regnode *p)
13896 {
13897     dVAR;
13898     register I32 offset;
13899
13900     if (!p)
13901         return(NULL);
13902
13903     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
13904         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(p), (int)REGNODE_MAX);
13905     }
13906
13907     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
13908     if (offset == 0)
13909         return(NULL);
13910
13911     return(p+offset);
13912 }
13913 #endif
13914
13915 STATIC void
13916 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
13917 {
13918     va_list args;
13919     STRLEN l1 = strlen(pat1);
13920     STRLEN l2 = strlen(pat2);
13921     char buf[512];
13922     SV *msv;
13923     const char *message;
13924
13925     PERL_ARGS_ASSERT_RE_CROAK2;
13926
13927     if (l1 > 510)
13928         l1 = 510;
13929     if (l1 + l2 > 510)
13930         l2 = 510 - l1;
13931     Copy(pat1, buf, l1 , char);
13932     Copy(pat2, buf + l1, l2 , char);
13933     buf[l1 + l2] = '\n';
13934     buf[l1 + l2 + 1] = '\0';
13935 #ifdef I_STDARG
13936     /* ANSI variant takes additional second argument */
13937     va_start(args, pat2);
13938 #else
13939     va_start(args);
13940 #endif
13941     msv = vmess(buf, &args);
13942     va_end(args);
13943     message = SvPV_const(msv,l1);
13944     if (l1 > 512)
13945         l1 = 512;
13946     Copy(message, buf, l1 , char);
13947     buf[l1-1] = '\0';                   /* Overwrite \n */
13948     Perl_croak(aTHX_ "%s", buf);
13949 }
13950
13951 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
13952
13953 #ifndef PERL_IN_XSUB_RE
13954 void
13955 Perl_save_re_context(pTHX)
13956 {
13957     dVAR;
13958
13959     struct re_save_state *state;
13960
13961     SAVEVPTR(PL_curcop);
13962     SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
13963
13964     state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
13965     PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
13966     SSPUSHUV(SAVEt_RE_STATE);
13967
13968     Copy(&PL_reg_state, state, 1, struct re_save_state);
13969
13970     PL_reg_oldsaved = NULL;
13971     PL_reg_oldsavedlen = 0;
13972     PL_reg_maxiter = 0;
13973     PL_reg_leftiter = 0;
13974     PL_reg_poscache = NULL;
13975     PL_reg_poscache_size = 0;
13976 #ifdef PERL_OLD_COPY_ON_WRITE
13977     PL_nrs = NULL;
13978 #endif
13979
13980     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
13981     if (PL_curpm) {
13982         const REGEXP * const rx = PM_GETRE(PL_curpm);
13983         if (rx) {
13984             U32 i;
13985             for (i = 1; i <= RX_NPARENS(rx); i++) {
13986                 char digits[TYPE_CHARS(long)];
13987                 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
13988                 GV *const *const gvp
13989                     = (GV**)hv_fetch(PL_defstash, digits, len, 0);
13990
13991                 if (gvp) {
13992                     GV * const gv = *gvp;
13993                     if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
13994                         save_scalar(gv);
13995                 }
13996             }
13997         }
13998     }
13999 }
14000 #endif
14001
14002 static void
14003 clear_re(pTHX_ void *r)
14004 {
14005     dVAR;
14006     ReREFCNT_dec((REGEXP *)r);
14007 }
14008
14009 #ifdef DEBUGGING
14010
14011 STATIC void
14012 S_put_byte(pTHX_ SV *sv, int c)
14013 {
14014     PERL_ARGS_ASSERT_PUT_BYTE;
14015
14016     /* Our definition of isPRINT() ignores locales, so only bytes that are
14017        not part of UTF-8 are considered printable. I assume that the same
14018        holds for UTF-EBCDIC.
14019        Also, code point 255 is not printable in either (it's E0 in EBCDIC,
14020        which Wikipedia says:
14021
14022        EO, or Eight Ones, is an 8-bit EBCDIC character code represented as all
14023        ones (binary 1111 1111, hexadecimal FF). It is similar, but not
14024        identical, to the ASCII delete (DEL) or rubout control character.
14025        ) So the old condition can be simplified to !isPRINT(c)  */
14026     if (!isPRINT(c)) {
14027         if (c < 256) {
14028             Perl_sv_catpvf(aTHX_ sv, "\\x%02x", c);
14029         }
14030         else {
14031             Perl_sv_catpvf(aTHX_ sv, "\\x{%x}", c);
14032         }
14033     }
14034     else {
14035         const char string = c;
14036         if (c == '-' || c == ']' || c == '\\' || c == '^')
14037             sv_catpvs(sv, "\\");
14038         sv_catpvn(sv, &string, 1);
14039     }
14040 }
14041
14042
14043 #define CLEAR_OPTSTART \
14044     if (optstart) STMT_START { \
14045             DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
14046             optstart=NULL; \
14047     } STMT_END
14048
14049 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
14050
14051 STATIC const regnode *
14052 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
14053             const regnode *last, const regnode *plast, 
14054             SV* sv, I32 indent, U32 depth)
14055 {
14056     dVAR;
14057     register U8 op = PSEUDO;    /* Arbitrary non-END op. */
14058     register const regnode *next;
14059     const regnode *optstart= NULL;
14060     
14061     RXi_GET_DECL(r,ri);
14062     GET_RE_DEBUG_FLAGS_DECL;
14063
14064     PERL_ARGS_ASSERT_DUMPUNTIL;
14065
14066 #ifdef DEBUG_DUMPUNTIL
14067     PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
14068         last ? last-start : 0,plast ? plast-start : 0);
14069 #endif
14070             
14071     if (plast && plast < last) 
14072         last= plast;
14073
14074     while (PL_regkind[op] != END && (!last || node < last)) {
14075         /* While that wasn't END last time... */
14076         NODE_ALIGN(node);
14077         op = OP(node);
14078         if (op == CLOSE || op == WHILEM)
14079             indent--;
14080         next = regnext((regnode *)node);
14081
14082         /* Where, what. */
14083         if (OP(node) == OPTIMIZED) {
14084             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
14085                 optstart = node;
14086             else
14087                 goto after_print;
14088         } else
14089             CLEAR_OPTSTART;
14090
14091         regprop(r, sv, node);
14092         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
14093                       (int)(2*indent + 1), "", SvPVX_const(sv));
14094         
14095         if (OP(node) != OPTIMIZED) {                  
14096             if (next == NULL)           /* Next ptr. */
14097                 PerlIO_printf(Perl_debug_log, " (0)");
14098             else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
14099                 PerlIO_printf(Perl_debug_log, " (FAIL)");
14100             else 
14101                 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
14102             (void)PerlIO_putc(Perl_debug_log, '\n'); 
14103         }
14104         
14105       after_print:
14106         if (PL_regkind[(U8)op] == BRANCHJ) {
14107             assert(next);
14108             {
14109                 register const regnode *nnode = (OP(next) == LONGJMP
14110                                              ? regnext((regnode *)next)
14111                                              : next);
14112                 if (last && nnode > last)
14113                     nnode = last;
14114                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
14115             }
14116         }
14117         else if (PL_regkind[(U8)op] == BRANCH) {
14118             assert(next);
14119             DUMPUNTIL(NEXTOPER(node), next);
14120         }
14121         else if ( PL_regkind[(U8)op]  == TRIE ) {
14122             const regnode *this_trie = node;
14123             const char op = OP(node);
14124             const U32 n = ARG(node);
14125             const reg_ac_data * const ac = op>=AHOCORASICK ?
14126                (reg_ac_data *)ri->data->data[n] :
14127                NULL;
14128             const reg_trie_data * const trie =
14129                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
14130 #ifdef DEBUGGING
14131             AV *const trie_words = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
14132 #endif
14133             const regnode *nextbranch= NULL;
14134             I32 word_idx;
14135             sv_setpvs(sv, "");
14136             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
14137                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
14138
14139                 PerlIO_printf(Perl_debug_log, "%*s%s ",
14140                    (int)(2*(indent+3)), "",
14141                     elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
14142                             PL_colors[0], PL_colors[1],
14143                             (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
14144                             PERL_PV_PRETTY_ELLIPSES    |
14145                             PERL_PV_PRETTY_LTGT
14146                             )
14147                             : "???"
14148                 );
14149                 if (trie->jump) {
14150                     U16 dist= trie->jump[word_idx+1];
14151                     PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
14152                                   (UV)((dist ? this_trie + dist : next) - start));
14153                     if (dist) {
14154                         if (!nextbranch)
14155                             nextbranch= this_trie + trie->jump[0];    
14156                         DUMPUNTIL(this_trie + dist, nextbranch);
14157                     }
14158                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
14159                         nextbranch= regnext((regnode *)nextbranch);
14160                 } else {
14161                     PerlIO_printf(Perl_debug_log, "\n");
14162                 }
14163             }
14164             if (last && next > last)
14165                 node= last;
14166             else
14167                 node= next;
14168         }
14169         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
14170             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
14171                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
14172         }
14173         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
14174             assert(next);
14175             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
14176         }
14177         else if ( op == PLUS || op == STAR) {
14178             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
14179         }
14180         else if (PL_regkind[(U8)op] == ANYOF) {
14181             /* arglen 1 + class block */
14182             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_CLASS)
14183                     ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
14184             node = NEXTOPER(node);
14185         }
14186         else if (PL_regkind[(U8)op] == EXACT) {
14187             /* Literal string, where present. */
14188             node += NODE_SZ_STR(node) - 1;
14189             node = NEXTOPER(node);
14190         }
14191         else {
14192             node = NEXTOPER(node);
14193             node += regarglen[(U8)op];
14194         }
14195         if (op == CURLYX || op == OPEN)
14196             indent++;
14197     }
14198     CLEAR_OPTSTART;
14199 #ifdef DEBUG_DUMPUNTIL    
14200     PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
14201 #endif
14202     return node;
14203 }
14204
14205 #endif  /* DEBUGGING */
14206
14207 /*
14208  * Local variables:
14209  * c-indentation-style: bsd
14210  * c-basic-offset: 4
14211  * indent-tabs-mode: nil
14212  * End:
14213  *
14214  * ex: set ts=8 sts=4 sw=4 et:
14215  */