]> git.vpit.fr Git - perl/modules/re-engine-Hooks.git/blob - src/5016003/regcomp.c
d3a891a6be874e55c51aafb65e2bb43b4eefc878
[perl/modules/re-engine-Hooks.git] / src / 5016003 / regcomp.c
1 /*    regcomp.c
2  */
3
4 /*
5  * 'A fair jaw-cracker dwarf-language must be.'            --Samwise Gamgee
6  *
7  *     [p.285 of _The Lord of the Rings_, II/iii: "The Ring Goes South"]
8  */
9
10 /* This file contains functions for compiling a regular expression.  See
11  * also regexec.c which funnily enough, contains functions for executing
12  * a regular expression.
13  *
14  * This file is also copied at build time to ext/re/re_comp.c, where
15  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
16  * This causes the main functions to be compiled under new names and with
17  * debugging support added, which makes "use re 'debug'" work.
18  */
19
20 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
21  * confused with the original package (see point 3 below).  Thanks, Henry!
22  */
23
24 /* Additional note: this code is very heavily munged from Henry's version
25  * in places.  In some spots I've traded clarity for efficiency, so don't
26  * blame Henry for some of the lack of readability.
27  */
28
29 /* The names of the functions have been changed from regcomp and
30  * regexec to pregcomp and pregexec in order to avoid conflicts
31  * with the POSIX routines of the same names.
32 */
33
34 #ifdef PERL_EXT_RE_BUILD
35 #include "re_top.h"
36 #endif
37
38 /*
39  * pregcomp and pregexec -- regsub and regerror are not used in perl
40  *
41  *      Copyright (c) 1986 by University of Toronto.
42  *      Written by Henry Spencer.  Not derived from licensed software.
43  *
44  *      Permission is granted to anyone to use this software for any
45  *      purpose on any computer system, and to redistribute it freely,
46  *      subject to the following restrictions:
47  *
48  *      1. The author is not responsible for the consequences of use of
49  *              this software, no matter how awful, even if they arise
50  *              from defects in it.
51  *
52  *      2. The origin of this software must not be misrepresented, either
53  *              by explicit claim or by omission.
54  *
55  *      3. Altered versions must be plainly marked as such, and must not
56  *              be misrepresented as being the original software.
57  *
58  *
59  ****    Alterations to Henry's code are...
60  ****
61  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
62  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
63  ****    by Larry Wall and others
64  ****
65  ****    You may distribute under the terms of either the GNU General Public
66  ****    License or the Artistic License, as specified in the README file.
67
68  *
69  * Beware that some of this code is subtly aware of the way operator
70  * precedence is structured in regular expressions.  Serious changes in
71  * regular-expression syntax might require a total rethink.
72  */
73 #include "EXTERN.h"
74 #define PERL_IN_REGCOMP_C
75 #include "perl.h"
76
77 #ifndef PERL_IN_XSUB_RE
78 #include "re_defs.h"
79 #endif
80
81 #define REG_COMP_C
82 #ifdef PERL_IN_XSUB_RE
83 #  include "re_comp.h"
84 #else
85 #  include "regcomp.h"
86 #endif
87
88 #include "dquote_static.c"
89 #ifndef PERL_IN_XSUB_RE
90 #  include "charclass_invlists.h"
91 #endif
92
93 #ifdef op
94 #undef op
95 #endif /* op */
96
97 #ifdef MSDOS
98 #  if defined(BUGGY_MSC6)
99  /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
100 #    pragma optimize("a",off)
101  /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
102 #    pragma optimize("w",on )
103 #  endif /* BUGGY_MSC6 */
104 #endif /* MSDOS */
105
106 #ifndef STATIC
107 #define STATIC  static
108 #endif
109
110 typedef struct RExC_state_t {
111     U32         flags;                  /* are we folding, multilining? */
112     char        *precomp;               /* uncompiled string. */
113     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
114     regexp      *rx;                    /* perl core regexp structure */
115     regexp_internal     *rxi;           /* internal data for regexp object pprivate field */        
116     char        *start;                 /* Start of input for compile */
117     char        *end;                   /* End of input for compile */
118     char        *parse;                 /* Input-scan pointer. */
119     I32         whilem_seen;            /* number of WHILEM in this expr */
120     regnode     *emit_start;            /* Start of emitted-code area */
121     regnode     *emit_bound;            /* First regnode outside of the allocated space */
122     regnode     *emit;                  /* Code-emit pointer; &regdummy = don't = compiling */
123     I32         naughty;                /* How bad is this pattern? */
124     I32         sawback;                /* Did we see \1, ...? */
125     U32         seen;
126     I32         size;                   /* Code size. */
127     I32         npar;                   /* Capture buffer count, (OPEN). */
128     I32         cpar;                   /* Capture buffer count, (CLOSE). */
129     I32         nestroot;               /* root parens we are in - used by accept */
130     I32         extralen;
131     I32         seen_zerolen;
132     I32         seen_evals;
133     regnode     **open_parens;          /* pointers to open parens */
134     regnode     **close_parens;         /* pointers to close parens */
135     regnode     *opend;                 /* END node in program */
136     I32         utf8;           /* whether the pattern is utf8 or not */
137     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
138                                 /* XXX use this for future optimisation of case
139                                  * where pattern must be upgraded to utf8. */
140     I32         uni_semantics;  /* If a d charset modifier should use unicode
141                                    rules, even if the pattern is not in
142                                    utf8 */
143     HV          *paren_names;           /* Paren names */
144     
145     regnode     **recurse;              /* Recurse regops */
146     I32         recurse_count;          /* Number of recurse regops */
147     I32         in_lookbehind;
148     I32         contains_locale;
149     I32         override_recoding;
150 #if ADD_TO_REGEXEC
151     char        *starttry;              /* -Dr: where regtry was called. */
152 #define RExC_starttry   (pRExC_state->starttry)
153 #endif
154 #ifdef DEBUGGING
155     const char  *lastparse;
156     I32         lastnum;
157     AV          *paren_name_list;       /* idx -> name */
158 #define RExC_lastparse  (pRExC_state->lastparse)
159 #define RExC_lastnum    (pRExC_state->lastnum)
160 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
161 #endif
162 } RExC_state_t;
163
164 #define RExC_flags      (pRExC_state->flags)
165 #define RExC_precomp    (pRExC_state->precomp)
166 #define RExC_rx_sv      (pRExC_state->rx_sv)
167 #define RExC_rx         (pRExC_state->rx)
168 #define RExC_rxi        (pRExC_state->rxi)
169 #define RExC_start      (pRExC_state->start)
170 #define RExC_end        (pRExC_state->end)
171 #define RExC_parse      (pRExC_state->parse)
172 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
173 #ifdef RE_TRACK_PATTERN_OFFSETS
174 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the others */
175 #endif
176 #define RExC_emit       (pRExC_state->emit)
177 #define RExC_emit_start (pRExC_state->emit_start)
178 #define RExC_emit_bound (pRExC_state->emit_bound)
179 #define RExC_naughty    (pRExC_state->naughty)
180 #define RExC_sawback    (pRExC_state->sawback)
181 #define RExC_seen       (pRExC_state->seen)
182 #define RExC_size       (pRExC_state->size)
183 #define RExC_npar       (pRExC_state->npar)
184 #define RExC_nestroot   (pRExC_state->nestroot)
185 #define RExC_extralen   (pRExC_state->extralen)
186 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
187 #define RExC_seen_evals (pRExC_state->seen_evals)
188 #define RExC_utf8       (pRExC_state->utf8)
189 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
190 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
191 #define RExC_open_parens        (pRExC_state->open_parens)
192 #define RExC_close_parens       (pRExC_state->close_parens)
193 #define RExC_opend      (pRExC_state->opend)
194 #define RExC_paren_names        (pRExC_state->paren_names)
195 #define RExC_recurse    (pRExC_state->recurse)
196 #define RExC_recurse_count      (pRExC_state->recurse_count)
197 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
198 #define RExC_contains_locale    (pRExC_state->contains_locale)
199 #define RExC_override_recoding  (pRExC_state->override_recoding)
200
201
202 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
203 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
204         ((*s) == '{' && regcurly(s)))
205
206 #ifdef SPSTART
207 #undef SPSTART          /* dratted cpp namespace... */
208 #endif
209 /*
210  * Flags to be passed up and down.
211  */
212 #define WORST           0       /* Worst case. */
213 #define HASWIDTH        0x01    /* Known to match non-null strings. */
214
215 /* Simple enough to be STAR/PLUS operand, in an EXACT node must be a single
216  * character, and if utf8, must be invariant.  Note that this is not the same thing as REGNODE_SIMPLE */
217 #define SIMPLE          0x02
218 #define SPSTART         0x04    /* Starts with * or +. */
219 #define TRYAGAIN        0x08    /* Weeded out a declaration. */
220 #define POSTPONED       0x10    /* (?1),(?&name), (??{...}) or similar */
221
222 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
223
224 /* whether trie related optimizations are enabled */
225 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
226 #define TRIE_STUDY_OPT
227 #define FULL_TRIE_STUDY
228 #define TRIE_STCLASS
229 #endif
230
231
232
233 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
234 #define PBITVAL(paren) (1 << ((paren) & 7))
235 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
236 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
237 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
238
239 /* If not already in utf8, do a longjmp back to the beginning */
240 #define UTF8_LONGJMP 42 /* Choose a value not likely to ever conflict */
241 #define REQUIRE_UTF8    STMT_START {                                       \
242                                      if (! UTF) JMPENV_JUMP(UTF8_LONGJMP); \
243                         } STMT_END
244
245 /* About scan_data_t.
246
247   During optimisation we recurse through the regexp program performing
248   various inplace (keyhole style) optimisations. In addition study_chunk
249   and scan_commit populate this data structure with information about
250   what strings MUST appear in the pattern. We look for the longest 
251   string that must appear at a fixed location, and we look for the
252   longest string that may appear at a floating location. So for instance
253   in the pattern:
254   
255     /FOO[xX]A.*B[xX]BAR/
256     
257   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
258   strings (because they follow a .* construct). study_chunk will identify
259   both FOO and BAR as being the longest fixed and floating strings respectively.
260   
261   The strings can be composites, for instance
262   
263      /(f)(o)(o)/
264      
265   will result in a composite fixed substring 'foo'.
266   
267   For each string some basic information is maintained:
268   
269   - offset or min_offset
270     This is the position the string must appear at, or not before.
271     It also implicitly (when combined with minlenp) tells us how many
272     characters must match before the string we are searching for.
273     Likewise when combined with minlenp and the length of the string it
274     tells us how many characters must appear after the string we have 
275     found.
276   
277   - max_offset
278     Only used for floating strings. This is the rightmost point that
279     the string can appear at. If set to I32 max it indicates that the
280     string can occur infinitely far to the right.
281   
282   - minlenp
283     A pointer to the minimum length of the pattern that the string 
284     was found inside. This is important as in the case of positive 
285     lookahead or positive lookbehind we can have multiple patterns 
286     involved. Consider
287     
288     /(?=FOO).*F/
289     
290     The minimum length of the pattern overall is 3, the minimum length
291     of the lookahead part is 3, but the minimum length of the part that
292     will actually match is 1. So 'FOO's minimum length is 3, but the 
293     minimum length for the F is 1. This is important as the minimum length
294     is used to determine offsets in front of and behind the string being 
295     looked for.  Since strings can be composites this is the length of the
296     pattern at the time it was committed with a scan_commit. Note that
297     the length is calculated by study_chunk, so that the minimum lengths
298     are not known until the full pattern has been compiled, thus the 
299     pointer to the value.
300   
301   - lookbehind
302   
303     In the case of lookbehind the string being searched for can be
304     offset past the start point of the final matching string. 
305     If this value was just blithely removed from the min_offset it would
306     invalidate some of the calculations for how many chars must match
307     before or after (as they are derived from min_offset and minlen and
308     the length of the string being searched for). 
309     When the final pattern is compiled and the data is moved from the
310     scan_data_t structure into the regexp structure the information
311     about lookbehind is factored in, with the information that would 
312     have been lost precalculated in the end_shift field for the 
313     associated string.
314
315   The fields pos_min and pos_delta are used to store the minimum offset
316   and the delta to the maximum offset at the current point in the pattern.    
317
318 */
319
320 typedef struct scan_data_t {
321     /*I32 len_min;      unused */
322     /*I32 len_delta;    unused */
323     I32 pos_min;
324     I32 pos_delta;
325     SV *last_found;
326     I32 last_end;           /* min value, <0 unless valid. */
327     I32 last_start_min;
328     I32 last_start_max;
329     SV **longest;           /* Either &l_fixed, or &l_float. */
330     SV *longest_fixed;      /* longest fixed string found in pattern */
331     I32 offset_fixed;       /* offset where it starts */
332     I32 *minlen_fixed;      /* pointer to the minlen relevant to the string */
333     I32 lookbehind_fixed;   /* is the position of the string modfied by LB */
334     SV *longest_float;      /* longest floating string found in pattern */
335     I32 offset_float_min;   /* earliest point in string it can appear */
336     I32 offset_float_max;   /* latest point in string it can appear */
337     I32 *minlen_float;      /* pointer to the minlen relevant to the string */
338     I32 lookbehind_float;   /* is the position of the string modified by LB */
339     I32 flags;
340     I32 whilem_c;
341     I32 *last_closep;
342     struct regnode_charclass_class *start_class;
343 } scan_data_t;
344
345 /*
346  * Forward declarations for pregcomp()'s friends.
347  */
348
349 static const scan_data_t zero_scan_data =
350   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
351
352 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
353 #define SF_BEFORE_SEOL          0x0001
354 #define SF_BEFORE_MEOL          0x0002
355 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
356 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
357
358 #ifdef NO_UNARY_PLUS
359 #  define SF_FIX_SHIFT_EOL      (0+2)
360 #  define SF_FL_SHIFT_EOL               (0+4)
361 #else
362 #  define SF_FIX_SHIFT_EOL      (+2)
363 #  define SF_FL_SHIFT_EOL               (+4)
364 #endif
365
366 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
367 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
368
369 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
370 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
371 #define SF_IS_INF               0x0040
372 #define SF_HAS_PAR              0x0080
373 #define SF_IN_PAR               0x0100
374 #define SF_HAS_EVAL             0x0200
375 #define SCF_DO_SUBSTR           0x0400
376 #define SCF_DO_STCLASS_AND      0x0800
377 #define SCF_DO_STCLASS_OR       0x1000
378 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
379 #define SCF_WHILEM_VISITED_POS  0x2000
380
381 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
382 #define SCF_SEEN_ACCEPT         0x8000 
383
384 #define UTF cBOOL(RExC_utf8)
385
386 /* The enums for all these are ordered so things work out correctly */
387 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
388 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_DEPENDS_CHARSET)
389 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
390 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags) >= REGEX_UNICODE_CHARSET)
391 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_RESTRICTED_CHARSET)
392 #define MORE_ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
393 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags) >= REGEX_ASCII_RESTRICTED_CHARSET)
394
395 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
396
397 #define OOB_UNICODE             12345678
398 #define OOB_NAMEDCLASS          -1
399
400 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
401 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
402
403
404 /* length of regex to show in messages that don't mark a position within */
405 #define RegexLengthToShowInErrorMessages 127
406
407 /*
408  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
409  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
410  * op/pragma/warn/regcomp.
411  */
412 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
413 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
414
415 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
416
417 /*
418  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
419  * arg. Show regex, up to a maximum length. If it's too long, chop and add
420  * "...".
421  */
422 #define _FAIL(code) STMT_START {                                        \
423     const char *ellipses = "";                                          \
424     IV len = RExC_end - RExC_precomp;                                   \
425                                                                         \
426     if (!SIZE_ONLY)                                                     \
427         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);                   \
428     if (len > RegexLengthToShowInErrorMessages) {                       \
429         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
430         len = RegexLengthToShowInErrorMessages - 10;                    \
431         ellipses = "...";                                               \
432     }                                                                   \
433     code;                                                               \
434 } STMT_END
435
436 #define FAIL(msg) _FAIL(                            \
437     Perl_croak(aTHX_ "%s in regex m/%.*s%s/",       \
438             msg, (int)len, RExC_precomp, ellipses))
439
440 #define FAIL2(msg,arg) _FAIL(                       \
441     Perl_croak(aTHX_ msg " in regex m/%.*s%s/",     \
442             arg, (int)len, RExC_precomp, ellipses))
443
444 /*
445  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
446  */
447 #define Simple_vFAIL(m) STMT_START {                                    \
448     const IV offset = RExC_parse - RExC_precomp;                        \
449     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
450             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
451 } STMT_END
452
453 /*
454  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
455  */
456 #define vFAIL(m) STMT_START {                           \
457     if (!SIZE_ONLY)                                     \
458         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);   \
459     Simple_vFAIL(m);                                    \
460 } STMT_END
461
462 /*
463  * Like Simple_vFAIL(), but accepts two arguments.
464  */
465 #define Simple_vFAIL2(m,a1) STMT_START {                        \
466     const IV offset = RExC_parse - RExC_precomp;                        \
467     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1,                   \
468             (int)offset, RExC_precomp, RExC_precomp + offset);  \
469 } STMT_END
470
471 /*
472  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
473  */
474 #define vFAIL2(m,a1) STMT_START {                       \
475     if (!SIZE_ONLY)                                     \
476         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);   \
477     Simple_vFAIL2(m, a1);                               \
478 } STMT_END
479
480
481 /*
482  * Like Simple_vFAIL(), but accepts three arguments.
483  */
484 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
485     const IV offset = RExC_parse - RExC_precomp;                \
486     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2,               \
487             (int)offset, RExC_precomp, RExC_precomp + offset);  \
488 } STMT_END
489
490 /*
491  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
492  */
493 #define vFAIL3(m,a1,a2) STMT_START {                    \
494     if (!SIZE_ONLY)                                     \
495         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);   \
496     Simple_vFAIL3(m, a1, a2);                           \
497 } STMT_END
498
499 /*
500  * Like Simple_vFAIL(), but accepts four arguments.
501  */
502 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
503     const IV offset = RExC_parse - RExC_precomp;                \
504     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3,           \
505             (int)offset, RExC_precomp, RExC_precomp + offset);  \
506 } STMT_END
507
508 #define ckWARNreg(loc,m) STMT_START {                                   \
509     const IV offset = loc - RExC_precomp;                               \
510     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
511             (int)offset, RExC_precomp, RExC_precomp + offset);          \
512 } STMT_END
513
514 #define ckWARNregdep(loc,m) STMT_START {                                \
515     const IV offset = loc - RExC_precomp;                               \
516     Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),     \
517             m REPORT_LOCATION,                                          \
518             (int)offset, RExC_precomp, RExC_precomp + offset);          \
519 } STMT_END
520
521 #define ckWARN2regdep(loc,m, a1) STMT_START {                           \
522     const IV offset = loc - RExC_precomp;                               \
523     Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),     \
524             m REPORT_LOCATION,                                          \
525             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
526 } STMT_END
527
528 #define ckWARN2reg(loc, m, a1) STMT_START {                             \
529     const IV offset = loc - RExC_precomp;                               \
530     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
531             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
532 } STMT_END
533
534 #define vWARN3(loc, m, a1, a2) STMT_START {                             \
535     const IV offset = loc - RExC_precomp;                               \
536     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
537             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
538 } STMT_END
539
540 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                         \
541     const IV offset = loc - RExC_precomp;                               \
542     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
543             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
544 } STMT_END
545
546 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
547     const IV offset = loc - RExC_precomp;                               \
548     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
549             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
550 } STMT_END
551
552 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
553     const IV offset = loc - RExC_precomp;                               \
554     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
555             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
556 } STMT_END
557
558 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
559     const IV offset = loc - RExC_precomp;                               \
560     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
561             a1, a2, a3, a4, (int)offset, RExC_precomp, RExC_precomp + offset); \
562 } STMT_END
563
564
565 /* Allow for side effects in s */
566 #define REGC(c,s) STMT_START {                  \
567     if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
568 } STMT_END
569
570 /* Macros for recording node offsets.   20001227 mjd@plover.com 
571  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
572  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
573  * Element 0 holds the number n.
574  * Position is 1 indexed.
575  */
576 #ifndef RE_TRACK_PATTERN_OFFSETS
577 #define Set_Node_Offset_To_R(node,byte)
578 #define Set_Node_Offset(node,byte)
579 #define Set_Cur_Node_Offset
580 #define Set_Node_Length_To_R(node,len)
581 #define Set_Node_Length(node,len)
582 #define Set_Node_Cur_Length(node)
583 #define Node_Offset(n) 
584 #define Node_Length(n) 
585 #define Set_Node_Offset_Length(node,offset,len)
586 #define ProgLen(ri) ri->u.proglen
587 #define SetProgLen(ri,x) ri->u.proglen = x
588 #else
589 #define ProgLen(ri) ri->u.offsets[0]
590 #define SetProgLen(ri,x) ri->u.offsets[0] = x
591 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
592     if (! SIZE_ONLY) {                                                  \
593         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
594                     __LINE__, (int)(node), (int)(byte)));               \
595         if((node) < 0) {                                                \
596             Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \
597         } else {                                                        \
598             RExC_offsets[2*(node)-1] = (byte);                          \
599         }                                                               \
600     }                                                                   \
601 } STMT_END
602
603 #define Set_Node_Offset(node,byte) \
604     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
605 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
606
607 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
608     if (! SIZE_ONLY) {                                                  \
609         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
610                 __LINE__, (int)(node), (int)(len)));                    \
611         if((node) < 0) {                                                \
612             Perl_croak(aTHX_ "value of node is %d in Length macro", (int)(node)); \
613         } else {                                                        \
614             RExC_offsets[2*(node)] = (len);                             \
615         }                                                               \
616     }                                                                   \
617 } STMT_END
618
619 #define Set_Node_Length(node,len) \
620     Set_Node_Length_To_R((node)-RExC_emit_start, len)
621 #define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
622 #define Set_Node_Cur_Length(node) \
623     Set_Node_Length(node, RExC_parse - parse_start)
624
625 /* Get offsets and lengths */
626 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
627 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
628
629 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
630     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
631     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
632 } STMT_END
633 #endif
634
635 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
636 #define EXPERIMENTAL_INPLACESCAN
637 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
638
639 #define DEBUG_STUDYDATA(str,data,depth)                              \
640 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
641     PerlIO_printf(Perl_debug_log,                                    \
642         "%*s" str "Pos:%"IVdf"/%"IVdf                                \
643         " Flags: 0x%"UVXf" Whilem_c: %"IVdf" Lcp: %"IVdf" %s",       \
644         (int)(depth)*2, "",                                          \
645         (IV)((data)->pos_min),                                       \
646         (IV)((data)->pos_delta),                                     \
647         (UV)((data)->flags),                                         \
648         (IV)((data)->whilem_c),                                      \
649         (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
650         is_inf ? "INF " : ""                                         \
651     );                                                               \
652     if ((data)->last_found)                                          \
653         PerlIO_printf(Perl_debug_log,                                \
654             "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
655             " %sFloat: '%s' @ %"IVdf"/%"IVdf"",                      \
656             SvPVX_const((data)->last_found),                         \
657             (IV)((data)->last_end),                                  \
658             (IV)((data)->last_start_min),                            \
659             (IV)((data)->last_start_max),                            \
660             ((data)->longest &&                                      \
661              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
662             SvPVX_const((data)->longest_fixed),                      \
663             (IV)((data)->offset_fixed),                              \
664             ((data)->longest &&                                      \
665              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
666             SvPVX_const((data)->longest_float),                      \
667             (IV)((data)->offset_float_min),                          \
668             (IV)((data)->offset_float_max)                           \
669         );                                                           \
670     PerlIO_printf(Perl_debug_log,"\n");                              \
671 });
672
673 static void clear_re(pTHX_ void *r);
674
675 /* Mark that we cannot extend a found fixed substring at this point.
676    Update the longest found anchored substring and the longest found
677    floating substrings if needed. */
678
679 STATIC void
680 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp, int is_inf)
681 {
682     const STRLEN l = CHR_SVLEN(data->last_found);
683     const STRLEN old_l = CHR_SVLEN(*data->longest);
684     GET_RE_DEBUG_FLAGS_DECL;
685
686     PERL_ARGS_ASSERT_SCAN_COMMIT;
687
688     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
689         SvSetMagicSV(*data->longest, data->last_found);
690         if (*data->longest == data->longest_fixed) {
691             data->offset_fixed = l ? data->last_start_min : data->pos_min;
692             if (data->flags & SF_BEFORE_EOL)
693                 data->flags
694                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
695             else
696                 data->flags &= ~SF_FIX_BEFORE_EOL;
697             data->minlen_fixed=minlenp;
698             data->lookbehind_fixed=0;
699         }
700         else { /* *data->longest == data->longest_float */
701             data->offset_float_min = l ? data->last_start_min : data->pos_min;
702             data->offset_float_max = (l
703                                       ? data->last_start_max
704                                       : data->pos_min + data->pos_delta);
705             if (is_inf || (U32)data->offset_float_max > (U32)I32_MAX)
706                 data->offset_float_max = I32_MAX;
707             if (data->flags & SF_BEFORE_EOL)
708                 data->flags
709                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
710             else
711                 data->flags &= ~SF_FL_BEFORE_EOL;
712             data->minlen_float=minlenp;
713             data->lookbehind_float=0;
714         }
715     }
716     SvCUR_set(data->last_found, 0);
717     {
718         SV * const sv = data->last_found;
719         if (SvUTF8(sv) && SvMAGICAL(sv)) {
720             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
721             if (mg)
722                 mg->mg_len = 0;
723         }
724     }
725     data->last_end = -1;
726     data->flags &= ~SF_BEFORE_EOL;
727     DEBUG_STUDYDATA("commit: ",data,0);
728 }
729
730 /* Can match anything (initialization) */
731 STATIC void
732 S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
733 {
734     PERL_ARGS_ASSERT_CL_ANYTHING;
735
736     ANYOF_BITMAP_SETALL(cl);
737     cl->flags = ANYOF_CLASS|ANYOF_EOS|ANYOF_UNICODE_ALL
738                 |ANYOF_LOC_NONBITMAP_FOLD|ANYOF_NON_UTF8_LATIN1_ALL;
739
740     /* If any portion of the regex is to operate under locale rules,
741      * initialization includes it.  The reason this isn't done for all regexes
742      * is that the optimizer was written under the assumption that locale was
743      * all-or-nothing.  Given the complexity and lack of documentation in the
744      * optimizer, and that there are inadequate test cases for locale, so many
745      * parts of it may not work properly, it is safest to avoid locale unless
746      * necessary. */
747     if (RExC_contains_locale) {
748         ANYOF_CLASS_SETALL(cl);     /* /l uses class */
749         cl->flags |= ANYOF_LOCALE;
750     }
751     else {
752         ANYOF_CLASS_ZERO(cl);       /* Only /l uses class now */
753     }
754 }
755
756 /* Can match anything (initialization) */
757 STATIC int
758 S_cl_is_anything(const struct regnode_charclass_class *cl)
759 {
760     int value;
761
762     PERL_ARGS_ASSERT_CL_IS_ANYTHING;
763
764     for (value = 0; value <= ANYOF_MAX; value += 2)
765         if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
766             return 1;
767     if (!(cl->flags & ANYOF_UNICODE_ALL))
768         return 0;
769     if (!ANYOF_BITMAP_TESTALLSET((const void*)cl))
770         return 0;
771     return 1;
772 }
773
774 /* Can match anything (initialization) */
775 STATIC void
776 S_cl_init(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
777 {
778     PERL_ARGS_ASSERT_CL_INIT;
779
780     Zero(cl, 1, struct regnode_charclass_class);
781     cl->type = ANYOF;
782     cl_anything(pRExC_state, cl);
783     ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
784 }
785
786 /* These two functions currently do the exact same thing */
787 #define cl_init_zero            S_cl_init
788
789 /* 'AND' a given class with another one.  Can create false positives.  'cl'
790  * should not be inverted.  'and_with->flags & ANYOF_CLASS' should be 0 if
791  * 'and_with' is a regnode_charclass instead of a regnode_charclass_class. */
792 STATIC void
793 S_cl_and(struct regnode_charclass_class *cl,
794         const struct regnode_charclass_class *and_with)
795 {
796     PERL_ARGS_ASSERT_CL_AND;
797
798     assert(and_with->type == ANYOF);
799
800     /* I (khw) am not sure all these restrictions are necessary XXX */
801     if (!(ANYOF_CLASS_TEST_ANY_SET(and_with))
802         && !(ANYOF_CLASS_TEST_ANY_SET(cl))
803         && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
804         && !(and_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
805         && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) {
806         int i;
807
808         if (and_with->flags & ANYOF_INVERT)
809             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
810                 cl->bitmap[i] &= ~and_with->bitmap[i];
811         else
812             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
813                 cl->bitmap[i] &= and_with->bitmap[i];
814     } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
815
816     if (and_with->flags & ANYOF_INVERT) {
817
818         /* Here, the and'ed node is inverted.  Get the AND of the flags that
819          * aren't affected by the inversion.  Those that are affected are
820          * handled individually below */
821         U8 affected_flags = cl->flags & ~INVERSION_UNAFFECTED_FLAGS;
822         cl->flags &= (and_with->flags & INVERSION_UNAFFECTED_FLAGS);
823         cl->flags |= affected_flags;
824
825         /* We currently don't know how to deal with things that aren't in the
826          * bitmap, but we know that the intersection is no greater than what
827          * is already in cl, so let there be false positives that get sorted
828          * out after the synthetic start class succeeds, and the node is
829          * matched for real. */
830
831         /* The inversion of these two flags indicate that the resulting
832          * intersection doesn't have them */
833         if (and_with->flags & ANYOF_UNICODE_ALL) {
834             cl->flags &= ~ANYOF_UNICODE_ALL;
835         }
836         if (and_with->flags & ANYOF_NON_UTF8_LATIN1_ALL) {
837             cl->flags &= ~ANYOF_NON_UTF8_LATIN1_ALL;
838         }
839     }
840     else {   /* and'd node is not inverted */
841         U8 outside_bitmap_but_not_utf8; /* Temp variable */
842
843         if (! ANYOF_NONBITMAP(and_with)) {
844
845             /* Here 'and_with' doesn't match anything outside the bitmap
846              * (except possibly ANYOF_UNICODE_ALL), which means the
847              * intersection can't either, except for ANYOF_UNICODE_ALL, in
848              * which case we don't know what the intersection is, but it's no
849              * greater than what cl already has, so can just leave it alone,
850              * with possible false positives */
851             if (! (and_with->flags & ANYOF_UNICODE_ALL)) {
852                 ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
853                 cl->flags &= ~ANYOF_NONBITMAP_NON_UTF8;
854             }
855         }
856         else if (! ANYOF_NONBITMAP(cl)) {
857
858             /* Here, 'and_with' does match something outside the bitmap, and cl
859              * doesn't have a list of things to match outside the bitmap.  If
860              * cl can match all code points above 255, the intersection will
861              * be those above-255 code points that 'and_with' matches.  If cl
862              * can't match all Unicode code points, it means that it can't
863              * match anything outside the bitmap (since the 'if' that got us
864              * into this block tested for that), so we leave the bitmap empty.
865              */
866             if (cl->flags & ANYOF_UNICODE_ALL) {
867                 ARG_SET(cl, ARG(and_with));
868
869                 /* and_with's ARG may match things that don't require UTF8.
870                  * And now cl's will too, in spite of this being an 'and'.  See
871                  * the comments below about the kludge */
872                 cl->flags |= and_with->flags & ANYOF_NONBITMAP_NON_UTF8;
873             }
874         }
875         else {
876             /* Here, both 'and_with' and cl match something outside the
877              * bitmap.  Currently we do not do the intersection, so just match
878              * whatever cl had at the beginning.  */
879         }
880
881
882         /* Take the intersection of the two sets of flags.  However, the
883          * ANYOF_NONBITMAP_NON_UTF8 flag is treated as an 'or'.  This is a
884          * kludge around the fact that this flag is not treated like the others
885          * which are initialized in cl_anything().  The way the optimizer works
886          * is that the synthetic start class (SSC) is initialized to match
887          * anything, and then the first time a real node is encountered, its
888          * values are AND'd with the SSC's with the result being the values of
889          * the real node.  However, there are paths through the optimizer where
890          * the AND never gets called, so those initialized bits are set
891          * inappropriately, which is not usually a big deal, as they just cause
892          * false positives in the SSC, which will just mean a probably
893          * imperceptible slow down in execution.  However this bit has a
894          * higher false positive consequence in that it can cause utf8.pm,
895          * utf8_heavy.pl ... to be loaded when not necessary, which is a much
896          * bigger slowdown and also causes significant extra memory to be used.
897          * In order to prevent this, the code now takes a different tack.  The
898          * bit isn't set unless some part of the regular expression needs it,
899          * but once set it won't get cleared.  This means that these extra
900          * modules won't get loaded unless there was some path through the
901          * pattern that would have required them anyway, and  so any false
902          * positives that occur by not ANDing them out when they could be
903          * aren't as severe as they would be if we treated this bit like all
904          * the others */
905         outside_bitmap_but_not_utf8 = (cl->flags | and_with->flags)
906                                       & ANYOF_NONBITMAP_NON_UTF8;
907         cl->flags &= and_with->flags;
908         cl->flags |= outside_bitmap_but_not_utf8;
909     }
910 }
911
912 /* 'OR' a given class with another one.  Can create false positives.  'cl'
913  * should not be inverted.  'or_with->flags & ANYOF_CLASS' should be 0 if
914  * 'or_with' is a regnode_charclass instead of a regnode_charclass_class. */
915 STATIC void
916 S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
917 {
918     PERL_ARGS_ASSERT_CL_OR;
919
920     if (or_with->flags & ANYOF_INVERT) {
921
922         /* Here, the or'd node is to be inverted.  This means we take the
923          * complement of everything not in the bitmap, but currently we don't
924          * know what that is, so give up and match anything */
925         if (ANYOF_NONBITMAP(or_with)) {
926             cl_anything(pRExC_state, cl);
927         }
928         /* We do not use
929          * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
930          *   <= (B1 | !B2) | (CL1 | !CL2)
931          * which is wasteful if CL2 is small, but we ignore CL2:
932          *   (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
933          * XXXX Can we handle case-fold?  Unclear:
934          *   (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
935          *   (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
936          */
937         else if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
938              && !(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
939              && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD) ) {
940             int i;
941
942             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
943                 cl->bitmap[i] |= ~or_with->bitmap[i];
944         } /* XXXX: logic is complicated otherwise */
945         else {
946             cl_anything(pRExC_state, cl);
947         }
948
949         /* And, we can just take the union of the flags that aren't affected
950          * by the inversion */
951         cl->flags |= or_with->flags & INVERSION_UNAFFECTED_FLAGS;
952
953         /* For the remaining flags:
954             ANYOF_UNICODE_ALL and inverted means to not match anything above
955                     255, which means that the union with cl should just be
956                     what cl has in it, so can ignore this flag
957             ANYOF_NON_UTF8_LATIN1_ALL and inverted means if not utf8 and ord
958                     is 127-255 to match them, but then invert that, so the
959                     union with cl should just be what cl has in it, so can
960                     ignore this flag
961          */
962     } else {    /* 'or_with' is not inverted */
963         /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
964         if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
965              && (!(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
966                  || (cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) ) {
967             int i;
968
969             /* OR char bitmap and class bitmap separately */
970             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
971                 cl->bitmap[i] |= or_with->bitmap[i];
972             if (ANYOF_CLASS_TEST_ANY_SET(or_with)) {
973                 for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++)
974                     cl->classflags[i] |= or_with->classflags[i];
975                 cl->flags |= ANYOF_CLASS;
976             }
977         }
978         else { /* XXXX: logic is complicated, leave it along for a moment. */
979             cl_anything(pRExC_state, cl);
980         }
981
982         if (ANYOF_NONBITMAP(or_with)) {
983
984             /* Use the added node's outside-the-bit-map match if there isn't a
985              * conflict.  If there is a conflict (both nodes match something
986              * outside the bitmap, but what they match outside is not the same
987              * pointer, and hence not easily compared until XXX we extend
988              * inversion lists this far), give up and allow the start class to
989              * match everything outside the bitmap.  If that stuff is all above
990              * 255, can just set UNICODE_ALL, otherwise caould be anything. */
991             if (! ANYOF_NONBITMAP(cl)) {
992                 ARG_SET(cl, ARG(or_with));
993             }
994             else if (ARG(cl) != ARG(or_with)) {
995
996                 if ((or_with->flags & ANYOF_NONBITMAP_NON_UTF8)) {
997                     cl_anything(pRExC_state, cl);
998                 }
999                 else {
1000                     cl->flags |= ANYOF_UNICODE_ALL;
1001                 }
1002             }
1003         }
1004
1005         /* Take the union */
1006         cl->flags |= or_with->flags;
1007     }
1008 }
1009
1010 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1011 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
1012 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1013 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list ? (TRIE_LIST_CUR( idx ) - 1) : 0 )
1014
1015
1016 #ifdef DEBUGGING
1017 /*
1018    dump_trie(trie,widecharmap,revcharmap)
1019    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1020    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1021
1022    These routines dump out a trie in a somewhat readable format.
1023    The _interim_ variants are used for debugging the interim
1024    tables that are used to generate the final compressed
1025    representation which is what dump_trie expects.
1026
1027    Part of the reason for their existence is to provide a form
1028    of documentation as to how the different representations function.
1029
1030 */
1031
1032 /*
1033   Dumps the final compressed table form of the trie to Perl_debug_log.
1034   Used for debugging make_trie().
1035 */
1036
1037 STATIC void
1038 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1039             AV *revcharmap, U32 depth)
1040 {
1041     U32 state;
1042     SV *sv=sv_newmortal();
1043     int colwidth= widecharmap ? 6 : 4;
1044     U16 word;
1045     GET_RE_DEBUG_FLAGS_DECL;
1046
1047     PERL_ARGS_ASSERT_DUMP_TRIE;
1048
1049     PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
1050         (int)depth * 2 + 2,"",
1051         "Match","Base","Ofs" );
1052
1053     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1054         SV ** const tmp = av_fetch( revcharmap, state, 0);
1055         if ( tmp ) {
1056             PerlIO_printf( Perl_debug_log, "%*s", 
1057                 colwidth,
1058                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1059                             PL_colors[0], PL_colors[1],
1060                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1061                             PERL_PV_ESCAPE_FIRSTCHAR 
1062                 ) 
1063             );
1064         }
1065     }
1066     PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
1067         (int)depth * 2 + 2,"");
1068
1069     for( state = 0 ; state < trie->uniquecharcount ; state++ )
1070         PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
1071     PerlIO_printf( Perl_debug_log, "\n");
1072
1073     for( state = 1 ; state < trie->statecount ; state++ ) {
1074         const U32 base = trie->states[ state ].trans.base;
1075
1076         PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state);
1077
1078         if ( trie->states[ state ].wordnum ) {
1079             PerlIO_printf( Perl_debug_log, " W%4X", trie->states[ state ].wordnum );
1080         } else {
1081             PerlIO_printf( Perl_debug_log, "%6s", "" );
1082         }
1083
1084         PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
1085
1086         if ( base ) {
1087             U32 ofs = 0;
1088
1089             while( ( base + ofs  < trie->uniquecharcount ) ||
1090                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
1091                      && trie->trans[ base + ofs - trie->uniquecharcount ].check != state))
1092                     ofs++;
1093
1094             PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
1095
1096             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
1097                 if ( ( base + ofs >= trie->uniquecharcount ) &&
1098                      ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
1099                      trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
1100                 {
1101                    PerlIO_printf( Perl_debug_log, "%*"UVXf,
1102                     colwidth,
1103                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
1104                 } else {
1105                     PerlIO_printf( Perl_debug_log, "%*s",colwidth,"   ." );
1106                 }
1107             }
1108
1109             PerlIO_printf( Perl_debug_log, "]");
1110
1111         }
1112         PerlIO_printf( Perl_debug_log, "\n" );
1113     }
1114     PerlIO_printf(Perl_debug_log, "%*sword_info N:(prev,len)=", (int)depth*2, "");
1115     for (word=1; word <= trie->wordcount; word++) {
1116         PerlIO_printf(Perl_debug_log, " %d:(%d,%d)",
1117             (int)word, (int)(trie->wordinfo[word].prev),
1118             (int)(trie->wordinfo[word].len));
1119     }
1120     PerlIO_printf(Perl_debug_log, "\n" );
1121 }    
1122 /*
1123   Dumps a fully constructed but uncompressed trie in list form.
1124   List tries normally only are used for construction when the number of 
1125   possible chars (trie->uniquecharcount) is very high.
1126   Used for debugging make_trie().
1127 */
1128 STATIC void
1129 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
1130                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
1131                          U32 depth)
1132 {
1133     U32 state;
1134     SV *sv=sv_newmortal();
1135     int colwidth= widecharmap ? 6 : 4;
1136     GET_RE_DEBUG_FLAGS_DECL;
1137
1138     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
1139
1140     /* print out the table precompression.  */
1141     PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
1142         (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
1143         "------:-----+-----------------\n" );
1144     
1145     for( state=1 ; state < next_alloc ; state ++ ) {
1146         U16 charid;
1147     
1148         PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
1149             (int)depth * 2 + 2,"", (UV)state  );
1150         if ( ! trie->states[ state ].wordnum ) {
1151             PerlIO_printf( Perl_debug_log, "%5s| ","");
1152         } else {
1153             PerlIO_printf( Perl_debug_log, "W%4x| ",
1154                 trie->states[ state ].wordnum
1155             );
1156         }
1157         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
1158             SV ** const tmp = av_fetch( revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
1159             if ( tmp ) {
1160                 PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
1161                     colwidth,
1162                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1163                             PL_colors[0], PL_colors[1],
1164                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1165                             PERL_PV_ESCAPE_FIRSTCHAR 
1166                     ) ,
1167                     TRIE_LIST_ITEM(state,charid).forid,
1168                     (UV)TRIE_LIST_ITEM(state,charid).newstate
1169                 );
1170                 if (!(charid % 10)) 
1171                     PerlIO_printf(Perl_debug_log, "\n%*s| ",
1172                         (int)((depth * 2) + 14), "");
1173             }
1174         }
1175         PerlIO_printf( Perl_debug_log, "\n");
1176     }
1177 }    
1178
1179 /*
1180   Dumps a fully constructed but uncompressed trie in table form.
1181   This is the normal DFA style state transition table, with a few 
1182   twists to facilitate compression later. 
1183   Used for debugging make_trie().
1184 */
1185 STATIC void
1186 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
1187                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
1188                           U32 depth)
1189 {
1190     U32 state;
1191     U16 charid;
1192     SV *sv=sv_newmortal();
1193     int colwidth= widecharmap ? 6 : 4;
1194     GET_RE_DEBUG_FLAGS_DECL;
1195
1196     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
1197     
1198     /*
1199        print out the table precompression so that we can do a visual check
1200        that they are identical.
1201      */
1202     
1203     PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
1204
1205     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1206         SV ** const tmp = av_fetch( revcharmap, charid, 0);
1207         if ( tmp ) {
1208             PerlIO_printf( Perl_debug_log, "%*s", 
1209                 colwidth,
1210                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1211                             PL_colors[0], PL_colors[1],
1212                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1213                             PERL_PV_ESCAPE_FIRSTCHAR 
1214                 ) 
1215             );
1216         }
1217     }
1218
1219     PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
1220
1221     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
1222         PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
1223     }
1224
1225     PerlIO_printf( Perl_debug_log, "\n" );
1226
1227     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
1228
1229         PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ", 
1230             (int)depth * 2 + 2,"",
1231             (UV)TRIE_NODENUM( state ) );
1232
1233         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1234             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
1235             if (v)
1236                 PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
1237             else
1238                 PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
1239         }
1240         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1241             PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check );
1242         } else {
1243             PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n", (UV)trie->trans[ state ].check,
1244             trie->states[ TRIE_NODENUM( state ) ].wordnum );
1245         }
1246     }
1247 }
1248
1249 #endif
1250
1251
1252 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
1253   startbranch: the first branch in the whole branch sequence
1254   first      : start branch of sequence of branch-exact nodes.
1255                May be the same as startbranch
1256   last       : Thing following the last branch.
1257                May be the same as tail.
1258   tail       : item following the branch sequence
1259   count      : words in the sequence
1260   flags      : currently the OP() type we will be building one of /EXACT(|F|Fl)/
1261   depth      : indent depth
1262
1263 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
1264
1265 A trie is an N'ary tree where the branches are determined by digital
1266 decomposition of the key. IE, at the root node you look up the 1st character and
1267 follow that branch repeat until you find the end of the branches. Nodes can be
1268 marked as "accepting" meaning they represent a complete word. Eg:
1269
1270   /he|she|his|hers/
1271
1272 would convert into the following structure. Numbers represent states, letters
1273 following numbers represent valid transitions on the letter from that state, if
1274 the number is in square brackets it represents an accepting state, otherwise it
1275 will be in parenthesis.
1276
1277       +-h->+-e->[3]-+-r->(8)-+-s->[9]
1278       |    |
1279       |   (2)
1280       |    |
1281      (1)   +-i->(6)-+-s->[7]
1282       |
1283       +-s->(3)-+-h->(4)-+-e->[5]
1284
1285       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
1286
1287 This shows that when matching against the string 'hers' we will begin at state 1
1288 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
1289 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
1290 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
1291 single traverse. We store a mapping from accepting to state to which word was
1292 matched, and then when we have multiple possibilities we try to complete the
1293 rest of the regex in the order in which they occured in the alternation.
1294
1295 The only prior NFA like behaviour that would be changed by the TRIE support is
1296 the silent ignoring of duplicate alternations which are of the form:
1297
1298  / (DUPE|DUPE) X? (?{ ... }) Y /x
1299
1300 Thus EVAL blocks following a trie may be called a different number of times with
1301 and without the optimisation. With the optimisations dupes will be silently
1302 ignored. This inconsistent behaviour of EVAL type nodes is well established as
1303 the following demonstrates:
1304
1305  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
1306
1307 which prints out 'word' three times, but
1308
1309  'words'=~/(word|word|word)(?{ print $1 })S/
1310
1311 which doesnt print it out at all. This is due to other optimisations kicking in.
1312
1313 Example of what happens on a structural level:
1314
1315 The regexp /(ac|ad|ab)+/ will produce the following debug output:
1316
1317    1: CURLYM[1] {1,32767}(18)
1318    5:   BRANCH(8)
1319    6:     EXACT <ac>(16)
1320    8:   BRANCH(11)
1321    9:     EXACT <ad>(16)
1322   11:   BRANCH(14)
1323   12:     EXACT <ab>(16)
1324   16:   SUCCEED(0)
1325   17:   NOTHING(18)
1326   18: END(0)
1327
1328 This would be optimizable with startbranch=5, first=5, last=16, tail=16
1329 and should turn into:
1330
1331    1: CURLYM[1] {1,32767}(18)
1332    5:   TRIE(16)
1333         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
1334           <ac>
1335           <ad>
1336           <ab>
1337   16:   SUCCEED(0)
1338   17:   NOTHING(18)
1339   18: END(0)
1340
1341 Cases where tail != last would be like /(?foo|bar)baz/:
1342
1343    1: BRANCH(4)
1344    2:   EXACT <foo>(8)
1345    4: BRANCH(7)
1346    5:   EXACT <bar>(8)
1347    7: TAIL(8)
1348    8: EXACT <baz>(10)
1349   10: END(0)
1350
1351 which would be optimizable with startbranch=1, first=1, last=7, tail=8
1352 and would end up looking like:
1353
1354     1: TRIE(8)
1355       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
1356         <foo>
1357         <bar>
1358    7: TAIL(8)
1359    8: EXACT <baz>(10)
1360   10: END(0)
1361
1362     d = uvuni_to_utf8_flags(d, uv, 0);
1363
1364 is the recommended Unicode-aware way of saying
1365
1366     *(d++) = uv;
1367 */
1368
1369 #define TRIE_STORE_REVCHAR(val)                                            \
1370     STMT_START {                                                           \
1371         if (UTF) {                                                         \
1372             SV *zlopp = newSV(7); /* XXX: optimize me */                   \
1373             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
1374             unsigned const char *const kapow = uvuni_to_utf8(flrbbbbb, val); \
1375             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
1376             SvPOK_on(zlopp);                                               \
1377             SvUTF8_on(zlopp);                                              \
1378             av_push(revcharmap, zlopp);                                    \
1379         } else {                                                           \
1380             char ooooff = (char)val;                                           \
1381             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
1382         }                                                                  \
1383         } STMT_END
1384
1385 #define TRIE_READ_CHAR STMT_START {                                                     \
1386     wordlen++;                                                                          \
1387     if ( UTF ) {                                                                        \
1388         /* if it is UTF then it is either already folded, or does not need folding */   \
1389         uvc = utf8n_to_uvuni( (const U8*) uc, UTF8_MAXLEN, &len, uniflags);             \
1390     }                                                                                   \
1391     else if (folder == PL_fold_latin1) {                                                \
1392         /* if we use this folder we have to obey unicode rules on latin-1 data */       \
1393         if ( foldlen > 0 ) {                                                            \
1394            uvc = utf8n_to_uvuni( (const U8*) scan, UTF8_MAXLEN, &len, uniflags );       \
1395            foldlen -= len;                                                              \
1396            scan += len;                                                                 \
1397            len = 0;                                                                     \
1398         } else {                                                                        \
1399             len = 1;                                                                    \
1400             uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, 1);                     \
1401             skiplen = UNISKIP(uvc);                                                     \
1402             foldlen -= skiplen;                                                         \
1403             scan = foldbuf + skiplen;                                                   \
1404         }                                                                               \
1405     } else {                                                                            \
1406         /* raw data, will be folded later if needed */                                  \
1407         uvc = (U32)*uc;                                                                 \
1408         len = 1;                                                                        \
1409     }                                                                                   \
1410 } STMT_END
1411
1412
1413
1414 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
1415     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
1416         U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
1417         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
1418     }                                                           \
1419     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
1420     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
1421     TRIE_LIST_CUR( state )++;                                   \
1422 } STMT_END
1423
1424 #define TRIE_LIST_NEW(state) STMT_START {                       \
1425     Newxz( trie->states[ state ].trans.list,               \
1426         4, reg_trie_trans_le );                                 \
1427      TRIE_LIST_CUR( state ) = 1;                                \
1428      TRIE_LIST_LEN( state ) = 4;                                \
1429 } STMT_END
1430
1431 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
1432     U16 dupe= trie->states[ state ].wordnum;                    \
1433     regnode * const noper_next = regnext( noper );              \
1434                                                                 \
1435     DEBUG_r({                                                   \
1436         /* store the word for dumping */                        \
1437         SV* tmp;                                                \
1438         if (OP(noper) != NOTHING)                               \
1439             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
1440         else                                                    \
1441             tmp = newSVpvn_utf8( "", 0, UTF );                  \
1442         av_push( trie_words, tmp );                             \
1443     });                                                         \
1444                                                                 \
1445     curword++;                                                  \
1446     trie->wordinfo[curword].prev   = 0;                         \
1447     trie->wordinfo[curword].len    = wordlen;                   \
1448     trie->wordinfo[curword].accept = state;                     \
1449                                                                 \
1450     if ( noper_next < tail ) {                                  \
1451         if (!trie->jump)                                        \
1452             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, sizeof(U16) ); \
1453         trie->jump[curword] = (U16)(noper_next - convert);      \
1454         if (!jumper)                                            \
1455             jumper = noper_next;                                \
1456         if (!nextbranch)                                        \
1457             nextbranch= regnext(cur);                           \
1458     }                                                           \
1459                                                                 \
1460     if ( dupe ) {                                               \
1461         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
1462         /* chain, so that when the bits of chain are later    */\
1463         /* linked together, the dups appear in the chain      */\
1464         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
1465         trie->wordinfo[dupe].prev = curword;                    \
1466     } else {                                                    \
1467         /* we haven't inserted this word yet.                */ \
1468         trie->states[ state ].wordnum = curword;                \
1469     }                                                           \
1470 } STMT_END
1471
1472
1473 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
1474      ( ( base + charid >=  ucharcount                                   \
1475          && base + charid < ubound                                      \
1476          && state == trie->trans[ base - ucharcount + charid ].check    \
1477          && trie->trans[ base - ucharcount + charid ].next )            \
1478            ? trie->trans[ base - ucharcount + charid ].next             \
1479            : ( state==1 ? special : 0 )                                 \
1480       )
1481
1482 #define MADE_TRIE       1
1483 #define MADE_JUMP_TRIE  2
1484 #define MADE_EXACT_TRIE 4
1485
1486 STATIC I32
1487 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth)
1488 {
1489     dVAR;
1490     /* first pass, loop through and scan words */
1491     reg_trie_data *trie;
1492     HV *widecharmap = NULL;
1493     AV *revcharmap = newAV();
1494     regnode *cur;
1495     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1496     STRLEN len = 0;
1497     UV uvc = 0;
1498     U16 curword = 0;
1499     U32 next_alloc = 0;
1500     regnode *jumper = NULL;
1501     regnode *nextbranch = NULL;
1502     regnode *convert = NULL;
1503     U32 *prev_states; /* temp array mapping each state to previous one */
1504     /* we just use folder as a flag in utf8 */
1505     const U8 * folder = NULL;
1506
1507 #ifdef DEBUGGING
1508     const U32 data_slot = add_data( pRExC_state, 4, "tuuu" );
1509     AV *trie_words = NULL;
1510     /* along with revcharmap, this only used during construction but both are
1511      * useful during debugging so we store them in the struct when debugging.
1512      */
1513 #else
1514     const U32 data_slot = add_data( pRExC_state, 2, "tu" );
1515     STRLEN trie_charcount=0;
1516 #endif
1517     SV *re_trie_maxbuff;
1518     GET_RE_DEBUG_FLAGS_DECL;
1519
1520     PERL_ARGS_ASSERT_MAKE_TRIE;
1521 #ifndef DEBUGGING
1522     PERL_UNUSED_ARG(depth);
1523 #endif
1524
1525     switch (flags) {
1526         case EXACT: break;
1527         case EXACTFA:
1528         case EXACTFU_SS:
1529         case EXACTFU_TRICKYFOLD:
1530         case EXACTFU: folder = PL_fold_latin1; break;
1531         case EXACTF:  folder = PL_fold; break;
1532         case EXACTFL: folder = PL_fold_locale; break;
1533         default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
1534     }
1535
1536     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
1537     trie->refcount = 1;
1538     trie->startstate = 1;
1539     trie->wordcount = word_count;
1540     RExC_rxi->data->data[ data_slot ] = (void*)trie;
1541     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
1542     if (flags == EXACT)
1543         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
1544     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
1545                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
1546
1547     DEBUG_r({
1548         trie_words = newAV();
1549     });
1550
1551     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
1552     if (!SvIOK(re_trie_maxbuff)) {
1553         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
1554     }
1555     DEBUG_OPTIMISE_r({
1556                 PerlIO_printf( Perl_debug_log,
1557                   "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
1558                   (int)depth * 2 + 2, "", 
1559                   REG_NODE_NUM(startbranch),REG_NODE_NUM(first), 
1560                   REG_NODE_NUM(last), REG_NODE_NUM(tail),
1561                   (int)depth);
1562     });
1563    
1564    /* Find the node we are going to overwrite */
1565     if ( first == startbranch && OP( last ) != BRANCH ) {
1566         /* whole branch chain */
1567         convert = first;
1568     } else {
1569         /* branch sub-chain */
1570         convert = NEXTOPER( first );
1571     }
1572         
1573     /*  -- First loop and Setup --
1574
1575        We first traverse the branches and scan each word to determine if it
1576        contains widechars, and how many unique chars there are, this is
1577        important as we have to build a table with at least as many columns as we
1578        have unique chars.
1579
1580        We use an array of integers to represent the character codes 0..255
1581        (trie->charmap) and we use a an HV* to store Unicode characters. We use the
1582        native representation of the character value as the key and IV's for the
1583        coded index.
1584
1585        *TODO* If we keep track of how many times each character is used we can
1586        remap the columns so that the table compression later on is more
1587        efficient in terms of memory by ensuring the most common value is in the
1588        middle and the least common are on the outside.  IMO this would be better
1589        than a most to least common mapping as theres a decent chance the most
1590        common letter will share a node with the least common, meaning the node
1591        will not be compressible. With a middle is most common approach the worst
1592        case is when we have the least common nodes twice.
1593
1594      */
1595
1596     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1597         regnode * const noper = NEXTOPER( cur );
1598         const U8 *uc = (U8*)STRING( noper );
1599         const U8 * const e  = uc + STR_LEN( noper );
1600         STRLEN foldlen = 0;
1601         U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1602         STRLEN skiplen = 0;
1603         const U8 *scan = (U8*)NULL;
1604         U32 wordlen      = 0;         /* required init */
1605         STRLEN chars = 0;
1606         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the bitmap?*/
1607
1608         if (OP(noper) == NOTHING) {
1609             trie->minlen= 0;
1610             continue;
1611         }
1612         if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
1613             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
1614                                           regardless of encoding */
1615             if (OP( noper ) == EXACTFU_SS) {
1616                 /* false positives are ok, so just set this */
1617                 TRIE_BITMAP_SET(trie,0xDF);
1618             }
1619         }
1620         for ( ; uc < e ; uc += len ) {
1621             TRIE_CHARCOUNT(trie)++;
1622             TRIE_READ_CHAR;
1623             chars++;
1624             if ( uvc < 256 ) {
1625                 if ( folder ) {
1626                     U8 folded= folder[ (U8) uvc ];
1627                     if ( !trie->charmap[ folded ] ) {
1628                         trie->charmap[ folded ]=( ++trie->uniquecharcount );
1629                         TRIE_STORE_REVCHAR( folded );
1630                     }
1631                 }
1632                 if ( !trie->charmap[ uvc ] ) {
1633                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
1634                     TRIE_STORE_REVCHAR( uvc );
1635                 }
1636                 if ( set_bit ) {
1637                     /* store the codepoint in the bitmap, and its folded
1638                      * equivalent. */
1639                     TRIE_BITMAP_SET(trie, uvc);
1640
1641                     /* store the folded codepoint */
1642                     if ( folder ) TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);
1643
1644                     if ( !UTF ) {
1645                         /* store first byte of utf8 representation of
1646                            variant codepoints */
1647                         if (! UNI_IS_INVARIANT(uvc)) {
1648                             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));
1649                         }
1650                     }
1651                     set_bit = 0; /* We've done our bit :-) */
1652                 }
1653             } else {
1654                 SV** svpp;
1655                 if ( !widecharmap )
1656                     widecharmap = newHV();
1657
1658                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
1659
1660                 if ( !svpp )
1661                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
1662
1663                 if ( !SvTRUE( *svpp ) ) {
1664                     sv_setiv( *svpp, ++trie->uniquecharcount );
1665                     TRIE_STORE_REVCHAR(uvc);
1666                 }
1667             }
1668         }
1669         if( cur == first ) {
1670             trie->minlen = chars;
1671             trie->maxlen = chars;
1672         } else if (chars < trie->minlen) {
1673             trie->minlen = chars;
1674         } else if (chars > trie->maxlen) {
1675             trie->maxlen = chars;
1676         }
1677         if (OP( noper ) == EXACTFU_SS) {
1678             /* XXX: workaround - 'ss' could match "\x{DF}" so minlen could be 1 and not 2*/
1679             if (trie->minlen > 1)
1680                 trie->minlen= 1;
1681         }
1682         if (OP( noper ) == EXACTFU_TRICKYFOLD) {
1683             /* XXX: workround - things like "\x{1FBE}\x{0308}\x{0301}" can match "\x{0390}" 
1684              *                - We assume that any such sequence might match a 2 byte string */
1685             if (trie->minlen > 2 )
1686                 trie->minlen= 2;
1687         }
1688
1689     } /* end first pass */
1690     DEBUG_TRIE_COMPILE_r(
1691         PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
1692                 (int)depth * 2 + 2,"",
1693                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
1694                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
1695                 (int)trie->minlen, (int)trie->maxlen )
1696     );
1697
1698     /*
1699         We now know what we are dealing with in terms of unique chars and
1700         string sizes so we can calculate how much memory a naive
1701         representation using a flat table  will take. If it's over a reasonable
1702         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
1703         conservative but potentially much slower representation using an array
1704         of lists.
1705
1706         At the end we convert both representations into the same compressed
1707         form that will be used in regexec.c for matching with. The latter
1708         is a form that cannot be used to construct with but has memory
1709         properties similar to the list form and access properties similar
1710         to the table form making it both suitable for fast searches and
1711         small enough that its feasable to store for the duration of a program.
1712
1713         See the comment in the code where the compressed table is produced
1714         inplace from the flat tabe representation for an explanation of how
1715         the compression works.
1716
1717     */
1718
1719
1720     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
1721     prev_states[1] = 0;
1722
1723     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1) > SvIV(re_trie_maxbuff) ) {
1724         /*
1725             Second Pass -- Array Of Lists Representation
1726
1727             Each state will be represented by a list of charid:state records
1728             (reg_trie_trans_le) the first such element holds the CUR and LEN
1729             points of the allocated array. (See defines above).
1730
1731             We build the initial structure using the lists, and then convert
1732             it into the compressed table form which allows faster lookups
1733             (but cant be modified once converted).
1734         */
1735
1736         STRLEN transcount = 1;
1737
1738         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
1739             "%*sCompiling trie using list compiler\n",
1740             (int)depth * 2 + 2, ""));
1741
1742         trie->states = (reg_trie_state *)
1743             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1744                                   sizeof(reg_trie_state) );
1745         TRIE_LIST_NEW(1);
1746         next_alloc = 2;
1747
1748         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1749
1750             regnode * const noper = NEXTOPER( cur );
1751             U8 *uc           = (U8*)STRING( noper );
1752             const U8 * const e = uc + STR_LEN( noper );
1753             U32 state        = 1;         /* required init */
1754             U16 charid       = 0;         /* sanity init */
1755             U8 *scan         = (U8*)NULL; /* sanity init */
1756             STRLEN foldlen   = 0;         /* required init */
1757             U32 wordlen      = 0;         /* required init */
1758             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1759             STRLEN skiplen   = 0;
1760
1761             if (OP(noper) != NOTHING) {
1762                 for ( ; uc < e ; uc += len ) {
1763
1764                     TRIE_READ_CHAR;
1765
1766                     if ( uvc < 256 ) {
1767                         charid = trie->charmap[ uvc ];
1768                     } else {
1769                         SV** const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1770                         if ( !svpp ) {
1771                             charid = 0;
1772                         } else {
1773                             charid=(U16)SvIV( *svpp );
1774                         }
1775                     }
1776                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
1777                     if ( charid ) {
1778
1779                         U16 check;
1780                         U32 newstate = 0;
1781
1782                         charid--;
1783                         if ( !trie->states[ state ].trans.list ) {
1784                             TRIE_LIST_NEW( state );
1785                         }
1786                         for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) {
1787                             if ( TRIE_LIST_ITEM( state, check ).forid == charid ) {
1788                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
1789                                 break;
1790                             }
1791                         }
1792                         if ( ! newstate ) {
1793                             newstate = next_alloc++;
1794                             prev_states[newstate] = state;
1795                             TRIE_LIST_PUSH( state, charid, newstate );
1796                             transcount++;
1797                         }
1798                         state = newstate;
1799                     } else {
1800                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1801                     }
1802                 }
1803             }
1804             TRIE_HANDLE_WORD(state);
1805
1806         } /* end second pass */
1807
1808         /* next alloc is the NEXT state to be allocated */
1809         trie->statecount = next_alloc; 
1810         trie->states = (reg_trie_state *)
1811             PerlMemShared_realloc( trie->states,
1812                                    next_alloc
1813                                    * sizeof(reg_trie_state) );
1814
1815         /* and now dump it out before we compress it */
1816         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
1817                                                          revcharmap, next_alloc,
1818                                                          depth+1)
1819         );
1820
1821         trie->trans = (reg_trie_trans *)
1822             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
1823         {
1824             U32 state;
1825             U32 tp = 0;
1826             U32 zp = 0;
1827
1828
1829             for( state=1 ; state < next_alloc ; state ++ ) {
1830                 U32 base=0;
1831
1832                 /*
1833                 DEBUG_TRIE_COMPILE_MORE_r(
1834                     PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
1835                 );
1836                 */
1837
1838                 if (trie->states[state].trans.list) {
1839                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
1840                     U16 maxid=minid;
1841                     U16 idx;
1842
1843                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1844                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
1845                         if ( forid < minid ) {
1846                             minid=forid;
1847                         } else if ( forid > maxid ) {
1848                             maxid=forid;
1849                         }
1850                     }
1851                     if ( transcount < tp + maxid - minid + 1) {
1852                         transcount *= 2;
1853                         trie->trans = (reg_trie_trans *)
1854                             PerlMemShared_realloc( trie->trans,
1855                                                      transcount
1856                                                      * sizeof(reg_trie_trans) );
1857                         Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans );
1858                     }
1859                     base = trie->uniquecharcount + tp - minid;
1860                     if ( maxid == minid ) {
1861                         U32 set = 0;
1862                         for ( ; zp < tp ; zp++ ) {
1863                             if ( ! trie->trans[ zp ].next ) {
1864                                 base = trie->uniquecharcount + zp - minid;
1865                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1866                                 trie->trans[ zp ].check = state;
1867                                 set = 1;
1868                                 break;
1869                             }
1870                         }
1871                         if ( !set ) {
1872                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1873                             trie->trans[ tp ].check = state;
1874                             tp++;
1875                             zp = tp;
1876                         }
1877                     } else {
1878                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1879                             const U32 tid = base -  trie->uniquecharcount + TRIE_LIST_ITEM( state, idx ).forid;
1880                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state, idx ).newstate;
1881                             trie->trans[ tid ].check = state;
1882                         }
1883                         tp += ( maxid - minid + 1 );
1884                     }
1885                     Safefree(trie->states[ state ].trans.list);
1886                 }
1887                 /*
1888                 DEBUG_TRIE_COMPILE_MORE_r(
1889                     PerlIO_printf( Perl_debug_log, " base: %d\n",base);
1890                 );
1891                 */
1892                 trie->states[ state ].trans.base=base;
1893             }
1894             trie->lasttrans = tp + 1;
1895         }
1896     } else {
1897         /*
1898            Second Pass -- Flat Table Representation.
1899
1900            we dont use the 0 slot of either trans[] or states[] so we add 1 to each.
1901            We know that we will need Charcount+1 trans at most to store the data
1902            (one row per char at worst case) So we preallocate both structures
1903            assuming worst case.
1904
1905            We then construct the trie using only the .next slots of the entry
1906            structs.
1907
1908            We use the .check field of the first entry of the node temporarily to
1909            make compression both faster and easier by keeping track of how many non
1910            zero fields are in the node.
1911
1912            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
1913            transition.
1914
1915            There are two terms at use here: state as a TRIE_NODEIDX() which is a
1916            number representing the first entry of the node, and state as a
1917            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1) and
1918            TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3) if there
1919            are 2 entrys per node. eg:
1920
1921              A B       A B
1922           1. 2 4    1. 3 7
1923           2. 0 3    3. 0 5
1924           3. 0 0    5. 0 0
1925           4. 0 0    7. 0 0
1926
1927            The table is internally in the right hand, idx form. However as we also
1928            have to deal with the states array which is indexed by nodenum we have to
1929            use TRIE_NODENUM() to convert.
1930
1931         */
1932         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
1933             "%*sCompiling trie using table compiler\n",
1934             (int)depth * 2 + 2, ""));
1935
1936         trie->trans = (reg_trie_trans *)
1937             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
1938                                   * trie->uniquecharcount + 1,
1939                                   sizeof(reg_trie_trans) );
1940         trie->states = (reg_trie_state *)
1941             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1942                                   sizeof(reg_trie_state) );
1943         next_alloc = trie->uniquecharcount + 1;
1944
1945
1946         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1947
1948             regnode * const noper   = NEXTOPER( cur );
1949             const U8 *uc     = (U8*)STRING( noper );
1950             const U8 * const e = uc + STR_LEN( noper );
1951
1952             U32 state        = 1;         /* required init */
1953
1954             U16 charid       = 0;         /* sanity init */
1955             U32 accept_state = 0;         /* sanity init */
1956             U8 *scan         = (U8*)NULL; /* sanity init */
1957
1958             STRLEN foldlen   = 0;         /* required init */
1959             U32 wordlen      = 0;         /* required init */
1960             STRLEN skiplen   = 0;
1961             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1962
1963
1964             if ( OP(noper) != NOTHING ) {
1965                 for ( ; uc < e ; uc += len ) {
1966
1967                     TRIE_READ_CHAR;
1968
1969                     if ( uvc < 256 ) {
1970                         charid = trie->charmap[ uvc ];
1971                     } else {
1972                         SV* const * const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1973                         charid = svpp ? (U16)SvIV(*svpp) : 0;
1974                     }
1975                     if ( charid ) {
1976                         charid--;
1977                         if ( !trie->trans[ state + charid ].next ) {
1978                             trie->trans[ state + charid ].next = next_alloc;
1979                             trie->trans[ state ].check++;
1980                             prev_states[TRIE_NODENUM(next_alloc)]
1981                                     = TRIE_NODENUM(state);
1982                             next_alloc += trie->uniquecharcount;
1983                         }
1984                         state = trie->trans[ state + charid ].next;
1985                     } else {
1986                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1987                     }
1988                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
1989                 }
1990             }
1991             accept_state = TRIE_NODENUM( state );
1992             TRIE_HANDLE_WORD(accept_state);
1993
1994         } /* end second pass */
1995
1996         /* and now dump it out before we compress it */
1997         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
1998                                                           revcharmap,
1999                                                           next_alloc, depth+1));
2000
2001         {
2002         /*
2003            * Inplace compress the table.*
2004
2005            For sparse data sets the table constructed by the trie algorithm will
2006            be mostly 0/FAIL transitions or to put it another way mostly empty.
2007            (Note that leaf nodes will not contain any transitions.)
2008
2009            This algorithm compresses the tables by eliminating most such
2010            transitions, at the cost of a modest bit of extra work during lookup:
2011
2012            - Each states[] entry contains a .base field which indicates the
2013            index in the state[] array wheres its transition data is stored.
2014
2015            - If .base is 0 there are no valid transitions from that node.
2016
2017            - If .base is nonzero then charid is added to it to find an entry in
2018            the trans array.
2019
2020            -If trans[states[state].base+charid].check!=state then the
2021            transition is taken to be a 0/Fail transition. Thus if there are fail
2022            transitions at the front of the node then the .base offset will point
2023            somewhere inside the previous nodes data (or maybe even into a node
2024            even earlier), but the .check field determines if the transition is
2025            valid.
2026
2027            XXX - wrong maybe?
2028            The following process inplace converts the table to the compressed
2029            table: We first do not compress the root node 1,and mark all its
2030            .check pointers as 1 and set its .base pointer as 1 as well. This
2031            allows us to do a DFA construction from the compressed table later,
2032            and ensures that any .base pointers we calculate later are greater
2033            than 0.
2034
2035            - We set 'pos' to indicate the first entry of the second node.
2036
2037            - We then iterate over the columns of the node, finding the first and
2038            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
2039            and set the .check pointers accordingly, and advance pos
2040            appropriately and repreat for the next node. Note that when we copy
2041            the next pointers we have to convert them from the original
2042            NODEIDX form to NODENUM form as the former is not valid post
2043            compression.
2044
2045            - If a node has no transitions used we mark its base as 0 and do not
2046            advance the pos pointer.
2047
2048            - If a node only has one transition we use a second pointer into the
2049            structure to fill in allocated fail transitions from other states.
2050            This pointer is independent of the main pointer and scans forward
2051            looking for null transitions that are allocated to a state. When it
2052            finds one it writes the single transition into the "hole".  If the
2053            pointer doesnt find one the single transition is appended as normal.
2054
2055            - Once compressed we can Renew/realloc the structures to release the
2056            excess space.
2057
2058            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
2059            specifically Fig 3.47 and the associated pseudocode.
2060
2061            demq
2062         */
2063         const U32 laststate = TRIE_NODENUM( next_alloc );
2064         U32 state, charid;
2065         U32 pos = 0, zp=0;
2066         trie->statecount = laststate;
2067
2068         for ( state = 1 ; state < laststate ; state++ ) {
2069             U8 flag = 0;
2070             const U32 stateidx = TRIE_NODEIDX( state );
2071             const U32 o_used = trie->trans[ stateidx ].check;
2072             U32 used = trie->trans[ stateidx ].check;
2073             trie->trans[ stateidx ].check = 0;
2074
2075             for ( charid = 0 ; used && charid < trie->uniquecharcount ; charid++ ) {
2076                 if ( flag || trie->trans[ stateidx + charid ].next ) {
2077                     if ( trie->trans[ stateidx + charid ].next ) {
2078                         if (o_used == 1) {
2079                             for ( ; zp < pos ; zp++ ) {
2080                                 if ( ! trie->trans[ zp ].next ) {
2081                                     break;
2082                                 }
2083                             }
2084                             trie->states[ state ].trans.base = zp + trie->uniquecharcount - charid ;
2085                             trie->trans[ zp ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2086                             trie->trans[ zp ].check = state;
2087                             if ( ++zp > pos ) pos = zp;
2088                             break;
2089                         }
2090                         used--;
2091                     }
2092                     if ( !flag ) {
2093                         flag = 1;
2094                         trie->states[ state ].trans.base = pos + trie->uniquecharcount - charid ;
2095                     }
2096                     trie->trans[ pos ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2097                     trie->trans[ pos ].check = state;
2098                     pos++;
2099                 }
2100             }
2101         }
2102         trie->lasttrans = pos + 1;
2103         trie->states = (reg_trie_state *)
2104             PerlMemShared_realloc( trie->states, laststate
2105                                    * sizeof(reg_trie_state) );
2106         DEBUG_TRIE_COMPILE_MORE_r(
2107                 PerlIO_printf( Perl_debug_log,
2108                     "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
2109                     (int)depth * 2 + 2,"",
2110                     (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1 ),
2111                     (IV)next_alloc,
2112                     (IV)pos,
2113                     ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
2114             );
2115
2116         } /* end table compress */
2117     }
2118     DEBUG_TRIE_COMPILE_MORE_r(
2119             PerlIO_printf(Perl_debug_log, "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
2120                 (int)depth * 2 + 2, "",
2121                 (UV)trie->statecount,
2122                 (UV)trie->lasttrans)
2123     );
2124     /* resize the trans array to remove unused space */
2125     trie->trans = (reg_trie_trans *)
2126         PerlMemShared_realloc( trie->trans, trie->lasttrans
2127                                * sizeof(reg_trie_trans) );
2128
2129     {   /* Modify the program and insert the new TRIE node */ 
2130         U8 nodetype =(U8)(flags & 0xFF);
2131         char *str=NULL;
2132         
2133 #ifdef DEBUGGING
2134         regnode *optimize = NULL;
2135 #ifdef RE_TRACK_PATTERN_OFFSETS
2136
2137         U32 mjd_offset = 0;
2138         U32 mjd_nodelen = 0;
2139 #endif /* RE_TRACK_PATTERN_OFFSETS */
2140 #endif /* DEBUGGING */
2141         /*
2142            This means we convert either the first branch or the first Exact,
2143            depending on whether the thing following (in 'last') is a branch
2144            or not and whther first is the startbranch (ie is it a sub part of
2145            the alternation or is it the whole thing.)
2146            Assuming its a sub part we convert the EXACT otherwise we convert
2147            the whole branch sequence, including the first.
2148          */
2149         /* Find the node we are going to overwrite */
2150         if ( first != startbranch || OP( last ) == BRANCH ) {
2151             /* branch sub-chain */
2152             NEXT_OFF( first ) = (U16)(last - first);
2153 #ifdef RE_TRACK_PATTERN_OFFSETS
2154             DEBUG_r({
2155                 mjd_offset= Node_Offset((convert));
2156                 mjd_nodelen= Node_Length((convert));
2157             });
2158 #endif
2159             /* whole branch chain */
2160         }
2161 #ifdef RE_TRACK_PATTERN_OFFSETS
2162         else {
2163             DEBUG_r({
2164                 const  regnode *nop = NEXTOPER( convert );
2165                 mjd_offset= Node_Offset((nop));
2166                 mjd_nodelen= Node_Length((nop));
2167             });
2168         }
2169         DEBUG_OPTIMISE_r(
2170             PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
2171                 (int)depth * 2 + 2, "",
2172                 (UV)mjd_offset, (UV)mjd_nodelen)
2173         );
2174 #endif
2175         /* But first we check to see if there is a common prefix we can 
2176            split out as an EXACT and put in front of the TRIE node.  */
2177         trie->startstate= 1;
2178         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
2179             U32 state;
2180             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
2181                 U32 ofs = 0;
2182                 I32 idx = -1;
2183                 U32 count = 0;
2184                 const U32 base = trie->states[ state ].trans.base;
2185
2186                 if ( trie->states[state].wordnum )
2187                         count = 1;
2188
2189                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2190                     if ( ( base + ofs >= trie->uniquecharcount ) &&
2191                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
2192                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
2193                     {
2194                         if ( ++count > 1 ) {
2195                             SV **tmp = av_fetch( revcharmap, ofs, 0);
2196                             const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
2197                             if ( state == 1 ) break;
2198                             if ( count == 2 ) {
2199                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
2200                                 DEBUG_OPTIMISE_r(
2201                                     PerlIO_printf(Perl_debug_log,
2202                                         "%*sNew Start State=%"UVuf" Class: [",
2203                                         (int)depth * 2 + 2, "",
2204                                         (UV)state));
2205                                 if (idx >= 0) {
2206                                     SV ** const tmp = av_fetch( revcharmap, idx, 0);
2207                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
2208
2209                                     TRIE_BITMAP_SET(trie,*ch);
2210                                     if ( folder )
2211                                         TRIE_BITMAP_SET(trie, folder[ *ch ]);
2212                                     DEBUG_OPTIMISE_r(
2213                                         PerlIO_printf(Perl_debug_log, "%s", (char*)ch)
2214                                     );
2215                                 }
2216                             }
2217                             TRIE_BITMAP_SET(trie,*ch);
2218                             if ( folder )
2219                                 TRIE_BITMAP_SET(trie,folder[ *ch ]);
2220                             DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
2221                         }
2222                         idx = ofs;
2223                     }
2224                 }
2225                 if ( count == 1 ) {
2226                     SV **tmp = av_fetch( revcharmap, idx, 0);
2227                     STRLEN len;
2228                     char *ch = SvPV( *tmp, len );
2229                     DEBUG_OPTIMISE_r({
2230                         SV *sv=sv_newmortal();
2231                         PerlIO_printf( Perl_debug_log,
2232                             "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
2233                             (int)depth * 2 + 2, "",
2234                             (UV)state, (UV)idx, 
2235                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6, 
2236                                 PL_colors[0], PL_colors[1],
2237                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2238                                 PERL_PV_ESCAPE_FIRSTCHAR 
2239                             )
2240                         );
2241                     });
2242                     if ( state==1 ) {
2243                         OP( convert ) = nodetype;
2244                         str=STRING(convert);
2245                         STR_LEN(convert)=0;
2246                     }
2247                     STR_LEN(convert) += len;
2248                     while (len--)
2249                         *str++ = *ch++;
2250                 } else {
2251 #ifdef DEBUGGING            
2252                     if (state>1)
2253                         DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
2254 #endif
2255                     break;
2256                 }
2257             }
2258             trie->prefixlen = (state-1);
2259             if (str) {
2260                 regnode *n = convert+NODE_SZ_STR(convert);
2261                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
2262                 trie->startstate = state;
2263                 trie->minlen -= (state - 1);
2264                 trie->maxlen -= (state - 1);
2265 #ifdef DEBUGGING
2266                /* At least the UNICOS C compiler choked on this
2267                 * being argument to DEBUG_r(), so let's just have
2268                 * it right here. */
2269                if (
2270 #ifdef PERL_EXT_RE_BUILD
2271                    1
2272 #else
2273                    DEBUG_r_TEST
2274 #endif
2275                    ) {
2276                    regnode *fix = convert;
2277                    U32 word = trie->wordcount;
2278                    mjd_nodelen++;
2279                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
2280                    while( ++fix < n ) {
2281                        Set_Node_Offset_Length(fix, 0, 0);
2282                    }
2283                    while (word--) {
2284                        SV ** const tmp = av_fetch( trie_words, word, 0 );
2285                        if (tmp) {
2286                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
2287                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
2288                            else
2289                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
2290                        }
2291                    }
2292                }
2293 #endif
2294                 if (trie->maxlen) {
2295                     convert = n;
2296                 } else {
2297                     NEXT_OFF(convert) = (U16)(tail - convert);
2298                     DEBUG_r(optimize= n);
2299                 }
2300             }
2301         }
2302         if (!jumper) 
2303             jumper = last; 
2304         if ( trie->maxlen ) {
2305             NEXT_OFF( convert ) = (U16)(tail - convert);
2306             ARG_SET( convert, data_slot );
2307             /* Store the offset to the first unabsorbed branch in 
2308                jump[0], which is otherwise unused by the jump logic. 
2309                We use this when dumping a trie and during optimisation. */
2310             if (trie->jump) 
2311                 trie->jump[0] = (U16)(nextbranch - convert);
2312             
2313             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
2314              *   and there is a bitmap
2315              *   and the first "jump target" node we found leaves enough room
2316              * then convert the TRIE node into a TRIEC node, with the bitmap
2317              * embedded inline in the opcode - this is hypothetically faster.
2318              */
2319             if ( !trie->states[trie->startstate].wordnum
2320                  && trie->bitmap
2321                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
2322             {
2323                 OP( convert ) = TRIEC;
2324                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
2325                 PerlMemShared_free(trie->bitmap);
2326                 trie->bitmap= NULL;
2327             } else 
2328                 OP( convert ) = TRIE;
2329
2330             /* store the type in the flags */
2331             convert->flags = nodetype;
2332             DEBUG_r({
2333             optimize = convert 
2334                       + NODE_STEP_REGNODE 
2335                       + regarglen[ OP( convert ) ];
2336             });
2337             /* XXX We really should free up the resource in trie now, 
2338                    as we won't use them - (which resources?) dmq */
2339         }
2340         /* needed for dumping*/
2341         DEBUG_r(if (optimize) {
2342             regnode *opt = convert;
2343
2344             while ( ++opt < optimize) {
2345                 Set_Node_Offset_Length(opt,0,0);
2346             }
2347             /* 
2348                 Try to clean up some of the debris left after the 
2349                 optimisation.
2350              */
2351             while( optimize < jumper ) {
2352                 mjd_nodelen += Node_Length((optimize));
2353                 OP( optimize ) = OPTIMIZED;
2354                 Set_Node_Offset_Length(optimize,0,0);
2355                 optimize++;
2356             }
2357             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
2358         });
2359     } /* end node insert */
2360     REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, convert);
2361
2362     /*  Finish populating the prev field of the wordinfo array.  Walk back
2363      *  from each accept state until we find another accept state, and if
2364      *  so, point the first word's .prev field at the second word. If the
2365      *  second already has a .prev field set, stop now. This will be the
2366      *  case either if we've already processed that word's accept state,
2367      *  or that state had multiple words, and the overspill words were
2368      *  already linked up earlier.
2369      */
2370     {
2371         U16 word;
2372         U32 state;
2373         U16 prev;
2374
2375         for (word=1; word <= trie->wordcount; word++) {
2376             prev = 0;
2377             if (trie->wordinfo[word].prev)
2378                 continue;
2379             state = trie->wordinfo[word].accept;
2380             while (state) {
2381                 state = prev_states[state];
2382                 if (!state)
2383                     break;
2384                 prev = trie->states[state].wordnum;
2385                 if (prev)
2386                     break;
2387             }
2388             trie->wordinfo[word].prev = prev;
2389         }
2390         Safefree(prev_states);
2391     }
2392
2393
2394     /* and now dump out the compressed format */
2395     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
2396
2397     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
2398 #ifdef DEBUGGING
2399     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
2400     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
2401 #else
2402     SvREFCNT_dec(revcharmap);
2403 #endif
2404     return trie->jump 
2405            ? MADE_JUMP_TRIE 
2406            : trie->startstate>1 
2407              ? MADE_EXACT_TRIE 
2408              : MADE_TRIE;
2409 }
2410
2411 STATIC void
2412 S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source,  regnode *stclass, U32 depth)
2413 {
2414 /* The Trie is constructed and compressed now so we can build a fail array if it's needed
2415
2416    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
2417    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
2418    ISBN 0-201-10088-6
2419
2420    We find the fail state for each state in the trie, this state is the longest proper
2421    suffix of the current state's 'word' that is also a proper prefix of another word in our
2422    trie. State 1 represents the word '' and is thus the default fail state. This allows
2423    the DFA not to have to restart after its tried and failed a word at a given point, it
2424    simply continues as though it had been matching the other word in the first place.
2425    Consider
2426       'abcdgu'=~/abcdefg|cdgu/
2427    When we get to 'd' we are still matching the first word, we would encounter 'g' which would
2428    fail, which would bring us to the state representing 'd' in the second word where we would
2429    try 'g' and succeed, proceeding to match 'cdgu'.
2430  */
2431  /* add a fail transition */
2432     const U32 trie_offset = ARG(source);
2433     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
2434     U32 *q;
2435     const U32 ucharcount = trie->uniquecharcount;
2436     const U32 numstates = trie->statecount;
2437     const U32 ubound = trie->lasttrans + ucharcount;
2438     U32 q_read = 0;
2439     U32 q_write = 0;
2440     U32 charid;
2441     U32 base = trie->states[ 1 ].trans.base;
2442     U32 *fail;
2443     reg_ac_data *aho;
2444     const U32 data_slot = add_data( pRExC_state, 1, "T" );
2445     GET_RE_DEBUG_FLAGS_DECL;
2446
2447     PERL_ARGS_ASSERT_MAKE_TRIE_FAILTABLE;
2448 #ifndef DEBUGGING
2449     PERL_UNUSED_ARG(depth);
2450 #endif
2451
2452
2453     ARG_SET( stclass, data_slot );
2454     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
2455     RExC_rxi->data->data[ data_slot ] = (void*)aho;
2456     aho->trie=trie_offset;
2457     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
2458     Copy( trie->states, aho->states, numstates, reg_trie_state );
2459     Newxz( q, numstates, U32);
2460     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
2461     aho->refcount = 1;
2462     fail = aho->fail;
2463     /* initialize fail[0..1] to be 1 so that we always have
2464        a valid final fail state */
2465     fail[ 0 ] = fail[ 1 ] = 1;
2466
2467     for ( charid = 0; charid < ucharcount ; charid++ ) {
2468         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
2469         if ( newstate ) {
2470             q[ q_write ] = newstate;
2471             /* set to point at the root */
2472             fail[ q[ q_write++ ] ]=1;
2473         }
2474     }
2475     while ( q_read < q_write) {
2476         const U32 cur = q[ q_read++ % numstates ];
2477         base = trie->states[ cur ].trans.base;
2478
2479         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
2480             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
2481             if (ch_state) {
2482                 U32 fail_state = cur;
2483                 U32 fail_base;
2484                 do {
2485                     fail_state = fail[ fail_state ];
2486                     fail_base = aho->states[ fail_state ].trans.base;
2487                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
2488
2489                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
2490                 fail[ ch_state ] = fail_state;
2491                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
2492                 {
2493                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
2494                 }
2495                 q[ q_write++ % numstates] = ch_state;
2496             }
2497         }
2498     }
2499     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
2500        when we fail in state 1, this allows us to use the
2501        charclass scan to find a valid start char. This is based on the principle
2502        that theres a good chance the string being searched contains lots of stuff
2503        that cant be a start char.
2504      */
2505     fail[ 0 ] = fail[ 1 ] = 0;
2506     DEBUG_TRIE_COMPILE_r({
2507         PerlIO_printf(Perl_debug_log,
2508                       "%*sStclass Failtable (%"UVuf" states): 0", 
2509                       (int)(depth * 2), "", (UV)numstates
2510         );
2511         for( q_read=1; q_read<numstates; q_read++ ) {
2512             PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
2513         }
2514         PerlIO_printf(Perl_debug_log, "\n");
2515     });
2516     Safefree(q);
2517     /*RExC_seen |= REG_SEEN_TRIEDFA;*/
2518 }
2519
2520
2521 /*
2522  * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2523  * These need to be revisited when a newer toolchain becomes available.
2524  */
2525 #if defined(__sparc64__) && defined(__GNUC__)
2526 #   if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2527 #       undef  SPARC64_GCC_WORKAROUND
2528 #       define SPARC64_GCC_WORKAROUND 1
2529 #   endif
2530 #endif
2531
2532 #define DEBUG_PEEP(str,scan,depth) \
2533     DEBUG_OPTIMISE_r({if (scan){ \
2534        SV * const mysv=sv_newmortal(); \
2535        regnode *Next = regnext(scan); \
2536        regprop(RExC_rx, mysv, scan); \
2537        PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
2538        (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
2539        Next ? (REG_NODE_NUM(Next)) : 0 ); \
2540    }});
2541
2542
2543 /* The below joins as many adjacent EXACTish nodes as possible into a single
2544  * one, and looks for problematic sequences of characters whose folds vs.
2545  * non-folds have sufficiently different lengths, that the optimizer would be
2546  * fooled into rejecting legitimate matches of them, and the trie construction
2547  * code can't cope with them.  The joining is only done if:
2548  * 1) there is room in the current conglomerated node to entirely contain the
2549  *    next one.
2550  * 2) they are the exact same node type
2551  *
2552  * The adjacent nodes actually may be separated by NOTHING kind nodes, and
2553  * these get optimized out
2554  *
2555  * If there are problematic code sequences, *min_subtract is set to the delta
2556  * that the minimum size of the node can be less than its actual size.  And,
2557  * the node type of the result is changed to reflect that it contains these
2558  * sequences.
2559  *
2560  * And *has_exactf_sharp_s is set to indicate whether or not the node is EXACTF
2561  * and contains LATIN SMALL LETTER SHARP S
2562  *
2563  * This is as good a place as any to discuss the design of handling these
2564  * problematic sequences.  It's been wrong in Perl for a very long time.  There
2565  * are three code points in Unicode whose folded lengths differ so much from
2566  * the un-folded lengths that it causes problems for the optimizer and trie
2567  * construction.  Why only these are problematic, and not others where lengths
2568  * also differ is something I (khw) do not understand.  New versions of Unicode
2569  * might add more such code points.  Hopefully the logic in fold_grind.t that
2570  * figures out what to test (in part by verifying that each size-combination
2571  * gets tested) will catch any that do come along, so they can be added to the
2572  * special handling below.  The chances of new ones are actually rather small,
2573  * as most, if not all, of the world's scripts that have casefolding have
2574  * already been encoded by Unicode.  Also, a number of Unicode's decisions were
2575  * made to allow compatibility with pre-existing standards, and almost all of
2576  * those have already been dealt with.  These would otherwise be the most
2577  * likely candidates for generating further tricky sequences.  In other words,
2578  * Unicode by itself is unlikely to add new ones unless it is for compatibility
2579  * with pre-existing standards, and there aren't many of those left.
2580  *
2581  * The previous designs for dealing with these involved assigning a special
2582  * node for them.  This approach doesn't work, as evidenced by this example:
2583  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
2584  * Both these fold to "sss", but if the pattern is parsed to create a node of
2585  * that would match just the \xDF, it won't be able to handle the case where a
2586  * successful match would have to cross the node's boundary.  The new approach
2587  * that hopefully generally solves the problem generates an EXACTFU_SS node
2588  * that is "sss".
2589  *
2590  * There are a number of components to the approach (a lot of work for just
2591  * three code points!):
2592  * 1)   This routine examines each EXACTFish node that could contain the
2593  *      problematic sequences.  It returns in *min_subtract how much to
2594  *      subtract from the the actual length of the string to get a real minimum
2595  *      for one that could match it.  This number is usually 0 except for the
2596  *      problematic sequences.  This delta is used by the caller to adjust the
2597  *      min length of the match, and the delta between min and max, so that the
2598  *      optimizer doesn't reject these possibilities based on size constraints.
2599  * 2)   These sequences are not currently correctly handled by the trie code
2600  *      either, so it changes the joined node type to ops that are not handled
2601  *      by trie's, those new ops being EXACTFU_SS and EXACTFU_TRICKYFOLD.
2602  * 3)   This is sufficient for the two Greek sequences (described below), but
2603  *      the one involving the Sharp s (\xDF) needs more.  The node type
2604  *      EXACTFU_SS is used for an EXACTFU node that contains at least one "ss"
2605  *      sequence in it.  For non-UTF-8 patterns and strings, this is the only
2606  *      case where there is a possible fold length change.  That means that a
2607  *      regular EXACTFU node without UTF-8 involvement doesn't have to concern
2608  *      itself with length changes, and so can be processed faster.  regexec.c
2609  *      takes advantage of this.  Generally, an EXACTFish node that is in UTF-8
2610  *      is pre-folded by regcomp.c.  This saves effort in regex matching.
2611  *      However, probably mostly for historical reasons, the pre-folding isn't
2612  *      done for non-UTF8 patterns (and it can't be for EXACTF and EXACTFL
2613  *      nodes, as what they fold to isn't known until runtime.)  The fold
2614  *      possibilities for the non-UTF8 patterns are quite simple, except for
2615  *      the sharp s.  All the ones that don't involve a UTF-8 target string
2616  *      are members of a fold-pair, and arrays are set up for all of them
2617  *      that quickly find the other member of the pair.  It might actually
2618  *      be faster to pre-fold these, but it isn't currently done, except for
2619  *      the sharp s.  Code elsewhere in this file makes sure that it gets
2620  *      folded to 'ss', even if the pattern isn't UTF-8.  This avoids the
2621  *      issues described in the next item.
2622  * 4)   A problem remains for the sharp s in EXACTF nodes.  Whether it matches
2623  *      'ss' or not is not knowable at compile time.  It will match iff the
2624  *      target string is in UTF-8, unlike the EXACTFU nodes, where it always
2625  *      matches; and the EXACTFL and EXACTFA nodes where it never does.  Thus
2626  *      it can't be folded to "ss" at compile time, unlike EXACTFU does as
2627  *      described in item 3).  An assumption that the optimizer part of
2628  *      regexec.c (probably unwittingly) makes is that a character in the
2629  *      pattern corresponds to at most a single character in the target string.
2630  *      (And I do mean character, and not byte here, unlike other parts of the
2631  *      documentation that have never been updated to account for multibyte
2632  *      Unicode.)  This assumption is wrong only in this case, as all other
2633  *      cases are either 1-1 folds when no UTF-8 is involved; or is true by
2634  *      virtue of having this file pre-fold UTF-8 patterns.   I'm
2635  *      reluctant to try to change this assumption, so instead the code punts.
2636  *      This routine examines EXACTF nodes for the sharp s, and returns a
2637  *      boolean indicating whether or not the node is an EXACTF node that
2638  *      contains a sharp s.  When it is true, the caller sets a flag that later
2639  *      causes the optimizer in this file to not set values for the floating
2640  *      and fixed string lengths, and thus avoids the optimizer code in
2641  *      regexec.c that makes the invalid assumption.  Thus, there is no
2642  *      optimization based on string lengths for EXACTF nodes that contain the
2643  *      sharp s.  This only happens for /id rules (which means the pattern
2644  *      isn't in UTF-8).
2645  */
2646
2647 #define JOIN_EXACT(scan,min_subtract,has_exactf_sharp_s, flags) \
2648     if (PL_regkind[OP(scan)] == EXACT) \
2649         join_exact(pRExC_state,(scan),(min_subtract),has_exactf_sharp_s, (flags),NULL,depth+1)
2650
2651 STATIC U32
2652 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) {
2653     /* Merge several consecutive EXACTish nodes into one. */
2654     regnode *n = regnext(scan);
2655     U32 stringok = 1;
2656     regnode *next = scan + NODE_SZ_STR(scan);
2657     U32 merged = 0;
2658     U32 stopnow = 0;
2659 #ifdef DEBUGGING
2660     regnode *stop = scan;
2661     GET_RE_DEBUG_FLAGS_DECL;
2662 #else
2663     PERL_UNUSED_ARG(depth);
2664 #endif
2665
2666     PERL_ARGS_ASSERT_JOIN_EXACT;
2667 #ifndef EXPERIMENTAL_INPLACESCAN
2668     PERL_UNUSED_ARG(flags);
2669     PERL_UNUSED_ARG(val);
2670 #endif
2671     DEBUG_PEEP("join",scan,depth);
2672
2673     /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
2674      * EXACT ones that are mergeable to the current one. */
2675     while (n
2676            && (PL_regkind[OP(n)] == NOTHING
2677                || (stringok && OP(n) == OP(scan)))
2678            && NEXT_OFF(n)
2679            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
2680     {
2681         
2682         if (OP(n) == TAIL || n > next)
2683             stringok = 0;
2684         if (PL_regkind[OP(n)] == NOTHING) {
2685             DEBUG_PEEP("skip:",n,depth);
2686             NEXT_OFF(scan) += NEXT_OFF(n);
2687             next = n + NODE_STEP_REGNODE;
2688 #ifdef DEBUGGING
2689             if (stringok)
2690                 stop = n;
2691 #endif
2692             n = regnext(n);
2693         }
2694         else if (stringok) {
2695             const unsigned int oldl = STR_LEN(scan);
2696             regnode * const nnext = regnext(n);
2697
2698             if (oldl + STR_LEN(n) > U8_MAX)
2699                 break;
2700             
2701             DEBUG_PEEP("merg",n,depth);
2702             merged++;
2703
2704             NEXT_OFF(scan) += NEXT_OFF(n);
2705             STR_LEN(scan) += STR_LEN(n);
2706             next = n + NODE_SZ_STR(n);
2707             /* Now we can overwrite *n : */
2708             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
2709 #ifdef DEBUGGING
2710             stop = next - 1;
2711 #endif
2712             n = nnext;
2713             if (stopnow) break;
2714         }
2715
2716 #ifdef EXPERIMENTAL_INPLACESCAN
2717         if (flags && !NEXT_OFF(n)) {
2718             DEBUG_PEEP("atch", val, depth);
2719             if (reg_off_by_arg[OP(n)]) {
2720                 ARG_SET(n, val - n);
2721             }
2722             else {
2723                 NEXT_OFF(n) = val - n;
2724             }
2725             stopnow = 1;
2726         }
2727 #endif
2728     }
2729
2730     *min_subtract = 0;
2731     *has_exactf_sharp_s = FALSE;
2732
2733     /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
2734      * can now analyze for sequences of problematic code points.  (Prior to
2735      * this final joining, sequences could have been split over boundaries, and
2736      * hence missed).  The sequences only happen in folding, hence for any
2737      * non-EXACT EXACTish node */
2738     if (OP(scan) != EXACT) {
2739         U8 *s;
2740         U8 * s0 = (U8*) STRING(scan);
2741         U8 * const s_end = s0 + STR_LEN(scan);
2742
2743         /* The below is perhaps overboard, but this allows us to save a test
2744          * each time through the loop at the expense of a mask.  This is
2745          * because on both EBCDIC and ASCII machines, 'S' and 's' differ by a
2746          * single bit.  On ASCII they are 32 apart; on EBCDIC, they are 64.
2747          * This uses an exclusive 'or' to find that bit and then inverts it to
2748          * form a mask, with just a single 0, in the bit position where 'S' and
2749          * 's' differ. */
2750         const U8 S_or_s_mask = (U8) ~ ('S' ^ 's');
2751         const U8 s_masked = 's' & S_or_s_mask;
2752
2753         /* One pass is made over the node's string looking for all the
2754          * possibilities.  to avoid some tests in the loop, there are two main
2755          * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
2756          * non-UTF-8 */
2757         if (UTF) {
2758
2759             /* There are two problematic Greek code points in Unicode
2760              * casefolding
2761              *
2762              * U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
2763              * U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
2764              *
2765              * which casefold to
2766              *
2767              * Unicode                      UTF-8
2768              *
2769              * U+03B9 U+0308 U+0301         0xCE 0xB9 0xCC 0x88 0xCC 0x81
2770              * U+03C5 U+0308 U+0301         0xCF 0x85 0xCC 0x88 0xCC 0x81
2771              *
2772              * This means that in case-insensitive matching (or "loose
2773              * matching", as Unicode calls it), an EXACTF of length six (the
2774              * UTF-8 encoded byte length of the above casefolded versions) can
2775              * match a target string of length two (the byte length of UTF-8
2776              * encoded U+0390 or U+03B0).  This would rather mess up the
2777              * minimum length computation.  (there are other code points that
2778              * also fold to these two sequences, but the delta is smaller)
2779              *
2780              * If these sequences are found, the minimum length is decreased by
2781              * four (six minus two).
2782              *
2783              * Similarly, 'ss' may match the single char and byte LATIN SMALL
2784              * LETTER SHARP S.  We decrease the min length by 1 for each
2785              * occurrence of 'ss' found */
2786
2787 #ifdef EBCDIC /* RD tunifold greek 0390 and 03B0 */
2788 #           define U390_first_byte 0xb4
2789             const U8 U390_tail[] = "\x68\xaf\x49\xaf\x42";
2790 #           define U3B0_first_byte 0xb5
2791             const U8 U3B0_tail[] = "\x46\xaf\x49\xaf\x42";
2792 #else
2793 #           define U390_first_byte 0xce
2794             const U8 U390_tail[] = "\xb9\xcc\x88\xcc\x81";
2795 #           define U3B0_first_byte 0xcf
2796             const U8 U3B0_tail[] = "\x85\xcc\x88\xcc\x81";
2797 #endif
2798             const U8 len = sizeof(U390_tail); /* (-1 for NUL; +1 for 1st byte;
2799                                                  yields a net of 0 */
2800             /* Examine the string for one of the problematic sequences */
2801             for (s = s0;
2802                  s < s_end - 1; /* Can stop 1 before the end, as minimum length
2803                                  * sequence we are looking for is 2 */
2804                  s += UTF8SKIP(s))
2805             {
2806
2807                 /* Look for the first byte in each problematic sequence */
2808                 switch (*s) {
2809                     /* We don't have to worry about other things that fold to
2810                      * 's' (such as the long s, U+017F), as all above-latin1
2811                      * code points have been pre-folded */
2812                     case 's':
2813                     case 'S':
2814
2815                         /* Current character is an 's' or 'S'.  If next one is
2816                          * as well, we have the dreaded sequence */
2817                         if (((*(s+1) & S_or_s_mask) == s_masked)
2818                             /* These two node types don't have special handling
2819                              * for 'ss' */
2820                             && OP(scan) != EXACTFL && OP(scan) != EXACTFA)
2821                         {
2822                             *min_subtract += 1;
2823                             OP(scan) = EXACTFU_SS;
2824                             s++;    /* No need to look at this character again */
2825                         }
2826                         break;
2827
2828                     case U390_first_byte:
2829                         if (s_end - s >= len
2830
2831                             /* The 1's are because are skipping comparing the
2832                              * first byte */
2833                             && memEQ(s + 1, U390_tail, len - 1))
2834                         {
2835                             goto greek_sequence;
2836                         }
2837                         break;
2838
2839                     case U3B0_first_byte:
2840                         if (! (s_end - s >= len
2841                                && memEQ(s + 1, U3B0_tail, len - 1)))
2842                         {
2843                             break;
2844                         }
2845                       greek_sequence:
2846                         *min_subtract += 4;
2847
2848                         /* This can't currently be handled by trie's, so change
2849                          * the node type to indicate this.  If EXACTFA and
2850                          * EXACTFL were ever to be handled by trie's, this
2851                          * would have to be changed.  If this node has already
2852                          * been changed to EXACTFU_SS in this loop, leave it as
2853                          * is.  (I (khw) think it doesn't matter in regexec.c
2854                          * for UTF patterns, but no need to change it */
2855                         if (OP(scan) == EXACTFU) {
2856                             OP(scan) = EXACTFU_TRICKYFOLD;
2857                         }
2858                         s += 6; /* We already know what this sequence is.  Skip
2859                                    the rest of it */
2860                         break;
2861                 }
2862             }
2863         }
2864         else if (OP(scan) != EXACTFL && OP(scan) != EXACTFA) {
2865
2866             /* Here, the pattern is not UTF-8.  We need to look only for the
2867              * 'ss' sequence, and in the EXACTF case, the sharp s, which can be
2868              * in the final position.  Otherwise we can stop looking 1 byte
2869              * earlier because have to find both the first and second 's' */
2870             const U8* upper = (OP(scan) == EXACTF) ? s_end : s_end -1;
2871
2872             for (s = s0; s < upper; s++) {
2873                 switch (*s) {
2874                     case 'S':
2875                     case 's':
2876                         if (s_end - s > 1
2877                             && ((*(s+1) & S_or_s_mask) == s_masked))
2878                         {
2879                             *min_subtract += 1;
2880
2881                             /* EXACTF nodes need to know that the minimum
2882                              * length changed so that a sharp s in the string
2883                              * can match this ss in the pattern, but they
2884                              * remain EXACTF nodes, as they are not trie'able,
2885                              * so don't have to invent a new node type to
2886                              * exclude them from the trie code */
2887                             if (OP(scan) != EXACTF) {
2888                                 OP(scan) = EXACTFU_SS;
2889                             }
2890                             s++;
2891                         }
2892                         break;
2893                     case LATIN_SMALL_LETTER_SHARP_S:
2894                         if (OP(scan) == EXACTF) {
2895                             *has_exactf_sharp_s = TRUE;
2896                         }
2897                         break;
2898                 }
2899             }
2900         }
2901     }
2902
2903 #ifdef DEBUGGING
2904     /* Allow dumping but overwriting the collection of skipped
2905      * ops and/or strings with fake optimized ops */
2906     n = scan + NODE_SZ_STR(scan);
2907     while (n <= stop) {
2908         OP(n) = OPTIMIZED;
2909         FLAGS(n) = 0;
2910         NEXT_OFF(n) = 0;
2911         n++;
2912     }
2913 #endif
2914     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
2915     return stopnow;
2916 }
2917
2918 /* REx optimizer.  Converts nodes into quicker variants "in place".
2919    Finds fixed substrings.  */
2920
2921 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
2922    to the position after last scanned or to NULL. */
2923
2924 #define INIT_AND_WITHP \
2925     assert(!and_withp); \
2926     Newx(and_withp,1,struct regnode_charclass_class); \
2927     SAVEFREEPV(and_withp)
2928
2929 /* this is a chain of data about sub patterns we are processing that
2930    need to be handled separately/specially in study_chunk. Its so
2931    we can simulate recursion without losing state.  */
2932 struct scan_frame;
2933 typedef struct scan_frame {
2934     regnode *last;  /* last node to process in this frame */
2935     regnode *next;  /* next node to process when last is reached */
2936     struct scan_frame *prev; /*previous frame*/
2937     I32 stop; /* what stopparen do we use */
2938 } scan_frame;
2939
2940
2941 #define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf)
2942
2943 #define CASE_SYNST_FNC(nAmE)                                       \
2944 case nAmE:                                                         \
2945     if (flags & SCF_DO_STCLASS_AND) {                              \
2946             for (value = 0; value < 256; value++)                  \
2947                 if (!is_ ## nAmE ## _cp(value))                       \
2948                     ANYOF_BITMAP_CLEAR(data->start_class, value);  \
2949     }                                                              \
2950     else {                                                         \
2951             for (value = 0; value < 256; value++)                  \
2952                 if (is_ ## nAmE ## _cp(value))                        \
2953                     ANYOF_BITMAP_SET(data->start_class, value);    \
2954     }                                                              \
2955     break;                                                         \
2956 case N ## nAmE:                                                    \
2957     if (flags & SCF_DO_STCLASS_AND) {                              \
2958             for (value = 0; value < 256; value++)                   \
2959                 if (is_ ## nAmE ## _cp(value))                         \
2960                     ANYOF_BITMAP_CLEAR(data->start_class, value);   \
2961     }                                                               \
2962     else {                                                          \
2963             for (value = 0; value < 256; value++)                   \
2964                 if (!is_ ## nAmE ## _cp(value))                        \
2965                     ANYOF_BITMAP_SET(data->start_class, value);     \
2966     }                                                               \
2967     break
2968
2969
2970
2971 STATIC I32
2972 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
2973                         I32 *minlenp, I32 *deltap,
2974                         regnode *last,
2975                         scan_data_t *data,
2976                         I32 stopparen,
2977                         U8* recursed,
2978                         struct regnode_charclass_class *and_withp,
2979                         U32 flags, U32 depth)
2980                         /* scanp: Start here (read-write). */
2981                         /* deltap: Write maxlen-minlen here. */
2982                         /* last: Stop before this one. */
2983                         /* data: string data about the pattern */
2984                         /* stopparen: treat close N as END */
2985                         /* recursed: which subroutines have we recursed into */
2986                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
2987 {
2988     dVAR;
2989     I32 min = 0, pars = 0, code;
2990     regnode *scan = *scanp, *next;
2991     I32 delta = 0;
2992     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
2993     int is_inf_internal = 0;            /* The studied chunk is infinite */
2994     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
2995     scan_data_t data_fake;
2996     SV *re_trie_maxbuff = NULL;
2997     regnode *first_non_open = scan;
2998     I32 stopmin = I32_MAX;
2999     scan_frame *frame = NULL;
3000     GET_RE_DEBUG_FLAGS_DECL;
3001
3002     PERL_ARGS_ASSERT_STUDY_CHUNK;
3003
3004 #ifdef DEBUGGING
3005     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
3006 #endif
3007
3008     if ( depth == 0 ) {
3009         while (first_non_open && OP(first_non_open) == OPEN)
3010             first_non_open=regnext(first_non_open);
3011     }
3012
3013
3014   fake_study_recurse:
3015     while ( scan && OP(scan) != END && scan < last ){
3016         UV min_subtract = 0;    /* How much to subtract from the minimum node
3017                                    length to get a real minimum (because the
3018                                    folded version may be shorter) */
3019         bool has_exactf_sharp_s = FALSE;
3020         /* Peephole optimizer: */
3021         DEBUG_STUDYDATA("Peep:", data,depth);
3022         DEBUG_PEEP("Peep",scan,depth);
3023
3024         /* Its not clear to khw or hv why this is done here, and not in the
3025          * clauses that deal with EXACT nodes.  khw's guess is that it's
3026          * because of a previous design */
3027         JOIN_EXACT(scan,&min_subtract, &has_exactf_sharp_s, 0);
3028
3029         /* Follow the next-chain of the current node and optimize
3030            away all the NOTHINGs from it.  */
3031         if (OP(scan) != CURLYX) {
3032             const int max = (reg_off_by_arg[OP(scan)]
3033                        ? I32_MAX
3034                        /* I32 may be smaller than U16 on CRAYs! */
3035                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
3036             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
3037             int noff;
3038             regnode *n = scan;
3039
3040             /* Skip NOTHING and LONGJMP. */
3041             while ((n = regnext(n))
3042                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
3043                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
3044                    && off + noff < max)
3045                 off += noff;
3046             if (reg_off_by_arg[OP(scan)])
3047                 ARG(scan) = off;
3048             else
3049                 NEXT_OFF(scan) = off;
3050         }
3051
3052
3053
3054         /* The principal pseudo-switch.  Cannot be a switch, since we
3055            look into several different things.  */
3056         if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
3057                    || OP(scan) == IFTHEN) {
3058             next = regnext(scan);
3059             code = OP(scan);
3060             /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
3061
3062             if (OP(next) == code || code == IFTHEN) {
3063                 /* NOTE - There is similar code to this block below for handling
3064                    TRIE nodes on a re-study.  If you change stuff here check there
3065                    too. */
3066                 I32 max1 = 0, min1 = I32_MAX, num = 0;
3067                 struct regnode_charclass_class accum;
3068                 regnode * const startbranch=scan;
3069
3070                 if (flags & SCF_DO_SUBSTR)
3071                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
3072                 if (flags & SCF_DO_STCLASS)
3073                     cl_init_zero(pRExC_state, &accum);
3074
3075                 while (OP(scan) == code) {
3076                     I32 deltanext, minnext, f = 0, fake;
3077                     struct regnode_charclass_class this_class;
3078
3079                     num++;
3080                     data_fake.flags = 0;
3081                     if (data) {
3082                         data_fake.whilem_c = data->whilem_c;
3083                         data_fake.last_closep = data->last_closep;
3084                     }
3085                     else
3086                         data_fake.last_closep = &fake;
3087
3088                     data_fake.pos_delta = delta;
3089                     next = regnext(scan);
3090                     scan = NEXTOPER(scan);
3091                     if (code != BRANCH)
3092                         scan = NEXTOPER(scan);
3093                     if (flags & SCF_DO_STCLASS) {
3094                         cl_init(pRExC_state, &this_class);
3095                         data_fake.start_class = &this_class;
3096                         f = SCF_DO_STCLASS_AND;
3097                     }
3098                     if (flags & SCF_WHILEM_VISITED_POS)
3099                         f |= SCF_WHILEM_VISITED_POS;
3100
3101                     /* we suppose the run is continuous, last=next...*/
3102                     minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
3103                                           next, &data_fake,
3104                                           stopparen, recursed, NULL, f,depth+1);
3105                     if (min1 > minnext)
3106                         min1 = minnext;
3107                     if (max1 < minnext + deltanext)
3108                         max1 = minnext + deltanext;
3109                     if (deltanext == I32_MAX)
3110                         is_inf = is_inf_internal = 1;
3111                     scan = next;
3112                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3113                         pars++;
3114                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
3115                         if ( stopmin > minnext) 
3116                             stopmin = min + min1;
3117                         flags &= ~SCF_DO_SUBSTR;
3118                         if (data)
3119                             data->flags |= SCF_SEEN_ACCEPT;
3120                     }
3121                     if (data) {
3122                         if (data_fake.flags & SF_HAS_EVAL)
3123                             data->flags |= SF_HAS_EVAL;
3124                         data->whilem_c = data_fake.whilem_c;
3125                     }
3126                     if (flags & SCF_DO_STCLASS)
3127                         cl_or(pRExC_state, &accum, &this_class);
3128                 }
3129                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
3130                     min1 = 0;
3131                 if (flags & SCF_DO_SUBSTR) {
3132                     data->pos_min += min1;
3133                     data->pos_delta += max1 - min1;
3134                     if (max1 != min1 || is_inf)
3135                         data->longest = &(data->longest_float);
3136                 }
3137                 min += min1;
3138                 delta += max1 - min1;
3139                 if (flags & SCF_DO_STCLASS_OR) {
3140                     cl_or(pRExC_state, data->start_class, &accum);
3141                     if (min1) {
3142                         cl_and(data->start_class, and_withp);
3143                         flags &= ~SCF_DO_STCLASS;
3144                     }
3145                 }
3146                 else if (flags & SCF_DO_STCLASS_AND) {
3147                     if (min1) {
3148                         cl_and(data->start_class, &accum);
3149                         flags &= ~SCF_DO_STCLASS;
3150                     }
3151                     else {
3152                         /* Switch to OR mode: cache the old value of
3153                          * data->start_class */
3154                         INIT_AND_WITHP;
3155                         StructCopy(data->start_class, and_withp,
3156                                    struct regnode_charclass_class);
3157                         flags &= ~SCF_DO_STCLASS_AND;
3158                         StructCopy(&accum, data->start_class,
3159                                    struct regnode_charclass_class);
3160                         flags |= SCF_DO_STCLASS_OR;
3161                         data->start_class->flags |= ANYOF_EOS;
3162                     }
3163                 }
3164
3165                 if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) == BRANCH ) {
3166                 /* demq.
3167
3168                    Assuming this was/is a branch we are dealing with: 'scan' now
3169                    points at the item that follows the branch sequence, whatever
3170                    it is. We now start at the beginning of the sequence and look
3171                    for subsequences of
3172
3173                    BRANCH->EXACT=>x1
3174                    BRANCH->EXACT=>x2
3175                    tail
3176
3177                    which would be constructed from a pattern like /A|LIST|OF|WORDS/
3178
3179                    If we can find such a subsequence we need to turn the first
3180                    element into a trie and then add the subsequent branch exact
3181                    strings to the trie.
3182
3183                    We have two cases
3184
3185                      1. patterns where the whole set of branches can be converted. 
3186
3187                      2. patterns where only a subset can be converted.
3188
3189                    In case 1 we can replace the whole set with a single regop
3190                    for the trie. In case 2 we need to keep the start and end
3191                    branches so
3192
3193                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
3194                      becomes BRANCH TRIE; BRANCH X;
3195
3196                   There is an additional case, that being where there is a 
3197                   common prefix, which gets split out into an EXACT like node
3198                   preceding the TRIE node.
3199
3200                   If x(1..n)==tail then we can do a simple trie, if not we make
3201                   a "jump" trie, such that when we match the appropriate word
3202                   we "jump" to the appropriate tail node. Essentially we turn
3203                   a nested if into a case structure of sorts.
3204
3205                 */
3206
3207                     int made=0;
3208                     if (!re_trie_maxbuff) {
3209                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
3210                         if (!SvIOK(re_trie_maxbuff))
3211                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
3212                     }
3213                     if ( SvIV(re_trie_maxbuff)>=0  ) {
3214                         regnode *cur;
3215                         regnode *first = (regnode *)NULL;
3216                         regnode *last = (regnode *)NULL;
3217                         regnode *tail = scan;
3218                         U8 trietype = 0;
3219                         U32 count=0;
3220
3221 #ifdef DEBUGGING
3222                         SV * const mysv = sv_newmortal();       /* for dumping */
3223 #endif
3224                         /* var tail is used because there may be a TAIL
3225                            regop in the way. Ie, the exacts will point to the
3226                            thing following the TAIL, but the last branch will
3227                            point at the TAIL. So we advance tail. If we
3228                            have nested (?:) we may have to move through several
3229                            tails.
3230                          */
3231
3232                         while ( OP( tail ) == TAIL ) {
3233                             /* this is the TAIL generated by (?:) */
3234                             tail = regnext( tail );
3235                         }
3236
3237                         
3238                         DEBUG_OPTIMISE_r({
3239                             regprop(RExC_rx, mysv, tail );
3240                             PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
3241                                 (int)depth * 2 + 2, "", 
3242                                 "Looking for TRIE'able sequences. Tail node is: ", 
3243                                 SvPV_nolen_const( mysv )
3244                             );
3245                         });
3246                         
3247                         /*
3248
3249                             Step through the branches
3250                                 cur represents each branch,
3251                                 noper is the first thing to be matched as part of that branch
3252                                 noper_next is the regnext() of that node.
3253
3254                             We normally handle a case like this /FOO[xyz]|BAR[pqr]/
3255                             via a "jump trie" but we also support building with NOJUMPTRIE,
3256                             which restricts the trie logic to structures like /FOO|BAR/.
3257
3258                             If noper is a trieable nodetype then the branch is a possible optimization
3259                             target. If we are building under NOJUMPTRIE then we require that noper_next
3260                             is the same as scan (our current position in the regex program).
3261
3262                             Once we have two or more consecutive such branches we can create a
3263                             trie of the EXACT's contents and stitch it in place into the program.
3264
3265                             If the sequence represents all of the branches in the alternation we
3266                             replace the entire thing with a single TRIE node.
3267
3268                             Otherwise when it is a subsequence we need to stitch it in place and
3269                             replace only the relevant branches. This means the first branch has
3270                             to remain as it is used by the alternation logic, and its next pointer,
3271                             and needs to be repointed at the item on the branch chain following
3272                             the last branch we have optimized away.
3273
3274                             This could be either a BRANCH, in which case the subsequence is internal,
3275                             or it could be the item following the branch sequence in which case the
3276                             subsequence is at the end (which does not necessarily mean the first node
3277                             is the start of the alternation).
3278
3279                             TRIE_TYPE(X) is a define which maps the optype to a trietype.
3280
3281                                 optype          |  trietype
3282                                 ----------------+-----------
3283                                 NOTHING         | NOTHING
3284                                 EXACT           | EXACT
3285                                 EXACTFU         | EXACTFU
3286                                 EXACTFU_SS      | EXACTFU
3287                                 EXACTFU_TRICKYFOLD | EXACTFU
3288                                 EXACTFA         | 0
3289
3290
3291                         */
3292 #define TRIE_TYPE(X) ( ( NOTHING == (X) ) ? NOTHING :   \
3293                        ( EXACT == (X) )   ? EXACT :        \
3294                        ( EXACTFU == (X) || EXACTFU_SS == (X) || EXACTFU_TRICKYFOLD == (X) ) ? EXACTFU :        \
3295                        0 )
3296
3297                         /* dont use tail as the end marker for this traverse */
3298                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
3299                             regnode * const noper = NEXTOPER( cur );
3300                             U8 noper_type = OP( noper );
3301                             U8 noper_trietype = TRIE_TYPE( noper_type );
3302 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
3303                             regnode * const noper_next = regnext( noper );
3304 #endif
3305
3306                             DEBUG_OPTIMISE_r({
3307                                 regprop(RExC_rx, mysv, cur);
3308                                 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
3309                                    (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
3310
3311                                 regprop(RExC_rx, mysv, noper);
3312                                 PerlIO_printf( Perl_debug_log, " -> %s",
3313                                     SvPV_nolen_const(mysv));
3314
3315                                 if ( noper_next ) {
3316                                   regprop(RExC_rx, mysv, noper_next );
3317                                   PerlIO_printf( Perl_debug_log,"\t=> %s\t",
3318                                     SvPV_nolen_const(mysv));
3319                                 }
3320                                 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d)\n",
3321                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur) );
3322                             });
3323
3324                             /* Is noper a trieable nodetype that can be merged with the
3325                              * current trie (if there is one)? */
3326                             if ( noper_trietype
3327                                   &&
3328                                   (
3329                                         /* XXX: Currently we cannot allow a NOTHING node to be the first element
3330                                          * of a TRIEABLE sequence, Otherwise we will overwrite the regop following
3331                                          * the NOTHING with the TRIE regop later on. This is because a NOTHING node
3332                                          * is only one regnode wide, and a TRIE is two regnodes. An example of a
3333                                          * problematic pattern is: "x" =~ /\A(?>(?:(?:)A|B|C?x))\z/
3334                                          * At a later point of time we can somewhat workaround this by handling
3335                                          * NOTHING -> EXACT sequences as generated by /(?:)A|(?:)B/ type patterns,
3336                                          * as we can effectively ignore the NOTHING regop in that case.
3337                                          * This clause, which allows NOTHING to start a sequence is left commented
3338                                          * out as a reference.
3339                                          * - Yves
3340
3341                                            ( noper_trietype == NOTHING)
3342                                            || ( trietype == NOTHING )
3343                                         */
3344                                         ( noper_trietype == NOTHING && trietype )
3345                                         || ( trietype == noper_trietype )
3346                                   )
3347 #ifdef NOJUMPTRIE
3348                                   && noper_next == tail
3349 #endif
3350                                   && count < U16_MAX)
3351                             {
3352                                 /* Handle mergable triable node
3353                                  * Either we are the first node in a new trieable sequence,
3354                                  * in which case we do some bookkeeping, otherwise we update
3355                                  * the end pointer. */
3356                                 count++;
3357                                 if ( !first ) {
3358                                     first = cur;
3359                                     trietype = noper_trietype;
3360                                 } else {
3361                                     if ( trietype == NOTHING )
3362                                         trietype = noper_trietype;
3363                                     last = cur;
3364                                 }
3365                             } /* end handle mergable triable node */
3366                             else {
3367                                 /* handle unmergable node -
3368                                  * noper may either be a triable node which can not be tried
3369                                  * together with the current trie, or a non triable node */
3370                                 if ( last ) {
3371                                     /* If last is set and trietype is not NOTHING then we have found
3372                                      * at least two triable branch sequences in a row of a similar
3373                                      * trietype so we can turn them into a trie. If/when we
3374                                      * allow NOTHING to start a trie sequence this condition will be
3375                                      * required, and it isn't expensive so we leave it in for now. */
3376                                     if ( trietype != NOTHING )
3377                                         make_trie( pRExC_state,
3378                                                 startbranch, first, cur, tail, count,
3379                                                 trietype, depth+1 );
3380                                     last = NULL; /* note: we clear/update first, trietype etc below, so we dont do it here */
3381                                 }
3382                                 if ( noper_trietype
3383 #ifdef NOJUMPTRIE
3384                                      && noper_next == tail
3385 #endif
3386                                 ){
3387                                     /* noper is triable, so we can start a new trie sequence */
3388                                     count = 1;
3389                                     first = cur;
3390                                     trietype = noper_trietype;
3391                                 } else if (first) {
3392                                     /* if we already saw a first but the current node is not triable then we have
3393                                      * to reset the first information. */
3394                                     count = 0;
3395                                     first = NULL;
3396                                     trietype = 0;
3397                                 }
3398                             } /* end handle unmergable node */
3399                         } /* loop over branches */
3400                         DEBUG_OPTIMISE_r({
3401                             regprop(RExC_rx, mysv, cur);
3402                             PerlIO_printf( Perl_debug_log,
3403                               "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
3404                               "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3405
3406                         });
3407                         if ( last && trietype != NOTHING ) {
3408                             /* the last branch of the sequence was part of a trie,
3409                              * so we have to construct it here outside of the loop
3410                              */
3411                             made= make_trie( pRExC_state, startbranch, first, scan, tail, count, trietype, depth+1 );
3412 #ifdef TRIE_STUDY_OPT
3413                             if ( ((made == MADE_EXACT_TRIE && 
3414                                  startbranch == first) 
3415                                  || ( first_non_open == first )) && 
3416                                  depth==0 ) {
3417                                 flags |= SCF_TRIE_RESTUDY;
3418                                 if ( startbranch == first 
3419                                      && scan == tail ) 
3420                                 {
3421                                     RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
3422                                 }
3423                             }
3424 #endif
3425                         } /* end if ( last) */
3426                     } /* TRIE_MAXBUF is non zero */
3427                     
3428                 } /* do trie */
3429                 
3430             }
3431             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
3432                 scan = NEXTOPER(NEXTOPER(scan));
3433             } else                      /* single branch is optimized. */
3434                 scan = NEXTOPER(scan);
3435             continue;
3436         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
3437             scan_frame *newframe = NULL;
3438             I32 paren;
3439             regnode *start;
3440             regnode *end;
3441
3442             if (OP(scan) != SUSPEND) {
3443             /* set the pointer */
3444                 if (OP(scan) == GOSUB) {
3445                     paren = ARG(scan);
3446                     RExC_recurse[ARG2L(scan)] = scan;
3447                     start = RExC_open_parens[paren-1];
3448                     end   = RExC_close_parens[paren-1];
3449                 } else {
3450                     paren = 0;
3451                     start = RExC_rxi->program + 1;
3452                     end   = RExC_opend;
3453                 }
3454                 if (!recursed) {
3455                     Newxz(recursed, (((RExC_npar)>>3) +1), U8);
3456                     SAVEFREEPV(recursed);
3457                 }
3458                 if (!PAREN_TEST(recursed,paren+1)) {
3459                     PAREN_SET(recursed,paren+1);
3460                     Newx(newframe,1,scan_frame);
3461                 } else {
3462                     if (flags & SCF_DO_SUBSTR) {
3463                         SCAN_COMMIT(pRExC_state,data,minlenp);
3464                         data->longest = &(data->longest_float);
3465                     }
3466                     is_inf = is_inf_internal = 1;
3467                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3468                         cl_anything(pRExC_state, data->start_class);
3469                     flags &= ~SCF_DO_STCLASS;
3470                 }
3471             } else {
3472                 Newx(newframe,1,scan_frame);
3473                 paren = stopparen;
3474                 start = scan+2;
3475                 end = regnext(scan);
3476             }
3477             if (newframe) {
3478                 assert(start);
3479                 assert(end);
3480                 SAVEFREEPV(newframe);
3481                 newframe->next = regnext(scan);
3482                 newframe->last = last;
3483                 newframe->stop = stopparen;
3484                 newframe->prev = frame;
3485
3486                 frame = newframe;
3487                 scan =  start;
3488                 stopparen = paren;
3489                 last = end;
3490
3491                 continue;
3492             }
3493         }
3494         else if (OP(scan) == EXACT) {
3495             I32 l = STR_LEN(scan);
3496             UV uc;
3497             if (UTF) {
3498                 const U8 * const s = (U8*)STRING(scan);
3499                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
3500                 l = utf8_length(s, s + l);
3501             } else {
3502                 uc = *((U8*)STRING(scan));
3503             }
3504             min += l;
3505             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
3506                 /* The code below prefers earlier match for fixed
3507                    offset, later match for variable offset.  */
3508                 if (data->last_end == -1) { /* Update the start info. */
3509                     data->last_start_min = data->pos_min;
3510                     data->last_start_max = is_inf
3511                         ? I32_MAX : data->pos_min + data->pos_delta;
3512                 }
3513                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
3514                 if (UTF)
3515                     SvUTF8_on(data->last_found);
3516                 {
3517                     SV * const sv = data->last_found;
3518                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3519                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
3520                     if (mg && mg->mg_len >= 0)
3521                         mg->mg_len += utf8_length((U8*)STRING(scan),
3522                                                   (U8*)STRING(scan)+STR_LEN(scan));
3523                 }
3524                 data->last_end = data->pos_min + l;
3525                 data->pos_min += l; /* As in the first entry. */
3526                 data->flags &= ~SF_BEFORE_EOL;
3527             }
3528             if (flags & SCF_DO_STCLASS_AND) {
3529                 /* Check whether it is compatible with what we know already! */
3530                 int compat = 1;
3531
3532
3533                 /* If compatible, we or it in below.  It is compatible if is
3534                  * in the bitmp and either 1) its bit or its fold is set, or 2)
3535                  * it's for a locale.  Even if there isn't unicode semantics
3536                  * here, at runtime there may be because of matching against a
3537                  * utf8 string, so accept a possible false positive for
3538                  * latin1-range folds */
3539                 if (uc >= 0x100 ||
3540                     (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3541                     && !ANYOF_BITMAP_TEST(data->start_class, uc)
3542                     && (!(data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD)
3543                         || !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3544                     )
3545                 {
3546                     compat = 0;
3547                 }
3548                 ANYOF_CLASS_ZERO(data->start_class);
3549                 ANYOF_BITMAP_ZERO(data->start_class);
3550                 if (compat)
3551                     ANYOF_BITMAP_SET(data->start_class, uc);
3552                 else if (uc >= 0x100) {
3553                     int i;
3554
3555                     /* Some Unicode code points fold to the Latin1 range; as
3556                      * XXX temporary code, instead of figuring out if this is
3557                      * one, just assume it is and set all the start class bits
3558                      * that could be some such above 255 code point's fold
3559                      * which will generate fals positives.  As the code
3560                      * elsewhere that does compute the fold settles down, it
3561                      * can be extracted out and re-used here */
3562                     for (i = 0; i < 256; i++){
3563                         if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3564                             ANYOF_BITMAP_SET(data->start_class, i);
3565                         }
3566                     }
3567                 }
3568                 data->start_class->flags &= ~ANYOF_EOS;
3569                 if (uc < 0x100)
3570                   data->start_class->flags &= ~ANYOF_UNICODE_ALL;
3571             }
3572             else if (flags & SCF_DO_STCLASS_OR) {
3573                 /* false positive possible if the class is case-folded */
3574                 if (uc < 0x100)
3575                     ANYOF_BITMAP_SET(data->start_class, uc);
3576                 else
3577                     data->start_class->flags |= ANYOF_UNICODE_ALL;
3578                 data->start_class->flags &= ~ANYOF_EOS;
3579                 cl_and(data->start_class, and_withp);
3580             }
3581             flags &= ~SCF_DO_STCLASS;
3582         }
3583         else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
3584             I32 l = STR_LEN(scan);
3585             UV uc = *((U8*)STRING(scan));
3586
3587             /* Search for fixed substrings supports EXACT only. */
3588             if (flags & SCF_DO_SUBSTR) {
3589                 assert(data);
3590                 SCAN_COMMIT(pRExC_state, data, minlenp);
3591             }
3592             if (UTF) {
3593                 const U8 * const s = (U8 *)STRING(scan);
3594                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
3595                 l = utf8_length(s, s + l);
3596             }
3597             else if (has_exactf_sharp_s) {
3598                 RExC_seen |= REG_SEEN_EXACTF_SHARP_S;
3599             }
3600             min += l - min_subtract;
3601             if (min < 0) {
3602                 min = 0;
3603             }
3604             delta += min_subtract;
3605             if (flags & SCF_DO_SUBSTR) {
3606                 data->pos_min += l - min_subtract;
3607                 if (data->pos_min < 0) {
3608                     data->pos_min = 0;
3609                 }
3610                 data->pos_delta += min_subtract;
3611                 if (min_subtract) {
3612                     data->longest = &(data->longest_float);
3613                 }
3614             }
3615             if (flags & SCF_DO_STCLASS_AND) {
3616                 /* Check whether it is compatible with what we know already! */
3617                 int compat = 1;
3618                 if (uc >= 0x100 ||
3619                  (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3620                   && !ANYOF_BITMAP_TEST(data->start_class, uc)
3621                   && !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3622                 {
3623                     compat = 0;
3624                 }
3625                 ANYOF_CLASS_ZERO(data->start_class);
3626                 ANYOF_BITMAP_ZERO(data->start_class);
3627                 if (compat) {
3628                     ANYOF_BITMAP_SET(data->start_class, uc);
3629                     data->start_class->flags &= ~ANYOF_EOS;
3630                     data->start_class->flags |= ANYOF_LOC_NONBITMAP_FOLD;
3631                     if (OP(scan) == EXACTFL) {
3632                         /* XXX This set is probably no longer necessary, and
3633                          * probably wrong as LOCALE now is on in the initial
3634                          * state */
3635                         data->start_class->flags |= ANYOF_LOCALE;
3636                     }
3637                     else {
3638
3639                         /* Also set the other member of the fold pair.  In case
3640                          * that unicode semantics is called for at runtime, use
3641                          * the full latin1 fold.  (Can't do this for locale,
3642                          * because not known until runtime) */
3643                         ANYOF_BITMAP_SET(data->start_class, PL_fold_latin1[uc]);
3644
3645                         /* All other (EXACTFL handled above) folds except under
3646                          * /iaa that include s, S, and sharp_s also may include
3647                          * the others */
3648                         if (OP(scan) != EXACTFA) {
3649                             if (uc == 's' || uc == 'S') {
3650                                 ANYOF_BITMAP_SET(data->start_class,
3651                                                  LATIN_SMALL_LETTER_SHARP_S);
3652                             }
3653                             else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3654                                 ANYOF_BITMAP_SET(data->start_class, 's');
3655                                 ANYOF_BITMAP_SET(data->start_class, 'S');
3656                             }
3657                         }
3658                     }
3659                 }
3660                 else if (uc >= 0x100) {
3661                     int i;
3662                     for (i = 0; i < 256; i++){
3663                         if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3664                             ANYOF_BITMAP_SET(data->start_class, i);
3665                         }
3666                     }
3667                 }
3668             }
3669             else if (flags & SCF_DO_STCLASS_OR) {
3670                 if (data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD) {
3671                     /* false positive possible if the class is case-folded.
3672                        Assume that the locale settings are the same... */
3673                     if (uc < 0x100) {
3674                         ANYOF_BITMAP_SET(data->start_class, uc);
3675                         if (OP(scan) != EXACTFL) {
3676
3677                             /* And set the other member of the fold pair, but
3678                              * can't do that in locale because not known until
3679                              * run-time */
3680                             ANYOF_BITMAP_SET(data->start_class,
3681                                              PL_fold_latin1[uc]);
3682
3683                             /* All folds except under /iaa that include s, S,
3684                              * and sharp_s also may include the others */
3685                             if (OP(scan) != EXACTFA) {
3686                                 if (uc == 's' || uc == 'S') {
3687                                     ANYOF_BITMAP_SET(data->start_class,
3688                                                    LATIN_SMALL_LETTER_SHARP_S);
3689                                 }
3690                                 else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3691                                     ANYOF_BITMAP_SET(data->start_class, 's');
3692                                     ANYOF_BITMAP_SET(data->start_class, 'S');
3693                                 }
3694                             }
3695                         }
3696                     }
3697                     data->start_class->flags &= ~ANYOF_EOS;
3698                 }
3699                 cl_and(data->start_class, and_withp);
3700             }
3701             flags &= ~SCF_DO_STCLASS;
3702         }
3703         else if (REGNODE_VARIES(OP(scan))) {
3704             I32 mincount, maxcount, minnext, deltanext, fl = 0;
3705             I32 f = flags, pos_before = 0;
3706             regnode * const oscan = scan;
3707             struct regnode_charclass_class this_class;
3708             struct regnode_charclass_class *oclass = NULL;
3709             I32 next_is_eval = 0;
3710
3711             switch (PL_regkind[OP(scan)]) {
3712             case WHILEM:                /* End of (?:...)* . */
3713                 scan = NEXTOPER(scan);
3714                 goto finish;
3715             case PLUS:
3716                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
3717                     next = NEXTOPER(scan);
3718                     if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
3719                         mincount = 1;
3720                         maxcount = REG_INFTY;
3721                         next = regnext(scan);
3722                         scan = NEXTOPER(scan);
3723                         goto do_curly;
3724                     }
3725                 }
3726                 if (flags & SCF_DO_SUBSTR)
3727                     data->pos_min++;
3728                 min++;
3729                 /* Fall through. */
3730             case STAR:
3731                 if (flags & SCF_DO_STCLASS) {
3732                     mincount = 0;
3733                     maxcount = REG_INFTY;
3734                     next = regnext(scan);
3735                     scan = NEXTOPER(scan);
3736                     goto do_curly;
3737                 }
3738                 is_inf = is_inf_internal = 1;
3739                 scan = regnext(scan);
3740                 if (flags & SCF_DO_SUBSTR) {
3741                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
3742                     data->longest = &(data->longest_float);
3743                 }
3744                 goto optimize_curly_tail;
3745             case CURLY:
3746                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
3747                     && (scan->flags == stopparen))
3748                 {
3749                     mincount = 1;
3750                     maxcount = 1;
3751                 } else {
3752                     mincount = ARG1(scan);
3753                     maxcount = ARG2(scan);
3754                 }
3755                 next = regnext(scan);
3756                 if (OP(scan) == CURLYX) {
3757                     I32 lp = (data ? *(data->last_closep) : 0);
3758                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
3759                 }
3760                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3761                 next_is_eval = (OP(scan) == EVAL);
3762               do_curly:
3763                 if (flags & SCF_DO_SUBSTR) {
3764                     if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
3765                     pos_before = data->pos_min;
3766                 }
3767                 if (data) {
3768                     fl = data->flags;
3769                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
3770                     if (is_inf)
3771                         data->flags |= SF_IS_INF;
3772                 }
3773                 if (flags & SCF_DO_STCLASS) {
3774                     cl_init(pRExC_state, &this_class);
3775                     oclass = data->start_class;
3776                     data->start_class = &this_class;
3777                     f |= SCF_DO_STCLASS_AND;
3778                     f &= ~SCF_DO_STCLASS_OR;
3779                 }
3780                 /* Exclude from super-linear cache processing any {n,m}
3781                    regops for which the combination of input pos and regex
3782                    pos is not enough information to determine if a match
3783                    will be possible.
3784
3785                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
3786                    regex pos at the \s*, the prospects for a match depend not
3787                    only on the input position but also on how many (bar\s*)
3788                    repeats into the {4,8} we are. */
3789                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
3790                     f &= ~SCF_WHILEM_VISITED_POS;
3791
3792                 /* This will finish on WHILEM, setting scan, or on NULL: */
3793                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, 
3794                                       last, data, stopparen, recursed, NULL,
3795                                       (mincount == 0
3796                                         ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
3797
3798                 if (flags & SCF_DO_STCLASS)
3799                     data->start_class = oclass;
3800                 if (mincount == 0 || minnext == 0) {
3801                     if (flags & SCF_DO_STCLASS_OR) {
3802                         cl_or(pRExC_state, data->start_class, &this_class);
3803                     }
3804                     else if (flags & SCF_DO_STCLASS_AND) {
3805                         /* Switch to OR mode: cache the old value of
3806                          * data->start_class */
3807                         INIT_AND_WITHP;
3808                         StructCopy(data->start_class, and_withp,
3809                                    struct regnode_charclass_class);
3810                         flags &= ~SCF_DO_STCLASS_AND;
3811                         StructCopy(&this_class, data->start_class,
3812                                    struct regnode_charclass_class);
3813                         flags |= SCF_DO_STCLASS_OR;
3814                         data->start_class->flags |= ANYOF_EOS;
3815                     }
3816                 } else {                /* Non-zero len */
3817                     if (flags & SCF_DO_STCLASS_OR) {
3818                         cl_or(pRExC_state, data->start_class, &this_class);
3819                         cl_and(data->start_class, and_withp);
3820                     }
3821                     else if (flags & SCF_DO_STCLASS_AND)
3822                         cl_and(data->start_class, &this_class);
3823                     flags &= ~SCF_DO_STCLASS;
3824                 }
3825                 if (!scan)              /* It was not CURLYX, but CURLY. */
3826                     scan = next;
3827                 if ( /* ? quantifier ok, except for (?{ ... }) */
3828                     (next_is_eval || !(mincount == 0 && maxcount == 1))
3829                     && (minnext == 0) && (deltanext == 0)
3830                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
3831                     && maxcount <= REG_INFTY/3) /* Complement check for big count */
3832                 {
3833                     ckWARNreg(RExC_parse,
3834                               "Quantifier unexpected on zero-length expression");
3835                 }
3836
3837                 min += minnext * mincount;
3838                 is_inf_internal |= ((maxcount == REG_INFTY
3839                                      && (minnext + deltanext) > 0)
3840                                     || deltanext == I32_MAX);
3841                 is_inf |= is_inf_internal;
3842                 delta += (minnext + deltanext) * maxcount - minnext * mincount;
3843
3844                 /* Try powerful optimization CURLYX => CURLYN. */
3845                 if (  OP(oscan) == CURLYX && data
3846                       && data->flags & SF_IN_PAR
3847                       && !(data->flags & SF_HAS_EVAL)
3848                       && !deltanext && minnext == 1 ) {
3849                     /* Try to optimize to CURLYN.  */
3850                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
3851                     regnode * const nxt1 = nxt;
3852 #ifdef DEBUGGING
3853                     regnode *nxt2;
3854 #endif
3855
3856                     /* Skip open. */
3857                     nxt = regnext(nxt);
3858                     if (!REGNODE_SIMPLE(OP(nxt))
3859                         && !(PL_regkind[OP(nxt)] == EXACT
3860                              && STR_LEN(nxt) == 1))
3861                         goto nogo;
3862 #ifdef DEBUGGING
3863                     nxt2 = nxt;
3864 #endif
3865                     nxt = regnext(nxt);
3866                     if (OP(nxt) != CLOSE)
3867                         goto nogo;
3868                     if (RExC_open_parens) {
3869                         RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3870                         RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
3871                     }
3872                     /* Now we know that nxt2 is the only contents: */
3873                     oscan->flags = (U8)ARG(nxt);
3874                     OP(oscan) = CURLYN;
3875                     OP(nxt1) = NOTHING; /* was OPEN. */
3876
3877 #ifdef DEBUGGING
3878                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3879                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
3880                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
3881                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
3882                     OP(nxt + 1) = OPTIMIZED; /* was count. */
3883                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
3884 #endif
3885                 }
3886               nogo:
3887
3888                 /* Try optimization CURLYX => CURLYM. */
3889                 if (  OP(oscan) == CURLYX && data
3890                       && !(data->flags & SF_HAS_PAR)
3891                       && !(data->flags & SF_HAS_EVAL)
3892                       && !deltanext     /* atom is fixed width */
3893                       && minnext != 0   /* CURLYM can't handle zero width */
3894                 ) {
3895                     /* XXXX How to optimize if data == 0? */
3896                     /* Optimize to a simpler form.  */
3897                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
3898                     regnode *nxt2;
3899
3900                     OP(oscan) = CURLYM;
3901                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
3902                             && (OP(nxt2) != WHILEM))
3903                         nxt = nxt2;
3904                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
3905                     /* Need to optimize away parenths. */
3906                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
3907                         /* Set the parenth number.  */
3908                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
3909
3910                         oscan->flags = (U8)ARG(nxt);
3911                         if (RExC_open_parens) {
3912                             RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3913                             RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
3914                         }
3915                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
3916                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
3917
3918 #ifdef DEBUGGING
3919                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3920                         OP(nxt + 1) = OPTIMIZED; /* was count. */
3921                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
3922                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
3923 #endif
3924 #if 0
3925                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
3926                             regnode *nnxt = regnext(nxt1);
3927                             if (nnxt == nxt) {
3928                                 if (reg_off_by_arg[OP(nxt1)])
3929                                     ARG_SET(nxt1, nxt2 - nxt1);
3930                                 else if (nxt2 - nxt1 < U16_MAX)
3931                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
3932                                 else
3933                                     OP(nxt) = NOTHING;  /* Cannot beautify */
3934                             }
3935                             nxt1 = nnxt;
3936                         }
3937 #endif
3938                         /* Optimize again: */
3939                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
3940                                     NULL, stopparen, recursed, NULL, 0,depth+1);
3941                     }
3942                     else
3943                         oscan->flags = 0;
3944                 }
3945                 else if ((OP(oscan) == CURLYX)
3946                          && (flags & SCF_WHILEM_VISITED_POS)
3947                          /* See the comment on a similar expression above.
3948                             However, this time it's not a subexpression
3949                             we care about, but the expression itself. */
3950                          && (maxcount == REG_INFTY)
3951                          && data && ++data->whilem_c < 16) {
3952                     /* This stays as CURLYX, we can put the count/of pair. */
3953                     /* Find WHILEM (as in regexec.c) */
3954                     regnode *nxt = oscan + NEXT_OFF(oscan);
3955
3956                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
3957                         nxt += ARG(nxt);
3958                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
3959                         | (RExC_whilem_seen << 4)); /* On WHILEM */
3960                 }
3961                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
3962                     pars++;
3963                 if (flags & SCF_DO_SUBSTR) {
3964                     SV *last_str = NULL;
3965                     int counted = mincount != 0;
3966
3967                     if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
3968 #if defined(SPARC64_GCC_WORKAROUND)
3969                         I32 b = 0;
3970                         STRLEN l = 0;
3971                         const char *s = NULL;
3972                         I32 old = 0;
3973
3974                         if (pos_before >= data->last_start_min)
3975                             b = pos_before;
3976                         else
3977                             b = data->last_start_min;
3978
3979                         l = 0;
3980                         s = SvPV_const(data->last_found, l);
3981                         old = b - data->last_start_min;
3982
3983 #else
3984                         I32 b = pos_before >= data->last_start_min
3985                             ? pos_before : data->last_start_min;
3986                         STRLEN l;
3987                         const char * const s = SvPV_const(data->last_found, l);
3988                         I32 old = b - data->last_start_min;
3989 #endif
3990
3991                         if (UTF)
3992                             old = utf8_hop((U8*)s, old) - (U8*)s;
3993                         l -= old;
3994                         /* Get the added string: */
3995                         last_str = newSVpvn_utf8(s  + old, l, UTF);
3996                         if (deltanext == 0 && pos_before == b) {
3997                             /* What was added is a constant string */
3998                             if (mincount > 1) {
3999                                 SvGROW(last_str, (mincount * l) + 1);
4000                                 repeatcpy(SvPVX(last_str) + l,
4001                                           SvPVX_const(last_str), l, mincount - 1);
4002                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
4003                                 /* Add additional parts. */
4004                                 SvCUR_set(data->last_found,
4005                                           SvCUR(data->last_found) - l);
4006                                 sv_catsv(data->last_found, last_str);
4007                                 {
4008                                     SV * sv = data->last_found;
4009                                     MAGIC *mg =
4010                                         SvUTF8(sv) && SvMAGICAL(sv) ?
4011                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
4012                                     if (mg && mg->mg_len >= 0)
4013                                         mg->mg_len += CHR_SVLEN(last_str) - l;
4014                                 }
4015                                 data->last_end += l * (mincount - 1);
4016                             }
4017                         } else {
4018                             /* start offset must point into the last copy */
4019                             data->last_start_min += minnext * (mincount - 1);
4020                             data->last_start_max += is_inf ? I32_MAX
4021                                 : (maxcount - 1) * (minnext + data->pos_delta);
4022                         }
4023                     }
4024                     /* It is counted once already... */
4025                     data->pos_min += minnext * (mincount - counted);
4026                     data->pos_delta += - counted * deltanext +
4027                         (minnext + deltanext) * maxcount - minnext * mincount;
4028                     if (mincount != maxcount) {
4029                          /* Cannot extend fixed substrings found inside
4030                             the group.  */
4031                         SCAN_COMMIT(pRExC_state,data,minlenp);
4032                         if (mincount && last_str) {
4033                             SV * const sv = data->last_found;
4034                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4035                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
4036
4037                             if (mg)
4038                                 mg->mg_len = -1;
4039                             sv_setsv(sv, last_str);
4040                             data->last_end = data->pos_min;
4041                             data->last_start_min =
4042                                 data->pos_min - CHR_SVLEN(last_str);
4043                             data->last_start_max = is_inf
4044                                 ? I32_MAX
4045                                 : data->pos_min + data->pos_delta
4046                                 - CHR_SVLEN(last_str);
4047                         }
4048                         data->longest = &(data->longest_float);
4049                     }
4050                     SvREFCNT_dec(last_str);
4051                 }
4052                 if (data && (fl & SF_HAS_EVAL))
4053                     data->flags |= SF_HAS_EVAL;
4054               optimize_curly_tail:
4055                 if (OP(oscan) != CURLYX) {
4056                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
4057                            && NEXT_OFF(next))
4058                         NEXT_OFF(oscan) += NEXT_OFF(next);
4059                 }
4060                 continue;
4061             default:                    /* REF, ANYOFV, and CLUMP only? */
4062                 if (flags & SCF_DO_SUBSTR) {
4063                     SCAN_COMMIT(pRExC_state,data,minlenp);      /* Cannot expect anything... */
4064                     data->longest = &(data->longest_float);
4065                 }
4066                 is_inf = is_inf_internal = 1;
4067                 if (flags & SCF_DO_STCLASS_OR)
4068                     cl_anything(pRExC_state, data->start_class);
4069                 flags &= ~SCF_DO_STCLASS;
4070                 break;
4071             }
4072         }
4073         else if (OP(scan) == LNBREAK) {
4074             if (flags & SCF_DO_STCLASS) {
4075                 int value = 0;
4076                 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
4077                 if (flags & SCF_DO_STCLASS_AND) {
4078                     for (value = 0; value < 256; value++)
4079                         if (!is_VERTWS_cp(value))
4080                             ANYOF_BITMAP_CLEAR(data->start_class, value);
4081                 }
4082                 else {
4083                     for (value = 0; value < 256; value++)
4084                         if (is_VERTWS_cp(value))
4085                             ANYOF_BITMAP_SET(data->start_class, value);
4086                 }
4087                 if (flags & SCF_DO_STCLASS_OR)
4088                     cl_and(data->start_class, and_withp);
4089                 flags &= ~SCF_DO_STCLASS;
4090             }
4091             min += 1;
4092             delta += 1;
4093             if (flags & SCF_DO_SUBSTR) {
4094                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
4095                 data->pos_min += 1;
4096                 data->pos_delta += 1;
4097                 data->longest = &(data->longest_float);
4098             }
4099         }
4100         else if (REGNODE_SIMPLE(OP(scan))) {
4101             int value = 0;
4102
4103             if (flags & SCF_DO_SUBSTR) {
4104                 SCAN_COMMIT(pRExC_state,data,minlenp);
4105                 data->pos_min++;
4106             }
4107             min++;
4108             if (flags & SCF_DO_STCLASS) {
4109                 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
4110
4111                 /* Some of the logic below assumes that switching
4112                    locale on will only add false positives. */
4113                 switch (PL_regkind[OP(scan)]) {
4114                 case SANY:
4115                 default:
4116                   do_default:
4117                     /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
4118                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4119                         cl_anything(pRExC_state, data->start_class);
4120                     break;
4121                 case REG_ANY:
4122                     if (OP(scan) == SANY)
4123                         goto do_default;
4124                     if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
4125                         value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
4126                                  || ANYOF_CLASS_TEST_ANY_SET(data->start_class));
4127                         cl_anything(pRExC_state, data->start_class);
4128                     }
4129                     if (flags & SCF_DO_STCLASS_AND || !value)
4130                         ANYOF_BITMAP_CLEAR(data->start_class,'\n');
4131                     break;
4132                 case ANYOF:
4133                     if (flags & SCF_DO_STCLASS_AND)
4134                         cl_and(data->start_class,
4135                                (struct regnode_charclass_class*)scan);
4136                     else
4137                         cl_or(pRExC_state, data->start_class,
4138                               (struct regnode_charclass_class*)scan);
4139                     break;
4140                 case ALNUM:
4141                     if (flags & SCF_DO_STCLASS_AND) {
4142                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
4143                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
4144                             if (OP(scan) == ALNUMU) {
4145                                 for (value = 0; value < 256; value++) {
4146                                     if (!isWORDCHAR_L1(value)) {
4147                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4148                                     }
4149                                 }
4150                             } else {
4151                                 for (value = 0; value < 256; value++) {
4152                                     if (!isALNUM(value)) {
4153                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4154                                     }
4155                                 }
4156                             }
4157                         }
4158                     }
4159                     else {
4160                         if (data->start_class->flags & ANYOF_LOCALE)
4161                             ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
4162
4163                         /* Even if under locale, set the bits for non-locale
4164                          * in case it isn't a true locale-node.  This will
4165                          * create false positives if it truly is locale */
4166                         if (OP(scan) == ALNUMU) {
4167                             for (value = 0; value < 256; value++) {
4168                                 if (isWORDCHAR_L1(value)) {
4169                                     ANYOF_BITMAP_SET(data->start_class, value);
4170                                 }
4171                             }
4172                         } else {
4173                             for (value = 0; value < 256; value++) {
4174                                 if (isALNUM(value)) {
4175                                     ANYOF_BITMAP_SET(data->start_class, value);
4176                                 }
4177                             }
4178                         }
4179                     }
4180                     break;
4181                 case NALNUM:
4182                     if (flags & SCF_DO_STCLASS_AND) {
4183                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
4184                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
4185                             if (OP(scan) == NALNUMU) {
4186                                 for (value = 0; value < 256; value++) {
4187                                     if (isWORDCHAR_L1(value)) {
4188                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4189                                     }
4190                                 }
4191                             } else {
4192                                 for (value = 0; value < 256; value++) {
4193                                     if (isALNUM(value)) {
4194                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4195                                     }
4196                                 }
4197                             }
4198                         }
4199                     }
4200                     else {
4201                         if (data->start_class->flags & ANYOF_LOCALE)
4202                             ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
4203
4204                         /* Even if under locale, set the bits for non-locale in
4205                          * case it isn't a true locale-node.  This will create
4206                          * false positives if it truly is locale */
4207                         if (OP(scan) == NALNUMU) {
4208                             for (value = 0; value < 256; value++) {
4209                                 if (! isWORDCHAR_L1(value)) {
4210                                     ANYOF_BITMAP_SET(data->start_class, value);
4211                                 }
4212                             }
4213                         } else {
4214                             for (value = 0; value < 256; value++) {
4215                                 if (! isALNUM(value)) {
4216                                     ANYOF_BITMAP_SET(data->start_class, value);
4217                                 }
4218                             }
4219                         }
4220                     }
4221                     break;
4222                 case SPACE:
4223                     if (flags & SCF_DO_STCLASS_AND) {
4224                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
4225                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
4226                             if (OP(scan) == SPACEU) {
4227                                 for (value = 0; value < 256; value++) {
4228                                     if (!isSPACE_L1(value)) {
4229                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4230                                     }
4231                                 }
4232                             } else {
4233                                 for (value = 0; value < 256; value++) {
4234                                     if (!isSPACE(value)) {
4235                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4236                                     }
4237                                 }
4238                             }
4239                         }
4240                     }
4241                     else {
4242                         if (data->start_class->flags & ANYOF_LOCALE) {
4243                             ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
4244                         }
4245                         if (OP(scan) == SPACEU) {
4246                             for (value = 0; value < 256; value++) {
4247                                 if (isSPACE_L1(value)) {
4248                                     ANYOF_BITMAP_SET(data->start_class, value);
4249                                 }
4250                             }
4251                         } else {
4252                             for (value = 0; value < 256; value++) {
4253                                 if (isSPACE(value)) {
4254                                     ANYOF_BITMAP_SET(data->start_class, value);
4255                                 }
4256                             }
4257                         }
4258                     }
4259                     break;
4260                 case NSPACE:
4261                     if (flags & SCF_DO_STCLASS_AND) {
4262                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
4263                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
4264                             if (OP(scan) == NSPACEU) {
4265                                 for (value = 0; value < 256; value++) {
4266                                     if (isSPACE_L1(value)) {
4267                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4268                                     }
4269                                 }
4270                             } else {
4271                                 for (value = 0; value < 256; value++) {
4272                                     if (isSPACE(value)) {
4273                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
4274                                     }
4275                                 }
4276                             }
4277                         }
4278                     }
4279                     else {
4280                         if (data->start_class->flags & ANYOF_LOCALE)
4281                             ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
4282                         if (OP(scan) == NSPACEU) {
4283                             for (value = 0; value < 256; value++) {
4284                                 if (!isSPACE_L1(value)) {
4285                                     ANYOF_BITMAP_SET(data->start_class, value);
4286                                 }
4287                             }
4288                         }
4289                         else {
4290                             for (value = 0; value < 256; value++) {
4291                                 if (!isSPACE(value)) {
4292                                     ANYOF_BITMAP_SET(data->start_class, value);
4293                                 }
4294                             }
4295                         }
4296                     }
4297                     break;
4298                 case DIGIT:
4299                     if (flags & SCF_DO_STCLASS_AND) {
4300                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
4301                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
4302                             for (value = 0; value < 256; value++)
4303                                 if (!isDIGIT(value))
4304                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
4305                         }
4306                     }
4307                     else {
4308                         if (data->start_class->flags & ANYOF_LOCALE)
4309                             ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
4310                         for (value = 0; value < 256; value++)
4311                             if (isDIGIT(value))
4312                                 ANYOF_BITMAP_SET(data->start_class, value);
4313                     }
4314                     break;
4315                 case NDIGIT:
4316                     if (flags & SCF_DO_STCLASS_AND) {
4317                         if (!(data->start_class->flags & ANYOF_LOCALE))
4318                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
4319                         for (value = 0; value < 256; value++)
4320                             if (isDIGIT(value))
4321                                 ANYOF_BITMAP_CLEAR(data->start_class, value);
4322                     }
4323                     else {
4324                         if (data->start_class->flags & ANYOF_LOCALE)
4325                             ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
4326                         for (value = 0; value < 256; value++)
4327                             if (!isDIGIT(value))
4328                                 ANYOF_BITMAP_SET(data->start_class, value);
4329                     }
4330                     break;
4331                 CASE_SYNST_FNC(VERTWS);
4332                 CASE_SYNST_FNC(HORIZWS);
4333
4334                 }
4335                 if (flags & SCF_DO_STCLASS_OR)
4336                     cl_and(data->start_class, and_withp);
4337                 flags &= ~SCF_DO_STCLASS;
4338             }
4339         }
4340         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
4341             data->flags |= (OP(scan) == MEOL
4342                             ? SF_BEFORE_MEOL
4343                             : SF_BEFORE_SEOL);
4344         }
4345         else if (  PL_regkind[OP(scan)] == BRANCHJ
4346                  /* Lookbehind, or need to calculate parens/evals/stclass: */
4347                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
4348                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
4349             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY 
4350                 || OP(scan) == UNLESSM )
4351             {
4352                 /* Negative Lookahead/lookbehind
4353                    In this case we can't do fixed string optimisation.
4354                 */
4355
4356                 I32 deltanext, minnext, fake = 0;
4357                 regnode *nscan;
4358                 struct regnode_charclass_class intrnl;
4359                 int f = 0;
4360
4361                 data_fake.flags = 0;
4362                 if (data) {
4363                     data_fake.whilem_c = data->whilem_c;
4364                     data_fake.last_closep = data->last_closep;
4365                 }
4366                 else
4367                     data_fake.last_closep = &fake;
4368                 data_fake.pos_delta = delta;
4369                 if ( flags & SCF_DO_STCLASS && !scan->flags
4370                      && OP(scan) == IFMATCH ) { /* Lookahead */
4371                     cl_init(pRExC_state, &intrnl);
4372                     data_fake.start_class = &intrnl;
4373                     f |= SCF_DO_STCLASS_AND;
4374                 }
4375                 if (flags & SCF_WHILEM_VISITED_POS)
4376                     f |= SCF_WHILEM_VISITED_POS;
4377                 next = regnext(scan);
4378                 nscan = NEXTOPER(NEXTOPER(scan));
4379                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext, 
4380                     last, &data_fake, stopparen, recursed, NULL, f, depth+1);
4381                 if (scan->flags) {
4382                     if (deltanext) {
4383                         FAIL("Variable length lookbehind not implemented");
4384                     }
4385                     else if (minnext > (I32)U8_MAX) {
4386                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4387                     }
4388                     scan->flags = (U8)minnext;
4389                 }
4390                 if (data) {
4391                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4392                         pars++;
4393                     if (data_fake.flags & SF_HAS_EVAL)
4394                         data->flags |= SF_HAS_EVAL;
4395                     data->whilem_c = data_fake.whilem_c;
4396                 }
4397                 if (f & SCF_DO_STCLASS_AND) {
4398                     if (flags & SCF_DO_STCLASS_OR) {
4399                         /* OR before, AND after: ideally we would recurse with
4400                          * data_fake to get the AND applied by study of the
4401                          * remainder of the pattern, and then derecurse;
4402                          * *** HACK *** for now just treat as "no information".
4403                          * See [perl #56690].
4404                          */
4405                         cl_init(pRExC_state, data->start_class);
4406                     }  else {
4407                         /* AND before and after: combine and continue */
4408                         const int was = (data->start_class->flags & ANYOF_EOS);
4409
4410                         cl_and(data->start_class, &intrnl);
4411                         if (was)
4412                             data->start_class->flags |= ANYOF_EOS;
4413                     }
4414                 }
4415             }
4416 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
4417             else {
4418                 /* Positive Lookahead/lookbehind
4419                    In this case we can do fixed string optimisation,
4420                    but we must be careful about it. Note in the case of
4421                    lookbehind the positions will be offset by the minimum
4422                    length of the pattern, something we won't know about
4423                    until after the recurse.
4424                 */
4425                 I32 deltanext, fake = 0;
4426                 regnode *nscan;
4427                 struct regnode_charclass_class intrnl;
4428                 int f = 0;
4429                 /* We use SAVEFREEPV so that when the full compile 
4430                     is finished perl will clean up the allocated 
4431                     minlens when it's all done. This way we don't
4432                     have to worry about freeing them when we know
4433                     they wont be used, which would be a pain.
4434                  */
4435                 I32 *minnextp;
4436                 Newx( minnextp, 1, I32 );
4437                 SAVEFREEPV(minnextp);
4438
4439                 if (data) {
4440                     StructCopy(data, &data_fake, scan_data_t);
4441                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
4442                         f |= SCF_DO_SUBSTR;
4443                         if (scan->flags) 
4444                             SCAN_COMMIT(pRExC_state, &data_fake,minlenp);
4445                         data_fake.last_found=newSVsv(data->last_found);
4446                     }
4447                 }
4448                 else
4449                     data_fake.last_closep = &fake;
4450                 data_fake.flags = 0;
4451                 data_fake.pos_delta = delta;
4452                 if (is_inf)
4453                     data_fake.flags |= SF_IS_INF;
4454                 if ( flags & SCF_DO_STCLASS && !scan->flags
4455                      && OP(scan) == IFMATCH ) { /* Lookahead */
4456                     cl_init(pRExC_state, &intrnl);
4457                     data_fake.start_class = &intrnl;
4458                     f |= SCF_DO_STCLASS_AND;
4459                 }
4460                 if (flags & SCF_WHILEM_VISITED_POS)
4461                     f |= SCF_WHILEM_VISITED_POS;
4462                 next = regnext(scan);
4463                 nscan = NEXTOPER(NEXTOPER(scan));
4464
4465                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext, 
4466                     last, &data_fake, stopparen, recursed, NULL, f,depth+1);
4467                 if (scan->flags) {
4468                     if (deltanext) {
4469                         FAIL("Variable length lookbehind not implemented");
4470                     }
4471                     else if (*minnextp > (I32)U8_MAX) {
4472                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4473                     }
4474                     scan->flags = (U8)*minnextp;
4475                 }
4476
4477                 *minnextp += min;
4478
4479                 if (f & SCF_DO_STCLASS_AND) {
4480                     const int was = (data->start_class->flags & ANYOF_EOS);
4481
4482                     cl_and(data->start_class, &intrnl);
4483                     if (was)
4484                         data->start_class->flags |= ANYOF_EOS;
4485                 }
4486                 if (data) {
4487                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4488                         pars++;
4489                     if (data_fake.flags & SF_HAS_EVAL)
4490                         data->flags |= SF_HAS_EVAL;
4491                     data->whilem_c = data_fake.whilem_c;
4492                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
4493                         if (RExC_rx->minlen<*minnextp)
4494                             RExC_rx->minlen=*minnextp;
4495                         SCAN_COMMIT(pRExC_state, &data_fake, minnextp);
4496                         SvREFCNT_dec(data_fake.last_found);
4497                         
4498                         if ( data_fake.minlen_fixed != minlenp ) 
4499                         {
4500                             data->offset_fixed= data_fake.offset_fixed;
4501                             data->minlen_fixed= data_fake.minlen_fixed;
4502                             data->lookbehind_fixed+= scan->flags;
4503                         }
4504                         if ( data_fake.minlen_float != minlenp )
4505                         {
4506                             data->minlen_float= data_fake.minlen_float;
4507                             data->offset_float_min=data_fake.offset_float_min;
4508                             data->offset_float_max=data_fake.offset_float_max;
4509                             data->lookbehind_float+= scan->flags;
4510                         }
4511                     }
4512                 }
4513
4514
4515             }
4516 #endif
4517         }
4518         else if (OP(scan) == OPEN) {
4519             if (stopparen != (I32)ARG(scan))
4520                 pars++;
4521         }
4522         else if (OP(scan) == CLOSE) {
4523             if (stopparen == (I32)ARG(scan)) {
4524                 break;
4525             }
4526             if ((I32)ARG(scan) == is_par) {
4527                 next = regnext(scan);
4528
4529                 if ( next && (OP(next) != WHILEM) && next < last)
4530                     is_par = 0;         /* Disable optimization */
4531             }
4532             if (data)
4533                 *(data->last_closep) = ARG(scan);
4534         }
4535         else if (OP(scan) == EVAL) {
4536                 if (data)
4537                     data->flags |= SF_HAS_EVAL;
4538         }
4539         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
4540             if (flags & SCF_DO_SUBSTR) {
4541                 SCAN_COMMIT(pRExC_state,data,minlenp);
4542                 flags &= ~SCF_DO_SUBSTR;
4543             }
4544             if (data && OP(scan)==ACCEPT) {
4545                 data->flags |= SCF_SEEN_ACCEPT;
4546                 if (stopmin > min)
4547                     stopmin = min;
4548             }
4549         }
4550         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
4551         {
4552                 if (flags & SCF_DO_SUBSTR) {
4553                     SCAN_COMMIT(pRExC_state,data,minlenp);
4554                     data->longest = &(data->longest_float);
4555                 }
4556                 is_inf = is_inf_internal = 1;
4557                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4558                     cl_anything(pRExC_state, data->start_class);
4559                 flags &= ~SCF_DO_STCLASS;
4560         }
4561         else if (OP(scan) == GPOS) {
4562             if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) &&
4563                 !(delta || is_inf || (data && data->pos_delta))) 
4564             {
4565                 if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR))
4566                     RExC_rx->extflags |= RXf_ANCH_GPOS;
4567                 if (RExC_rx->gofs < (U32)min)
4568                     RExC_rx->gofs = min;
4569             } else {
4570                 RExC_rx->extflags |= RXf_GPOS_FLOAT;
4571                 RExC_rx->gofs = 0;
4572             }       
4573         }
4574 #ifdef TRIE_STUDY_OPT
4575 #ifdef FULL_TRIE_STUDY
4576         else if (PL_regkind[OP(scan)] == TRIE) {
4577             /* NOTE - There is similar code to this block above for handling
4578                BRANCH nodes on the initial study.  If you change stuff here
4579                check there too. */
4580             regnode *trie_node= scan;
4581             regnode *tail= regnext(scan);
4582             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4583             I32 max1 = 0, min1 = I32_MAX;
4584             struct regnode_charclass_class accum;
4585
4586             if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
4587                 SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
4588             if (flags & SCF_DO_STCLASS)
4589                 cl_init_zero(pRExC_state, &accum);
4590                 
4591             if (!trie->jump) {
4592                 min1= trie->minlen;
4593                 max1= trie->maxlen;
4594             } else {
4595                 const regnode *nextbranch= NULL;
4596                 U32 word;
4597                 
4598                 for ( word=1 ; word <= trie->wordcount ; word++) 
4599                 {
4600                     I32 deltanext=0, minnext=0, f = 0, fake;
4601                     struct regnode_charclass_class this_class;
4602                     
4603                     data_fake.flags = 0;
4604                     if (data) {
4605                         data_fake.whilem_c = data->whilem_c;
4606                         data_fake.last_closep = data->last_closep;
4607                     }
4608                     else
4609                         data_fake.last_closep = &fake;
4610                     data_fake.pos_delta = delta;
4611                     if (flags & SCF_DO_STCLASS) {
4612                         cl_init(pRExC_state, &this_class);
4613                         data_fake.start_class = &this_class;
4614                         f = SCF_DO_STCLASS_AND;
4615                     }
4616                     if (flags & SCF_WHILEM_VISITED_POS)
4617                         f |= SCF_WHILEM_VISITED_POS;
4618     
4619                     if (trie->jump[word]) {
4620                         if (!nextbranch)
4621                             nextbranch = trie_node + trie->jump[0];
4622                         scan= trie_node + trie->jump[word];
4623                         /* We go from the jump point to the branch that follows
4624                            it. Note this means we need the vestigal unused branches
4625                            even though they arent otherwise used.
4626                          */
4627                         minnext = study_chunk(pRExC_state, &scan, minlenp, 
4628                             &deltanext, (regnode *)nextbranch, &data_fake, 
4629                             stopparen, recursed, NULL, f,depth+1);
4630                     }
4631                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
4632                         nextbranch= regnext((regnode*)nextbranch);
4633                     
4634                     if (min1 > (I32)(minnext + trie->minlen))
4635                         min1 = minnext + trie->minlen;
4636                     if (max1 < (I32)(minnext + deltanext + trie->maxlen))
4637                         max1 = minnext + deltanext + trie->maxlen;
4638                     if (deltanext == I32_MAX)
4639                         is_inf = is_inf_internal = 1;
4640                     
4641                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4642                         pars++;
4643                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4644                         if ( stopmin > min + min1) 
4645                             stopmin = min + min1;
4646                         flags &= ~SCF_DO_SUBSTR;
4647                         if (data)
4648                             data->flags |= SCF_SEEN_ACCEPT;
4649                     }
4650                     if (data) {
4651                         if (data_fake.flags & SF_HAS_EVAL)
4652                             data->flags |= SF_HAS_EVAL;
4653                         data->whilem_c = data_fake.whilem_c;
4654                     }
4655                     if (flags & SCF_DO_STCLASS)
4656                         cl_or(pRExC_state, &accum, &this_class);
4657                 }
4658             }
4659             if (flags & SCF_DO_SUBSTR) {
4660                 data->pos_min += min1;
4661                 data->pos_delta += max1 - min1;
4662                 if (max1 != min1 || is_inf)
4663                     data->longest = &(data->longest_float);
4664             }
4665             min += min1;
4666             delta += max1 - min1;
4667             if (flags & SCF_DO_STCLASS_OR) {
4668                 cl_or(pRExC_state, data->start_class, &accum);
4669                 if (min1) {
4670                     cl_and(data->start_class, and_withp);
4671                     flags &= ~SCF_DO_STCLASS;
4672                 }
4673             }
4674             else if (flags & SCF_DO_STCLASS_AND) {
4675                 if (min1) {
4676                     cl_and(data->start_class, &accum);
4677                     flags &= ~SCF_DO_STCLASS;
4678                 }
4679                 else {
4680                     /* Switch to OR mode: cache the old value of
4681                      * data->start_class */
4682                     INIT_AND_WITHP;
4683                     StructCopy(data->start_class, and_withp,
4684                                struct regnode_charclass_class);
4685                     flags &= ~SCF_DO_STCLASS_AND;
4686                     StructCopy(&accum, data->start_class,
4687                                struct regnode_charclass_class);
4688                     flags |= SCF_DO_STCLASS_OR;
4689                     data->start_class->flags |= ANYOF_EOS;
4690                 }
4691             }
4692             scan= tail;
4693             continue;
4694         }
4695 #else
4696         else if (PL_regkind[OP(scan)] == TRIE) {
4697             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4698             U8*bang=NULL;
4699             
4700             min += trie->minlen;
4701             delta += (trie->maxlen - trie->minlen);
4702             flags &= ~SCF_DO_STCLASS; /* xxx */
4703             if (flags & SCF_DO_SUBSTR) {
4704                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
4705                 data->pos_min += trie->minlen;
4706                 data->pos_delta += (trie->maxlen - trie->minlen);
4707                 if (trie->maxlen != trie->minlen)
4708                     data->longest = &(data->longest_float);
4709             }
4710             if (trie->jump) /* no more substrings -- for now /grr*/
4711                 flags &= ~SCF_DO_SUBSTR; 
4712         }
4713 #endif /* old or new */
4714 #endif /* TRIE_STUDY_OPT */
4715
4716         /* Else: zero-length, ignore. */
4717         scan = regnext(scan);
4718     }
4719     if (frame) {
4720         last = frame->last;
4721         scan = frame->next;
4722         stopparen = frame->stop;
4723         frame = frame->prev;
4724         goto fake_study_recurse;
4725     }
4726
4727   finish:
4728     assert(!frame);
4729     DEBUG_STUDYDATA("pre-fin:",data,depth);
4730
4731     *scanp = scan;
4732     *deltap = is_inf_internal ? I32_MAX : delta;
4733     if (flags & SCF_DO_SUBSTR && is_inf)
4734         data->pos_delta = I32_MAX - data->pos_min;
4735     if (is_par > (I32)U8_MAX)
4736         is_par = 0;
4737     if (is_par && pars==1 && data) {
4738         data->flags |= SF_IN_PAR;
4739         data->flags &= ~SF_HAS_PAR;
4740     }
4741     else if (pars && data) {
4742         data->flags |= SF_HAS_PAR;
4743         data->flags &= ~SF_IN_PAR;
4744     }
4745     if (flags & SCF_DO_STCLASS_OR)
4746         cl_and(data->start_class, and_withp);
4747     if (flags & SCF_TRIE_RESTUDY)
4748         data->flags |=  SCF_TRIE_RESTUDY;
4749     
4750     DEBUG_STUDYDATA("post-fin:",data,depth);
4751     
4752     return min < stopmin ? min : stopmin;
4753 }
4754
4755 STATIC U32
4756 S_add_data(RExC_state_t *pRExC_state, U32 n, const char *s)
4757 {
4758     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
4759
4760     PERL_ARGS_ASSERT_ADD_DATA;
4761
4762     Renewc(RExC_rxi->data,
4763            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
4764            char, struct reg_data);
4765     if(count)
4766         Renew(RExC_rxi->data->what, count + n, U8);
4767     else
4768         Newx(RExC_rxi->data->what, n, U8);
4769     RExC_rxi->data->count = count + n;
4770     Copy(s, RExC_rxi->data->what + count, n, U8);
4771     return count;
4772 }
4773
4774 /*XXX: todo make this not included in a non debugging perl */
4775 #ifndef PERL_IN_XSUB_RE
4776 void
4777 Perl_reginitcolors(pTHX)
4778 {
4779     dVAR;
4780     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
4781     if (s) {
4782         char *t = savepv(s);
4783         int i = 0;
4784         PL_colors[0] = t;
4785         while (++i < 6) {
4786             t = strchr(t, '\t');
4787             if (t) {
4788                 *t = '\0';
4789                 PL_colors[i] = ++t;
4790             }
4791             else
4792                 PL_colors[i] = t = (char *)"";
4793         }
4794     } else {
4795         int i = 0;
4796         while (i < 6)
4797             PL_colors[i++] = (char *)"";
4798     }
4799     PL_colorset = 1;
4800 }
4801 #endif
4802
4803
4804 #ifdef TRIE_STUDY_OPT
4805 #define CHECK_RESTUDY_GOTO                                  \
4806         if (                                                \
4807               (data.flags & SCF_TRIE_RESTUDY)               \
4808               && ! restudied++                              \
4809         )     goto reStudy
4810 #else
4811 #define CHECK_RESTUDY_GOTO
4812 #endif        
4813
4814 /*
4815  - pregcomp - compile a regular expression into internal code
4816  *
4817  * We can't allocate space until we know how big the compiled form will be,
4818  * but we can't compile it (and thus know how big it is) until we've got a
4819  * place to put the code.  So we cheat:  we compile it twice, once with code
4820  * generation turned off and size counting turned on, and once "for real".
4821  * This also means that we don't allocate space until we are sure that the
4822  * thing really will compile successfully, and we never have to move the
4823  * code and thus invalidate pointers into it.  (Note that it has to be in
4824  * one piece because free() must be able to free it all.) [NB: not true in perl]
4825  *
4826  * Beware that the optimization-preparation code in here knows about some
4827  * of the structure of the compiled regexp.  [I'll say.]
4828  */
4829
4830
4831
4832 #ifndef PERL_IN_XSUB_RE
4833 #define RE_ENGINE_PTR &reh_regexp_engine
4834 #else
4835 extern const struct regexp_engine my_reg_engine;
4836 #define RE_ENGINE_PTR &my_reg_engine
4837 #endif
4838
4839 #ifndef PERL_IN_XSUB_RE 
4840 REGEXP *
4841 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
4842 {
4843     dVAR;
4844     HV * const table = GvHV(PL_hintgv);
4845
4846     PERL_ARGS_ASSERT_PREGCOMP;
4847
4848     /* Dispatch a request to compile a regexp to correct 
4849        regexp engine. */
4850     if (table) {
4851         SV **ptr= hv_fetchs(table, "regcomp", FALSE);
4852         GET_RE_DEBUG_FLAGS_DECL;
4853         if (ptr && SvIOK(*ptr) && SvIV(*ptr)) {
4854             const regexp_engine *eng=INT2PTR(regexp_engine*,SvIV(*ptr));
4855             DEBUG_COMPILE_r({
4856                 PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
4857                     SvIV(*ptr));
4858             });            
4859             return CALLREGCOMP_ENG(eng, pattern, flags);
4860         } 
4861     }
4862     return Perl_re_compile(aTHX_ pattern, flags);
4863 }
4864 #endif
4865
4866 REGEXP *
4867 Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags)
4868 {
4869     dVAR;
4870     REGEXP *rx;
4871     struct regexp *r;
4872     register regexp_internal *ri;
4873     STRLEN plen;
4874     char* VOL exp;
4875     char* xend;
4876     regnode *scan;
4877     I32 flags;
4878     I32 minlen = 0;
4879     U32 pm_flags;
4880
4881     /* these are all flags - maybe they should be turned
4882      * into a single int with different bit masks */
4883     I32 sawlookahead = 0;
4884     I32 sawplus = 0;
4885     I32 sawopen = 0;
4886     bool used_setjump = FALSE;
4887     regex_charset initial_charset = get_regex_charset(orig_pm_flags);
4888
4889     U8 jump_ret = 0;
4890     dJMPENV;
4891     scan_data_t data;
4892     RExC_state_t RExC_state;
4893     RExC_state_t * const pRExC_state = &RExC_state;
4894 #ifdef TRIE_STUDY_OPT    
4895     int restudied;
4896     RExC_state_t copyRExC_state;
4897 #endif    
4898     GET_RE_DEBUG_FLAGS_DECL;
4899
4900     PERL_ARGS_ASSERT_RE_COMPILE;
4901
4902     DEBUG_r(if (!PL_colorset) reginitcolors());
4903
4904 #ifndef PERL_IN_XSUB_RE
4905     /* Initialize these here instead of as-needed, as is quick and avoids
4906      * having to test them each time otherwise */
4907     if (! PL_AboveLatin1) {
4908         PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
4909         PL_ASCII = _new_invlist_C_array(ASCII_invlist);
4910         PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
4911
4912         PL_L1PosixAlnum = _new_invlist_C_array(L1PosixAlnum_invlist);
4913         PL_PosixAlnum = _new_invlist_C_array(PosixAlnum_invlist);
4914
4915         PL_L1PosixAlpha = _new_invlist_C_array(L1PosixAlpha_invlist);
4916         PL_PosixAlpha = _new_invlist_C_array(PosixAlpha_invlist);
4917
4918         PL_PosixBlank = _new_invlist_C_array(PosixBlank_invlist);
4919         PL_XPosixBlank = _new_invlist_C_array(XPosixBlank_invlist);
4920
4921         PL_L1Cased = _new_invlist_C_array(L1Cased_invlist);
4922
4923         PL_PosixCntrl = _new_invlist_C_array(PosixCntrl_invlist);
4924         PL_XPosixCntrl = _new_invlist_C_array(XPosixCntrl_invlist);
4925
4926         PL_PosixDigit = _new_invlist_C_array(PosixDigit_invlist);
4927
4928         PL_L1PosixGraph = _new_invlist_C_array(L1PosixGraph_invlist);
4929         PL_PosixGraph = _new_invlist_C_array(PosixGraph_invlist);
4930
4931         PL_L1PosixAlnum = _new_invlist_C_array(L1PosixAlnum_invlist);
4932         PL_PosixAlnum = _new_invlist_C_array(PosixAlnum_invlist);
4933
4934         PL_L1PosixLower = _new_invlist_C_array(L1PosixLower_invlist);
4935         PL_PosixLower = _new_invlist_C_array(PosixLower_invlist);
4936
4937         PL_L1PosixPrint = _new_invlist_C_array(L1PosixPrint_invlist);
4938         PL_PosixPrint = _new_invlist_C_array(PosixPrint_invlist);
4939
4940         PL_L1PosixPunct = _new_invlist_C_array(L1PosixPunct_invlist);
4941         PL_PosixPunct = _new_invlist_C_array(PosixPunct_invlist);
4942
4943         PL_PerlSpace = _new_invlist_C_array(PerlSpace_invlist);
4944         PL_XPerlSpace = _new_invlist_C_array(XPerlSpace_invlist);
4945
4946         PL_PosixSpace = _new_invlist_C_array(PosixSpace_invlist);
4947         PL_XPosixSpace = _new_invlist_C_array(XPosixSpace_invlist);
4948
4949         PL_L1PosixUpper = _new_invlist_C_array(L1PosixUpper_invlist);
4950         PL_PosixUpper = _new_invlist_C_array(PosixUpper_invlist);
4951
4952         PL_VertSpace = _new_invlist_C_array(VertSpace_invlist);
4953
4954         PL_PosixWord = _new_invlist_C_array(PosixWord_invlist);
4955         PL_L1PosixWord = _new_invlist_C_array(L1PosixWord_invlist);
4956
4957         PL_PosixXDigit = _new_invlist_C_array(PosixXDigit_invlist);
4958         PL_XPosixXDigit = _new_invlist_C_array(XPosixXDigit_invlist);
4959     }
4960 #endif
4961
4962     exp = SvPV(pattern, plen);
4963
4964     if (plen == 0) { /* ignore the utf8ness if the pattern is 0 length */
4965         RExC_utf8 = RExC_orig_utf8 = 0;
4966     }
4967     else {
4968         RExC_utf8 = RExC_orig_utf8 = SvUTF8(pattern);
4969     }
4970     RExC_uni_semantics = 0;
4971     RExC_contains_locale = 0;
4972
4973     /****************** LONG JUMP TARGET HERE***********************/
4974     /* Longjmp back to here if have to switch in midstream to utf8 */
4975     if (! RExC_orig_utf8) {
4976         JMPENV_PUSH(jump_ret);
4977         used_setjump = TRUE;
4978     }
4979
4980     if (jump_ret == 0) {    /* First time through */
4981         xend = exp + plen;
4982
4983         DEBUG_COMPILE_r({
4984             SV *dsv= sv_newmortal();
4985             RE_PV_QUOTED_DECL(s, RExC_utf8,
4986                 dsv, exp, plen, 60);
4987             PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
4988                            PL_colors[4],PL_colors[5],s);
4989         });
4990     }
4991     else {  /* longjumped back */
4992         STRLEN len = plen;
4993
4994         /* If the cause for the longjmp was other than changing to utf8, pop
4995          * our own setjmp, and longjmp to the correct handler */
4996         if (jump_ret != UTF8_LONGJMP) {
4997             JMPENV_POP;
4998             JMPENV_JUMP(jump_ret);
4999         }
5000
5001         GET_RE_DEBUG_FLAGS;
5002
5003         /* It's possible to write a regexp in ascii that represents Unicode
5004         codepoints outside of the byte range, such as via \x{100}. If we
5005         detect such a sequence we have to convert the entire pattern to utf8
5006         and then recompile, as our sizing calculation will have been based
5007         on 1 byte == 1 character, but we will need to use utf8 to encode
5008         at least some part of the pattern, and therefore must convert the whole
5009         thing.
5010         -- dmq */
5011         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
5012             "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
5013         exp = (char*)Perl_bytes_to_utf8(aTHX_
5014                                         (U8*)SvPV_nomg(pattern, plen),
5015                                         &len);
5016         xend = exp + len;
5017         RExC_orig_utf8 = RExC_utf8 = 1;
5018         SAVEFREEPV(exp);
5019     }
5020
5021 #ifdef TRIE_STUDY_OPT
5022     restudied = 0;
5023 #endif
5024
5025     pm_flags = orig_pm_flags;
5026
5027     if (initial_charset == REGEX_LOCALE_CHARSET) {
5028         RExC_contains_locale = 1;
5029     }
5030     else if (RExC_utf8 && initial_charset == REGEX_DEPENDS_CHARSET) {
5031
5032         /* Set to use unicode semantics if the pattern is in utf8 and has the
5033          * 'depends' charset specified, as it means unicode when utf8  */
5034         set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
5035     }
5036
5037     RExC_precomp = exp;
5038     RExC_flags = pm_flags;
5039     RExC_sawback = 0;
5040
5041     RExC_seen = 0;
5042     RExC_in_lookbehind = 0;
5043     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
5044     RExC_seen_evals = 0;
5045     RExC_extralen = 0;
5046     RExC_override_recoding = 0;
5047
5048     /* First pass: determine size, legality. */
5049     RExC_parse = exp;
5050     RExC_start = exp;
5051     RExC_end = xend;
5052     RExC_naughty = 0;
5053     RExC_npar = 1;
5054     RExC_nestroot = 0;
5055     RExC_size = 0L;
5056     RExC_emit = &PL_regdummy;
5057     RExC_whilem_seen = 0;
5058     RExC_open_parens = NULL;
5059     RExC_close_parens = NULL;
5060     RExC_opend = NULL;
5061     RExC_paren_names = NULL;
5062 #ifdef DEBUGGING
5063     RExC_paren_name_list = NULL;
5064 #endif
5065     RExC_recurse = NULL;
5066     RExC_recurse_count = 0;
5067
5068 #if 0 /* REGC() is (currently) a NOP at the first pass.
5069        * Clever compilers notice this and complain. --jhi */
5070     REGC((U8)REG_MAGIC, (char*)RExC_emit);
5071 #endif
5072     DEBUG_PARSE_r(
5073         PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n");
5074         RExC_lastnum=0;
5075         RExC_lastparse=NULL;
5076     );
5077     if (reg(pRExC_state, 0, &flags,1) == NULL) {
5078         RExC_precomp = NULL;
5079         return(NULL);
5080     }
5081
5082     /* Here, finished first pass.  Get rid of any added setjmp */
5083     if (used_setjump) {
5084         JMPENV_POP;
5085     }
5086
5087     DEBUG_PARSE_r({
5088         PerlIO_printf(Perl_debug_log, 
5089             "Required size %"IVdf" nodes\n"
5090             "Starting second pass (creation)\n", 
5091             (IV)RExC_size);
5092         RExC_lastnum=0; 
5093         RExC_lastparse=NULL; 
5094     });
5095
5096     /* The first pass could have found things that force Unicode semantics */
5097     if ((RExC_utf8 || RExC_uni_semantics)
5098          && get_regex_charset(pm_flags) == REGEX_DEPENDS_CHARSET)
5099     {
5100         set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
5101     }
5102
5103     /* Small enough for pointer-storage convention?
5104        If extralen==0, this means that we will not need long jumps. */
5105     if (RExC_size >= 0x10000L && RExC_extralen)
5106         RExC_size += RExC_extralen;
5107     else
5108         RExC_extralen = 0;
5109     if (RExC_whilem_seen > 15)
5110         RExC_whilem_seen = 15;
5111
5112     /* Allocate space and zero-initialize. Note, the two step process 
5113        of zeroing when in debug mode, thus anything assigned has to 
5114        happen after that */
5115     rx = (REGEXP*) newSV_type(SVt_REGEXP);
5116     r = (struct regexp*)SvANY(rx);
5117     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
5118          char, regexp_internal);
5119     if ( r == NULL || ri == NULL )
5120         FAIL("Regexp out of space");
5121 #ifdef DEBUGGING
5122     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
5123     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char);
5124 #else 
5125     /* bulk initialize base fields with 0. */
5126     Zero(ri, sizeof(regexp_internal), char);        
5127 #endif
5128
5129     /* non-zero initialization begins here */
5130     RXi_SET( r, ri );
5131     r->engine= RE_ENGINE_PTR;
5132     r->extflags = pm_flags;
5133     {
5134         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
5135         bool has_charset = (get_regex_charset(r->extflags) != REGEX_DEPENDS_CHARSET);
5136
5137         /* The caret is output if there are any defaults: if not all the STD
5138          * flags are set, or if no character set specifier is needed */
5139         bool has_default =
5140                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
5141                     || ! has_charset);
5142         bool has_runon = ((RExC_seen & REG_SEEN_RUN_ON_COMMENT)==REG_SEEN_RUN_ON_COMMENT);
5143         U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD)
5144                             >> RXf_PMf_STD_PMMOD_SHIFT);
5145         const char *fptr = STD_PAT_MODS;        /*"msix"*/
5146         char *p;
5147         /* Allocate for the worst case, which is all the std flags are turned
5148          * on.  If more precision is desired, we could do a population count of
5149          * the flags set.  This could be done with a small lookup table, or by
5150          * shifting, masking and adding, or even, when available, assembly
5151          * language for a machine-language population count.
5152          * We never output a minus, as all those are defaults, so are
5153          * covered by the caret */
5154         const STRLEN wraplen = plen + has_p + has_runon
5155             + has_default       /* If needs a caret */
5156
5157                 /* If needs a character set specifier */
5158             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
5159             + (sizeof(STD_PAT_MODS) - 1)
5160             + (sizeof("(?:)") - 1);
5161
5162         p = sv_grow(MUTABLE_SV(rx), wraplen + 1); /* +1 for the ending NUL */
5163         SvPOK_on(rx);
5164         SvFLAGS(rx) |= SvUTF8(pattern);
5165         *p++='('; *p++='?';
5166
5167         /* If a default, cover it using the caret */
5168         if (has_default) {
5169             *p++= DEFAULT_PAT_MOD;
5170         }
5171         if (has_charset) {
5172             STRLEN len;
5173             const char* const name = get_regex_charset_name(r->extflags, &len);
5174             Copy(name, p, len, char);
5175             p += len;
5176         }
5177         if (has_p)
5178             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
5179         {
5180             char ch;
5181             while((ch = *fptr++)) {
5182                 if(reganch & 1)
5183                     *p++ = ch;
5184                 reganch >>= 1;
5185             }
5186         }
5187
5188         *p++ = ':';
5189         Copy(RExC_precomp, p, plen, char);
5190         assert ((RX_WRAPPED(rx) - p) < 16);
5191         r->pre_prefix = p - RX_WRAPPED(rx);
5192         p += plen;
5193         if (has_runon)
5194             *p++ = '\n';
5195         *p++ = ')';
5196         *p = 0;
5197         SvCUR_set(rx, p - SvPVX_const(rx));
5198     }
5199
5200     r->intflags = 0;
5201     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
5202     
5203     if (RExC_seen & REG_SEEN_RECURSE) {
5204         Newxz(RExC_open_parens, RExC_npar,regnode *);
5205         SAVEFREEPV(RExC_open_parens);
5206         Newxz(RExC_close_parens,RExC_npar,regnode *);
5207         SAVEFREEPV(RExC_close_parens);
5208     }
5209
5210     /* Useful during FAIL. */
5211 #ifdef RE_TRACK_PATTERN_OFFSETS
5212     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
5213     DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
5214                           "%s %"UVuf" bytes for offset annotations.\n",
5215                           ri->u.offsets ? "Got" : "Couldn't get",
5216                           (UV)((2*RExC_size+1) * sizeof(U32))));
5217 #endif
5218     SetProgLen(ri,RExC_size);
5219     RExC_rx_sv = rx;
5220     RExC_rx = r;
5221     RExC_rxi = ri;
5222     REH_CALL_COMP_BEGIN_HOOK(pRExC_state->rx);
5223
5224     /* Second pass: emit code. */
5225     RExC_flags = pm_flags;      /* don't let top level (?i) bleed */
5226     RExC_parse = exp;
5227     RExC_end = xend;
5228     RExC_naughty = 0;
5229     RExC_npar = 1;
5230     RExC_emit_start = ri->program;
5231     RExC_emit = ri->program;
5232     RExC_emit_bound = ri->program + RExC_size + 1;
5233
5234     /* Store the count of eval-groups for security checks: */
5235     RExC_rx->seen_evals = RExC_seen_evals;
5236     REGC((U8)REG_MAGIC, (char*) RExC_emit++);
5237     if (reg(pRExC_state, 0, &flags,1) == NULL) {
5238         ReREFCNT_dec(rx);   
5239         return(NULL);
5240     }
5241     /* XXXX To minimize changes to RE engine we always allocate
5242        3-units-long substrs field. */
5243     Newx(r->substrs, 1, struct reg_substr_data);
5244     if (RExC_recurse_count) {
5245         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
5246         SAVEFREEPV(RExC_recurse);
5247     }
5248
5249 reStudy:
5250     r->minlen = minlen = sawlookahead = sawplus = sawopen = 0;
5251     Zero(r->substrs, 1, struct reg_substr_data);
5252
5253 #ifdef TRIE_STUDY_OPT
5254     if (!restudied) {
5255         StructCopy(&zero_scan_data, &data, scan_data_t);
5256         copyRExC_state = RExC_state;
5257     } else {
5258         U32 seen=RExC_seen;
5259         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
5260         
5261         RExC_state = copyRExC_state;
5262         if (seen & REG_TOP_LEVEL_BRANCHES) 
5263             RExC_seen |= REG_TOP_LEVEL_BRANCHES;
5264         else
5265             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES;
5266         if (data.last_found) {
5267             SvREFCNT_dec(data.longest_fixed);
5268             SvREFCNT_dec(data.longest_float);
5269             SvREFCNT_dec(data.last_found);
5270         }
5271         StructCopy(&zero_scan_data, &data, scan_data_t);
5272     }
5273 #else
5274     StructCopy(&zero_scan_data, &data, scan_data_t);
5275 #endif    
5276
5277     /* Dig out information for optimizations. */
5278     r->extflags = RExC_flags; /* was pm_op */
5279     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
5280  
5281     if (UTF)
5282         SvUTF8_on(rx);  /* Unicode in it? */
5283     ri->regstclass = NULL;
5284     if (RExC_naughty >= 10)     /* Probably an expensive pattern. */
5285         r->intflags |= PREGf_NAUGHTY;
5286     scan = ri->program + 1;             /* First BRANCH. */
5287
5288     /* testing for BRANCH here tells us whether there is "must appear"
5289        data in the pattern. If there is then we can use it for optimisations */
5290     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /*  Only one top-level choice. */
5291         I32 fake;
5292         STRLEN longest_float_length, longest_fixed_length;
5293         struct regnode_charclass_class ch_class; /* pointed to by data */
5294         int stclass_flag;
5295         I32 last_close = 0; /* pointed to by data */
5296         regnode *first= scan;
5297         regnode *first_next= regnext(first);
5298         /*
5299          * Skip introductions and multiplicators >= 1
5300          * so that we can extract the 'meat' of the pattern that must 
5301          * match in the large if() sequence following.
5302          * NOTE that EXACT is NOT covered here, as it is normally
5303          * picked up by the optimiser separately. 
5304          *
5305          * This is unfortunate as the optimiser isnt handling lookahead
5306          * properly currently.
5307          *
5308          */
5309         while ((OP(first) == OPEN && (sawopen = 1)) ||
5310                /* An OR of *one* alternative - should not happen now. */
5311             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
5312             /* for now we can't handle lookbehind IFMATCH*/
5313             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
5314             (OP(first) == PLUS) ||
5315             (OP(first) == MINMOD) ||
5316                /* An {n,m} with n>0 */
5317             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
5318             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
5319         {
5320                 /* 
5321                  * the only op that could be a regnode is PLUS, all the rest
5322                  * will be regnode_1 or regnode_2.
5323                  *
5324                  */
5325                 if (OP(first) == PLUS)
5326                     sawplus = 1;
5327                 else
5328                     first += regarglen[OP(first)];
5329
5330                 first = NEXTOPER(first);
5331                 first_next= regnext(first);
5332         }
5333
5334         /* Starting-point info. */
5335       again:
5336         DEBUG_PEEP("first:",first,0);
5337         /* Ignore EXACT as we deal with it later. */
5338         if (PL_regkind[OP(first)] == EXACT) {
5339             if (OP(first) == EXACT)
5340                 NOOP;   /* Empty, get anchored substr later. */
5341             else
5342                 ri->regstclass = first;
5343         }
5344 #ifdef TRIE_STCLASS
5345         else if (PL_regkind[OP(first)] == TRIE &&
5346                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0) 
5347         {
5348             regnode *trie_op;
5349             /* this can happen only on restudy */
5350             if ( OP(first) == TRIE ) {
5351                 struct regnode_1 *trieop = (struct regnode_1 *)
5352                     PerlMemShared_calloc(1, sizeof(struct regnode_1));
5353                 StructCopy(first,trieop,struct regnode_1);
5354                 trie_op=(regnode *)trieop;
5355             } else {
5356                 struct regnode_charclass *trieop = (struct regnode_charclass *)
5357                     PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
5358                 StructCopy(first,trieop,struct regnode_charclass);
5359                 trie_op=(regnode *)trieop;
5360             }
5361             OP(trie_op)+=2;
5362             make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
5363             ri->regstclass = trie_op;
5364         }
5365 #endif
5366         else if (REGNODE_SIMPLE(OP(first)))
5367             ri->regstclass = first;
5368         else if (PL_regkind[OP(first)] == BOUND ||
5369                  PL_regkind[OP(first)] == NBOUND)
5370             ri->regstclass = first;
5371         else if (PL_regkind[OP(first)] == BOL) {
5372             r->extflags |= (OP(first) == MBOL
5373                            ? RXf_ANCH_MBOL
5374                            : (OP(first) == SBOL
5375                               ? RXf_ANCH_SBOL
5376                               : RXf_ANCH_BOL));
5377             first = NEXTOPER(first);
5378             goto again;
5379         }
5380         else if (OP(first) == GPOS) {
5381             r->extflags |= RXf_ANCH_GPOS;
5382             first = NEXTOPER(first);
5383             goto again;
5384         }
5385         else if ((!sawopen || !RExC_sawback) &&
5386             (OP(first) == STAR &&
5387             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
5388             !(r->extflags & RXf_ANCH) && !(RExC_seen & REG_SEEN_EVAL))
5389         {
5390             /* turn .* into ^.* with an implied $*=1 */
5391             const int type =
5392                 (OP(NEXTOPER(first)) == REG_ANY)
5393                     ? RXf_ANCH_MBOL
5394                     : RXf_ANCH_SBOL;
5395             r->extflags |= type;
5396             r->intflags |= PREGf_IMPLICIT;
5397             first = NEXTOPER(first);
5398             goto again;
5399         }
5400         if (sawplus && !sawlookahead && (!sawopen || !RExC_sawback)
5401             && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
5402             /* x+ must match at the 1st pos of run of x's */
5403             r->intflags |= PREGf_SKIP;
5404
5405         /* Scan is after the zeroth branch, first is atomic matcher. */
5406 #ifdef TRIE_STUDY_OPT
5407         DEBUG_PARSE_r(
5408             if (!restudied)
5409                 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
5410                               (IV)(first - scan + 1))
5411         );
5412 #else
5413         DEBUG_PARSE_r(
5414             PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
5415                 (IV)(first - scan + 1))
5416         );
5417 #endif
5418
5419
5420         /*
5421         * If there's something expensive in the r.e., find the
5422         * longest literal string that must appear and make it the
5423         * regmust.  Resolve ties in favor of later strings, since
5424         * the regstart check works with the beginning of the r.e.
5425         * and avoiding duplication strengthens checking.  Not a
5426         * strong reason, but sufficient in the absence of others.
5427         * [Now we resolve ties in favor of the earlier string if
5428         * it happens that c_offset_min has been invalidated, since the
5429         * earlier string may buy us something the later one won't.]
5430         */
5431
5432         data.longest_fixed = newSVpvs("");
5433         data.longest_float = newSVpvs("");
5434         data.last_found = newSVpvs("");
5435         data.longest = &(data.longest_fixed);
5436         first = scan;
5437         if (!ri->regstclass) {
5438             cl_init(pRExC_state, &ch_class);
5439             data.start_class = &ch_class;
5440             stclass_flag = SCF_DO_STCLASS_AND;
5441         } else                          /* XXXX Check for BOUND? */
5442             stclass_flag = 0;
5443         data.last_closep = &last_close;
5444         
5445         minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */
5446             &data, -1, NULL, NULL,
5447             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
5448
5449
5450         CHECK_RESTUDY_GOTO;
5451
5452
5453         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
5454              && data.last_start_min == 0 && data.last_end > 0
5455              && !RExC_seen_zerolen
5456              && !(RExC_seen & REG_SEEN_VERBARG)
5457              && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
5458             r->extflags |= RXf_CHECK_ALL;
5459         scan_commit(pRExC_state, &data,&minlen,0);
5460         SvREFCNT_dec(data.last_found);
5461
5462         /* Note that code very similar to this but for anchored string 
5463            follows immediately below, changes may need to be made to both. 
5464            Be careful. 
5465          */
5466         longest_float_length = CHR_SVLEN(data.longest_float);
5467         if (longest_float_length
5468             || (data.flags & SF_FL_BEFORE_EOL
5469                 && (!(data.flags & SF_FL_BEFORE_MEOL)
5470                     || (RExC_flags & RXf_PMf_MULTILINE)))) 
5471         {
5472             I32 t,ml;
5473
5474             /* See comments for join_exact for why REG_SEEN_EXACTF_SHARP_S */
5475             if ((RExC_seen & REG_SEEN_EXACTF_SHARP_S)
5476                 || (SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
5477                     && data.offset_fixed == data.offset_float_min
5478                     && SvCUR(data.longest_fixed) == SvCUR(data.longest_float)))
5479                     goto remove_float;          /* As in (a)+. */
5480
5481             /* copy the information about the longest float from the reg_scan_data
5482                over to the program. */
5483             if (SvUTF8(data.longest_float)) {
5484                 r->float_utf8 = data.longest_float;
5485                 r->float_substr = NULL;
5486             } else {
5487                 r->float_substr = data.longest_float;
5488                 r->float_utf8 = NULL;
5489             }
5490             /* float_end_shift is how many chars that must be matched that 
5491                follow this item. We calculate it ahead of time as once the
5492                lookbehind offset is added in we lose the ability to correctly
5493                calculate it.*/
5494             ml = data.minlen_float ? *(data.minlen_float) 
5495                                    : (I32)longest_float_length;
5496             r->float_end_shift = ml - data.offset_float_min
5497                 - longest_float_length + (SvTAIL(data.longest_float) != 0)
5498                 + data.lookbehind_float;
5499             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
5500             r->float_max_offset = data.offset_float_max;
5501             if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
5502                 r->float_max_offset -= data.lookbehind_float;
5503             
5504             t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
5505                        && (!(data.flags & SF_FL_BEFORE_MEOL)
5506                            || (RExC_flags & RXf_PMf_MULTILINE)));
5507             fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0);
5508         }
5509         else {
5510           remove_float:
5511             r->float_substr = r->float_utf8 = NULL;
5512             SvREFCNT_dec(data.longest_float);
5513             longest_float_length = 0;
5514         }
5515
5516         /* Note that code very similar to this but for floating string 
5517            is immediately above, changes may need to be made to both. 
5518            Be careful. 
5519          */
5520         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
5521
5522         /* See comments for join_exact for why REG_SEEN_EXACTF_SHARP_S */
5523         if (! (RExC_seen & REG_SEEN_EXACTF_SHARP_S)
5524             && (longest_fixed_length
5525                 || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
5526                     && (!(data.flags & SF_FIX_BEFORE_MEOL)
5527                         || (RExC_flags & RXf_PMf_MULTILINE)))) )
5528         {
5529             I32 t,ml;
5530
5531             /* copy the information about the longest fixed 
5532                from the reg_scan_data over to the program. */
5533             if (SvUTF8(data.longest_fixed)) {
5534                 r->anchored_utf8 = data.longest_fixed;
5535                 r->anchored_substr = NULL;
5536             } else {
5537                 r->anchored_substr = data.longest_fixed;
5538                 r->anchored_utf8 = NULL;
5539             }
5540             /* fixed_end_shift is how many chars that must be matched that 
5541                follow this item. We calculate it ahead of time as once the
5542                lookbehind offset is added in we lose the ability to correctly
5543                calculate it.*/
5544             ml = data.minlen_fixed ? *(data.minlen_fixed) 
5545                                    : (I32)longest_fixed_length;
5546             r->anchored_end_shift = ml - data.offset_fixed
5547                 - longest_fixed_length + (SvTAIL(data.longest_fixed) != 0)
5548                 + data.lookbehind_fixed;
5549             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
5550
5551             t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
5552                  && (!(data.flags & SF_FIX_BEFORE_MEOL)
5553                      || (RExC_flags & RXf_PMf_MULTILINE)));
5554             fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0);
5555         }
5556         else {
5557             r->anchored_substr = r->anchored_utf8 = NULL;
5558             SvREFCNT_dec(data.longest_fixed);
5559             longest_fixed_length = 0;
5560         }
5561         if (ri->regstclass
5562             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
5563             ri->regstclass = NULL;
5564
5565         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
5566             && stclass_flag
5567             && !(data.start_class->flags & ANYOF_EOS)
5568             && !cl_is_anything(data.start_class))
5569         {
5570             const U32 n = add_data(pRExC_state, 1, "f");
5571             data.start_class->flags |= ANYOF_IS_SYNTHETIC;
5572
5573             Newx(RExC_rxi->data->data[n], 1,
5574                 struct regnode_charclass_class);
5575             StructCopy(data.start_class,
5576                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
5577                        struct regnode_charclass_class);
5578             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5579             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5580             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
5581                       regprop(r, sv, (regnode*)data.start_class);
5582                       PerlIO_printf(Perl_debug_log,
5583                                     "synthetic stclass \"%s\".\n",
5584                                     SvPVX_const(sv));});
5585         }
5586
5587         /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
5588         if (longest_fixed_length > longest_float_length) {
5589             r->check_end_shift = r->anchored_end_shift;
5590             r->check_substr = r->anchored_substr;
5591             r->check_utf8 = r->anchored_utf8;
5592             r->check_offset_min = r->check_offset_max = r->anchored_offset;
5593             if (r->extflags & RXf_ANCH_SINGLE)
5594                 r->extflags |= RXf_NOSCAN;
5595         }
5596         else {
5597             r->check_end_shift = r->float_end_shift;
5598             r->check_substr = r->float_substr;
5599             r->check_utf8 = r->float_utf8;
5600             r->check_offset_min = r->float_min_offset;
5601             r->check_offset_max = r->float_max_offset;
5602         }
5603         /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
5604            This should be changed ASAP!  */
5605         if ((r->check_substr || r->check_utf8) && !(r->extflags & RXf_ANCH_GPOS)) {
5606             r->extflags |= RXf_USE_INTUIT;
5607             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
5608                 r->extflags |= RXf_INTUIT_TAIL;
5609         }
5610         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
5611         if ( (STRLEN)minlen < longest_float_length )
5612             minlen= longest_float_length;
5613         if ( (STRLEN)minlen < longest_fixed_length )
5614             minlen= longest_fixed_length;     
5615         */
5616     }
5617     else {
5618         /* Several toplevels. Best we can is to set minlen. */
5619         I32 fake;
5620         struct regnode_charclass_class ch_class;
5621         I32 last_close = 0;
5622
5623         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
5624
5625         scan = ri->program + 1;
5626         cl_init(pRExC_state, &ch_class);
5627         data.start_class = &ch_class;
5628         data.last_closep = &last_close;
5629
5630         
5631         minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
5632             &data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
5633         
5634         CHECK_RESTUDY_GOTO;
5635
5636         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
5637                 = r->float_substr = r->float_utf8 = NULL;
5638
5639         if (!(data.start_class->flags & ANYOF_EOS)
5640             && !cl_is_anything(data.start_class))
5641         {
5642             const U32 n = add_data(pRExC_state, 1, "f");
5643             data.start_class->flags |= ANYOF_IS_SYNTHETIC;
5644
5645             Newx(RExC_rxi->data->data[n], 1,
5646                 struct regnode_charclass_class);
5647             StructCopy(data.start_class,
5648                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
5649                        struct regnode_charclass_class);
5650             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5651             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5652             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
5653                       regprop(r, sv, (regnode*)data.start_class);
5654                       PerlIO_printf(Perl_debug_log,
5655                                     "synthetic stclass \"%s\".\n",
5656                                     SvPVX_const(sv));});
5657         }
5658     }
5659
5660     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
5661        the "real" pattern. */
5662     DEBUG_OPTIMISE_r({
5663         PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n",
5664                       (IV)minlen, (IV)r->minlen);
5665     });
5666     r->minlenret = minlen;
5667     if (r->minlen < minlen) 
5668         r->minlen = minlen;
5669     
5670     if (RExC_seen & REG_SEEN_GPOS)
5671         r->extflags |= RXf_GPOS_SEEN;
5672     if (RExC_seen & REG_SEEN_LOOKBEHIND)
5673         r->extflags |= RXf_LOOKBEHIND_SEEN;
5674     if (RExC_seen & REG_SEEN_EVAL)
5675         r->extflags |= RXf_EVAL_SEEN;
5676     if (RExC_seen & REG_SEEN_CANY)
5677         r->extflags |= RXf_CANY_SEEN;
5678     if (RExC_seen & REG_SEEN_VERBARG)
5679         r->intflags |= PREGf_VERBARG_SEEN;
5680     if (RExC_seen & REG_SEEN_CUTGROUP)
5681         r->intflags |= PREGf_CUTGROUP_SEEN;
5682     if (RExC_paren_names)
5683         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
5684     else
5685         RXp_PAREN_NAMES(r) = NULL;
5686
5687 #ifdef STUPID_PATTERN_CHECKS            
5688     if (RX_PRELEN(rx) == 0)
5689         r->extflags |= RXf_NULL;
5690     if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5691         /* XXX: this should happen BEFORE we compile */
5692         r->extflags |= (RXf_SKIPWHITE|RXf_WHITE); 
5693     else if (RX_PRELEN(rx) == 3 && memEQ("\\s+", RX_PRECOMP(rx), 3))
5694         r->extflags |= RXf_WHITE;
5695     else if (RX_PRELEN(rx) == 1 && RXp_PRECOMP(rx)[0] == '^')
5696         r->extflags |= RXf_START_ONLY;
5697 #else
5698     if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5699             /* XXX: this should happen BEFORE we compile */
5700             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE); 
5701     else {
5702         regnode *first = ri->program + 1;
5703         U8 fop = OP(first);
5704
5705         if (PL_regkind[fop] == NOTHING && OP(NEXTOPER(first)) == END)
5706             r->extflags |= RXf_NULL;
5707         else if (PL_regkind[fop] == BOL && OP(NEXTOPER(first)) == END)
5708             r->extflags |= RXf_START_ONLY;
5709         else if (fop == PLUS && OP(NEXTOPER(first)) == SPACE
5710                              && OP(regnext(first)) == END)
5711             r->extflags |= RXf_WHITE;    
5712     }
5713 #endif
5714 #ifdef DEBUGGING
5715     if (RExC_paren_names) {
5716         ri->name_list_idx = add_data( pRExC_state, 1, "a" );
5717         ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list);
5718     } else
5719 #endif
5720         ri->name_list_idx = 0;
5721
5722     if (RExC_recurse_count) {
5723         for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
5724             const regnode *scan = RExC_recurse[RExC_recurse_count-1];
5725             ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
5726         }
5727     }
5728     Newxz(r->offs, RExC_npar, regexp_paren_pair);
5729     /* assume we don't need to swap parens around before we match */
5730
5731     DEBUG_DUMP_r({
5732         PerlIO_printf(Perl_debug_log,"Final program:\n");
5733         regdump(r);
5734     });
5735 #ifdef RE_TRACK_PATTERN_OFFSETS
5736     DEBUG_OFFSETS_r(if (ri->u.offsets) {
5737         const U32 len = ri->u.offsets[0];
5738         U32 i;
5739         GET_RE_DEBUG_FLAGS_DECL;
5740         PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
5741         for (i = 1; i <= len; i++) {
5742             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
5743                 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
5744                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
5745             }
5746         PerlIO_printf(Perl_debug_log, "\n");
5747     });
5748 #endif
5749     return rx;
5750 }
5751
5752 #undef RE_ENGINE_PTR
5753
5754
5755 SV*
5756 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
5757                     const U32 flags)
5758 {
5759     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
5760
5761     PERL_UNUSED_ARG(value);
5762
5763     if (flags & RXapif_FETCH) {
5764         return reg_named_buff_fetch(rx, key, flags);
5765     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
5766         Perl_croak_no_modify(aTHX);
5767         return NULL;
5768     } else if (flags & RXapif_EXISTS) {
5769         return reg_named_buff_exists(rx, key, flags)
5770             ? &PL_sv_yes
5771             : &PL_sv_no;
5772     } else if (flags & RXapif_REGNAMES) {
5773         return reg_named_buff_all(rx, flags);
5774     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
5775         return reg_named_buff_scalar(rx, flags);
5776     } else {
5777         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
5778         return NULL;
5779     }
5780 }
5781
5782 SV*
5783 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
5784                          const U32 flags)
5785 {
5786     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
5787     PERL_UNUSED_ARG(lastkey);
5788
5789     if (flags & RXapif_FIRSTKEY)
5790         return reg_named_buff_firstkey(rx, flags);
5791     else if (flags & RXapif_NEXTKEY)
5792         return reg_named_buff_nextkey(rx, flags);
5793     else {
5794         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter", (int)flags);
5795         return NULL;
5796     }
5797 }
5798
5799 SV*
5800 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
5801                           const U32 flags)
5802 {
5803     AV *retarray = NULL;
5804     SV *ret;
5805     struct regexp *const rx = (struct regexp *)SvANY(r);
5806
5807     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
5808
5809     if (flags & RXapif_ALL)
5810         retarray=newAV();
5811
5812     if (rx && RXp_PAREN_NAMES(rx)) {
5813         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
5814         if (he_str) {
5815             IV i;
5816             SV* sv_dat=HeVAL(he_str);
5817             I32 *nums=(I32*)SvPVX(sv_dat);
5818             for ( i=0; i<SvIVX(sv_dat); i++ ) {
5819                 if ((I32)(rx->nparens) >= nums[i]
5820                     && rx->offs[nums[i]].start != -1
5821                     && rx->offs[nums[i]].end != -1)
5822                 {
5823                     ret = newSVpvs("");
5824                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
5825                     if (!retarray)
5826                         return ret;
5827                 } else {
5828                     if (retarray)
5829                         ret = newSVsv(&PL_sv_undef);
5830                 }
5831                 if (retarray)
5832                     av_push(retarray, ret);
5833             }
5834             if (retarray)
5835                 return newRV_noinc(MUTABLE_SV(retarray));
5836         }
5837     }
5838     return NULL;
5839 }
5840
5841 bool
5842 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
5843                            const U32 flags)
5844 {
5845     struct regexp *const rx = (struct regexp *)SvANY(r);
5846
5847     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
5848
5849     if (rx && RXp_PAREN_NAMES(rx)) {
5850         if (flags & RXapif_ALL) {
5851             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
5852         } else {
5853             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
5854             if (sv) {
5855                 SvREFCNT_dec(sv);
5856                 return TRUE;
5857             } else {
5858                 return FALSE;
5859             }
5860         }
5861     } else {
5862         return FALSE;
5863     }
5864 }
5865
5866 SV*
5867 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
5868 {
5869     struct regexp *const rx = (struct regexp *)SvANY(r);
5870
5871     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
5872
5873     if ( rx && RXp_PAREN_NAMES(rx) ) {
5874         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
5875
5876         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
5877     } else {
5878         return FALSE;
5879     }
5880 }
5881
5882 SV*
5883 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
5884 {
5885     struct regexp *const rx = (struct regexp *)SvANY(r);
5886     GET_RE_DEBUG_FLAGS_DECL;
5887
5888     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
5889
5890     if (rx && RXp_PAREN_NAMES(rx)) {
5891         HV *hv = RXp_PAREN_NAMES(rx);
5892         HE *temphe;
5893         while ( (temphe = hv_iternext_flags(hv,0)) ) {
5894             IV i;
5895             IV parno = 0;
5896             SV* sv_dat = HeVAL(temphe);
5897             I32 *nums = (I32*)SvPVX(sv_dat);
5898             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5899                 if ((I32)(rx->lastparen) >= nums[i] &&
5900                     rx->offs[nums[i]].start != -1 &&
5901                     rx->offs[nums[i]].end != -1)
5902                 {
5903                     parno = nums[i];
5904                     break;
5905                 }
5906             }
5907             if (parno || flags & RXapif_ALL) {
5908                 return newSVhek(HeKEY_hek(temphe));
5909             }
5910         }
5911     }
5912     return NULL;
5913 }
5914
5915 SV*
5916 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
5917 {
5918     SV *ret;
5919     AV *av;
5920     I32 length;
5921     struct regexp *const rx = (struct regexp *)SvANY(r);
5922
5923     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
5924
5925     if (rx && RXp_PAREN_NAMES(rx)) {
5926         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
5927             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
5928         } else if (flags & RXapif_ONE) {
5929             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
5930             av = MUTABLE_AV(SvRV(ret));
5931             length = av_len(av);
5932             SvREFCNT_dec(ret);
5933             return newSViv(length + 1);
5934         } else {
5935             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", (int)flags);
5936             return NULL;
5937         }
5938     }
5939     return &PL_sv_undef;
5940 }
5941
5942 SV*
5943 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
5944 {
5945     struct regexp *const rx = (struct regexp *)SvANY(r);
5946     AV *av = newAV();
5947
5948     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
5949
5950     if (rx && RXp_PAREN_NAMES(rx)) {
5951         HV *hv= RXp_PAREN_NAMES(rx);
5952         HE *temphe;
5953         (void)hv_iterinit(hv);
5954         while ( (temphe = hv_iternext_flags(hv,0)) ) {
5955             IV i;
5956             IV parno = 0;
5957             SV* sv_dat = HeVAL(temphe);
5958             I32 *nums = (I32*)SvPVX(sv_dat);
5959             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5960                 if ((I32)(rx->lastparen) >= nums[i] &&
5961                     rx->offs[nums[i]].start != -1 &&
5962                     rx->offs[nums[i]].end != -1)
5963                 {
5964                     parno = nums[i];
5965                     break;
5966                 }
5967             }
5968             if (parno || flags & RXapif_ALL) {
5969                 av_push(av, newSVhek(HeKEY_hek(temphe)));
5970             }
5971         }
5972     }
5973
5974     return newRV_noinc(MUTABLE_SV(av));
5975 }
5976
5977 void
5978 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
5979                              SV * const sv)
5980 {
5981     struct regexp *const rx = (struct regexp *)SvANY(r);
5982     char *s = NULL;
5983     I32 i = 0;
5984     I32 s1, t1;
5985
5986     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
5987         
5988     if (!rx->subbeg) {
5989         sv_setsv(sv,&PL_sv_undef);
5990         return;
5991     } 
5992     else               
5993     if (paren == RX_BUFF_IDX_PREMATCH && rx->offs[0].start != -1) {
5994         /* $` */
5995         i = rx->offs[0].start;
5996         s = rx->subbeg;
5997     }
5998     else 
5999     if (paren == RX_BUFF_IDX_POSTMATCH && rx->offs[0].end != -1) {
6000         /* $' */
6001         s = rx->subbeg + rx->offs[0].end;
6002         i = rx->sublen - rx->offs[0].end;
6003     } 
6004     else
6005     if ( 0 <= paren && paren <= (I32)rx->nparens &&
6006         (s1 = rx->offs[paren].start) != -1 &&
6007         (t1 = rx->offs[paren].end) != -1)
6008     {
6009         /* $& $1 ... */
6010         i = t1 - s1;
6011         s = rx->subbeg + s1;
6012     } else {
6013         sv_setsv(sv,&PL_sv_undef);
6014         return;
6015     }          
6016     assert(rx->sublen >= (s - rx->subbeg) + i );
6017     if (i >= 0) {
6018         const int oldtainted = PL_tainted;
6019         TAINT_NOT;
6020         sv_setpvn(sv, s, i);
6021         PL_tainted = oldtainted;
6022         if ( (rx->extflags & RXf_CANY_SEEN)
6023             ? (RXp_MATCH_UTF8(rx)
6024                         && (!i || is_utf8_string((U8*)s, i)))
6025             : (RXp_MATCH_UTF8(rx)) )
6026         {
6027             SvUTF8_on(sv);
6028         }
6029         else
6030             SvUTF8_off(sv);
6031         if (PL_tainting) {
6032             if (RXp_MATCH_TAINTED(rx)) {
6033                 if (SvTYPE(sv) >= SVt_PVMG) {
6034                     MAGIC* const mg = SvMAGIC(sv);
6035                     MAGIC* mgt;
6036                     PL_tainted = 1;
6037                     SvMAGIC_set(sv, mg->mg_moremagic);
6038                     SvTAINT(sv);
6039                     if ((mgt = SvMAGIC(sv))) {
6040                         mg->mg_moremagic = mgt;
6041                         SvMAGIC_set(sv, mg);
6042                     }
6043                 } else {
6044                     PL_tainted = 1;
6045                     SvTAINT(sv);
6046                 }
6047             } else 
6048                 SvTAINTED_off(sv);
6049         }
6050     } else {
6051         sv_setsv(sv,&PL_sv_undef);
6052         return;
6053     }
6054 }
6055
6056 void
6057 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
6058                                                          SV const * const value)
6059 {
6060     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
6061
6062     PERL_UNUSED_ARG(rx);
6063     PERL_UNUSED_ARG(paren);
6064     PERL_UNUSED_ARG(value);
6065
6066     if (!PL_localizing)
6067         Perl_croak_no_modify(aTHX);
6068 }
6069
6070 I32
6071 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
6072                               const I32 paren)
6073 {
6074     struct regexp *const rx = (struct regexp *)SvANY(r);
6075     I32 i;
6076     I32 s1, t1;
6077
6078     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
6079
6080     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
6081         switch (paren) {
6082       /* $` / ${^PREMATCH} */
6083       case RX_BUFF_IDX_PREMATCH:
6084         if (rx->offs[0].start != -1) {
6085                         i = rx->offs[0].start;
6086                         if (i > 0) {
6087                                 s1 = 0;
6088                                 t1 = i;
6089                                 goto getlen;
6090                         }
6091             }
6092         return 0;
6093       /* $' / ${^POSTMATCH} */
6094       case RX_BUFF_IDX_POSTMATCH:
6095             if (rx->offs[0].end != -1) {
6096                         i = rx->sublen - rx->offs[0].end;
6097                         if (i > 0) {
6098                                 s1 = rx->offs[0].end;
6099                                 t1 = rx->sublen;
6100                                 goto getlen;
6101                         }
6102             }
6103         return 0;
6104       /* $& / ${^MATCH}, $1, $2, ... */
6105       default:
6106             if (paren <= (I32)rx->nparens &&
6107             (s1 = rx->offs[paren].start) != -1 &&
6108             (t1 = rx->offs[paren].end) != -1)
6109             {
6110             i = t1 - s1;
6111             goto getlen;
6112         } else {
6113             if (ckWARN(WARN_UNINITIALIZED))
6114                 report_uninit((const SV *)sv);
6115             return 0;
6116         }
6117     }
6118   getlen:
6119     if (i > 0 && RXp_MATCH_UTF8(rx)) {
6120         const char * const s = rx->subbeg + s1;
6121         const U8 *ep;
6122         STRLEN el;
6123
6124         i = t1 - s1;
6125         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
6126                         i = el;
6127     }
6128     return i;
6129 }
6130
6131 SV*
6132 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
6133 {
6134     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
6135         PERL_UNUSED_ARG(rx);
6136         if (0)
6137             return NULL;
6138         else
6139             return newSVpvs("Regexp");
6140 }
6141
6142 /* Scans the name of a named buffer from the pattern.
6143  * If flags is REG_RSN_RETURN_NULL returns null.
6144  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
6145  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
6146  * to the parsed name as looked up in the RExC_paren_names hash.
6147  * If there is an error throws a vFAIL().. type exception.
6148  */
6149
6150 #define REG_RSN_RETURN_NULL    0
6151 #define REG_RSN_RETURN_NAME    1
6152 #define REG_RSN_RETURN_DATA    2
6153
6154 STATIC SV*
6155 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
6156 {
6157     char *name_start = RExC_parse;
6158
6159     PERL_ARGS_ASSERT_REG_SCAN_NAME;
6160
6161     if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
6162          /* skip IDFIRST by using do...while */
6163         if (UTF)
6164             do {
6165                 RExC_parse += UTF8SKIP(RExC_parse);
6166             } while (isALNUM_utf8((U8*)RExC_parse));
6167         else
6168             do {
6169                 RExC_parse++;
6170             } while (isALNUM(*RExC_parse));
6171     }
6172
6173     if ( flags ) {
6174         SV* sv_name
6175             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
6176                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
6177         if ( flags == REG_RSN_RETURN_NAME)
6178             return sv_name;
6179         else if (flags==REG_RSN_RETURN_DATA) {
6180             HE *he_str = NULL;
6181             SV *sv_dat = NULL;
6182             if ( ! sv_name )      /* should not happen*/
6183                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
6184             if (RExC_paren_names)
6185                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
6186             if ( he_str )
6187                 sv_dat = HeVAL(he_str);
6188             if ( ! sv_dat )
6189                 vFAIL("Reference to nonexistent named group");
6190             return sv_dat;
6191         }
6192         else {
6193             Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
6194                        (unsigned long) flags);
6195         }
6196         /* NOT REACHED */
6197     }
6198     return NULL;
6199 }
6200
6201 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
6202     int rem=(int)(RExC_end - RExC_parse);                       \
6203     int cut;                                                    \
6204     int num;                                                    \
6205     int iscut=0;                                                \
6206     if (rem>10) {                                               \
6207         rem=10;                                                 \
6208         iscut=1;                                                \
6209     }                                                           \
6210     cut=10-rem;                                                 \
6211     if (RExC_lastparse!=RExC_parse)                             \
6212         PerlIO_printf(Perl_debug_log," >%.*s%-*s",              \
6213             rem, RExC_parse,                                    \
6214             cut + 4,                                            \
6215             iscut ? "..." : "<"                                 \
6216         );                                                      \
6217     else                                                        \
6218         PerlIO_printf(Perl_debug_log,"%16s","");                \
6219                                                                 \
6220     if (SIZE_ONLY)                                              \
6221        num = RExC_size + 1;                                     \
6222     else                                                        \
6223        num=REG_NODE_NUM(RExC_emit);                             \
6224     if (RExC_lastnum!=num)                                      \
6225        PerlIO_printf(Perl_debug_log,"|%4d",num);                \
6226     else                                                        \
6227        PerlIO_printf(Perl_debug_log,"|%4s","");                 \
6228     PerlIO_printf(Perl_debug_log,"|%*s%-4s",                    \
6229         (int)((depth*2)), "",                                   \
6230         (funcname)                                              \
6231     );                                                          \
6232     RExC_lastnum=num;                                           \
6233     RExC_lastparse=RExC_parse;                                  \
6234 })
6235
6236
6237
6238 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
6239     DEBUG_PARSE_MSG((funcname));                            \
6240     PerlIO_printf(Perl_debug_log,"%4s","\n");               \
6241 })
6242 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({           \
6243     DEBUG_PARSE_MSG((funcname));                            \
6244     PerlIO_printf(Perl_debug_log,fmt "\n",args);               \
6245 })
6246
6247 /* This section of code defines the inversion list object and its methods.  The
6248  * interfaces are highly subject to change, so as much as possible is static to
6249  * this file.  An inversion list is here implemented as a malloc'd C UV array
6250  * with some added info that is placed as UVs at the beginning in a header
6251  * portion.  An inversion list for Unicode is an array of code points, sorted
6252  * by ordinal number.  The zeroth element is the first code point in the list.
6253  * The 1th element is the first element beyond that not in the list.  In other
6254  * words, the first range is
6255  *  invlist[0]..(invlist[1]-1)
6256  * The other ranges follow.  Thus every element whose index is divisible by two
6257  * marks the beginning of a range that is in the list, and every element not
6258  * divisible by two marks the beginning of a range not in the list.  A single
6259  * element inversion list that contains the single code point N generally
6260  * consists of two elements
6261  *  invlist[0] == N
6262  *  invlist[1] == N+1
6263  * (The exception is when N is the highest representable value on the
6264  * machine, in which case the list containing just it would be a single
6265  * element, itself.  By extension, if the last range in the list extends to
6266  * infinity, then the first element of that range will be in the inversion list
6267  * at a position that is divisible by two, and is the final element in the
6268  * list.)
6269  * Taking the complement (inverting) an inversion list is quite simple, if the
6270  * first element is 0, remove it; otherwise add a 0 element at the beginning.
6271  * This implementation reserves an element at the beginning of each inversion list
6272  * to contain 0 when the list contains 0, and contains 1 otherwise.  The actual
6273  * beginning of the list is either that element if 0, or the next one if 1.
6274  *
6275  * More about inversion lists can be found in "Unicode Demystified"
6276  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
6277  * More will be coming when functionality is added later.
6278  *
6279  * The inversion list data structure is currently implemented as an SV pointing
6280  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
6281  * array of UV whose memory management is automatically handled by the existing
6282  * facilities for SV's.
6283  *
6284  * Some of the methods should always be private to the implementation, and some
6285  * should eventually be made public */
6286
6287 #define INVLIST_LEN_OFFSET 0    /* Number of elements in the inversion list */
6288 #define INVLIST_ITER_OFFSET 1   /* Current iteration position */
6289
6290 /* This is a combination of a version and data structure type, so that one
6291  * being passed in can be validated to be an inversion list of the correct
6292  * vintage.  When the structure of the header is changed, a new random number
6293  * in the range 2**31-1 should be generated and the new() method changed to
6294  * insert that at this location.  Then, if an auxiliary program doesn't change
6295  * correspondingly, it will be discovered immediately */
6296 #define INVLIST_VERSION_ID_OFFSET 2
6297 #define INVLIST_VERSION_ID 1064334010
6298
6299 /* For safety, when adding new elements, remember to #undef them at the end of
6300  * the inversion list code section */
6301
6302 #define INVLIST_ZERO_OFFSET 3   /* 0 or 1; must be last element in header */
6303 /* The UV at position ZERO contains either 0 or 1.  If 0, the inversion list
6304  * contains the code point U+00000, and begins here.  If 1, the inversion list
6305  * doesn't contain U+0000, and it begins at the next UV in the array.
6306  * Inverting an inversion list consists of adding or removing the 0 at the
6307  * beginning of it.  By reserving a space for that 0, inversion can be made
6308  * very fast */
6309
6310 #define HEADER_LENGTH (INVLIST_ZERO_OFFSET + 1)
6311
6312 /* Internally things are UVs */
6313 #define TO_INTERNAL_SIZE(x) ((x + HEADER_LENGTH) * sizeof(UV))
6314 #define FROM_INTERNAL_SIZE(x) ((x / sizeof(UV)) - HEADER_LENGTH)
6315
6316 #define INVLIST_INITIAL_LEN 10
6317
6318 PERL_STATIC_INLINE UV*
6319 S__invlist_array_init(pTHX_ SV* const invlist, const bool will_have_0)
6320 {
6321     /* Returns a pointer to the first element in the inversion list's array.
6322      * This is called upon initialization of an inversion list.  Where the
6323      * array begins depends on whether the list has the code point U+0000
6324      * in it or not.  The other parameter tells it whether the code that
6325      * follows this call is about to put a 0 in the inversion list or not.
6326      * The first element is either the element with 0, if 0, or the next one,
6327      * if 1 */
6328
6329     UV* zero = get_invlist_zero_addr(invlist);
6330
6331     PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
6332
6333     /* Must be empty */
6334     assert(! *get_invlist_len_addr(invlist));
6335
6336     /* 1^1 = 0; 1^0 = 1 */
6337     *zero = 1 ^ will_have_0;
6338     return zero + *zero;
6339 }
6340
6341 PERL_STATIC_INLINE UV*
6342 S_invlist_array(pTHX_ SV* const invlist)
6343 {
6344     /* Returns the pointer to the inversion list's array.  Every time the
6345      * length changes, this needs to be called in case malloc or realloc moved
6346      * it */
6347
6348     PERL_ARGS_ASSERT_INVLIST_ARRAY;
6349
6350     /* Must not be empty.  If these fail, you probably didn't check for <len>
6351      * being non-zero before trying to get the array */
6352     assert(*get_invlist_len_addr(invlist));
6353     assert(*get_invlist_zero_addr(invlist) == 0
6354            || *get_invlist_zero_addr(invlist) == 1);
6355
6356     /* The array begins either at the element reserved for zero if the
6357      * list contains 0 (that element will be set to 0), or otherwise the next
6358      * element (in which case the reserved element will be set to 1). */
6359     return (UV *) (get_invlist_zero_addr(invlist)
6360                    + *get_invlist_zero_addr(invlist));
6361 }
6362
6363 PERL_STATIC_INLINE UV*
6364 S_get_invlist_len_addr(pTHX_ SV* invlist)
6365 {
6366     /* Return the address of the UV that contains the current number
6367      * of used elements in the inversion list */
6368
6369     PERL_ARGS_ASSERT_GET_INVLIST_LEN_ADDR;
6370
6371     return (UV *) (SvPVX(invlist) + (INVLIST_LEN_OFFSET * sizeof (UV)));
6372 }
6373
6374 PERL_STATIC_INLINE UV
6375 S_invlist_len(pTHX_ SV* const invlist)
6376 {
6377     /* Returns the current number of elements stored in the inversion list's
6378      * array */
6379
6380     PERL_ARGS_ASSERT_INVLIST_LEN;
6381
6382     return *get_invlist_len_addr(invlist);
6383 }
6384
6385 PERL_STATIC_INLINE void
6386 S_invlist_set_len(pTHX_ SV* const invlist, const UV len)
6387 {
6388     /* Sets the current number of elements stored in the inversion list */
6389
6390     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
6391
6392     *get_invlist_len_addr(invlist) = len;
6393
6394     assert(len <= SvLEN(invlist));
6395
6396     SvCUR_set(invlist, TO_INTERNAL_SIZE(len));
6397     /* If the list contains U+0000, that element is part of the header,
6398      * and should not be counted as part of the array.  It will contain
6399      * 0 in that case, and 1 otherwise.  So we could flop 0=>1, 1=>0 and
6400      * subtract:
6401      *  SvCUR_set(invlist,
6402      *            TO_INTERNAL_SIZE(len
6403      *                             - (*get_invlist_zero_addr(inv_list) ^ 1)));
6404      * But, this is only valid if len is not 0.  The consequences of not doing
6405      * this is that the memory allocation code may think that 1 more UV is
6406      * being used than actually is, and so might do an unnecessary grow.  That
6407      * seems worth not bothering to make this the precise amount.
6408      *
6409      * Note that when inverting, SvCUR shouldn't change */
6410 }
6411
6412 PERL_STATIC_INLINE UV
6413 S_invlist_max(pTHX_ SV* const invlist)
6414 {
6415     /* Returns the maximum number of elements storable in the inversion list's
6416      * array, without having to realloc() */
6417
6418     PERL_ARGS_ASSERT_INVLIST_MAX;
6419
6420     return FROM_INTERNAL_SIZE(SvLEN(invlist));
6421 }
6422
6423 PERL_STATIC_INLINE UV*
6424 S_get_invlist_zero_addr(pTHX_ SV* invlist)
6425 {
6426     /* Return the address of the UV that is reserved to hold 0 if the inversion
6427      * list contains 0.  This has to be the last element of the heading, as the
6428      * list proper starts with either it if 0, or the next element if not.
6429      * (But we force it to contain either 0 or 1) */
6430
6431     PERL_ARGS_ASSERT_GET_INVLIST_ZERO_ADDR;
6432
6433     return (UV *) (SvPVX(invlist) + (INVLIST_ZERO_OFFSET * sizeof (UV)));
6434 }
6435
6436 #ifndef PERL_IN_XSUB_RE
6437 SV*
6438 Perl__new_invlist(pTHX_ IV initial_size)
6439 {
6440
6441     /* Return a pointer to a newly constructed inversion list, with enough
6442      * space to store 'initial_size' elements.  If that number is negative, a
6443      * system default is used instead */
6444
6445     SV* new_list;
6446
6447     if (initial_size < 0) {
6448         initial_size = INVLIST_INITIAL_LEN;
6449     }
6450
6451     /* Allocate the initial space */
6452     new_list = newSV(TO_INTERNAL_SIZE(initial_size));
6453     invlist_set_len(new_list, 0);
6454
6455     /* Force iterinit() to be used to get iteration to work */
6456     *get_invlist_iter_addr(new_list) = UV_MAX;
6457
6458     /* This should force a segfault if a method doesn't initialize this
6459      * properly */
6460     *get_invlist_zero_addr(new_list) = UV_MAX;
6461
6462     *get_invlist_version_id_addr(new_list) = INVLIST_VERSION_ID;
6463 #if HEADER_LENGTH != 4
6464 #   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
6465 #endif
6466
6467     return new_list;
6468 }
6469 #endif
6470
6471 STATIC SV*
6472 S__new_invlist_C_array(pTHX_ UV* list)
6473 {
6474     /* Return a pointer to a newly constructed inversion list, initialized to
6475      * point to <list>, which has to be in the exact correct inversion list
6476      * form, including internal fields.  Thus this is a dangerous routine that
6477      * should not be used in the wrong hands */
6478
6479     SV* invlist = newSV_type(SVt_PV);
6480
6481     PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
6482
6483     SvPV_set(invlist, (char *) list);
6484     SvLEN_set(invlist, 0);  /* Means we own the contents, and the system
6485                                shouldn't touch it */
6486     SvCUR_set(invlist, TO_INTERNAL_SIZE(invlist_len(invlist)));
6487
6488     if (*get_invlist_version_id_addr(invlist) != INVLIST_VERSION_ID) {
6489         Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
6490     }
6491
6492     return invlist;
6493 }
6494
6495 STATIC void
6496 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
6497 {
6498     /* Grow the maximum size of an inversion list */
6499
6500     PERL_ARGS_ASSERT_INVLIST_EXTEND;
6501
6502     SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max));
6503 }
6504
6505 PERL_STATIC_INLINE void
6506 S_invlist_trim(pTHX_ SV* const invlist)
6507 {
6508     PERL_ARGS_ASSERT_INVLIST_TRIM;
6509
6510     /* Change the length of the inversion list to how many entries it currently
6511      * has */
6512
6513     SvPV_shrink_to_cur((SV *) invlist);
6514 }
6515
6516 /* An element is in an inversion list iff its index is even numbered: 0, 2, 4,
6517  * etc */
6518 #define ELEMENT_RANGE_MATCHES_INVLIST(i) (! ((i) & 1))
6519 #define PREV_RANGE_MATCHES_INVLIST(i) (! ELEMENT_RANGE_MATCHES_INVLIST(i))
6520
6521 #define _invlist_union_complement_2nd(a, b, output) _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
6522
6523 STATIC void
6524 S__append_range_to_invlist(pTHX_ SV* const invlist, const UV start, const UV end)
6525 {
6526    /* Subject to change or removal.  Append the range from 'start' to 'end' at
6527     * the end of the inversion list.  The range must be above any existing
6528     * ones. */
6529
6530     UV* array;
6531     UV max = invlist_max(invlist);
6532     UV len = invlist_len(invlist);
6533
6534     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
6535
6536     if (len == 0) { /* Empty lists must be initialized */
6537         array = _invlist_array_init(invlist, start == 0);
6538     }
6539     else {
6540         /* Here, the existing list is non-empty. The current max entry in the
6541          * list is generally the first value not in the set, except when the
6542          * set extends to the end of permissible values, in which case it is
6543          * the first entry in that final set, and so this call is an attempt to
6544          * append out-of-order */
6545
6546         UV final_element = len - 1;
6547         array = invlist_array(invlist);
6548         if (array[final_element] > start
6549             || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
6550         {
6551             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",
6552                        array[final_element], start,
6553                        ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
6554         }
6555
6556         /* Here, it is a legal append.  If the new range begins with the first
6557          * value not in the set, it is extending the set, so the new first
6558          * value not in the set is one greater than the newly extended range.
6559          * */
6560         if (array[final_element] == start) {
6561             if (end != UV_MAX) {
6562                 array[final_element] = end + 1;
6563             }
6564             else {
6565                 /* But if the end is the maximum representable on the machine,
6566                  * just let the range that this would extend to have no end */
6567                 invlist_set_len(invlist, len - 1);
6568             }
6569             return;
6570         }
6571     }
6572
6573     /* Here the new range doesn't extend any existing set.  Add it */
6574
6575     len += 2;   /* Includes an element each for the start and end of range */
6576
6577     /* If overflows the existing space, extend, which may cause the array to be
6578      * moved */
6579     if (max < len) {
6580         invlist_extend(invlist, len);
6581         invlist_set_len(invlist, len);  /* Have to set len here to avoid assert
6582                                            failure in invlist_array() */
6583         array = invlist_array(invlist);
6584     }
6585     else {
6586         invlist_set_len(invlist, len);
6587     }
6588
6589     /* The next item on the list starts the range, the one after that is
6590      * one past the new range.  */
6591     array[len - 2] = start;
6592     if (end != UV_MAX) {
6593         array[len - 1] = end + 1;
6594     }
6595     else {
6596         /* But if the end is the maximum representable on the machine, just let
6597          * the range have no end */
6598         invlist_set_len(invlist, len - 1);
6599     }
6600 }
6601
6602 #ifndef PERL_IN_XSUB_RE
6603
6604 STATIC IV
6605 S_invlist_search(pTHX_ SV* const invlist, const UV cp)
6606 {
6607     /* Searches the inversion list for the entry that contains the input code
6608      * point <cp>.  If <cp> is not in the list, -1 is returned.  Otherwise, the
6609      * return value is the index into the list's array of the range that
6610      * contains <cp> */
6611
6612     IV low = 0;
6613     IV high = invlist_len(invlist);
6614     const UV * const array = invlist_array(invlist);
6615
6616     PERL_ARGS_ASSERT_INVLIST_SEARCH;
6617
6618     /* If list is empty or the code point is before the first element, return
6619      * failure. */
6620     if (high == 0 || cp < array[0]) {
6621         return -1;
6622     }
6623
6624     /* Binary search.  What we are looking for is <i> such that
6625      *  array[i] <= cp < array[i+1]
6626      * The loop below converges on the i+1. */
6627     while (low < high) {
6628         IV mid = (low + high) / 2;
6629         if (array[mid] <= cp) {
6630             low = mid + 1;
6631
6632             /* We could do this extra test to exit the loop early.
6633             if (cp < array[low]) {
6634                 return mid;
6635             }
6636             */
6637         }
6638         else { /* cp < array[mid] */
6639             high = mid;
6640         }
6641     }
6642
6643     return high - 1;
6644 }
6645
6646 void
6647 Perl__invlist_populate_swatch(pTHX_ SV* const invlist, const UV start, const UV end, U8* swatch)
6648 {
6649     /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
6650      * but is used when the swash has an inversion list.  This makes this much
6651      * faster, as it uses a binary search instead of a linear one.  This is
6652      * intimately tied to that function, and perhaps should be in utf8.c,
6653      * except it is intimately tied to inversion lists as well.  It assumes
6654      * that <swatch> is all 0's on input */
6655
6656     UV current = start;
6657     const IV len = invlist_len(invlist);
6658     IV i;
6659     const UV * array;
6660
6661     PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
6662
6663     if (len == 0) { /* Empty inversion list */
6664         return;
6665     }
6666
6667     array = invlist_array(invlist);
6668
6669     /* Find which element it is */
6670     i = invlist_search(invlist, start);
6671
6672     /* We populate from <start> to <end> */
6673     while (current < end) {
6674         UV upper;
6675
6676         /* The inversion list gives the results for every possible code point
6677          * after the first one in the list.  Only those ranges whose index is
6678          * even are ones that the inversion list matches.  For the odd ones,
6679          * and if the initial code point is not in the list, we have to skip
6680          * forward to the next element */
6681         if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
6682             i++;
6683             if (i >= len) { /* Finished if beyond the end of the array */
6684                 return;
6685             }
6686             current = array[i];
6687             if (current >= end) {   /* Finished if beyond the end of what we
6688                                        are populating */
6689                 return;
6690             }
6691         }
6692         assert(current >= start);
6693
6694         /* The current range ends one below the next one, except don't go past
6695          * <end> */
6696         i++;
6697         upper = (i < len && array[i] < end) ? array[i] : end;
6698
6699         /* Here we are in a range that matches.  Populate a bit in the 3-bit U8
6700          * for each code point in it */
6701         for (; current < upper; current++) {
6702             const STRLEN offset = (STRLEN)(current - start);
6703             swatch[offset >> 3] |= 1 << (offset & 7);
6704         }
6705
6706         /* Quit if at the end of the list */
6707         if (i >= len) {
6708
6709             /* But first, have to deal with the highest possible code point on
6710              * the platform.  The previous code assumes that <end> is one
6711              * beyond where we want to populate, but that is impossible at the
6712              * platform's infinity, so have to handle it specially */
6713             if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
6714             {
6715                 const STRLEN offset = (STRLEN)(end - start);
6716                 swatch[offset >> 3] |= 1 << (offset & 7);
6717             }
6718             return;
6719         }
6720
6721         /* Advance to the next range, which will be for code points not in the
6722          * inversion list */
6723         current = array[i];
6724     }
6725
6726     return;
6727 }
6728
6729
6730 void
6731 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** output)
6732 {
6733     /* Take the union of two inversion lists and point <output> to it.  *output
6734      * should be defined upon input, and if it points to one of the two lists,
6735      * the reference count to that list will be decremented.  The first list,
6736      * <a>, may be NULL, in which case a copy of the second list is returned.
6737      * If <complement_b> is TRUE, the union is taken of the complement
6738      * (inversion) of <b> instead of b itself.
6739      *
6740      * The basis for this comes from "Unicode Demystified" Chapter 13 by
6741      * Richard Gillam, published by Addison-Wesley, and explained at some
6742      * length there.  The preface says to incorporate its examples into your
6743      * code at your own risk.
6744      *
6745      * The algorithm is like a merge sort.
6746      *
6747      * XXX A potential performance improvement is to keep track as we go along
6748      * if only one of the inputs contributes to the result, meaning the other
6749      * is a subset of that one.  In that case, we can skip the final copy and
6750      * return the larger of the input lists, but then outside code might need
6751      * to keep track of whether to free the input list or not */
6752
6753     UV* array_a;    /* a's array */
6754     UV* array_b;
6755     UV len_a;       /* length of a's array */
6756     UV len_b;
6757
6758     SV* u;                      /* the resulting union */
6759     UV* array_u;
6760     UV len_u;
6761
6762     UV i_a = 0;             /* current index into a's array */
6763     UV i_b = 0;
6764     UV i_u = 0;
6765
6766     /* running count, as explained in the algorithm source book; items are
6767      * stopped accumulating and are output when the count changes to/from 0.
6768      * The count is incremented when we start a range that's in the set, and
6769      * decremented when we start a range that's not in the set.  So its range
6770      * is 0 to 2.  Only when the count is zero is something not in the set.
6771      */
6772     UV count = 0;
6773
6774     PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
6775     assert(a != b);
6776
6777     /* If either one is empty, the union is the other one */
6778     if (a == NULL || ((len_a = invlist_len(a)) == 0)) {
6779         if (*output == a) {
6780             if (a != NULL) {
6781                 SvREFCNT_dec(a);
6782             }
6783         }
6784         if (*output != b) {
6785             *output = invlist_clone(b);
6786             if (complement_b) {
6787                 _invlist_invert(*output);
6788             }
6789         } /* else *output already = b; */
6790         return;
6791     }
6792     else if ((len_b = invlist_len(b)) == 0) {
6793         if (*output == b) {
6794             SvREFCNT_dec(b);
6795         }
6796
6797         /* The complement of an empty list is a list that has everything in it,
6798          * so the union with <a> includes everything too */
6799         if (complement_b) {
6800             if (a == *output) {
6801                 SvREFCNT_dec(a);
6802             }
6803             *output = _new_invlist(1);
6804             _append_range_to_invlist(*output, 0, UV_MAX);
6805         }
6806         else if (*output != a) {
6807             *output = invlist_clone(a);
6808         }
6809         /* else *output already = a; */
6810         return;
6811     }
6812
6813     /* Here both lists exist and are non-empty */
6814     array_a = invlist_array(a);
6815     array_b = invlist_array(b);
6816
6817     /* If are to take the union of 'a' with the complement of b, set it
6818      * up so are looking at b's complement. */
6819     if (complement_b) {
6820
6821         /* To complement, we invert: if the first element is 0, remove it.  To
6822          * do this, we just pretend the array starts one later, and clear the
6823          * flag as we don't have to do anything else later */
6824         if (array_b[0] == 0) {
6825             array_b++;
6826             len_b--;
6827             complement_b = FALSE;
6828         }
6829         else {
6830
6831             /* But if the first element is not zero, we unshift a 0 before the
6832              * array.  The data structure reserves a space for that 0 (which
6833              * should be a '1' right now), so physical shifting is unneeded,
6834              * but temporarily change that element to 0.  Before exiting the
6835              * routine, we must restore the element to '1' */
6836             array_b--;
6837             len_b++;
6838             array_b[0] = 0;
6839         }
6840     }
6841
6842     /* Size the union for the worst case: that the sets are completely
6843      * disjoint */
6844     u = _new_invlist(len_a + len_b);
6845
6846     /* Will contain U+0000 if either component does */
6847     array_u = _invlist_array_init(u, (len_a > 0 && array_a[0] == 0)
6848                                       || (len_b > 0 && array_b[0] == 0));
6849
6850     /* Go through each list item by item, stopping when exhausted one of
6851      * them */
6852     while (i_a < len_a && i_b < len_b) {
6853         UV cp;      /* The element to potentially add to the union's array */
6854         bool cp_in_set;   /* is it in the the input list's set or not */
6855
6856         /* We need to take one or the other of the two inputs for the union.
6857          * Since we are merging two sorted lists, we take the smaller of the
6858          * next items.  In case of a tie, we take the one that is in its set
6859          * first.  If we took one not in the set first, it would decrement the
6860          * count, possibly to 0 which would cause it to be output as ending the
6861          * range, and the next time through we would take the same number, and
6862          * output it again as beginning the next range.  By doing it the
6863          * opposite way, there is no possibility that the count will be
6864          * momentarily decremented to 0, and thus the two adjoining ranges will
6865          * be seamlessly merged.  (In a tie and both are in the set or both not
6866          * in the set, it doesn't matter which we take first.) */
6867         if (array_a[i_a] < array_b[i_b]
6868             || (array_a[i_a] == array_b[i_b]
6869                 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
6870         {
6871             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
6872             cp= array_a[i_a++];
6873         }
6874         else {
6875             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
6876             cp= array_b[i_b++];
6877         }
6878
6879         /* Here, have chosen which of the two inputs to look at.  Only output
6880          * if the running count changes to/from 0, which marks the
6881          * beginning/end of a range in that's in the set */
6882         if (cp_in_set) {
6883             if (count == 0) {
6884                 array_u[i_u++] = cp;
6885             }
6886             count++;
6887         }
6888         else {
6889             count--;
6890             if (count == 0) {
6891                 array_u[i_u++] = cp;
6892             }
6893         }
6894     }
6895
6896     /* Here, we are finished going through at least one of the lists, which
6897      * means there is something remaining in at most one.  We check if the list
6898      * that hasn't been exhausted is positioned such that we are in the middle
6899      * of a range in its set or not.  (i_a and i_b point to the element beyond
6900      * the one we care about.) If in the set, we decrement 'count'; if 0, there
6901      * is potentially more to output.
6902      * There are four cases:
6903      *  1) Both weren't in their sets, count is 0, and remains 0.  What's left
6904      *     in the union is entirely from the non-exhausted set.
6905      *  2) Both were in their sets, count is 2.  Nothing further should
6906      *     be output, as everything that remains will be in the exhausted
6907      *     list's set, hence in the union; decrementing to 1 but not 0 insures
6908      *     that
6909      *  3) the exhausted was in its set, non-exhausted isn't, count is 1.
6910      *     Nothing further should be output because the union includes
6911      *     everything from the exhausted set.  Not decrementing ensures that.
6912      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1;
6913      *     decrementing to 0 insures that we look at the remainder of the
6914      *     non-exhausted set */
6915     if ((i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
6916         || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
6917     {
6918         count--;
6919     }
6920
6921     /* The final length is what we've output so far, plus what else is about to
6922      * be output.  (If 'count' is non-zero, then the input list we exhausted
6923      * has everything remaining up to the machine's limit in its set, and hence
6924      * in the union, so there will be no further output. */
6925     len_u = i_u;
6926     if (count == 0) {
6927         /* At most one of the subexpressions will be non-zero */
6928         len_u += (len_a - i_a) + (len_b - i_b);
6929     }
6930
6931     /* Set result to final length, which can change the pointer to array_u, so
6932      * re-find it */
6933     if (len_u != invlist_len(u)) {
6934         invlist_set_len(u, len_u);
6935         invlist_trim(u);
6936         array_u = invlist_array(u);
6937     }
6938
6939     /* When 'count' is 0, the list that was exhausted (if one was shorter than
6940      * the other) ended with everything above it not in its set.  That means
6941      * that the remaining part of the union is precisely the same as the
6942      * non-exhausted list, so can just copy it unchanged.  (If both list were
6943      * exhausted at the same time, then the operations below will be both 0.)
6944      */
6945     if (count == 0) {
6946         IV copy_count; /* At most one will have a non-zero copy count */
6947         if ((copy_count = len_a - i_a) > 0) {
6948             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
6949         }
6950         else if ((copy_count = len_b - i_b) > 0) {
6951             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
6952         }
6953     }
6954
6955     /*  We may be removing a reference to one of the inputs */
6956     if (a == *output || b == *output) {
6957         SvREFCNT_dec(*output);
6958     }
6959
6960     /* If we've changed b, restore it */
6961     if (complement_b) {
6962         array_b[0] = 1;
6963     }
6964
6965     *output = u;
6966     return;
6967 }
6968
6969 void
6970 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** i)
6971 {
6972     /* Take the intersection of two inversion lists and point <i> to it.  *i
6973      * should be defined upon input, and if it points to one of the two lists,
6974      * the reference count to that list will be decremented.
6975      * If <complement_b> is TRUE, the result will be the intersection of <a>
6976      * and the complement (or inversion) of <b> instead of <b> directly.
6977      *
6978      * The basis for this comes from "Unicode Demystified" Chapter 13 by
6979      * Richard Gillam, published by Addison-Wesley, and explained at some
6980      * length there.  The preface says to incorporate its examples into your
6981      * code at your own risk.  In fact, it had bugs
6982      *
6983      * The algorithm is like a merge sort, and is essentially the same as the
6984      * union above
6985      */
6986
6987     UV* array_a;                /* a's array */
6988     UV* array_b;
6989     UV len_a;   /* length of a's array */
6990     UV len_b;
6991
6992     SV* r;                   /* the resulting intersection */
6993     UV* array_r;
6994     UV len_r;
6995
6996     UV i_a = 0;             /* current index into a's array */
6997     UV i_b = 0;
6998     UV i_r = 0;
6999
7000     /* running count, as explained in the algorithm source book; items are
7001      * stopped accumulating and are output when the count changes to/from 2.
7002      * The count is incremented when we start a range that's in the set, and
7003      * decremented when we start a range that's not in the set.  So its range
7004      * is 0 to 2.  Only when the count is 2 is something in the intersection.
7005      */
7006     UV count = 0;
7007
7008     PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
7009     assert(a != b);
7010
7011     /* Special case if either one is empty */
7012     len_a = invlist_len(a);
7013     if ((len_a == 0) || ((len_b = invlist_len(b)) == 0)) {
7014
7015         if (len_a != 0 && complement_b) {
7016
7017             /* Here, 'a' is not empty, therefore from the above 'if', 'b' must
7018              * be empty.  Here, also we are using 'b's complement, which hence
7019              * must be every possible code point.  Thus the intersection is
7020              * simply 'a'. */
7021             if (*i != a) {
7022                 *i = invlist_clone(a);
7023
7024                 if (*i == b) {
7025                     SvREFCNT_dec(b);
7026                 }
7027             }
7028             /* else *i is already 'a' */
7029             return;
7030         }
7031
7032         /* Here, 'a' or 'b' is empty and not using the complement of 'b'.  The
7033          * intersection must be empty */
7034         if (*i == a) {
7035             SvREFCNT_dec(a);
7036         }
7037         else if (*i == b) {
7038             SvREFCNT_dec(b);
7039         }
7040         *i = _new_invlist(0);
7041         return;
7042     }
7043
7044     /* Here both lists exist and are non-empty */
7045     array_a = invlist_array(a);
7046     array_b = invlist_array(b);
7047
7048     /* If are to take the intersection of 'a' with the complement of b, set it
7049      * up so are looking at b's complement. */
7050     if (complement_b) {
7051
7052         /* To complement, we invert: if the first element is 0, remove it.  To
7053          * do this, we just pretend the array starts one later, and clear the
7054          * flag as we don't have to do anything else later */
7055         if (array_b[0] == 0) {
7056             array_b++;
7057             len_b--;
7058             complement_b = FALSE;
7059         }
7060         else {
7061
7062             /* But if the first element is not zero, we unshift a 0 before the
7063              * array.  The data structure reserves a space for that 0 (which
7064              * should be a '1' right now), so physical shifting is unneeded,
7065              * but temporarily change that element to 0.  Before exiting the
7066              * routine, we must restore the element to '1' */
7067             array_b--;
7068             len_b++;
7069             array_b[0] = 0;
7070         }
7071     }
7072
7073     /* Size the intersection for the worst case: that the intersection ends up
7074      * fragmenting everything to be completely disjoint */
7075     r= _new_invlist(len_a + len_b);
7076
7077     /* Will contain U+0000 iff both components do */
7078     array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
7079                                      && len_b > 0 && array_b[0] == 0);
7080
7081     /* Go through each list item by item, stopping when exhausted one of
7082      * them */
7083     while (i_a < len_a && i_b < len_b) {
7084         UV cp;      /* The element to potentially add to the intersection's
7085                        array */
7086         bool cp_in_set; /* Is it in the input list's set or not */
7087
7088         /* We need to take one or the other of the two inputs for the
7089          * intersection.  Since we are merging two sorted lists, we take the
7090          * smaller of the next items.  In case of a tie, we take the one that
7091          * is not in its set first (a difference from the union algorithm).  If
7092          * we took one in the set first, it would increment the count, possibly
7093          * to 2 which would cause it to be output as starting a range in the
7094          * intersection, and the next time through we would take that same
7095          * number, and output it again as ending the set.  By doing it the
7096          * opposite of this, there is no possibility that the count will be
7097          * momentarily incremented to 2.  (In a tie and both are in the set or
7098          * both not in the set, it doesn't matter which we take first.) */
7099         if (array_a[i_a] < array_b[i_b]
7100             || (array_a[i_a] == array_b[i_b]
7101                 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
7102         {
7103             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
7104             cp= array_a[i_a++];
7105         }
7106         else {
7107             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
7108             cp= array_b[i_b++];
7109         }
7110
7111         /* Here, have chosen which of the two inputs to look at.  Only output
7112          * if the running count changes to/from 2, which marks the
7113          * beginning/end of a range that's in the intersection */
7114         if (cp_in_set) {
7115             count++;
7116             if (count == 2) {
7117                 array_r[i_r++] = cp;
7118             }
7119         }
7120         else {
7121             if (count == 2) {
7122                 array_r[i_r++] = cp;
7123             }
7124             count--;
7125         }
7126     }
7127
7128     /* Here, we are finished going through at least one of the lists, which
7129      * means there is something remaining in at most one.  We check if the list
7130      * that has been exhausted is positioned such that we are in the middle
7131      * of a range in its set or not.  (i_a and i_b point to elements 1 beyond
7132      * the ones we care about.)  There are four cases:
7133      *  1) Both weren't in their sets, count is 0, and remains 0.  There's
7134      *     nothing left in the intersection.
7135      *  2) Both were in their sets, count is 2 and perhaps is incremented to
7136      *     above 2.  What should be output is exactly that which is in the
7137      *     non-exhausted set, as everything it has is also in the intersection
7138      *     set, and everything it doesn't have can't be in the intersection
7139      *  3) The exhausted was in its set, non-exhausted isn't, count is 1, and
7140      *     gets incremented to 2.  Like the previous case, the intersection is
7141      *     everything that remains in the non-exhausted set.
7142      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1, and
7143      *     remains 1.  And the intersection has nothing more. */
7144     if ((i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
7145         || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
7146     {
7147         count++;
7148     }
7149
7150     /* The final length is what we've output so far plus what else is in the
7151      * intersection.  At most one of the subexpressions below will be non-zero */
7152     len_r = i_r;
7153     if (count >= 2) {
7154         len_r += (len_a - i_a) + (len_b - i_b);
7155     }
7156
7157     /* Set result to final length, which can change the pointer to array_r, so
7158      * re-find it */
7159     if (len_r != invlist_len(r)) {
7160         invlist_set_len(r, len_r);
7161         invlist_trim(r);
7162         array_r = invlist_array(r);
7163     }
7164
7165     /* Finish outputting any remaining */
7166     if (count >= 2) { /* At most one will have a non-zero copy count */
7167         IV copy_count;
7168         if ((copy_count = len_a - i_a) > 0) {
7169             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
7170         }
7171         else if ((copy_count = len_b - i_b) > 0) {
7172             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
7173         }
7174     }
7175
7176     /*  We may be removing a reference to one of the inputs */
7177     if (a == *i || b == *i) {
7178         SvREFCNT_dec(*i);
7179     }
7180
7181     /* If we've changed b, restore it */
7182     if (complement_b) {
7183         array_b[0] = 1;
7184     }
7185
7186     *i = r;
7187     return;
7188 }
7189
7190 SV*
7191 Perl__add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end)
7192 {
7193     /* Add the range from 'start' to 'end' inclusive to the inversion list's
7194      * set.  A pointer to the inversion list is returned.  This may actually be
7195      * a new list, in which case the passed in one has been destroyed.  The
7196      * passed in inversion list can be NULL, in which case a new one is created
7197      * with just the one range in it */
7198
7199     SV* range_invlist;
7200     UV len;
7201
7202     if (invlist == NULL) {
7203         invlist = _new_invlist(2);
7204         len = 0;
7205     }
7206     else {
7207         len = invlist_len(invlist);
7208     }
7209
7210     /* If comes after the final entry, can just append it to the end */
7211     if (len == 0
7212         || start >= invlist_array(invlist)
7213                                     [invlist_len(invlist) - 1])
7214     {
7215         _append_range_to_invlist(invlist, start, end);
7216         return invlist;
7217     }
7218
7219     /* Here, can't just append things, create and return a new inversion list
7220      * which is the union of this range and the existing inversion list */
7221     range_invlist = _new_invlist(2);
7222     _append_range_to_invlist(range_invlist, start, end);
7223
7224     _invlist_union(invlist, range_invlist, &invlist);
7225
7226     /* The temporary can be freed */
7227     SvREFCNT_dec(range_invlist);
7228
7229     return invlist;
7230 }
7231
7232 #endif
7233
7234 PERL_STATIC_INLINE SV*
7235 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
7236     return _add_range_to_invlist(invlist, cp, cp);
7237 }
7238
7239 #ifndef PERL_IN_XSUB_RE
7240 void
7241 Perl__invlist_invert(pTHX_ SV* const invlist)
7242 {
7243     /* Complement the input inversion list.  This adds a 0 if the list didn't
7244      * have a zero; removes it otherwise.  As described above, the data
7245      * structure is set up so that this is very efficient */
7246
7247     UV* len_pos = get_invlist_len_addr(invlist);
7248
7249     PERL_ARGS_ASSERT__INVLIST_INVERT;
7250
7251     /* The inverse of matching nothing is matching everything */
7252     if (*len_pos == 0) {
7253         _append_range_to_invlist(invlist, 0, UV_MAX);
7254         return;
7255     }
7256
7257     /* The exclusive or complents 0 to 1; and 1 to 0.  If the result is 1, the
7258      * zero element was a 0, so it is being removed, so the length decrements
7259      * by 1; and vice-versa.  SvCUR is unaffected */
7260     if (*get_invlist_zero_addr(invlist) ^= 1) {
7261         (*len_pos)--;
7262     }
7263     else {
7264         (*len_pos)++;
7265     }
7266 }
7267
7268 void
7269 Perl__invlist_invert_prop(pTHX_ SV* const invlist)
7270 {
7271     /* Complement the input inversion list (which must be a Unicode property,
7272      * all of which don't match above the Unicode maximum code point.)  And
7273      * Perl has chosen to not have the inversion match above that either.  This
7274      * adds a 0x110000 if the list didn't end with it, and removes it if it did
7275      */
7276
7277     UV len;
7278     UV* array;
7279
7280     PERL_ARGS_ASSERT__INVLIST_INVERT_PROP;
7281
7282     _invlist_invert(invlist);
7283
7284     len = invlist_len(invlist);
7285
7286     if (len != 0) { /* If empty do nothing */
7287         array = invlist_array(invlist);
7288         if (array[len - 1] != PERL_UNICODE_MAX + 1) {
7289             /* Add 0x110000.  First, grow if necessary */
7290             len++;
7291             if (invlist_max(invlist) < len) {
7292                 invlist_extend(invlist, len);
7293                 array = invlist_array(invlist);
7294             }
7295             invlist_set_len(invlist, len);
7296             array[len - 1] = PERL_UNICODE_MAX + 1;
7297         }
7298         else {  /* Remove the 0x110000 */
7299             invlist_set_len(invlist, len - 1);
7300         }
7301     }
7302
7303     return;
7304 }
7305 #endif
7306
7307 PERL_STATIC_INLINE SV*
7308 S_invlist_clone(pTHX_ SV* const invlist)
7309 {
7310
7311     /* Return a new inversion list that is a copy of the input one, which is
7312      * unchanged */
7313
7314     /* Need to allocate extra space to accommodate Perl's addition of a
7315      * trailing NUL to SvPV's, since it thinks they are always strings */
7316     SV* new_invlist = _new_invlist(invlist_len(invlist) + 1);
7317     STRLEN length = SvCUR(invlist);
7318
7319     PERL_ARGS_ASSERT_INVLIST_CLONE;
7320
7321     SvCUR_set(new_invlist, length); /* This isn't done automatically */
7322     Copy(SvPVX(invlist), SvPVX(new_invlist), length, char);
7323
7324     return new_invlist;
7325 }
7326
7327 PERL_STATIC_INLINE UV*
7328 S_get_invlist_iter_addr(pTHX_ SV* invlist)
7329 {
7330     /* Return the address of the UV that contains the current iteration
7331      * position */
7332
7333     PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
7334
7335     return (UV *) (SvPVX(invlist) + (INVLIST_ITER_OFFSET * sizeof (UV)));
7336 }
7337
7338 PERL_STATIC_INLINE UV*
7339 S_get_invlist_version_id_addr(pTHX_ SV* invlist)
7340 {
7341     /* Return the address of the UV that contains the version id. */
7342
7343     PERL_ARGS_ASSERT_GET_INVLIST_VERSION_ID_ADDR;
7344
7345     return (UV *) (SvPVX(invlist) + (INVLIST_VERSION_ID_OFFSET * sizeof (UV)));
7346 }
7347
7348 PERL_STATIC_INLINE void
7349 S_invlist_iterinit(pTHX_ SV* invlist)   /* Initialize iterator for invlist */
7350 {
7351     PERL_ARGS_ASSERT_INVLIST_ITERINIT;
7352
7353     *get_invlist_iter_addr(invlist) = 0;
7354 }
7355
7356 STATIC bool
7357 S_invlist_iternext(pTHX_ SV* invlist, UV* start, UV* end)
7358 {
7359     /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
7360      * This call sets in <*start> and <*end>, the next range in <invlist>.
7361      * Returns <TRUE> if successful and the next call will return the next
7362      * range; <FALSE> if was already at the end of the list.  If the latter,
7363      * <*start> and <*end> are unchanged, and the next call to this function
7364      * will start over at the beginning of the list */
7365
7366     UV* pos = get_invlist_iter_addr(invlist);
7367     UV len = invlist_len(invlist);
7368     UV *array;
7369
7370     PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
7371
7372     if (*pos >= len) {
7373         *pos = UV_MAX;  /* Force iternit() to be required next time */
7374         return FALSE;
7375     }
7376
7377     array = invlist_array(invlist);
7378
7379     *start = array[(*pos)++];
7380
7381     if (*pos >= len) {
7382         *end = UV_MAX;
7383     }
7384     else {
7385         *end = array[(*pos)++] - 1;
7386     }
7387
7388     return TRUE;
7389 }
7390
7391 #ifndef PERL_IN_XSUB_RE
7392 SV *
7393 Perl__invlist_contents(pTHX_ SV* const invlist)
7394 {
7395     /* Get the contents of an inversion list into a string SV so that they can
7396      * be printed out.  It uses the format traditionally done for debug tracing
7397      */
7398
7399     UV start, end;
7400     SV* output = newSVpvs("\n");
7401
7402     PERL_ARGS_ASSERT__INVLIST_CONTENTS;
7403
7404     invlist_iterinit(invlist);
7405     while (invlist_iternext(invlist, &start, &end)) {
7406         if (end == UV_MAX) {
7407             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\tINFINITY\n", start);
7408         }
7409         else if (end != start) {
7410             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\t%04"UVXf"\n",
7411                     start,       end);
7412         }
7413         else {
7414             Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\n", start);
7415         }
7416     }
7417
7418     return output;
7419 }
7420 #endif
7421
7422 #if 0
7423 void
7424 S_invlist_dump(pTHX_ SV* const invlist, const char * const header)
7425 {
7426     /* Dumps out the ranges in an inversion list.  The string 'header'
7427      * if present is output on a line before the first range */
7428
7429     UV start, end;
7430
7431     if (header && strlen(header)) {
7432         PerlIO_printf(Perl_debug_log, "%s\n", header);
7433     }
7434     invlist_iterinit(invlist);
7435     while (invlist_iternext(invlist, &start, &end)) {
7436         if (end == UV_MAX) {
7437             PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. INFINITY\n", start);
7438         }
7439         else {
7440             PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. 0x%04"UVXf"\n", start, end);
7441         }
7442     }
7443 }
7444 #endif
7445
7446 #undef HEADER_LENGTH
7447 #undef INVLIST_INITIAL_LENGTH
7448 #undef TO_INTERNAL_SIZE
7449 #undef FROM_INTERNAL_SIZE
7450 #undef INVLIST_LEN_OFFSET
7451 #undef INVLIST_ZERO_OFFSET
7452 #undef INVLIST_ITER_OFFSET
7453 #undef INVLIST_VERSION_ID
7454
7455 /* End of inversion list object */
7456
7457 /*
7458  - reg - regular expression, i.e. main body or parenthesized thing
7459  *
7460  * Caller must absorb opening parenthesis.
7461  *
7462  * Combining parenthesis handling with the base level of regular expression
7463  * is a trifle forced, but the need to tie the tails of the branches to what
7464  * follows makes it hard to avoid.
7465  */
7466 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
7467 #ifdef DEBUGGING
7468 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
7469 #else
7470 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
7471 #endif
7472
7473 STATIC regnode *
7474 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
7475     /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
7476 {
7477     dVAR;
7478     register regnode *ret;              /* Will be the head of the group. */
7479     register regnode *br;
7480     register regnode *lastbr;
7481     register regnode *ender = NULL;
7482     register I32 parno = 0;
7483     I32 flags;
7484     U32 oregflags = RExC_flags;
7485     bool have_branch = 0;
7486     bool is_open = 0;
7487     I32 freeze_paren = 0;
7488     I32 after_freeze = 0;
7489
7490     /* for (?g), (?gc), and (?o) warnings; warning
7491        about (?c) will warn about (?g) -- japhy    */
7492
7493 #define WASTED_O  0x01
7494 #define WASTED_G  0x02
7495 #define WASTED_C  0x04
7496 #define WASTED_GC (0x02|0x04)
7497     I32 wastedflags = 0x00;
7498
7499     char * parse_start = RExC_parse; /* MJD */
7500     char * const oregcomp_parse = RExC_parse;
7501
7502     GET_RE_DEBUG_FLAGS_DECL;
7503
7504     PERL_ARGS_ASSERT_REG;
7505     DEBUG_PARSE("reg ");
7506
7507     *flagp = 0;                         /* Tentatively. */
7508
7509
7510     /* Make an OPEN node, if parenthesized. */
7511     if (paren) {
7512         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
7513             char *start_verb = RExC_parse;
7514             STRLEN verb_len = 0;
7515             char *start_arg = NULL;
7516             unsigned char op = 0;
7517             int argok = 1;
7518             int internal_argval = 0; /* internal_argval is only useful if !argok */
7519             while ( *RExC_parse && *RExC_parse != ')' ) {
7520                 if ( *RExC_parse == ':' ) {
7521                     start_arg = RExC_parse + 1;
7522                     break;
7523                 }
7524                 RExC_parse++;
7525             }
7526             ++start_verb;
7527             verb_len = RExC_parse - start_verb;
7528             if ( start_arg ) {
7529                 RExC_parse++;
7530                 while ( *RExC_parse && *RExC_parse != ')' ) 
7531                     RExC_parse++;
7532                 if ( *RExC_parse != ')' ) 
7533                     vFAIL("Unterminated verb pattern argument");
7534                 if ( RExC_parse == start_arg )
7535                     start_arg = NULL;
7536             } else {
7537                 if ( *RExC_parse != ')' )
7538                     vFAIL("Unterminated verb pattern");
7539             }
7540             
7541             switch ( *start_verb ) {
7542             case 'A':  /* (*ACCEPT) */
7543                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
7544                     op = ACCEPT;
7545                     internal_argval = RExC_nestroot;
7546                 }
7547                 break;
7548             case 'C':  /* (*COMMIT) */
7549                 if ( memEQs(start_verb,verb_len,"COMMIT") )
7550                     op = COMMIT;
7551                 break;
7552             case 'F':  /* (*FAIL) */
7553                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
7554                     op = OPFAIL;
7555                     argok = 0;
7556                 }
7557                 break;
7558             case ':':  /* (*:NAME) */
7559             case 'M':  /* (*MARK:NAME) */
7560                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
7561                     op = MARKPOINT;
7562                     argok = -1;
7563                 }
7564                 break;
7565             case 'P':  /* (*PRUNE) */
7566                 if ( memEQs(start_verb,verb_len,"PRUNE") )
7567                     op = PRUNE;
7568                 break;
7569             case 'S':   /* (*SKIP) */  
7570                 if ( memEQs(start_verb,verb_len,"SKIP") ) 
7571                     op = SKIP;
7572                 break;
7573             case 'T':  /* (*THEN) */
7574                 /* [19:06] <TimToady> :: is then */
7575                 if ( memEQs(start_verb,verb_len,"THEN") ) {
7576                     op = CUTGROUP;
7577                     RExC_seen |= REG_SEEN_CUTGROUP;
7578                 }
7579                 break;
7580             }
7581             if ( ! op ) {
7582                 RExC_parse++;
7583                 vFAIL3("Unknown verb pattern '%.*s'",
7584                     verb_len, start_verb);
7585             }
7586             if ( argok ) {
7587                 if ( start_arg && internal_argval ) {
7588                     vFAIL3("Verb pattern '%.*s' may not have an argument",
7589                         verb_len, start_verb); 
7590                 } else if ( argok < 0 && !start_arg ) {
7591                     vFAIL3("Verb pattern '%.*s' has a mandatory argument",
7592                         verb_len, start_verb);    
7593                 } else {
7594                     ret = reganode(pRExC_state, op, internal_argval);
7595                     if ( ! internal_argval && ! SIZE_ONLY ) {
7596                         if (start_arg) {
7597                             SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
7598                             ARG(ret) = add_data( pRExC_state, 1, "S" );
7599                             RExC_rxi->data->data[ARG(ret)]=(void*)sv;
7600                             ret->flags = 0;
7601                         } else {
7602                             ret->flags = 1; 
7603                         }
7604                     }               
7605                 }
7606                 if (!internal_argval)
7607                     RExC_seen |= REG_SEEN_VERBARG;
7608             } else if ( start_arg ) {
7609                 vFAIL3("Verb pattern '%.*s' may not have an argument",
7610                         verb_len, start_verb);    
7611             } else {
7612                 ret = reg_node(pRExC_state, op);
7613             }
7614             nextchar(pRExC_state);
7615             return ret;
7616         } else 
7617         if (*RExC_parse == '?') { /* (?...) */
7618             bool is_logical = 0;
7619             const char * const seqstart = RExC_parse;
7620             bool has_use_defaults = FALSE;
7621
7622             RExC_parse++;
7623             paren = *RExC_parse++;
7624             ret = NULL;                 /* For look-ahead/behind. */
7625             switch (paren) {
7626
7627             case 'P':   /* (?P...) variants for those used to PCRE/Python */
7628                 paren = *RExC_parse++;
7629                 if ( paren == '<')         /* (?P<...>) named capture */
7630                     goto named_capture;
7631                 else if (paren == '>') {   /* (?P>name) named recursion */
7632                     goto named_recursion;
7633                 }
7634                 else if (paren == '=') {   /* (?P=...)  named backref */
7635                     /* this pretty much dupes the code for \k<NAME> in regatom(), if
7636                        you change this make sure you change that */
7637                     char* name_start = RExC_parse;
7638                     U32 num = 0;
7639                     SV *sv_dat = reg_scan_name(pRExC_state,
7640                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
7641                     if (RExC_parse == name_start || *RExC_parse != ')')
7642                         vFAIL2("Sequence %.3s... not terminated",parse_start);
7643
7644                     if (!SIZE_ONLY) {
7645                         num = add_data( pRExC_state, 1, "S" );
7646                         RExC_rxi->data->data[num]=(void*)sv_dat;
7647                         SvREFCNT_inc_simple_void(sv_dat);
7648                     }
7649                     RExC_sawback = 1;
7650                     ret = reganode(pRExC_state,
7651                                    ((! FOLD)
7652                                      ? NREF
7653                                      : (MORE_ASCII_RESTRICTED)
7654                                        ? NREFFA
7655                                        : (AT_LEAST_UNI_SEMANTICS)
7656                                          ? NREFFU
7657                                          : (LOC)
7658                                            ? NREFFL
7659                                            : NREFF),
7660                                     num);
7661                     *flagp |= HASWIDTH;
7662
7663                     Set_Node_Offset(ret, parse_start+1);
7664                     Set_Node_Cur_Length(ret); /* MJD */
7665
7666                     nextchar(pRExC_state);
7667                     return ret;
7668                 }
7669                 RExC_parse++;
7670                 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7671                 /*NOTREACHED*/
7672             case '<':           /* (?<...) */
7673                 if (*RExC_parse == '!')
7674                     paren = ',';
7675                 else if (*RExC_parse != '=') 
7676               named_capture:
7677                 {               /* (?<...>) */
7678                     char *name_start;
7679                     SV *svname;
7680                     paren= '>';
7681             case '\'':          /* (?'...') */
7682                     name_start= RExC_parse;
7683                     svname = reg_scan_name(pRExC_state,
7684                         SIZE_ONLY ?  /* reverse test from the others */
7685                         REG_RSN_RETURN_NAME : 
7686                         REG_RSN_RETURN_NULL);
7687                     if (RExC_parse == name_start) {
7688                         RExC_parse++;
7689                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7690                         /*NOTREACHED*/
7691                     }
7692                     if (*RExC_parse != paren)
7693                         vFAIL2("Sequence (?%c... not terminated",
7694                             paren=='>' ? '<' : paren);
7695                     if (SIZE_ONLY) {
7696                         HE *he_str;
7697                         SV *sv_dat = NULL;
7698                         if (!svname) /* shouldn't happen */
7699                             Perl_croak(aTHX_
7700                                 "panic: reg_scan_name returned NULL");
7701                         if (!RExC_paren_names) {
7702                             RExC_paren_names= newHV();
7703                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
7704 #ifdef DEBUGGING
7705                             RExC_paren_name_list= newAV();
7706                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
7707 #endif
7708                         }
7709                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
7710                         if ( he_str )
7711                             sv_dat = HeVAL(he_str);
7712                         if ( ! sv_dat ) {
7713                             /* croak baby croak */
7714                             Perl_croak(aTHX_
7715                                 "panic: paren_name hash element allocation failed");
7716                         } else if ( SvPOK(sv_dat) ) {
7717                             /* (?|...) can mean we have dupes so scan to check
7718                                its already been stored. Maybe a flag indicating
7719                                we are inside such a construct would be useful,
7720                                but the arrays are likely to be quite small, so
7721                                for now we punt -- dmq */
7722                             IV count = SvIV(sv_dat);
7723                             I32 *pv = (I32*)SvPVX(sv_dat);
7724                             IV i;
7725                             for ( i = 0 ; i < count ; i++ ) {
7726                                 if ( pv[i] == RExC_npar ) {
7727                                     count = 0;
7728                                     break;
7729                                 }
7730                             }
7731                             if ( count ) {
7732                                 pv = (I32*)SvGROW(sv_dat, SvCUR(sv_dat) + sizeof(I32)+1);
7733                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
7734                                 pv[count] = RExC_npar;
7735                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
7736                             }
7737                         } else {
7738                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
7739                             sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
7740                             SvIOK_on(sv_dat);
7741                             SvIV_set(sv_dat, 1);
7742                         }
7743 #ifdef DEBUGGING
7744                         /* Yes this does cause a memory leak in debugging Perls */
7745                         if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
7746                             SvREFCNT_dec(svname);
7747 #endif
7748
7749                         /*sv_dump(sv_dat);*/
7750                     }
7751                     nextchar(pRExC_state);
7752                     paren = 1;
7753                     goto capturing_parens;
7754                 }
7755                 RExC_seen |= REG_SEEN_LOOKBEHIND;
7756                 RExC_in_lookbehind++;
7757                 RExC_parse++;
7758             case '=':           /* (?=...) */
7759                 RExC_seen_zerolen++;
7760                 break;
7761             case '!':           /* (?!...) */
7762                 RExC_seen_zerolen++;
7763                 if (*RExC_parse == ')') {
7764                     ret=reg_node(pRExC_state, OPFAIL);
7765                     nextchar(pRExC_state);
7766                     return ret;
7767                 }
7768                 break;
7769             case '|':           /* (?|...) */
7770                 /* branch reset, behave like a (?:...) except that
7771                    buffers in alternations share the same numbers */
7772                 paren = ':'; 
7773                 after_freeze = freeze_paren = RExC_npar;
7774                 break;
7775             case ':':           /* (?:...) */
7776             case '>':           /* (?>...) */
7777                 break;
7778             case '$':           /* (?$...) */
7779             case '@':           /* (?@...) */
7780                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
7781                 break;
7782             case '#':           /* (?#...) */
7783                 while (*RExC_parse && *RExC_parse != ')')
7784                     RExC_parse++;
7785                 if (*RExC_parse != ')')
7786                     FAIL("Sequence (?#... not terminated");
7787                 nextchar(pRExC_state);
7788                 *flagp = TRYAGAIN;
7789                 return NULL;
7790             case '0' :           /* (?0) */
7791             case 'R' :           /* (?R) */
7792                 if (*RExC_parse != ')')
7793                     FAIL("Sequence (?R) not terminated");
7794                 ret = reg_node(pRExC_state, GOSTART);
7795                 *flagp |= POSTPONED;
7796                 nextchar(pRExC_state);
7797                 return ret;
7798                 /*notreached*/
7799             { /* named and numeric backreferences */
7800                 I32 num;
7801             case '&':            /* (?&NAME) */
7802                 parse_start = RExC_parse - 1;
7803               named_recursion:
7804                 {
7805                     SV *sv_dat = reg_scan_name(pRExC_state,
7806                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
7807                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
7808                 }
7809                 goto gen_recurse_regop;
7810                 /* NOT REACHED */
7811             case '+':
7812                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
7813                     RExC_parse++;
7814                     vFAIL("Illegal pattern");
7815                 }
7816                 goto parse_recursion;
7817                 /* NOT REACHED*/
7818             case '-': /* (?-1) */
7819                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
7820                     RExC_parse--; /* rewind to let it be handled later */
7821                     goto parse_flags;
7822                 } 
7823                 /*FALLTHROUGH */
7824             case '1': case '2': case '3': case '4': /* (?1) */
7825             case '5': case '6': case '7': case '8': case '9':
7826                 RExC_parse--;
7827               parse_recursion:
7828                 num = atoi(RExC_parse);
7829                 parse_start = RExC_parse - 1; /* MJD */
7830                 if (*RExC_parse == '-')
7831                     RExC_parse++;
7832                 while (isDIGIT(*RExC_parse))
7833                         RExC_parse++;
7834                 if (*RExC_parse!=')') 
7835                     vFAIL("Expecting close bracket");
7836
7837               gen_recurse_regop:
7838                 if ( paren == '-' ) {
7839                     /*
7840                     Diagram of capture buffer numbering.
7841                     Top line is the normal capture buffer numbers
7842                     Bottom line is the negative indexing as from
7843                     the X (the (?-2))
7844
7845                     +   1 2    3 4 5 X          6 7
7846                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
7847                     -   5 4    3 2 1 X          x x
7848
7849                     */
7850                     num = RExC_npar + num;
7851                     if (num < 1)  {
7852                         RExC_parse++;
7853                         vFAIL("Reference to nonexistent group");
7854                     }
7855                 } else if ( paren == '+' ) {
7856                     num = RExC_npar + num - 1;
7857                 }
7858
7859                 ret = reganode(pRExC_state, GOSUB, num);
7860                 if (!SIZE_ONLY) {
7861                     if (num > (I32)RExC_rx->nparens) {
7862                         RExC_parse++;
7863                         vFAIL("Reference to nonexistent group");
7864                     }
7865                     ARG2L_SET( ret, RExC_recurse_count++);
7866                     RExC_emit++;
7867                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
7868                         "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
7869                 } else {
7870                     RExC_size++;
7871                 }
7872                 RExC_seen |= REG_SEEN_RECURSE;
7873                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
7874                 Set_Node_Offset(ret, parse_start); /* MJD */
7875
7876                 *flagp |= POSTPONED;
7877                 nextchar(pRExC_state);
7878                 return ret;
7879             } /* named and numeric backreferences */
7880             /* NOT REACHED */
7881
7882             case '?':           /* (??...) */
7883                 is_logical = 1;
7884                 if (*RExC_parse != '{') {
7885                     RExC_parse++;
7886                     vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7887                     /*NOTREACHED*/
7888                 }
7889                 *flagp |= POSTPONED;
7890                 paren = *RExC_parse++;
7891                 /* FALL THROUGH */
7892             case '{':           /* (?{...}) */
7893             {
7894                 I32 count = 1;
7895                 U32 n = 0;
7896                 char c;
7897                 char *s = RExC_parse;
7898
7899                 RExC_seen_zerolen++;
7900                 RExC_seen |= REG_SEEN_EVAL;
7901                 while (count && (c = *RExC_parse)) {
7902                     if (c == '\\') {
7903                         if (RExC_parse[1])
7904                             RExC_parse++;
7905                     }
7906                     else if (c == '{')
7907                         count++;
7908                     else if (c == '}')
7909                         count--;
7910                     RExC_parse++;
7911                 }
7912                 if (*RExC_parse != ')') {
7913                     RExC_parse = s;
7914                     vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
7915                 }
7916                 if (!SIZE_ONLY) {
7917                     PAD *pad;
7918                     OP_4tree *sop, *rop;
7919                     SV * const sv = newSVpvn(s, RExC_parse - 1 - s);
7920
7921                     ENTER;
7922                     Perl_save_re_context(aTHX);
7923                     rop = Perl_sv_compile_2op_is_broken(aTHX_ sv, &sop, "re", &pad);
7924                     sop->op_private |= OPpREFCOUNTED;
7925                     /* re_dup will OpREFCNT_inc */
7926                     OpREFCNT_set(sop, 1);
7927                     LEAVE;
7928
7929                     n = add_data(pRExC_state, 3, "nop");
7930                     RExC_rxi->data->data[n] = (void*)rop;
7931                     RExC_rxi->data->data[n+1] = (void*)sop;
7932                     RExC_rxi->data->data[n+2] = (void*)pad;
7933                     SvREFCNT_dec(sv);
7934                 }
7935                 else {                                          /* First pass */
7936                     if (PL_reginterp_cnt < ++RExC_seen_evals
7937                         && IN_PERL_RUNTIME)
7938                         /* No compiled RE interpolated, has runtime
7939                            components ===> unsafe.  */
7940                         FAIL("Eval-group not allowed at runtime, use re 'eval'");
7941                     if (PL_tainting && PL_tainted)
7942                         FAIL("Eval-group in insecure regular expression");
7943 #if PERL_VERSION > 8
7944                     if (IN_PERL_COMPILETIME)
7945                         PL_cv_has_eval = 1;
7946 #endif
7947                 }
7948
7949                 nextchar(pRExC_state);
7950                 if (is_logical) {
7951                     ret = reg_node(pRExC_state, LOGICAL);
7952                     if (!SIZE_ONLY)
7953                         ret->flags = 2;
7954                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
7955                     /* deal with the length of this later - MJD */
7956                     return ret;
7957                 }
7958                 ret = reganode(pRExC_state, EVAL, n);
7959                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
7960                 Set_Node_Offset(ret, parse_start);
7961                 return ret;
7962             }
7963             case '(':           /* (?(?{...})...) and (?(?=...)...) */
7964             {
7965                 int is_define= 0;
7966                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
7967                     if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
7968                         || RExC_parse[1] == '<'
7969                         || RExC_parse[1] == '{') { /* Lookahead or eval. */
7970                         I32 flag;
7971
7972                         ret = reg_node(pRExC_state, LOGICAL);
7973                         if (!SIZE_ONLY)
7974                             ret->flags = 1;
7975                         REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
7976                         goto insert_if;
7977                     }
7978                 }
7979                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
7980                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
7981                 {
7982                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
7983                     char *name_start= RExC_parse++;
7984                     U32 num = 0;
7985                     SV *sv_dat=reg_scan_name(pRExC_state,
7986                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
7987                     if (RExC_parse == name_start || *RExC_parse != ch)
7988                         vFAIL2("Sequence (?(%c... not terminated",
7989                             (ch == '>' ? '<' : ch));
7990                     RExC_parse++;
7991                     if (!SIZE_ONLY) {
7992                         num = add_data( pRExC_state, 1, "S" );
7993                         RExC_rxi->data->data[num]=(void*)sv_dat;
7994                         SvREFCNT_inc_simple_void(sv_dat);
7995                     }
7996                     ret = reganode(pRExC_state,NGROUPP,num);
7997                     goto insert_if_check_paren;
7998                 }
7999                 else if (RExC_parse[0] == 'D' &&
8000                          RExC_parse[1] == 'E' &&
8001                          RExC_parse[2] == 'F' &&
8002                          RExC_parse[3] == 'I' &&
8003                          RExC_parse[4] == 'N' &&
8004                          RExC_parse[5] == 'E')
8005                 {
8006                     ret = reganode(pRExC_state,DEFINEP,0);
8007                     RExC_parse +=6 ;
8008                     is_define = 1;
8009                     goto insert_if_check_paren;
8010                 }
8011                 else if (RExC_parse[0] == 'R') {
8012                     RExC_parse++;
8013                     parno = 0;
8014                     if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
8015                         parno = atoi(RExC_parse++);
8016                         while (isDIGIT(*RExC_parse))
8017                             RExC_parse++;
8018                     } else if (RExC_parse[0] == '&') {
8019                         SV *sv_dat;
8020                         RExC_parse++;
8021                         sv_dat = reg_scan_name(pRExC_state,
8022                             SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8023                         parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
8024                     }
8025                     ret = reganode(pRExC_state,INSUBP,parno); 
8026                     goto insert_if_check_paren;
8027                 }
8028                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
8029                     /* (?(1)...) */
8030                     char c;
8031                     parno = atoi(RExC_parse++);
8032
8033                     while (isDIGIT(*RExC_parse))
8034                         RExC_parse++;
8035                     ret = reganode(pRExC_state, GROUPP, parno);
8036
8037                  insert_if_check_paren:
8038                     if ((c = *nextchar(pRExC_state)) != ')')
8039                         vFAIL("Switch condition not recognized");
8040                   insert_if:
8041                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
8042                     br = regbranch(pRExC_state, &flags, 1,depth+1);
8043                     if (br == NULL)
8044                         br = reganode(pRExC_state, LONGJMP, 0);
8045                     else
8046                         REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
8047                     c = *nextchar(pRExC_state);
8048                     if (flags&HASWIDTH)
8049                         *flagp |= HASWIDTH;
8050                     if (c == '|') {
8051                         if (is_define) 
8052                             vFAIL("(?(DEFINE)....) does not allow branches");
8053                         lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
8054                         regbranch(pRExC_state, &flags, 1,depth+1);
8055                         REGTAIL(pRExC_state, ret, lastbr);
8056                         if (flags&HASWIDTH)
8057                             *flagp |= HASWIDTH;
8058                         c = *nextchar(pRExC_state);
8059                     }
8060                     else
8061                         lastbr = NULL;
8062                     if (c != ')')
8063                         vFAIL("Switch (?(condition)... contains too many branches");
8064                     ender = reg_node(pRExC_state, TAIL);
8065                     REGTAIL(pRExC_state, br, ender);
8066                     if (lastbr) {
8067                         REGTAIL(pRExC_state, lastbr, ender);
8068                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
8069                     }
8070                     else
8071                         REGTAIL(pRExC_state, ret, ender);
8072                     RExC_size++; /* XXX WHY do we need this?!!
8073                                     For large programs it seems to be required
8074                                     but I can't figure out why. -- dmq*/
8075                     return ret;
8076                 }
8077                 else {
8078                     vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
8079                 }
8080             }
8081             case 0:
8082                 RExC_parse--; /* for vFAIL to print correctly */
8083                 vFAIL("Sequence (? incomplete");
8084                 break;
8085             case DEFAULT_PAT_MOD:   /* Use default flags with the exceptions
8086                                        that follow */
8087                 has_use_defaults = TRUE;
8088                 STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
8089                 set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
8090                                                 ? REGEX_UNICODE_CHARSET
8091                                                 : REGEX_DEPENDS_CHARSET);
8092                 goto parse_flags;
8093             default:
8094                 --RExC_parse;
8095                 parse_flags:      /* (?i) */  
8096             {
8097                 U32 posflags = 0, negflags = 0;
8098                 U32 *flagsp = &posflags;
8099                 char has_charset_modifier = '\0';
8100                 regex_charset cs = get_regex_charset(RExC_flags);
8101                 if (cs == REGEX_DEPENDS_CHARSET
8102                     && (RExC_utf8 || RExC_uni_semantics))
8103                 {
8104                     cs = REGEX_UNICODE_CHARSET;
8105                 }
8106
8107                 while (*RExC_parse) {
8108                     /* && strchr("iogcmsx", *RExC_parse) */
8109                     /* (?g), (?gc) and (?o) are useless here
8110                        and must be globally applied -- japhy */
8111                     switch (*RExC_parse) {
8112                     CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
8113                     case LOCALE_PAT_MOD:
8114                         if (has_charset_modifier) {
8115                             goto excess_modifier;
8116                         }
8117                         else if (flagsp == &negflags) {
8118                             goto neg_modifier;
8119                         }
8120                         cs = REGEX_LOCALE_CHARSET;
8121                         has_charset_modifier = LOCALE_PAT_MOD;
8122                         RExC_contains_locale = 1;
8123                         break;
8124                     case UNICODE_PAT_MOD:
8125                         if (has_charset_modifier) {
8126                             goto excess_modifier;
8127                         }
8128                         else if (flagsp == &negflags) {
8129                             goto neg_modifier;
8130                         }
8131                         cs = REGEX_UNICODE_CHARSET;
8132                         has_charset_modifier = UNICODE_PAT_MOD;
8133                         break;
8134                     case ASCII_RESTRICT_PAT_MOD:
8135                         if (flagsp == &negflags) {
8136                             goto neg_modifier;
8137                         }
8138                         if (has_charset_modifier) {
8139                             if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
8140                                 goto excess_modifier;
8141                             }
8142                             /* Doubled modifier implies more restricted */
8143                             cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
8144                         }
8145                         else {
8146                             cs = REGEX_ASCII_RESTRICTED_CHARSET;
8147                         }
8148                         has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
8149                         break;
8150                     case DEPENDS_PAT_MOD:
8151                         if (has_use_defaults) {
8152                             goto fail_modifiers;
8153                         }
8154                         else if (flagsp == &negflags) {
8155                             goto neg_modifier;
8156                         }
8157                         else if (has_charset_modifier) {
8158                             goto excess_modifier;
8159                         }
8160
8161                         /* The dual charset means unicode semantics if the
8162                          * pattern (or target, not known until runtime) are
8163                          * utf8, or something in the pattern indicates unicode
8164                          * semantics */
8165                         cs = (RExC_utf8 || RExC_uni_semantics)
8166                              ? REGEX_UNICODE_CHARSET
8167                              : REGEX_DEPENDS_CHARSET;
8168                         has_charset_modifier = DEPENDS_PAT_MOD;
8169                         break;
8170                     excess_modifier:
8171                         RExC_parse++;
8172                         if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
8173                             vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
8174                         }
8175                         else if (has_charset_modifier == *(RExC_parse - 1)) {
8176                             vFAIL2("Regexp modifier \"%c\" may not appear twice", *(RExC_parse - 1));
8177                         }
8178                         else {
8179                             vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
8180                         }
8181                         /*NOTREACHED*/
8182                     neg_modifier:
8183                         RExC_parse++;
8184                         vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", *(RExC_parse - 1));
8185                         /*NOTREACHED*/
8186                     case ONCE_PAT_MOD: /* 'o' */
8187                     case GLOBAL_PAT_MOD: /* 'g' */
8188                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
8189                             const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
8190                             if (! (wastedflags & wflagbit) ) {
8191                                 wastedflags |= wflagbit;
8192                                 vWARN5(
8193                                     RExC_parse + 1,
8194                                     "Useless (%s%c) - %suse /%c modifier",
8195                                     flagsp == &negflags ? "?-" : "?",
8196                                     *RExC_parse,
8197                                     flagsp == &negflags ? "don't " : "",
8198                                     *RExC_parse
8199                                 );
8200                             }
8201                         }
8202                         break;
8203                         
8204                     case CONTINUE_PAT_MOD: /* 'c' */
8205                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
8206                             if (! (wastedflags & WASTED_C) ) {
8207                                 wastedflags |= WASTED_GC;
8208                                 vWARN3(
8209                                     RExC_parse + 1,
8210                                     "Useless (%sc) - %suse /gc modifier",
8211                                     flagsp == &negflags ? "?-" : "?",
8212                                     flagsp == &negflags ? "don't " : ""
8213                                 );
8214                             }
8215                         }
8216                         break;
8217                     case KEEPCOPY_PAT_MOD: /* 'p' */
8218                         if (flagsp == &negflags) {
8219                             if (SIZE_ONLY)
8220                                 ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
8221                         } else {
8222                             *flagsp |= RXf_PMf_KEEPCOPY;
8223                         }
8224                         break;
8225                     case '-':
8226                         /* A flag is a default iff it is following a minus, so
8227                          * if there is a minus, it means will be trying to
8228                          * re-specify a default which is an error */
8229                         if (has_use_defaults || flagsp == &negflags) {
8230             fail_modifiers:
8231                             RExC_parse++;
8232                             vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8233                             /*NOTREACHED*/
8234                         }
8235                         flagsp = &negflags;
8236                         wastedflags = 0;  /* reset so (?g-c) warns twice */
8237                         break;
8238                     case ':':
8239                         paren = ':';
8240                         /*FALLTHROUGH*/
8241                     case ')':
8242                         RExC_flags |= posflags;
8243                         RExC_flags &= ~negflags;
8244                         set_regex_charset(&RExC_flags, cs);
8245                         if (paren != ':') {
8246                             oregflags |= posflags;
8247                             oregflags &= ~negflags;
8248                             set_regex_charset(&oregflags, cs);
8249                         }
8250                         nextchar(pRExC_state);
8251                         if (paren != ':') {
8252                             *flagp = TRYAGAIN;
8253                             return NULL;
8254                         } else {
8255                             ret = NULL;
8256                             goto parse_rest;
8257                         }
8258                         /*NOTREACHED*/
8259                     default:
8260                         RExC_parse++;
8261                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8262                         /*NOTREACHED*/
8263                     }                           
8264                     ++RExC_parse;
8265                 }
8266             }} /* one for the default block, one for the switch */
8267         }
8268         else {                  /* (...) */
8269           capturing_parens:
8270             parno = RExC_npar;
8271             RExC_npar++;
8272             
8273             ret = reganode(pRExC_state, OPEN, parno);
8274             if (!SIZE_ONLY ){
8275                 if (!RExC_nestroot) 
8276                     RExC_nestroot = parno;
8277                 if (RExC_seen & REG_SEEN_RECURSE
8278                     && !RExC_open_parens[parno-1])
8279                 {
8280                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
8281                         "Setting open paren #%"IVdf" to %d\n", 
8282                         (IV)parno, REG_NODE_NUM(ret)));
8283                     RExC_open_parens[parno-1]= ret;
8284                 }
8285             }
8286             Set_Node_Length(ret, 1); /* MJD */
8287             Set_Node_Offset(ret, RExC_parse); /* MJD */
8288             is_open = 1;
8289         }
8290     }
8291     else                        /* ! paren */
8292         ret = NULL;
8293    
8294    parse_rest:
8295     /* Pick up the branches, linking them together. */
8296     parse_start = RExC_parse;   /* MJD */
8297     br = regbranch(pRExC_state, &flags, 1,depth+1);
8298
8299     /*     branch_len = (paren != 0); */
8300
8301     if (br == NULL)
8302         return(NULL);
8303     if (*RExC_parse == '|') {
8304         if (!SIZE_ONLY && RExC_extralen) {
8305             reginsert(pRExC_state, BRANCHJ, br, depth+1);
8306         }
8307         else {                  /* MJD */
8308             reginsert(pRExC_state, BRANCH, br, depth+1);
8309             Set_Node_Length(br, paren != 0);
8310             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
8311         }
8312         have_branch = 1;
8313         if (SIZE_ONLY)
8314             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
8315     }
8316     else if (paren == ':') {
8317         *flagp |= flags&SIMPLE;
8318     }
8319     if (is_open) {                              /* Starts with OPEN. */
8320         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
8321     }
8322     else if (paren != '?')              /* Not Conditional */
8323         ret = br;
8324     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
8325     lastbr = br;
8326     while (*RExC_parse == '|') {
8327         if (!SIZE_ONLY && RExC_extralen) {
8328             ender = reganode(pRExC_state, LONGJMP,0);
8329             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
8330         }
8331         if (SIZE_ONLY)
8332             RExC_extralen += 2;         /* Account for LONGJMP. */
8333         nextchar(pRExC_state);
8334         if (freeze_paren) {
8335             if (RExC_npar > after_freeze)
8336                 after_freeze = RExC_npar;
8337             RExC_npar = freeze_paren;       
8338         }
8339         br = regbranch(pRExC_state, &flags, 0, depth+1);
8340
8341         if (br == NULL)
8342             return(NULL);
8343         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
8344         lastbr = br;
8345         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
8346     }
8347
8348     if (have_branch || paren != ':') {
8349         /* Make a closing node, and hook it on the end. */
8350         switch (paren) {
8351         case ':':
8352             ender = reg_node(pRExC_state, TAIL);
8353             break;
8354         case 1:
8355             ender = reganode(pRExC_state, CLOSE, parno);
8356             if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
8357                 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
8358                         "Setting close paren #%"IVdf" to %d\n", 
8359                         (IV)parno, REG_NODE_NUM(ender)));
8360                 RExC_close_parens[parno-1]= ender;
8361                 if (RExC_nestroot == parno) 
8362                     RExC_nestroot = 0;
8363             }       
8364             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
8365             Set_Node_Length(ender,1); /* MJD */
8366             break;
8367         case '<':
8368         case ',':
8369         case '=':
8370         case '!':
8371             *flagp &= ~HASWIDTH;
8372             /* FALL THROUGH */
8373         case '>':
8374             ender = reg_node(pRExC_state, SUCCEED);
8375             break;
8376         case 0:
8377             ender = reg_node(pRExC_state, END);
8378             if (!SIZE_ONLY) {
8379                 assert(!RExC_opend); /* there can only be one! */
8380                 RExC_opend = ender;
8381             }
8382             break;
8383         }
8384         REGTAIL(pRExC_state, lastbr, ender);
8385
8386         if (have_branch && !SIZE_ONLY) {
8387             if (depth==1)
8388                 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
8389
8390             /* Hook the tails of the branches to the closing node. */
8391             for (br = ret; br; br = regnext(br)) {
8392                 const U8 op = PL_regkind[OP(br)];
8393                 if (op == BRANCH) {
8394                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
8395                 }
8396                 else if (op == BRANCHJ) {
8397                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
8398                 }
8399             }
8400         }
8401     }
8402
8403     {
8404         const char *p;
8405         static const char parens[] = "=!<,>";
8406
8407         if (paren && (p = strchr(parens, paren))) {
8408             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
8409             int flag = (p - parens) > 1;
8410
8411             if (paren == '>')
8412                 node = SUSPEND, flag = 0;
8413             reginsert(pRExC_state, node,ret, depth+1);
8414             Set_Node_Cur_Length(ret);
8415             Set_Node_Offset(ret, parse_start + 1);
8416             ret->flags = flag;
8417             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
8418         }
8419     }
8420
8421     /* Check for proper termination. */
8422     if (paren) {
8423         RExC_flags = oregflags;
8424         if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
8425             RExC_parse = oregcomp_parse;
8426             vFAIL("Unmatched (");
8427         }
8428     }
8429     else if (!paren && RExC_parse < RExC_end) {
8430         if (*RExC_parse == ')') {
8431             RExC_parse++;
8432             vFAIL("Unmatched )");
8433         }
8434         else
8435             FAIL("Junk on end of regexp");      /* "Can't happen". */
8436         /* NOTREACHED */
8437     }
8438
8439     if (RExC_in_lookbehind) {
8440         RExC_in_lookbehind--;
8441     }
8442     if (after_freeze > RExC_npar)
8443         RExC_npar = after_freeze;
8444     return(ret);
8445 }
8446
8447 /*
8448  - regbranch - one alternative of an | operator
8449  *
8450  * Implements the concatenation operator.
8451  */
8452 STATIC regnode *
8453 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
8454 {
8455     dVAR;
8456     register regnode *ret;
8457     register regnode *chain = NULL;
8458     register regnode *latest;
8459     I32 flags = 0, c = 0;
8460     GET_RE_DEBUG_FLAGS_DECL;
8461
8462     PERL_ARGS_ASSERT_REGBRANCH;
8463
8464     DEBUG_PARSE("brnc");
8465
8466     if (first)
8467         ret = NULL;
8468     else {
8469         if (!SIZE_ONLY && RExC_extralen)
8470             ret = reganode(pRExC_state, BRANCHJ,0);
8471         else {
8472             ret = reg_node(pRExC_state, BRANCH);
8473             Set_Node_Length(ret, 1);
8474         }
8475     }
8476
8477     if (!first && SIZE_ONLY)
8478         RExC_extralen += 1;                     /* BRANCHJ */
8479
8480     *flagp = WORST;                     /* Tentatively. */
8481
8482     RExC_parse--;
8483     nextchar(pRExC_state);
8484     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
8485         flags &= ~TRYAGAIN;
8486         latest = regpiece(pRExC_state, &flags,depth+1);
8487         if (latest == NULL) {
8488             if (flags & TRYAGAIN)
8489                 continue;
8490             return(NULL);
8491         }
8492         else if (ret == NULL)
8493             ret = latest;
8494         *flagp |= flags&(HASWIDTH|POSTPONED);
8495         if (chain == NULL)      /* First piece. */
8496             *flagp |= flags&SPSTART;
8497         else {
8498             RExC_naughty++;
8499             REGTAIL(pRExC_state, chain, latest);
8500         }
8501         chain = latest;
8502         c++;
8503     }
8504     if (chain == NULL) {        /* Loop ran zero times. */
8505         chain = reg_node(pRExC_state, NOTHING);
8506         if (ret == NULL)
8507             ret = chain;
8508     }
8509     if (c == 1) {
8510         *flagp |= flags&SIMPLE;
8511     }
8512
8513     return ret;
8514 }
8515
8516 /*
8517  - regpiece - something followed by possible [*+?]
8518  *
8519  * Note that the branching code sequences used for ? and the general cases
8520  * of * and + are somewhat optimized:  they use the same NOTHING node as
8521  * both the endmarker for their branch list and the body of the last branch.
8522  * It might seem that this node could be dispensed with entirely, but the
8523  * endmarker role is not redundant.
8524  */
8525 STATIC regnode *
8526 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
8527 {
8528     dVAR;
8529     register regnode *ret;
8530     register char op;
8531     register char *next;
8532     I32 flags;
8533     const char * const origparse = RExC_parse;
8534     I32 min;
8535     I32 max = REG_INFTY;
8536 #ifdef RE_TRACK_PATTERN_OFFSETS
8537     char *parse_start;
8538 #endif
8539     const char *maxpos = NULL;
8540     GET_RE_DEBUG_FLAGS_DECL;
8541
8542     PERL_ARGS_ASSERT_REGPIECE;
8543
8544     DEBUG_PARSE("piec");
8545
8546     ret = regatom(pRExC_state, &flags,depth+1);
8547     if (ret == NULL) {
8548         if (flags & TRYAGAIN)
8549             *flagp |= TRYAGAIN;
8550         return(NULL);
8551     }
8552
8553     op = *RExC_parse;
8554
8555     if (op == '{' && regcurly(RExC_parse)) {
8556         maxpos = NULL;
8557 #ifdef RE_TRACK_PATTERN_OFFSETS
8558         parse_start = RExC_parse; /* MJD */
8559 #endif
8560         next = RExC_parse + 1;
8561         while (isDIGIT(*next) || *next == ',') {
8562             if (*next == ',') {
8563                 if (maxpos)
8564                     break;
8565                 else
8566                     maxpos = next;
8567             }
8568             next++;
8569         }
8570         if (*next == '}') {             /* got one */
8571             if (!maxpos)
8572                 maxpos = next;
8573             RExC_parse++;
8574             min = atoi(RExC_parse);
8575             if (*maxpos == ',')
8576                 maxpos++;
8577             else
8578                 maxpos = RExC_parse;
8579             max = atoi(maxpos);
8580             if (!max && *maxpos != '0')
8581                 max = REG_INFTY;                /* meaning "infinity" */
8582             else if (max >= REG_INFTY)
8583                 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
8584             RExC_parse = next;
8585             nextchar(pRExC_state);
8586
8587         do_curly:
8588             if ((flags&SIMPLE)) {
8589                 RExC_naughty += 2 + RExC_naughty / 2;
8590                 reginsert(pRExC_state, CURLY, ret, depth+1);
8591                 Set_Node_Offset(ret, parse_start+1); /* MJD */
8592                 Set_Node_Cur_Length(ret);
8593             }
8594             else {
8595                 regnode * const w = reg_node(pRExC_state, WHILEM);
8596
8597                 w->flags = 0;
8598                 REGTAIL(pRExC_state, ret, w);
8599                 if (!SIZE_ONLY && RExC_extralen) {
8600                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
8601                     reginsert(pRExC_state, NOTHING,ret, depth+1);
8602                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
8603                 }
8604                 reginsert(pRExC_state, CURLYX,ret, depth+1);
8605                                 /* MJD hk */
8606                 Set_Node_Offset(ret, parse_start+1);
8607                 Set_Node_Length(ret,
8608                                 op == '{' ? (RExC_parse - parse_start) : 1);
8609
8610                 if (!SIZE_ONLY && RExC_extralen)
8611                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
8612                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
8613                 if (SIZE_ONLY)
8614                     RExC_whilem_seen++, RExC_extralen += 3;
8615                 RExC_naughty += 4 + RExC_naughty;       /* compound interest */
8616             }
8617             ret->flags = 0;
8618
8619             if (min > 0)
8620                 *flagp = WORST;
8621             if (max > 0)
8622                 *flagp |= HASWIDTH;
8623             if (max < min)
8624                 vFAIL("Can't do {n,m} with n > m");
8625             if (!SIZE_ONLY) {
8626                 ARG1_SET(ret, (U16)min);
8627                 ARG2_SET(ret, (U16)max);
8628             }
8629
8630             goto nest_check;
8631         }
8632     }
8633
8634     if (!ISMULT1(op)) {
8635         *flagp = flags;
8636         return(ret);
8637     }
8638
8639 #if 0                           /* Now runtime fix should be reliable. */
8640
8641     /* if this is reinstated, don't forget to put this back into perldiag:
8642
8643             =item Regexp *+ operand could be empty at {#} in regex m/%s/
8644
8645            (F) The part of the regexp subject to either the * or + quantifier
8646            could match an empty string. The {#} shows in the regular
8647            expression about where the problem was discovered.
8648
8649     */
8650
8651     if (!(flags&HASWIDTH) && op != '?')
8652       vFAIL("Regexp *+ operand could be empty");
8653 #endif
8654
8655 #ifdef RE_TRACK_PATTERN_OFFSETS
8656     parse_start = RExC_parse;
8657 #endif
8658     nextchar(pRExC_state);
8659
8660     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
8661
8662     if (op == '*' && (flags&SIMPLE)) {
8663         reginsert(pRExC_state, STAR, ret, depth+1);
8664         ret->flags = 0;
8665         RExC_naughty += 4;
8666     }
8667     else if (op == '*') {
8668         min = 0;
8669         goto do_curly;
8670     }
8671     else if (op == '+' && (flags&SIMPLE)) {
8672         reginsert(pRExC_state, PLUS, ret, depth+1);
8673         ret->flags = 0;
8674         RExC_naughty += 3;
8675     }
8676     else if (op == '+') {
8677         min = 1;
8678         goto do_curly;
8679     }
8680     else if (op == '?') {
8681         min = 0; max = 1;
8682         goto do_curly;
8683     }
8684   nest_check:
8685     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
8686         ckWARN3reg(RExC_parse,
8687                    "%.*s matches null string many times",
8688                    (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
8689                    origparse);
8690     }
8691
8692     if (RExC_parse < RExC_end && *RExC_parse == '?') {
8693         nextchar(pRExC_state);
8694         reginsert(pRExC_state, MINMOD, ret, depth+1);
8695         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
8696     }
8697 #ifndef REG_ALLOW_MINMOD_SUSPEND
8698     else
8699 #endif
8700     if (RExC_parse < RExC_end && *RExC_parse == '+') {
8701         regnode *ender;
8702         nextchar(pRExC_state);
8703         ender = reg_node(pRExC_state, SUCCEED);
8704         REGTAIL(pRExC_state, ret, ender);
8705         reginsert(pRExC_state, SUSPEND, ret, depth+1);
8706         ret->flags = 0;
8707         ender = reg_node(pRExC_state, TAIL);
8708         REGTAIL(pRExC_state, ret, ender);
8709         /*ret= ender;*/
8710     }
8711
8712     if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
8713         RExC_parse++;
8714         vFAIL("Nested quantifiers");
8715     }
8716
8717     return(ret);
8718 }
8719
8720
8721 /* reg_namedseq(pRExC_state,UVp, UV depth)
8722    
8723    This is expected to be called by a parser routine that has 
8724    recognized '\N' and needs to handle the rest. RExC_parse is
8725    expected to point at the first char following the N at the time
8726    of the call.
8727
8728    The \N may be inside (indicated by valuep not being NULL) or outside a
8729    character class.
8730
8731    \N may begin either a named sequence, or if outside a character class, mean
8732    to match a non-newline.  For non single-quoted regexes, the tokenizer has
8733    attempted to decide which, and in the case of a named sequence converted it
8734    into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...},
8735    where c1... are the characters in the sequence.  For single-quoted regexes,
8736    the tokenizer passes the \N sequence through unchanged; this code will not
8737    attempt to determine this nor expand those.  The net effect is that if the
8738    beginning of the passed-in pattern isn't '{U+' or there is no '}', it
8739    signals that this \N occurrence means to match a non-newline.
8740    
8741    Only the \N{U+...} form should occur in a character class, for the same
8742    reason that '.' inside a character class means to just match a period: it
8743    just doesn't make sense.
8744    
8745    If valuep is non-null then it is assumed that we are parsing inside 
8746    of a charclass definition and the first codepoint in the resolved
8747    string is returned via *valuep and the routine will return NULL. 
8748    In this mode if a multichar string is returned from the charnames 
8749    handler, a warning will be issued, and only the first char in the 
8750    sequence will be examined. If the string returned is zero length
8751    then the value of *valuep is undefined and NON-NULL will 
8752    be returned to indicate failure. (This will NOT be a valid pointer 
8753    to a regnode.)
8754    
8755    If valuep is null then it is assumed that we are parsing normal text and a
8756    new EXACT node is inserted into the program containing the resolved string,
8757    and a pointer to the new node is returned.  But if the string is zero length
8758    a NOTHING node is emitted instead.
8759
8760    On success RExC_parse is set to the char following the endbrace.
8761    Parsing failures will generate a fatal error via vFAIL(...)
8762  */
8763 STATIC regnode *
8764 S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep, I32 *flagp, U32 depth)
8765 {
8766     char * endbrace;    /* '}' following the name */
8767     regnode *ret = NULL;
8768     char* p;
8769
8770     GET_RE_DEBUG_FLAGS_DECL;
8771  
8772     PERL_ARGS_ASSERT_REG_NAMEDSEQ;
8773
8774     GET_RE_DEBUG_FLAGS;
8775
8776     /* The [^\n] meaning of \N ignores spaces and comments under the /x
8777      * modifier.  The other meaning does not */
8778     p = (RExC_flags & RXf_PMf_EXTENDED)
8779         ? regwhite( pRExC_state, RExC_parse )
8780         : RExC_parse;
8781    
8782     /* Disambiguate between \N meaning a named character versus \N meaning
8783      * [^\n].  The former is assumed when it can't be the latter. */
8784     if (*p != '{' || regcurly(p)) {
8785         RExC_parse = p;
8786         if (valuep) {
8787             /* no bare \N in a charclass */
8788             vFAIL("\\N in a character class must be a named character: \\N{...}");
8789         }
8790         nextchar(pRExC_state);
8791         ret = reg_node(pRExC_state, REG_ANY);
8792         *flagp |= HASWIDTH|SIMPLE;
8793         RExC_naughty++;
8794         RExC_parse--;
8795         Set_Node_Length(ret, 1); /* MJD */
8796         return ret;
8797     }
8798
8799     /* Here, we have decided it should be a named sequence */
8800
8801     /* The test above made sure that the next real character is a '{', but
8802      * under the /x modifier, it could be separated by space (or a comment and
8803      * \n) and this is not allowed (for consistency with \x{...} and the
8804      * tokenizer handling of \N{NAME}). */
8805     if (*RExC_parse != '{') {
8806         vFAIL("Missing braces on \\N{}");
8807     }
8808
8809     RExC_parse++;       /* Skip past the '{' */
8810
8811     if (! (endbrace = strchr(RExC_parse, '}')) /* no trailing brace */
8812         || ! (endbrace == RExC_parse            /* nothing between the {} */
8813               || (endbrace - RExC_parse >= 2    /* U+ (bad hex is checked below */
8814                   && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg) */
8815     {
8816         if (endbrace) RExC_parse = endbrace;    /* position msg's '<--HERE' */
8817         vFAIL("\\N{NAME} must be resolved by the lexer");
8818     }
8819
8820     if (endbrace == RExC_parse) {   /* empty: \N{} */
8821         if (! valuep) {
8822             RExC_parse = endbrace + 1;  
8823             return reg_node(pRExC_state,NOTHING);
8824         }
8825
8826         if (SIZE_ONLY) {
8827             ckWARNreg(RExC_parse,
8828                     "Ignoring zero length \\N{} in character class"
8829             );
8830             RExC_parse = endbrace + 1;  
8831         }
8832         *valuep = 0;
8833         return (regnode *) &RExC_parse; /* Invalid regnode pointer */
8834     }
8835
8836     REQUIRE_UTF8;       /* named sequences imply Unicode semantics */
8837     RExC_parse += 2;    /* Skip past the 'U+' */
8838
8839     if (valuep) {   /* In a bracketed char class */
8840         /* We only pay attention to the first char of 
8841         multichar strings being returned. I kinda wonder
8842         if this makes sense as it does change the behaviour
8843         from earlier versions, OTOH that behaviour was broken
8844         as well. XXX Solution is to recharacterize as
8845         [rest-of-class]|multi1|multi2... */
8846
8847         STRLEN length_of_hex;
8848         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
8849             | PERL_SCAN_DISALLOW_PREFIX
8850             | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
8851     
8852         char * endchar = RExC_parse + strcspn(RExC_parse, ".}");
8853         if (endchar < endbrace) {
8854             ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
8855         }
8856
8857         length_of_hex = (STRLEN)(endchar - RExC_parse);
8858         *valuep = grok_hex(RExC_parse, &length_of_hex, &flags, NULL);
8859
8860         /* The tokenizer should have guaranteed validity, but it's possible to
8861          * bypass it by using single quoting, so check */
8862         if (length_of_hex == 0
8863             || length_of_hex != (STRLEN)(endchar - RExC_parse) )
8864         {
8865             RExC_parse += length_of_hex;        /* Includes all the valid */
8866             RExC_parse += (RExC_orig_utf8)      /* point to after 1st invalid */
8867                             ? UTF8SKIP(RExC_parse)
8868                             : 1;
8869             /* Guard against malformed utf8 */
8870             if (RExC_parse >= endchar) RExC_parse = endchar;
8871             vFAIL("Invalid hexadecimal number in \\N{U+...}");
8872         }    
8873
8874         RExC_parse = endbrace + 1;
8875         if (endchar == endbrace) return NULL;
8876
8877         ret = (regnode *) &RExC_parse;  /* Invalid regnode pointer */
8878     }
8879     else {      /* Not a char class */
8880
8881         /* What is done here is to convert this to a sub-pattern of the form
8882          * (?:\x{char1}\x{char2}...)
8883          * and then call reg recursively.  That way, it retains its atomicness,
8884          * while not having to worry about special handling that some code
8885          * points may have.  toke.c has converted the original Unicode values
8886          * to native, so that we can just pass on the hex values unchanged.  We
8887          * do have to set a flag to keep recoding from happening in the
8888          * recursion */
8889
8890         SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP);
8891         STRLEN len;
8892         char *endchar;      /* Points to '.' or '}' ending cur char in the input
8893                                stream */
8894         char *orig_end = RExC_end;
8895
8896         while (RExC_parse < endbrace) {
8897
8898             /* Code points are separated by dots.  If none, there is only one
8899              * code point, and is terminated by the brace */
8900             endchar = RExC_parse + strcspn(RExC_parse, ".}");
8901
8902             /* Convert to notation the rest of the code understands */
8903             sv_catpv(substitute_parse, "\\x{");
8904             sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
8905             sv_catpv(substitute_parse, "}");
8906
8907             /* Point to the beginning of the next character in the sequence. */
8908             RExC_parse = endchar + 1;
8909         }
8910         sv_catpv(substitute_parse, ")");
8911
8912         RExC_parse = SvPV(substitute_parse, len);
8913
8914         /* Don't allow empty number */
8915         if (len < 8) {
8916             vFAIL("Invalid hexadecimal number in \\N{U+...}");
8917         }
8918         RExC_end = RExC_parse + len;
8919
8920         /* The values are Unicode, and therefore not subject to recoding */
8921         RExC_override_recoding = 1;
8922
8923         ret = reg(pRExC_state, 1, flagp, depth+1);
8924
8925         RExC_parse = endbrace;
8926         RExC_end = orig_end;
8927         RExC_override_recoding = 0;
8928
8929         nextchar(pRExC_state);
8930     }
8931
8932     return ret;
8933 }
8934
8935
8936 /*
8937  * reg_recode
8938  *
8939  * It returns the code point in utf8 for the value in *encp.
8940  *    value: a code value in the source encoding
8941  *    encp:  a pointer to an Encode object
8942  *
8943  * If the result from Encode is not a single character,
8944  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
8945  */
8946 STATIC UV
8947 S_reg_recode(pTHX_ const char value, SV **encp)
8948 {
8949     STRLEN numlen = 1;
8950     SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP);
8951     const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
8952     const STRLEN newlen = SvCUR(sv);
8953     UV uv = UNICODE_REPLACEMENT;
8954
8955     PERL_ARGS_ASSERT_REG_RECODE;
8956
8957     if (newlen)
8958         uv = SvUTF8(sv)
8959              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
8960              : *(U8*)s;
8961
8962     if (!newlen || numlen != newlen) {
8963         uv = UNICODE_REPLACEMENT;
8964         *encp = NULL;
8965     }
8966     return uv;
8967 }
8968
8969
8970 /*
8971  - regatom - the lowest level
8972
8973    Try to identify anything special at the start of the pattern. If there
8974    is, then handle it as required. This may involve generating a single regop,
8975    such as for an assertion; or it may involve recursing, such as to
8976    handle a () structure.
8977
8978    If the string doesn't start with something special then we gobble up
8979    as much literal text as we can.
8980
8981    Once we have been able to handle whatever type of thing started the
8982    sequence, we return.
8983
8984    Note: we have to be careful with escapes, as they can be both literal
8985    and special, and in the case of \10 and friends can either, depending
8986    on context. Specifically there are two separate switches for handling
8987    escape sequences, with the one for handling literal escapes requiring
8988    a dummy entry for all of the special escapes that are actually handled
8989    by the other.
8990 */
8991
8992 STATIC regnode *
8993 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
8994 {
8995     dVAR;
8996     register regnode *ret = NULL;
8997     I32 flags;
8998     char *parse_start = RExC_parse;
8999     U8 op;
9000     GET_RE_DEBUG_FLAGS_DECL;
9001     DEBUG_PARSE("atom");
9002     *flagp = WORST;             /* Tentatively. */
9003
9004     PERL_ARGS_ASSERT_REGATOM;
9005
9006 tryagain:
9007     switch ((U8)*RExC_parse) {
9008     case '^':
9009         RExC_seen_zerolen++;
9010         nextchar(pRExC_state);
9011         if (RExC_flags & RXf_PMf_MULTILINE)
9012             ret = reg_node(pRExC_state, MBOL);
9013         else if (RExC_flags & RXf_PMf_SINGLELINE)
9014             ret = reg_node(pRExC_state, SBOL);
9015         else
9016             ret = reg_node(pRExC_state, BOL);
9017         Set_Node_Length(ret, 1); /* MJD */
9018         break;
9019     case '$':
9020         nextchar(pRExC_state);
9021         if (*RExC_parse)
9022             RExC_seen_zerolen++;
9023         if (RExC_flags & RXf_PMf_MULTILINE)
9024             ret = reg_node(pRExC_state, MEOL);
9025         else if (RExC_flags & RXf_PMf_SINGLELINE)
9026             ret = reg_node(pRExC_state, SEOL);
9027         else
9028             ret = reg_node(pRExC_state, EOL);
9029         Set_Node_Length(ret, 1); /* MJD */
9030         break;
9031     case '.':
9032         nextchar(pRExC_state);
9033         if (RExC_flags & RXf_PMf_SINGLELINE)
9034             ret = reg_node(pRExC_state, SANY);
9035         else
9036             ret = reg_node(pRExC_state, REG_ANY);
9037         *flagp |= HASWIDTH|SIMPLE;
9038         RExC_naughty++;
9039         Set_Node_Length(ret, 1); /* MJD */
9040         break;
9041     case '[':
9042     {
9043         char * const oregcomp_parse = ++RExC_parse;
9044         ret = regclass(pRExC_state,depth+1);
9045         if (*RExC_parse != ']') {
9046             RExC_parse = oregcomp_parse;
9047             vFAIL("Unmatched [");
9048         }
9049         nextchar(pRExC_state);
9050         *flagp |= HASWIDTH|SIMPLE;
9051         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
9052         break;
9053     }
9054     case '(':
9055         nextchar(pRExC_state);
9056         ret = reg(pRExC_state, 1, &flags,depth+1);
9057         if (ret == NULL) {
9058                 if (flags & TRYAGAIN) {
9059                     if (RExC_parse == RExC_end) {
9060                          /* Make parent create an empty node if needed. */
9061                         *flagp |= TRYAGAIN;
9062                         return(NULL);
9063                     }
9064                     goto tryagain;
9065                 }
9066                 return(NULL);
9067         }
9068         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
9069         break;
9070     case '|':
9071     case ')':
9072         if (flags & TRYAGAIN) {
9073             *flagp |= TRYAGAIN;
9074             return NULL;
9075         }
9076         vFAIL("Internal urp");
9077                                 /* Supposed to be caught earlier. */
9078         break;
9079     case '{':
9080         if (!regcurly(RExC_parse)) {
9081             RExC_parse++;
9082             goto defchar;
9083         }
9084         /* FALL THROUGH */
9085     case '?':
9086     case '+':
9087     case '*':
9088         RExC_parse++;
9089         vFAIL("Quantifier follows nothing");
9090         break;
9091     case '\\':
9092         /* Special Escapes
9093
9094            This switch handles escape sequences that resolve to some kind
9095            of special regop and not to literal text. Escape sequnces that
9096            resolve to literal text are handled below in the switch marked
9097            "Literal Escapes".
9098
9099            Every entry in this switch *must* have a corresponding entry
9100            in the literal escape switch. However, the opposite is not
9101            required, as the default for this switch is to jump to the
9102            literal text handling code.
9103         */
9104         switch ((U8)*++RExC_parse) {
9105         /* Special Escapes */
9106         case 'A':
9107             RExC_seen_zerolen++;
9108             ret = reg_node(pRExC_state, SBOL);
9109             *flagp |= SIMPLE;
9110             goto finish_meta_pat;
9111         case 'G':
9112             ret = reg_node(pRExC_state, GPOS);
9113             RExC_seen |= REG_SEEN_GPOS;
9114             *flagp |= SIMPLE;
9115             goto finish_meta_pat;
9116         case 'K':
9117             RExC_seen_zerolen++;
9118             ret = reg_node(pRExC_state, KEEPS);
9119             *flagp |= SIMPLE;
9120             /* XXX:dmq : disabling in-place substitution seems to
9121              * be necessary here to avoid cases of memory corruption, as
9122              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
9123              */
9124             RExC_seen |= REG_SEEN_LOOKBEHIND;
9125             goto finish_meta_pat;
9126         case 'Z':
9127             ret = reg_node(pRExC_state, SEOL);
9128             *flagp |= SIMPLE;
9129             RExC_seen_zerolen++;                /* Do not optimize RE away */
9130             goto finish_meta_pat;
9131         case 'z':
9132             ret = reg_node(pRExC_state, EOS);
9133             *flagp |= SIMPLE;
9134             RExC_seen_zerolen++;                /* Do not optimize RE away */
9135             goto finish_meta_pat;
9136         case 'C':
9137             ret = reg_node(pRExC_state, CANY);
9138             RExC_seen |= REG_SEEN_CANY;
9139             *flagp |= HASWIDTH|SIMPLE;
9140             goto finish_meta_pat;
9141         case 'X':
9142             ret = reg_node(pRExC_state, CLUMP);
9143             *flagp |= HASWIDTH;
9144             goto finish_meta_pat;
9145         case 'w':
9146             switch (get_regex_charset(RExC_flags)) {
9147                 case REGEX_LOCALE_CHARSET:
9148                     op = ALNUML;
9149                     break;
9150                 case REGEX_UNICODE_CHARSET:
9151                     op = ALNUMU;
9152                     break;
9153                 case REGEX_ASCII_RESTRICTED_CHARSET:
9154                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9155                     op = ALNUMA;
9156                     break;
9157                 case REGEX_DEPENDS_CHARSET:
9158                     op = ALNUM;
9159                     break;
9160                 default:
9161                     goto bad_charset;
9162             }
9163             ret = reg_node(pRExC_state, op);
9164             *flagp |= HASWIDTH|SIMPLE;
9165             goto finish_meta_pat;
9166         case 'W':
9167             switch (get_regex_charset(RExC_flags)) {
9168                 case REGEX_LOCALE_CHARSET:
9169                     op = NALNUML;
9170                     break;
9171                 case REGEX_UNICODE_CHARSET:
9172                     op = NALNUMU;
9173                     break;
9174                 case REGEX_ASCII_RESTRICTED_CHARSET:
9175                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9176                     op = NALNUMA;
9177                     break;
9178                 case REGEX_DEPENDS_CHARSET:
9179                     op = NALNUM;
9180                     break;
9181                 default:
9182                     goto bad_charset;
9183             }
9184             ret = reg_node(pRExC_state, op);
9185             *flagp |= HASWIDTH|SIMPLE;
9186             goto finish_meta_pat;
9187         case 'b':
9188             RExC_seen_zerolen++;
9189             RExC_seen |= REG_SEEN_LOOKBEHIND;
9190             switch (get_regex_charset(RExC_flags)) {
9191                 case REGEX_LOCALE_CHARSET:
9192                     op = BOUNDL;
9193                     break;
9194                 case REGEX_UNICODE_CHARSET:
9195                     op = BOUNDU;
9196                     break;
9197                 case REGEX_ASCII_RESTRICTED_CHARSET:
9198                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9199                     op = BOUNDA;
9200                     break;
9201                 case REGEX_DEPENDS_CHARSET:
9202                     op = BOUND;
9203                     break;
9204                 default:
9205                     goto bad_charset;
9206             }
9207             ret = reg_node(pRExC_state, op);
9208             FLAGS(ret) = get_regex_charset(RExC_flags);
9209             *flagp |= SIMPLE;
9210             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
9211                 ckWARNregdep(RExC_parse, "\"\\b{\" is deprecated; use \"\\b\\{\" instead");
9212             }
9213             goto finish_meta_pat;
9214         case 'B':
9215             RExC_seen_zerolen++;
9216             RExC_seen |= REG_SEEN_LOOKBEHIND;
9217             switch (get_regex_charset(RExC_flags)) {
9218                 case REGEX_LOCALE_CHARSET:
9219                     op = NBOUNDL;
9220                     break;
9221                 case REGEX_UNICODE_CHARSET:
9222                     op = NBOUNDU;
9223                     break;
9224                 case REGEX_ASCII_RESTRICTED_CHARSET:
9225                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9226                     op = NBOUNDA;
9227                     break;
9228                 case REGEX_DEPENDS_CHARSET:
9229                     op = NBOUND;
9230                     break;
9231                 default:
9232                     goto bad_charset;
9233             }
9234             ret = reg_node(pRExC_state, op);
9235             FLAGS(ret) = get_regex_charset(RExC_flags);
9236             *flagp |= SIMPLE;
9237             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
9238                 ckWARNregdep(RExC_parse, "\"\\B{\" is deprecated; use \"\\B\\{\" instead");
9239             }
9240             goto finish_meta_pat;
9241         case 's':
9242             switch (get_regex_charset(RExC_flags)) {
9243                 case REGEX_LOCALE_CHARSET:
9244                     op = SPACEL;
9245                     break;
9246                 case REGEX_UNICODE_CHARSET:
9247                     op = SPACEU;
9248                     break;
9249                 case REGEX_ASCII_RESTRICTED_CHARSET:
9250                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9251                     op = SPACEA;
9252                     break;
9253                 case REGEX_DEPENDS_CHARSET:
9254                     op = SPACE;
9255                     break;
9256                 default:
9257                     goto bad_charset;
9258             }
9259             ret = reg_node(pRExC_state, op);
9260             *flagp |= HASWIDTH|SIMPLE;
9261             goto finish_meta_pat;
9262         case 'S':
9263             switch (get_regex_charset(RExC_flags)) {
9264                 case REGEX_LOCALE_CHARSET:
9265                     op = NSPACEL;
9266                     break;
9267                 case REGEX_UNICODE_CHARSET:
9268                     op = NSPACEU;
9269                     break;
9270                 case REGEX_ASCII_RESTRICTED_CHARSET:
9271                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9272                     op = NSPACEA;
9273                     break;
9274                 case REGEX_DEPENDS_CHARSET:
9275                     op = NSPACE;
9276                     break;
9277                 default:
9278                     goto bad_charset;
9279             }
9280             ret = reg_node(pRExC_state, op);
9281             *flagp |= HASWIDTH|SIMPLE;
9282             goto finish_meta_pat;
9283         case 'd':
9284             switch (get_regex_charset(RExC_flags)) {
9285                 case REGEX_LOCALE_CHARSET:
9286                     op = DIGITL;
9287                     break;
9288                 case REGEX_ASCII_RESTRICTED_CHARSET:
9289                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9290                     op = DIGITA;
9291                     break;
9292                 case REGEX_DEPENDS_CHARSET: /* No difference between these */
9293                 case REGEX_UNICODE_CHARSET:
9294                     op = DIGIT;
9295                     break;
9296                 default:
9297                     goto bad_charset;
9298             }
9299             ret = reg_node(pRExC_state, op);
9300             *flagp |= HASWIDTH|SIMPLE;
9301             goto finish_meta_pat;
9302         case 'D':
9303             switch (get_regex_charset(RExC_flags)) {
9304                 case REGEX_LOCALE_CHARSET:
9305                     op = NDIGITL;
9306                     break;
9307                 case REGEX_ASCII_RESTRICTED_CHARSET:
9308                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9309                     op = NDIGITA;
9310                     break;
9311                 case REGEX_DEPENDS_CHARSET: /* No difference between these */
9312                 case REGEX_UNICODE_CHARSET:
9313                     op = NDIGIT;
9314                     break;
9315                 default:
9316                     goto bad_charset;
9317             }
9318             ret = reg_node(pRExC_state, op);
9319             *flagp |= HASWIDTH|SIMPLE;
9320             goto finish_meta_pat;
9321         case 'R':
9322             ret = reg_node(pRExC_state, LNBREAK);
9323             *flagp |= HASWIDTH|SIMPLE;
9324             goto finish_meta_pat;
9325         case 'h':
9326             ret = reg_node(pRExC_state, HORIZWS);
9327             *flagp |= HASWIDTH|SIMPLE;
9328             goto finish_meta_pat;
9329         case 'H':
9330             ret = reg_node(pRExC_state, NHORIZWS);
9331             *flagp |= HASWIDTH|SIMPLE;
9332             goto finish_meta_pat;
9333         case 'v':
9334             ret = reg_node(pRExC_state, VERTWS);
9335             *flagp |= HASWIDTH|SIMPLE;
9336             goto finish_meta_pat;
9337         case 'V':
9338             ret = reg_node(pRExC_state, NVERTWS);
9339             *flagp |= HASWIDTH|SIMPLE;
9340          finish_meta_pat:           
9341             nextchar(pRExC_state);
9342             Set_Node_Length(ret, 2); /* MJD */
9343             break;          
9344         case 'p':
9345         case 'P':
9346             {
9347                 char* const oldregxend = RExC_end;
9348 #ifdef DEBUGGING
9349                 char* parse_start = RExC_parse - 2;
9350 #endif
9351
9352                 if (RExC_parse[1] == '{') {
9353                   /* a lovely hack--pretend we saw [\pX] instead */
9354                     RExC_end = strchr(RExC_parse, '}');
9355                     if (!RExC_end) {
9356                         const U8 c = (U8)*RExC_parse;
9357                         RExC_parse += 2;
9358                         RExC_end = oldregxend;
9359                         vFAIL2("Missing right brace on \\%c{}", c);
9360                     }
9361                     RExC_end++;
9362                 }
9363                 else {
9364                     RExC_end = RExC_parse + 2;
9365                     if (RExC_end > oldregxend)
9366                         RExC_end = oldregxend;
9367                 }
9368                 RExC_parse--;
9369
9370                 ret = regclass(pRExC_state,depth+1);
9371
9372                 RExC_end = oldregxend;
9373                 RExC_parse--;
9374
9375                 Set_Node_Offset(ret, parse_start + 2);
9376                 Set_Node_Cur_Length(ret);
9377                 nextchar(pRExC_state);
9378                 *flagp |= HASWIDTH|SIMPLE;
9379             }
9380             break;
9381         case 'N': 
9382             /* Handle \N and \N{NAME} here and not below because it can be
9383             multicharacter. join_exact() will join them up later on. 
9384             Also this makes sure that things like /\N{BLAH}+/ and 
9385             \N{BLAH} being multi char Just Happen. dmq*/
9386             ++RExC_parse;
9387             ret= reg_namedseq(pRExC_state, NULL, flagp, depth);
9388             break;
9389         case 'k':    /* Handle \k<NAME> and \k'NAME' */
9390         parse_named_seq:
9391         {   
9392             char ch= RExC_parse[1];         
9393             if (ch != '<' && ch != '\'' && ch != '{') {
9394                 RExC_parse++;
9395                 vFAIL2("Sequence %.2s... not terminated",parse_start);
9396             } else {
9397                 /* this pretty much dupes the code for (?P=...) in reg(), if
9398                    you change this make sure you change that */
9399                 char* name_start = (RExC_parse += 2);
9400                 U32 num = 0;
9401                 SV *sv_dat = reg_scan_name(pRExC_state,
9402                     SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
9403                 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
9404                 if (RExC_parse == name_start || *RExC_parse != ch)
9405                     vFAIL2("Sequence %.3s... not terminated",parse_start);
9406
9407                 if (!SIZE_ONLY) {
9408                     num = add_data( pRExC_state, 1, "S" );
9409                     RExC_rxi->data->data[num]=(void*)sv_dat;
9410                     SvREFCNT_inc_simple_void(sv_dat);
9411                 }
9412
9413                 RExC_sawback = 1;
9414                 ret = reganode(pRExC_state,
9415                                ((! FOLD)
9416                                  ? NREF
9417                                  : (MORE_ASCII_RESTRICTED)
9418                                    ? NREFFA
9419                                    : (AT_LEAST_UNI_SEMANTICS)
9420                                      ? NREFFU
9421                                      : (LOC)
9422                                        ? NREFFL
9423                                        : NREFF),
9424                                 num);
9425                 *flagp |= HASWIDTH;
9426
9427                 /* override incorrect value set in reganode MJD */
9428                 Set_Node_Offset(ret, parse_start+1);
9429                 Set_Node_Cur_Length(ret); /* MJD */
9430                 nextchar(pRExC_state);
9431
9432             }
9433             break;
9434         }
9435         case 'g': 
9436         case '1': case '2': case '3': case '4':
9437         case '5': case '6': case '7': case '8': case '9':
9438             {
9439                 I32 num;
9440                 bool isg = *RExC_parse == 'g';
9441                 bool isrel = 0; 
9442                 bool hasbrace = 0;
9443                 if (isg) {
9444                     RExC_parse++;
9445                     if (*RExC_parse == '{') {
9446                         RExC_parse++;
9447                         hasbrace = 1;
9448                     }
9449                     if (*RExC_parse == '-') {
9450                         RExC_parse++;
9451                         isrel = 1;
9452                     }
9453                     if (hasbrace && !isDIGIT(*RExC_parse)) {
9454                         if (isrel) RExC_parse--;
9455                         RExC_parse -= 2;                            
9456                         goto parse_named_seq;
9457                 }   }
9458                 num = atoi(RExC_parse);
9459                 if (isg && num == 0)
9460                     vFAIL("Reference to invalid group 0");
9461                 if (isrel) {
9462                     num = RExC_npar - num;
9463                     if (num < 1)
9464                         vFAIL("Reference to nonexistent or unclosed group");
9465                 }
9466                 if (!isg && num > 9 && num >= RExC_npar)
9467                     goto defchar;
9468                 else {
9469                     char * const parse_start = RExC_parse - 1; /* MJD */
9470                     while (isDIGIT(*RExC_parse))
9471                         RExC_parse++;
9472                     if (parse_start == RExC_parse - 1) 
9473                         vFAIL("Unterminated \\g... pattern");
9474                     if (hasbrace) {
9475                         if (*RExC_parse != '}') 
9476                             vFAIL("Unterminated \\g{...} pattern");
9477                         RExC_parse++;
9478                     }    
9479                     if (!SIZE_ONLY) {
9480                         if (num > (I32)RExC_rx->nparens)
9481                             vFAIL("Reference to nonexistent group");
9482                     }
9483                     RExC_sawback = 1;
9484                     ret = reganode(pRExC_state,
9485                                    ((! FOLD)
9486                                      ? REF
9487                                      : (MORE_ASCII_RESTRICTED)
9488                                        ? REFFA
9489                                        : (AT_LEAST_UNI_SEMANTICS)
9490                                          ? REFFU
9491                                          : (LOC)
9492                                            ? REFFL
9493                                            : REFF),
9494                                     num);
9495                     *flagp |= HASWIDTH;
9496
9497                     /* override incorrect value set in reganode MJD */
9498                     Set_Node_Offset(ret, parse_start+1);
9499                     Set_Node_Cur_Length(ret); /* MJD */
9500                     RExC_parse--;
9501                     nextchar(pRExC_state);
9502                 }
9503             }
9504             break;
9505         case '\0':
9506             if (RExC_parse >= RExC_end)
9507                 FAIL("Trailing \\");
9508             /* FALL THROUGH */
9509         default:
9510             /* Do not generate "unrecognized" warnings here, we fall
9511                back into the quick-grab loop below */
9512             parse_start--;
9513             goto defchar;
9514         }
9515         break;
9516
9517     case '#':
9518         if (RExC_flags & RXf_PMf_EXTENDED) {
9519             if ( reg_skipcomment( pRExC_state ) )
9520                 goto tryagain;
9521         }
9522         /* FALL THROUGH */
9523
9524     default:
9525
9526             parse_start = RExC_parse - 1;
9527
9528             RExC_parse++;
9529
9530         defchar: {
9531             register STRLEN len;
9532             register UV ender;
9533             register char *p;
9534             char *s;
9535             STRLEN foldlen;
9536             U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
9537             U8 node_type;
9538
9539             /* Is this a LATIN LOWER CASE SHARP S in an EXACTFU node?  If so,
9540              * it is folded to 'ss' even if not utf8 */
9541             bool is_exactfu_sharp_s;
9542
9543             ender = 0;
9544             node_type = ((! FOLD) ? EXACT
9545                         : (LOC)
9546                           ? EXACTFL
9547                           : (MORE_ASCII_RESTRICTED)
9548                             ? EXACTFA
9549                             : (AT_LEAST_UNI_SEMANTICS)
9550                               ? EXACTFU
9551                               : EXACTF);
9552             ret = reg_node(pRExC_state, node_type);
9553             s = STRING(ret);
9554
9555             /* XXX The node can hold up to 255 bytes, yet this only goes to
9556              * 127.  I (khw) do not know why.  Keeping it somewhat less than
9557              * 255 allows us to not have to worry about overflow due to
9558              * converting to utf8 and fold expansion, but that value is
9559              * 255-UTF8_MAXBYTES_CASE.  join_exact() may join adjacent nodes
9560              * split up by this limit into a single one using the real max of
9561              * 255.  Even at 127, this breaks under rare circumstances.  If
9562              * folding, we do not want to split a node at a character that is a
9563              * non-final in a multi-char fold, as an input string could just
9564              * happen to want to match across the node boundary.  The join
9565              * would solve that problem if the join actually happens.  But a
9566              * series of more than two nodes in a row each of 127 would cause
9567              * the first join to succeed to get to 254, but then there wouldn't
9568              * be room for the next one, which could at be one of those split
9569              * multi-char folds.  I don't know of any fool-proof solution.  One
9570              * could back off to end with only a code point that isn't such a
9571              * non-final, but it is possible for there not to be any in the
9572              * entire node. */
9573             for (len = 0, p = RExC_parse - 1;
9574                  len < 127 && p < RExC_end;
9575                  len++)
9576             {
9577                 char * const oldp = p;
9578
9579                 if (RExC_flags & RXf_PMf_EXTENDED)
9580                     p = regwhite( pRExC_state, p );
9581                 switch ((U8)*p) {
9582                 case '^':
9583                 case '$':
9584                 case '.':
9585                 case '[':
9586                 case '(':
9587                 case ')':
9588                 case '|':
9589                     goto loopdone;
9590                 case '\\':
9591                     /* Literal Escapes Switch
9592
9593                        This switch is meant to handle escape sequences that
9594                        resolve to a literal character.
9595
9596                        Every escape sequence that represents something
9597                        else, like an assertion or a char class, is handled
9598                        in the switch marked 'Special Escapes' above in this
9599                        routine, but also has an entry here as anything that
9600                        isn't explicitly mentioned here will be treated as
9601                        an unescaped equivalent literal.
9602                     */
9603
9604                     switch ((U8)*++p) {
9605                     /* These are all the special escapes. */
9606                     case 'A':             /* Start assertion */
9607                     case 'b': case 'B':   /* Word-boundary assertion*/
9608                     case 'C':             /* Single char !DANGEROUS! */
9609                     case 'd': case 'D':   /* digit class */
9610                     case 'g': case 'G':   /* generic-backref, pos assertion */
9611                     case 'h': case 'H':   /* HORIZWS */
9612                     case 'k': case 'K':   /* named backref, keep marker */
9613                     case 'N':             /* named char sequence */
9614                     case 'p': case 'P':   /* Unicode property */
9615                               case 'R':   /* LNBREAK */
9616                     case 's': case 'S':   /* space class */
9617                     case 'v': case 'V':   /* VERTWS */
9618                     case 'w': case 'W':   /* word class */
9619                     case 'X':             /* eXtended Unicode "combining character sequence" */
9620                     case 'z': case 'Z':   /* End of line/string assertion */
9621                         --p;
9622                         goto loopdone;
9623
9624                     /* Anything after here is an escape that resolves to a
9625                        literal. (Except digits, which may or may not)
9626                      */
9627                     case 'n':
9628                         ender = '\n';
9629                         p++;
9630                         break;
9631                     case 'r':
9632                         ender = '\r';
9633                         p++;
9634                         break;
9635                     case 't':
9636                         ender = '\t';
9637                         p++;
9638                         break;
9639                     case 'f':
9640                         ender = '\f';
9641                         p++;
9642                         break;
9643                     case 'e':
9644                           ender = ASCII_TO_NATIVE('\033');
9645                         p++;
9646                         break;
9647                     case 'a':
9648                           ender = ASCII_TO_NATIVE('\007');
9649                         p++;
9650                         break;
9651                     case 'o':
9652                         {
9653                             STRLEN brace_len = len;
9654                             UV result;
9655                             const char* error_msg;
9656
9657                             bool valid = grok_bslash_o(p,
9658                                                        &result,
9659                                                        &brace_len,
9660                                                        &error_msg,
9661                                                        1);
9662                             p += brace_len;
9663                             if (! valid) {
9664                                 RExC_parse = p; /* going to die anyway; point
9665                                                    to exact spot of failure */
9666                                 vFAIL(error_msg);
9667                             }
9668                             else
9669                             {
9670                                 ender = result;
9671                             }
9672                             if (PL_encoding && ender < 0x100) {
9673                                 goto recode_encoding;
9674                             }
9675                             if (ender > 0xff) {
9676                                 REQUIRE_UTF8;
9677                             }
9678                             break;
9679                         }
9680                     case 'x':
9681                         if (*++p == '{') {
9682                             char* const e = strchr(p, '}');
9683
9684                             if (!e) {
9685                                 RExC_parse = p + 1;
9686                                 vFAIL("Missing right brace on \\x{}");
9687                             }
9688                             else {
9689                                 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
9690                                     | PERL_SCAN_DISALLOW_PREFIX;
9691                                 STRLEN numlen = e - p - 1;
9692                                 ender = grok_hex(p + 1, &numlen, &flags, NULL);
9693                                 if (ender > 0xff)
9694                                     REQUIRE_UTF8;
9695                                 p = e + 1;
9696                             }
9697                         }
9698                         else {
9699                             I32 flags = PERL_SCAN_DISALLOW_PREFIX;
9700                             STRLEN numlen = 2;
9701                             ender = grok_hex(p, &numlen, &flags, NULL);
9702                             p += numlen;
9703                         }
9704                         if (PL_encoding && ender < 0x100)
9705                             goto recode_encoding;
9706                         break;
9707                     case 'c':
9708                         p++;
9709                         ender = grok_bslash_c(*p++, UTF, SIZE_ONLY);
9710                         break;
9711                     case '0': case '1': case '2': case '3':case '4':
9712                     case '5': case '6': case '7': case '8':case '9':
9713                         if (*p == '0' ||
9714                             (isDIGIT(p[1]) && atoi(p) >= RExC_npar))
9715                         {
9716                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
9717                             STRLEN numlen = 3;
9718                             ender = grok_oct(p, &numlen, &flags, NULL);
9719                             if (ender > 0xff) {
9720                                 REQUIRE_UTF8;
9721                             }
9722                             p += numlen;
9723                         }
9724                         else {
9725                             --p;
9726                             goto loopdone;
9727                         }
9728                         if (PL_encoding && ender < 0x100)
9729                             goto recode_encoding;
9730                         break;
9731                     recode_encoding:
9732                         if (! RExC_override_recoding) {
9733                             SV* enc = PL_encoding;
9734                             ender = reg_recode((const char)(U8)ender, &enc);
9735                             if (!enc && SIZE_ONLY)
9736                                 ckWARNreg(p, "Invalid escape in the specified encoding");
9737                             REQUIRE_UTF8;
9738                         }
9739                         break;
9740                     case '\0':
9741                         if (p >= RExC_end)
9742                             FAIL("Trailing \\");
9743                         /* FALL THROUGH */
9744                     default:
9745                         if (!SIZE_ONLY&& isALPHA(*p)) {
9746                             /* Include any { following the alpha to emphasize
9747                              * that it could be part of an escape at some point
9748                              * in the future */
9749                             int len = (*(p + 1) == '{') ? 2 : 1;
9750                             ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
9751                         }
9752                         goto normal_default;
9753                     }
9754                     break;
9755                 default:
9756                   normal_default:
9757                     if (UTF8_IS_START(*p) && UTF) {
9758                         STRLEN numlen;
9759                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
9760                                                &numlen, UTF8_ALLOW_DEFAULT);
9761                         p += numlen;
9762                     }
9763                     else
9764                         ender = (U8) *p++;
9765                     break;
9766                 } /* End of switch on the literal */
9767
9768                 is_exactfu_sharp_s = (node_type == EXACTFU
9769                                       && ender == LATIN_SMALL_LETTER_SHARP_S);
9770                 if ( RExC_flags & RXf_PMf_EXTENDED)
9771                     p = regwhite( pRExC_state, p );
9772                 if ((UTF && FOLD) || is_exactfu_sharp_s) {
9773                     /* Prime the casefolded buffer.  Locale rules, which apply
9774                      * only to code points < 256, aren't known until execution,
9775                      * so for them, just output the original character using
9776                      * utf8.  If we start to fold non-UTF patterns, be sure to
9777                      * update join_exact() */
9778                     if (LOC && ender < 256) {
9779                         if (UNI_IS_INVARIANT(ender)) {
9780                             *tmpbuf = (U8) ender;
9781                             foldlen = 1;
9782                         } else {
9783                             *tmpbuf = UTF8_TWO_BYTE_HI(ender);
9784                             *(tmpbuf + 1) = UTF8_TWO_BYTE_LO(ender);
9785                             foldlen = 2;
9786                         }
9787                     }
9788                     else if (isASCII(ender)) {  /* Note: Here can't also be LOC
9789                                                  */
9790                         ender = toLOWER(ender);
9791                         *tmpbuf = (U8) ender;
9792                         foldlen = 1;
9793                     }
9794                     else if (! MORE_ASCII_RESTRICTED && ! LOC) {
9795
9796                         /* Locale and /aa require more selectivity about the
9797                          * fold, so are handled below.  Otherwise, here, just
9798                          * use the fold */
9799                         ender = toFOLD_uni(ender, tmpbuf, &foldlen);
9800                     }
9801                     else {
9802                         /* Under locale rules or /aa we are not to mix,
9803                          * respectively, ords < 256 or ASCII with non-.  So
9804                          * reject folds that mix them, using only the
9805                          * non-folded code point.  So do the fold to a
9806                          * temporary, and inspect each character in it. */
9807                         U8 trialbuf[UTF8_MAXBYTES_CASE+1];
9808                         U8* s = trialbuf;
9809                         UV tmpender = toFOLD_uni(ender, trialbuf, &foldlen);
9810                         U8* e = s + foldlen;
9811                         bool fold_ok = TRUE;
9812
9813                         while (s < e) {
9814                             if (isASCII(*s)
9815                                 || (LOC && (UTF8_IS_INVARIANT(*s)
9816                                            || UTF8_IS_DOWNGRADEABLE_START(*s))))
9817                             {
9818                                 fold_ok = FALSE;
9819                                 break;
9820                             }
9821                             s += UTF8SKIP(s);
9822                         }
9823                         if (fold_ok) {
9824                             Copy(trialbuf, tmpbuf, foldlen, U8);
9825                             ender = tmpender;
9826                         }
9827                         else {
9828                             uvuni_to_utf8(tmpbuf, ender);
9829                             foldlen = UNISKIP(ender);
9830                         }
9831                     }
9832                 }
9833                 if (p < RExC_end && ISMULT2(p)) { /* Back off on ?+*. */
9834                     if (len)
9835                         p = oldp;
9836                     else if (UTF || is_exactfu_sharp_s) {
9837                          if (FOLD) {
9838                               /* Emit all the Unicode characters. */
9839                               STRLEN numlen;
9840                               for (foldbuf = tmpbuf;
9841                                    foldlen;
9842                                    foldlen -= numlen) {
9843
9844                                    /* tmpbuf has been constructed by us, so we
9845                                     * know it is valid utf8 */
9846                                    ender = valid_utf8_to_uvchr(foldbuf, &numlen);
9847                                    if (numlen > 0) {
9848                                         const STRLEN unilen = reguni(pRExC_state, ender, s);
9849                                         s       += unilen;
9850                                         len     += unilen;
9851                                         /* In EBCDIC the numlen
9852                                          * and unilen can differ. */
9853                                         foldbuf += numlen;
9854                                         if (numlen >= foldlen)
9855                                              break;
9856                                    }
9857                                    else
9858                                         break; /* "Can't happen." */
9859                               }
9860                          }
9861                          else {
9862                               const STRLEN unilen = reguni(pRExC_state, ender, s);
9863                               if (unilen > 0) {
9864                                    s   += unilen;
9865                                    len += unilen;
9866                               }
9867                          }
9868                     }
9869                     else {
9870                         len++;
9871                         REGC((char)ender, s++);
9872                     }
9873                     break;
9874                 }
9875                 if (UTF || is_exactfu_sharp_s) {
9876                      if (FOLD) {
9877                           /* Emit all the Unicode characters. */
9878                           STRLEN numlen;
9879                           for (foldbuf = tmpbuf;
9880                                foldlen;
9881                                foldlen -= numlen) {
9882                                ender = valid_utf8_to_uvchr(foldbuf, &numlen);
9883                                if (numlen > 0) {
9884                                     const STRLEN unilen = reguni(pRExC_state, ender, s);
9885                                     len     += unilen;
9886                                     s       += unilen;
9887                                     /* In EBCDIC the numlen
9888                                      * and unilen can differ. */
9889                                     foldbuf += numlen;
9890                                     if (numlen >= foldlen)
9891                                          break;
9892                                }
9893                                else
9894                                     break;
9895                           }
9896                      }
9897                      else {
9898                           const STRLEN unilen = reguni(pRExC_state, ender, s);
9899                           if (unilen > 0) {
9900                                s   += unilen;
9901                                len += unilen;
9902                           }
9903                      }
9904                      len--;
9905                 }
9906                 else {
9907                     REGC((char)ender, s++);
9908                 }
9909             }
9910         loopdone:   /* Jumped to when encounters something that shouldn't be in
9911                        the node */
9912             RExC_parse = p - 1;
9913             Set_Node_Cur_Length(ret); /* MJD */
9914             nextchar(pRExC_state);
9915             {
9916                 /* len is STRLEN which is unsigned, need to copy to signed */
9917                 IV iv = len;
9918                 if (iv < 0)
9919                     vFAIL("Internal disaster");
9920             }
9921             if (len > 0)
9922                 *flagp |= HASWIDTH;
9923             if (len == 1 && UNI_IS_INVARIANT(ender))
9924                 *flagp |= SIMPLE;
9925
9926             if (SIZE_ONLY)
9927                 RExC_size += STR_SZ(len);
9928             else {
9929                 STR_LEN(ret) = len;
9930                 RExC_emit += STR_SZ(len);
9931             }
9932         }
9933         break;
9934     }
9935
9936     return(ret);
9937
9938 /* Jumped to when an unrecognized character set is encountered */
9939 bad_charset:
9940     Perl_croak(aTHX_ "panic: Unknown regex character set encoding: %u", get_regex_charset(RExC_flags));
9941     return(NULL);
9942 }
9943
9944 STATIC char *
9945 S_regwhite( RExC_state_t *pRExC_state, char *p )
9946 {
9947     const char *e = RExC_end;
9948
9949     PERL_ARGS_ASSERT_REGWHITE;
9950
9951     while (p < e) {
9952         if (isSPACE(*p))
9953             ++p;
9954         else if (*p == '#') {
9955             bool ended = 0;
9956             do {
9957                 if (*p++ == '\n') {
9958                     ended = 1;
9959                     break;
9960                 }
9961             } while (p < e);
9962             if (!ended)
9963                 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
9964         }
9965         else
9966             break;
9967     }
9968     return p;
9969 }
9970
9971 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
9972    Character classes ([:foo:]) can also be negated ([:^foo:]).
9973    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
9974    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
9975    but trigger failures because they are currently unimplemented. */
9976
9977 #define POSIXCC_DONE(c)   ((c) == ':')
9978 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
9979 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
9980
9981 STATIC I32
9982 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
9983 {
9984     dVAR;
9985     I32 namedclass = OOB_NAMEDCLASS;
9986
9987     PERL_ARGS_ASSERT_REGPPOSIXCC;
9988
9989     if (value == '[' && RExC_parse + 1 < RExC_end &&
9990         /* I smell either [: or [= or [. -- POSIX has been here, right? */
9991         POSIXCC(UCHARAT(RExC_parse))) {
9992         const char c = UCHARAT(RExC_parse);
9993         char* const s = RExC_parse++;
9994
9995         while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
9996             RExC_parse++;
9997         if (RExC_parse == RExC_end)
9998             /* Grandfather lone [:, [=, [. */
9999             RExC_parse = s;
10000         else {
10001             const char* const t = RExC_parse++; /* skip over the c */
10002             assert(*t == c);
10003
10004             if (UCHARAT(RExC_parse) == ']') {
10005                 const char *posixcc = s + 1;
10006                 RExC_parse++; /* skip over the ending ] */
10007
10008                 if (*s == ':') {
10009                     const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
10010                     const I32 skip = t - posixcc;
10011
10012                     /* Initially switch on the length of the name.  */
10013                     switch (skip) {
10014                     case 4:
10015                         if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
10016                             namedclass = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
10017                         break;
10018                     case 5:
10019                         /* Names all of length 5.  */
10020                         /* alnum alpha ascii blank cntrl digit graph lower
10021                            print punct space upper  */
10022                         /* Offset 4 gives the best switch position.  */
10023                         switch (posixcc[4]) {
10024                         case 'a':
10025                             if (memEQ(posixcc, "alph", 4)) /* alpha */
10026                                 namedclass = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
10027                             break;
10028                         case 'e':
10029                             if (memEQ(posixcc, "spac", 4)) /* space */
10030                                 namedclass = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
10031                             break;
10032                         case 'h':
10033                             if (memEQ(posixcc, "grap", 4)) /* graph */
10034                                 namedclass = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
10035                             break;
10036                         case 'i':
10037                             if (memEQ(posixcc, "asci", 4)) /* ascii */
10038                                 namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII;
10039                             break;
10040                         case 'k':
10041                             if (memEQ(posixcc, "blan", 4)) /* blank */
10042                                 namedclass = complement ? ANYOF_NBLANK : ANYOF_BLANK;
10043                             break;
10044                         case 'l':
10045                             if (memEQ(posixcc, "cntr", 4)) /* cntrl */
10046                                 namedclass = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
10047                             break;
10048                         case 'm':
10049                             if (memEQ(posixcc, "alnu", 4)) /* alnum */
10050                                 namedclass = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
10051                             break;
10052                         case 'r':
10053                             if (memEQ(posixcc, "lowe", 4)) /* lower */
10054                                 namedclass = complement ? ANYOF_NLOWER : ANYOF_LOWER;
10055                             else if (memEQ(posixcc, "uppe", 4)) /* upper */
10056                                 namedclass = complement ? ANYOF_NUPPER : ANYOF_UPPER;
10057                             break;
10058                         case 't':
10059                             if (memEQ(posixcc, "digi", 4)) /* digit */
10060                                 namedclass = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
10061                             else if (memEQ(posixcc, "prin", 4)) /* print */
10062                                 namedclass = complement ? ANYOF_NPRINT : ANYOF_PRINT;
10063                             else if (memEQ(posixcc, "punc", 4)) /* punct */
10064                                 namedclass = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
10065                             break;
10066                         }
10067                         break;
10068                     case 6:
10069                         if (memEQ(posixcc, "xdigit", 6))
10070                             namedclass = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
10071                         break;
10072                     }
10073
10074                     if (namedclass == OOB_NAMEDCLASS)
10075                         Simple_vFAIL3("POSIX class [:%.*s:] unknown",
10076                                       t - s - 1, s + 1);
10077                     assert (posixcc[skip] == ':');
10078                     assert (posixcc[skip+1] == ']');
10079                 } else if (!SIZE_ONLY) {
10080                     /* [[=foo=]] and [[.foo.]] are still future. */
10081
10082                     /* adjust RExC_parse so the warning shows after
10083                        the class closes */
10084                     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
10085                         RExC_parse++;
10086                     Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
10087                 }
10088             } else {
10089                 /* Maternal grandfather:
10090                  * "[:" ending in ":" but not in ":]" */
10091                 RExC_parse = s;
10092             }
10093         }
10094     }
10095
10096     return namedclass;
10097 }
10098
10099 STATIC void
10100 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
10101 {
10102     dVAR;
10103
10104     PERL_ARGS_ASSERT_CHECKPOSIXCC;
10105
10106     if (POSIXCC(UCHARAT(RExC_parse))) {
10107         const char *s = RExC_parse;
10108         const char  c = *s++;
10109
10110         while (isALNUM(*s))
10111             s++;
10112         if (*s && c == *s && s[1] == ']') {
10113             ckWARN3reg(s+2,
10114                        "POSIX syntax [%c %c] belongs inside character classes",
10115                        c, c);
10116
10117             /* [[=foo=]] and [[.foo.]] are still future. */
10118             if (POSIXCC_NOTYET(c)) {
10119                 /* adjust RExC_parse so the error shows after
10120                    the class closes */
10121                 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
10122                     NOOP;
10123                 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
10124             }
10125         }
10126     }
10127 }
10128
10129 /* Generate the code to add a full posix character <class> to the bracketed
10130  * character class given by <node>.  (<node> is needed only under locale rules)
10131  * destlist     is the inversion list for non-locale rules that this class is
10132  *              to be added to
10133  * sourcelist   is the ASCII-range inversion list to add under /a rules
10134  * Xsourcelist  is the full Unicode range list to use otherwise. */
10135 #define DO_POSIX(node, class, destlist, sourcelist, Xsourcelist)           \
10136     if (LOC) {                                                             \
10137         SV* scratch_list = NULL;                                           \
10138                                                                            \
10139         /* Set this class in the node for runtime matching */              \
10140         ANYOF_CLASS_SET(node, class);                                      \
10141                                                                            \
10142         /* For above Latin1 code points, we use the full Unicode range */  \
10143         _invlist_intersection(PL_AboveLatin1,                              \
10144                               Xsourcelist,                                 \
10145                               &scratch_list);                              \
10146         /* And set the output to it, adding instead if there already is an \
10147          * output.  Checking if <destlist> is NULL first saves an extra    \
10148          * clone.  Its reference count will be decremented at the next     \
10149          * union, etc, or if this is the only instance, at the end of the  \
10150          * routine */                                                      \
10151         if (! destlist) {                                                  \
10152             destlist = scratch_list;                                       \
10153         }                                                                  \
10154         else {                                                             \
10155             _invlist_union(destlist, scratch_list, &destlist);             \
10156             SvREFCNT_dec(scratch_list);                                    \
10157         }                                                                  \
10158     }                                                                      \
10159     else {                                                                 \
10160         /* For non-locale, just add it to any existing list */             \
10161         _invlist_union(destlist,                                           \
10162                        (AT_LEAST_ASCII_RESTRICTED)                         \
10163                            ? sourcelist                                    \
10164                            : Xsourcelist,                                  \
10165                        &destlist);                                         \
10166     }
10167
10168 /* Like DO_POSIX, but matches the complement of <sourcelist> and <Xsourcelist>.
10169  */
10170 #define DO_N_POSIX(node, class, destlist, sourcelist, Xsourcelist)         \
10171     if (LOC) {                                                             \
10172         SV* scratch_list = NULL;                                           \
10173         ANYOF_CLASS_SET(node, class);                                      \
10174         _invlist_subtract(PL_AboveLatin1, Xsourcelist, &scratch_list);     \
10175         if (! destlist) {                                                  \
10176             destlist = scratch_list;                                       \
10177         }                                                                  \
10178         else {                                                             \
10179             _invlist_union(destlist, scratch_list, &destlist);             \
10180             SvREFCNT_dec(scratch_list);                                    \
10181         }                                                                  \
10182     }                                                                      \
10183     else {                                                                 \
10184         _invlist_union_complement_2nd(destlist,                            \
10185                                     (AT_LEAST_ASCII_RESTRICTED)            \
10186                                         ? sourcelist                       \
10187                                         : Xsourcelist,                     \
10188                                     &destlist);                            \
10189         /* Under /d, everything in the upper half of the Latin1 range      \
10190          * matches this complement */                                      \
10191         if (DEPENDS_SEMANTICS) {                                           \
10192             ANYOF_FLAGS(node) |= ANYOF_NON_UTF8_LATIN1_ALL;                \
10193         }                                                                  \
10194     }
10195
10196 /* Generate the code to add a posix character <class> to the bracketed
10197  * character class given by <node>.  (<node> is needed only under locale rules)
10198  * destlist       is the inversion list for non-locale rules that this class is
10199  *                to be added to
10200  * sourcelist     is the ASCII-range inversion list to add under /a rules
10201  * l1_sourcelist  is the Latin1 range list to use otherwise.
10202  * Xpropertyname  is the name to add to <run_time_list> of the property to
10203  *                specify the code points above Latin1 that will have to be
10204  *                determined at run-time
10205  * run_time_list  is a SV* that contains text names of properties that are to
10206  *                be computed at run time.  This concatenates <Xpropertyname>
10207  *                to it, apppropriately
10208  * This is essentially DO_POSIX, but we know only the Latin1 values at compile
10209  * time */
10210 #define DO_POSIX_LATIN1_ONLY_KNOWN(node, class, destlist, sourcelist,      \
10211                               l1_sourcelist, Xpropertyname, run_time_list) \
10212     /* If not /a matching, there are going to be code points we will have  \
10213      * to defer to runtime to look-up */                                   \
10214     if (! AT_LEAST_ASCII_RESTRICTED) {                                     \
10215         Perl_sv_catpvf(aTHX_ run_time_list, "+utf8::%s\n", Xpropertyname); \
10216     }                                                                      \
10217     if (LOC) {                                                             \
10218         ANYOF_CLASS_SET(node, class);                                      \
10219     }                                                                      \
10220     else {                                                                 \
10221         _invlist_union(destlist,                                           \
10222                        (AT_LEAST_ASCII_RESTRICTED)                         \
10223                            ? sourcelist                                    \
10224                            : l1_sourcelist,                                \
10225                        &destlist);                                         \
10226     }
10227
10228 /* Like DO_POSIX_LATIN1_ONLY_KNOWN, but for the complement.  A combination of
10229  * this and DO_N_POSIX */
10230 #define DO_N_POSIX_LATIN1_ONLY_KNOWN(node, class, destlist, sourcelist,    \
10231                               l1_sourcelist, Xpropertyname, run_time_list) \
10232     if (AT_LEAST_ASCII_RESTRICTED) {                                       \
10233         _invlist_union_complement_2nd(destlist, sourcelist, &destlist);    \
10234     }                                                                      \
10235     else {                                                                 \
10236         Perl_sv_catpvf(aTHX_ run_time_list, "!utf8::%s\n", Xpropertyname); \
10237         if (LOC) {                                                         \
10238             ANYOF_CLASS_SET(node, namedclass);                             \
10239         }                                                                  \
10240         else {                                                             \
10241             SV* scratch_list = NULL;                                       \
10242             _invlist_subtract(PL_Latin1, l1_sourcelist, &scratch_list);    \
10243             if (! destlist) {                                              \
10244                 destlist = scratch_list;                                   \
10245             }                                                              \
10246             else {                                                         \
10247                 _invlist_union(destlist, scratch_list, &destlist);         \
10248                 SvREFCNT_dec(scratch_list);                                \
10249             }                                                              \
10250             if (DEPENDS_SEMANTICS) {                                       \
10251                 ANYOF_FLAGS(node) |= ANYOF_NON_UTF8_LATIN1_ALL;            \
10252             }                                                              \
10253         }                                                                  \
10254     }
10255
10256 STATIC U8
10257 S_set_regclass_bit_fold(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, SV** invlist_ptr, AV** alternate_ptr)
10258 {
10259
10260     /* Handle the setting of folds in the bitmap for non-locale ANYOF nodes.
10261      * Locale folding is done at run-time, so this function should not be
10262      * called for nodes that are for locales.
10263      *
10264      * This function sets the bit corresponding to the fold of the input
10265      * 'value', if not already set.  The fold of 'f' is 'F', and the fold of
10266      * 'F' is 'f'.
10267      *
10268      * It also knows about the characters that are in the bitmap that have
10269      * folds that are matchable only outside it, and sets the appropriate lists
10270      * and flags.
10271      *
10272      * It returns the number of bits that actually changed from 0 to 1 */
10273
10274     U8 stored = 0;
10275     U8 fold;
10276
10277     PERL_ARGS_ASSERT_SET_REGCLASS_BIT_FOLD;
10278
10279     fold = (AT_LEAST_UNI_SEMANTICS) ? PL_fold_latin1[value]
10280                                     : PL_fold[value];
10281
10282     /* It assumes the bit for 'value' has already been set */
10283     if (fold != value && ! ANYOF_BITMAP_TEST(node, fold)) {
10284         ANYOF_BITMAP_SET(node, fold);
10285         stored++;
10286     }
10287     if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value) && (! isASCII(value) || ! MORE_ASCII_RESTRICTED)) {
10288         /* Certain Latin1 characters have matches outside the bitmap.  To get
10289          * here, 'value' is one of those characters.   None of these matches is
10290          * valid for ASCII characters under /aa, which have been excluded by
10291          * the 'if' above.  The matches fall into three categories:
10292          * 1) They are singly folded-to or -from an above 255 character, as
10293          *    LATIN SMALL LETTER Y WITH DIAERESIS and LATIN CAPITAL LETTER Y
10294          *    WITH DIAERESIS;
10295          * 2) They are part of a multi-char fold with another character in the
10296          *    bitmap, only LATIN SMALL LETTER SHARP S => "ss" fits that bill;
10297          * 3) They are part of a multi-char fold with a character not in the
10298          *    bitmap, such as various ligatures.
10299          * We aren't dealing fully with multi-char folds, except we do deal
10300          * with the pattern containing a character that has a multi-char fold
10301          * (not so much the inverse).
10302          * For types 1) and 3), the matches only happen when the target string
10303          * is utf8; that's not true for 2), and we set a flag for it.
10304          *
10305          * The code below adds to the passed in inversion list the single fold
10306          * closures for 'value'.  The values are hard-coded here so that an
10307          * innocent-looking character class, like /[ks]/i won't have to go out
10308          * to disk to find the possible matches.  XXX It would be better to
10309          * generate these via regen, in case a new version of the Unicode
10310          * standard adds new mappings, though that is not really likely. */
10311         switch (value) {
10312             case 'k':
10313             case 'K':
10314                 /* KELVIN SIGN */
10315                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212A);
10316                 break;
10317             case 's':
10318             case 'S':
10319                 /* LATIN SMALL LETTER LONG S */
10320                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x017F);
10321                 break;
10322             case MICRO_SIGN:
10323                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10324                                                  GREEK_SMALL_LETTER_MU);
10325                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10326                                                  GREEK_CAPITAL_LETTER_MU);
10327                 break;
10328             case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
10329             case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
10330                 /* ANGSTROM SIGN */
10331                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212B);
10332                 if (DEPENDS_SEMANTICS) {    /* See DEPENDS comment below */
10333                     *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10334                                                      PL_fold_latin1[value]);
10335                 }
10336                 break;
10337             case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
10338                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10339                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
10340                 break;
10341             case LATIN_SMALL_LETTER_SHARP_S:
10342                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10343                                         LATIN_CAPITAL_LETTER_SHARP_S);
10344
10345                 /* Under /a, /d, and /u, this can match the two chars "ss" */
10346                 if (! MORE_ASCII_RESTRICTED) {
10347                     add_alternate(alternate_ptr, (U8 *) "ss", 2);
10348
10349                     /* And under /u or /a, it can match even if the target is
10350                      * not utf8 */
10351                     if (AT_LEAST_UNI_SEMANTICS) {
10352                         ANYOF_FLAGS(node) |= ANYOF_NONBITMAP_NON_UTF8;
10353                     }
10354                 }
10355                 break;
10356             case 'F': case 'f':
10357             case 'I': case 'i':
10358             case 'L': case 'l':
10359             case 'T': case 't':
10360             case 'A': case 'a':
10361             case 'H': case 'h':
10362             case 'J': case 'j':
10363             case 'N': case 'n':
10364             case 'W': case 'w':
10365             case 'Y': case 'y':
10366                 /* These all are targets of multi-character folds from code
10367                  * points that require UTF8 to express, so they can't match
10368                  * unless the target string is in UTF-8, so no action here is
10369                  * necessary, as regexec.c properly handles the general case
10370                  * for UTF-8 matching */
10371                 break;
10372             default:
10373                 /* Use deprecated warning to increase the chances of this
10374                  * being output */
10375                 ckWARN2regdep(RExC_parse, "Perl folding rules are not up-to-date for 0x%x; please use the perlbug utility to report;", value);
10376                 break;
10377         }
10378     }
10379     else if (DEPENDS_SEMANTICS
10380             && ! isASCII(value)
10381             && PL_fold_latin1[value] != value)
10382     {
10383            /* Under DEPENDS rules, non-ASCII Latin1 characters match their
10384             * folds only when the target string is in UTF-8.  We add the fold
10385             * here to the list of things to match outside the bitmap, which
10386             * won't be looked at unless it is UTF8 (or else if something else
10387             * says to look even if not utf8, but those things better not happen
10388             * under DEPENDS semantics. */
10389         *invlist_ptr = add_cp_to_invlist(*invlist_ptr, PL_fold_latin1[value]);
10390     }
10391
10392     return stored;
10393 }
10394
10395
10396 PERL_STATIC_INLINE U8
10397 S_set_regclass_bit(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, SV** invlist_ptr, AV** alternate_ptr)
10398 {
10399     /* This inline function sets a bit in the bitmap if not already set, and if
10400      * appropriate, its fold, returning the number of bits that actually
10401      * changed from 0 to 1 */
10402
10403     U8 stored;
10404
10405     PERL_ARGS_ASSERT_SET_REGCLASS_BIT;
10406
10407     if (ANYOF_BITMAP_TEST(node, value)) {   /* Already set */
10408         return 0;
10409     }
10410
10411     ANYOF_BITMAP_SET(node, value);
10412     stored = 1;
10413
10414     if (FOLD && ! LOC) {        /* Locale folds aren't known until runtime */
10415         stored += set_regclass_bit_fold(pRExC_state, node, value, invlist_ptr, alternate_ptr);
10416     }
10417
10418     return stored;
10419 }
10420
10421 STATIC void
10422 S_add_alternate(pTHX_ AV** alternate_ptr, U8* string, STRLEN len)
10423 {
10424     /* Adds input 'string' with length 'len' to the ANYOF node's unicode
10425      * alternate list, pointed to by 'alternate_ptr'.  This is an array of
10426      * the multi-character folds of characters in the node */
10427     SV *sv;
10428
10429     PERL_ARGS_ASSERT_ADD_ALTERNATE;
10430
10431     if (! *alternate_ptr) {
10432         *alternate_ptr = newAV();
10433     }
10434     sv = newSVpvn_utf8((char*)string, len, TRUE);
10435     av_push(*alternate_ptr, sv);
10436     return;
10437 }
10438
10439 /*
10440    parse a class specification and produce either an ANYOF node that
10441    matches the pattern or perhaps will be optimized into an EXACTish node
10442    instead. The node contains a bit map for the first 256 characters, with the
10443    corresponding bit set if that character is in the list.  For characters
10444    above 255, a range list is used */
10445
10446 STATIC regnode *
10447 S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
10448 {
10449     dVAR;
10450     register UV nextvalue;
10451     register IV prevvalue = OOB_UNICODE;
10452     register IV range = 0;
10453     UV value = 0; /* XXX:dmq: needs to be referenceable (unfortunately) */
10454     register regnode *ret;
10455     STRLEN numlen;
10456     IV namedclass;
10457     char *rangebegin = NULL;
10458     bool need_class = 0;
10459     bool allow_full_fold = TRUE;   /* Assume wants multi-char folding */
10460     SV *listsv = NULL;
10461     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
10462                                       than just initialized.  */
10463     SV* properties = NULL;    /* Code points that match \p{} \P{} */
10464     UV element_count = 0;   /* Number of distinct elements in the class.
10465                                Optimizations may be possible if this is tiny */
10466     UV n;
10467
10468     /* Unicode properties are stored in a swash; this holds the current one
10469      * being parsed.  If this swash is the only above-latin1 component of the
10470      * character class, an optimization is to pass it directly on to the
10471      * execution engine.  Otherwise, it is set to NULL to indicate that there
10472      * are other things in the class that have to be dealt with at execution
10473      * time */
10474     SV* swash = NULL;           /* Code points that match \p{} \P{} */
10475
10476     /* Set if a component of this character class is user-defined; just passed
10477      * on to the engine */
10478     UV has_user_defined_property = 0;
10479
10480     /* code points this node matches that can't be stored in the bitmap */
10481     SV* nonbitmap = NULL;
10482
10483     /* The items that are to match that aren't stored in the bitmap, but are a
10484      * result of things that are stored there.  This is the fold closure of
10485      * such a character, either because it has DEPENDS semantics and shouldn't
10486      * be matched unless the target string is utf8, or is a code point that is
10487      * too large for the bit map, as for example, the fold of the MICRO SIGN is
10488      * above 255.  This all is solely for performance reasons.  By having this
10489      * code know the outside-the-bitmap folds that the bitmapped characters are
10490      * involved with, we don't have to go out to disk to find the list of
10491      * matches, unless the character class includes code points that aren't
10492      * storable in the bit map.  That means that a character class with an 's'
10493      * in it, for example, doesn't need to go out to disk to find everything
10494      * that matches.  A 2nd list is used so that the 'nonbitmap' list is kept
10495      * empty unless there is something whose fold we don't know about, and will
10496      * have to go out to the disk to find. */
10497     SV* l1_fold_invlist = NULL;
10498
10499     /* List of multi-character folds that are matched by this node */
10500     AV* unicode_alternate  = NULL;
10501 #ifdef EBCDIC
10502     UV literal_endpoint = 0;
10503 #endif
10504     UV stored = 0;  /* how many chars stored in the bitmap */
10505
10506     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
10507         case we need to change the emitted regop to an EXACT. */
10508     const char * orig_parse = RExC_parse;
10509     GET_RE_DEBUG_FLAGS_DECL;
10510
10511     PERL_ARGS_ASSERT_REGCLASS;
10512 #ifndef DEBUGGING
10513     PERL_UNUSED_ARG(depth);
10514 #endif
10515
10516     DEBUG_PARSE("clas");
10517
10518     /* Assume we are going to generate an ANYOF node. */
10519     ret = reganode(pRExC_state, ANYOF, 0);
10520
10521
10522     if (!SIZE_ONLY) {
10523         ANYOF_FLAGS(ret) = 0;
10524     }
10525
10526     if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
10527         RExC_naughty++;
10528         RExC_parse++;
10529         if (!SIZE_ONLY)
10530             ANYOF_FLAGS(ret) |= ANYOF_INVERT;
10531
10532         /* We have decided to not allow multi-char folds in inverted character
10533          * classes, due to the confusion that can happen, especially with
10534          * classes that are designed for a non-Unicode world:  You have the
10535          * peculiar case that:
10536             "s s" =~ /^[^\xDF]+$/i => Y
10537             "ss"  =~ /^[^\xDF]+$/i => N
10538          *
10539          * See [perl #89750] */
10540         allow_full_fold = FALSE;
10541     }
10542
10543     if (SIZE_ONLY) {
10544         RExC_size += ANYOF_SKIP;
10545         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
10546     }
10547     else {
10548         RExC_emit += ANYOF_SKIP;
10549         if (LOC) {
10550             ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
10551         }
10552         ANYOF_BITMAP_ZERO(ret);
10553         listsv = newSVpvs("# comment\n");
10554         initial_listsv_len = SvCUR(listsv);
10555     }
10556
10557     nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
10558
10559     if (!SIZE_ONLY && POSIXCC(nextvalue))
10560         checkposixcc(pRExC_state);
10561
10562     /* allow 1st char to be ] (allowing it to be - is dealt with later) */
10563     if (UCHARAT(RExC_parse) == ']')
10564         goto charclassloop;
10565
10566 parseit:
10567     while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
10568
10569     charclassloop:
10570
10571         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
10572
10573         if (!range) {
10574             rangebegin = RExC_parse;
10575             element_count++;
10576         }
10577         if (UTF) {
10578             value = utf8n_to_uvchr((U8*)RExC_parse,
10579                                    RExC_end - RExC_parse,
10580                                    &numlen, UTF8_ALLOW_DEFAULT);
10581             RExC_parse += numlen;
10582         }
10583         else
10584             value = UCHARAT(RExC_parse++);
10585
10586         nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
10587         if (value == '[' && POSIXCC(nextvalue))
10588             namedclass = regpposixcc(pRExC_state, value);
10589         else if (value == '\\') {
10590             if (UTF) {
10591                 value = utf8n_to_uvchr((U8*)RExC_parse,
10592                                    RExC_end - RExC_parse,
10593                                    &numlen, UTF8_ALLOW_DEFAULT);
10594                 RExC_parse += numlen;
10595             }
10596             else
10597                 value = UCHARAT(RExC_parse++);
10598             /* Some compilers cannot handle switching on 64-bit integer
10599              * values, therefore value cannot be an UV.  Yes, this will
10600              * be a problem later if we want switch on Unicode.
10601              * A similar issue a little bit later when switching on
10602              * namedclass. --jhi */
10603             switch ((I32)value) {
10604             case 'w':   namedclass = ANYOF_ALNUM;       break;
10605             case 'W':   namedclass = ANYOF_NALNUM;      break;
10606             case 's':   namedclass = ANYOF_SPACE;       break;
10607             case 'S':   namedclass = ANYOF_NSPACE;      break;
10608             case 'd':   namedclass = ANYOF_DIGIT;       break;
10609             case 'D':   namedclass = ANYOF_NDIGIT;      break;
10610             case 'v':   namedclass = ANYOF_VERTWS;      break;
10611             case 'V':   namedclass = ANYOF_NVERTWS;     break;
10612             case 'h':   namedclass = ANYOF_HORIZWS;     break;
10613             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
10614             case 'N':  /* Handle \N{NAME} in class */
10615                 {
10616                     /* We only pay attention to the first char of 
10617                     multichar strings being returned. I kinda wonder
10618                     if this makes sense as it does change the behaviour
10619                     from earlier versions, OTOH that behaviour was broken
10620                     as well. */
10621                     UV v; /* value is register so we cant & it /grrr */
10622                     if (reg_namedseq(pRExC_state, &v, NULL, depth)) {
10623                         goto parseit;
10624                     }
10625                     value= v; 
10626                 }
10627                 break;
10628             case 'p':
10629             case 'P':
10630                 {
10631                 char *e;
10632                 if (RExC_parse >= RExC_end)
10633                     vFAIL2("Empty \\%c{}", (U8)value);
10634                 if (*RExC_parse == '{') {
10635                     const U8 c = (U8)value;
10636                     e = strchr(RExC_parse++, '}');
10637                     if (!e)
10638                         vFAIL2("Missing right brace on \\%c{}", c);
10639                     while (isSPACE(UCHARAT(RExC_parse)))
10640                         RExC_parse++;
10641                     if (e == RExC_parse)
10642                         vFAIL2("Empty \\%c{}", c);
10643                     n = e - RExC_parse;
10644                     while (isSPACE(UCHARAT(RExC_parse + n - 1)))
10645                         n--;
10646                 }
10647                 else {
10648                     e = RExC_parse;
10649                     n = 1;
10650                 }
10651                 if (!SIZE_ONLY) {
10652                     SV** invlistsvp;
10653                     SV* invlist;
10654                     char* name;
10655                     if (UCHARAT(RExC_parse) == '^') {
10656                          RExC_parse++;
10657                          n--;
10658                          value = value == 'p' ? 'P' : 'p'; /* toggle */
10659                          while (isSPACE(UCHARAT(RExC_parse))) {
10660                               RExC_parse++;
10661                               n--;
10662                          }
10663                     }
10664                     /* Try to get the definition of the property into
10665                      * <invlist>.  If /i is in effect, the effective property
10666                      * will have its name be <__NAME_i>.  The design is
10667                      * discussed in commit
10668                      * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
10669                     Newx(name, n + sizeof("_i__\n"), char);
10670
10671                     sprintf(name, "%s%.*s%s\n",
10672                                     (FOLD) ? "__" : "",
10673                                     (int)n,
10674                                     RExC_parse,
10675                                     (FOLD) ? "_i" : ""
10676                     );
10677
10678                     /* Look up the property name, and get its swash and
10679                      * inversion list, if the property is found  */
10680                     if (swash) {
10681                         SvREFCNT_dec(swash);
10682                     }
10683                     swash = _core_swash_init("utf8", name, &PL_sv_undef,
10684                                              1, /* binary */
10685                                              0, /* not tr/// */
10686                                              TRUE, /* this routine will handle
10687                                                       undefined properties */
10688                                              NULL, FALSE /* No inversion list */
10689                                             );
10690                     if (   ! swash
10691                         || ! SvROK(swash)
10692                         || ! SvTYPE(SvRV(swash)) == SVt_PVHV
10693                         || ! (invlistsvp =
10694                                 hv_fetchs(MUTABLE_HV(SvRV(swash)),
10695                                 "INVLIST", FALSE))
10696                         || ! (invlist = *invlistsvp))
10697                     {
10698                         if (swash) {
10699                             SvREFCNT_dec(swash);
10700                             swash = NULL;
10701                         }
10702
10703                         /* Here didn't find it.  It could be a user-defined
10704                          * property that will be available at run-time.  Add it
10705                          * to the list to look up then */
10706                         Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s\n",
10707                                         (value == 'p' ? '+' : '!'),
10708                                         name);
10709                         has_user_defined_property = 1;
10710
10711                         /* We don't know yet, so have to assume that the
10712                          * property could match something in the Latin1 range,
10713                          * hence something that isn't utf8 */
10714                         ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
10715                     }
10716                     else {
10717
10718                         /* Here, did get the swash and its inversion list.  If
10719                          * the swash is from a user-defined property, then this
10720                          * whole character class should be regarded as such */
10721                         SV** user_defined_svp =
10722                                             hv_fetchs(MUTABLE_HV(SvRV(swash)),
10723                                                         "USER_DEFINED", FALSE);
10724                         if (user_defined_svp) {
10725                             has_user_defined_property
10726                                                     |= SvUV(*user_defined_svp);
10727                         }
10728
10729                         /* Invert if asking for the complement */
10730                         if (value == 'P') {
10731                             _invlist_union_complement_2nd(properties, invlist, &properties);
10732
10733                             /* The swash can't be used as-is, because we've
10734                              * inverted things; delay removing it to here after
10735                              * have copied its invlist above */
10736                             SvREFCNT_dec(swash);
10737                             swash = NULL;
10738                         }
10739                         else {
10740                             _invlist_union(properties, invlist, &properties);
10741                         }
10742                     }
10743                     Safefree(name);
10744                 }
10745                 RExC_parse = e + 1;
10746                 namedclass = ANYOF_MAX;  /* no official name, but it's named */
10747
10748                 /* \p means they want Unicode semantics */
10749                 RExC_uni_semantics = 1;
10750                 }
10751                 break;
10752             case 'n':   value = '\n';                   break;
10753             case 'r':   value = '\r';                   break;
10754             case 't':   value = '\t';                   break;
10755             case 'f':   value = '\f';                   break;
10756             case 'b':   value = '\b';                   break;
10757             case 'e':   value = ASCII_TO_NATIVE('\033');break;
10758             case 'a':   value = ASCII_TO_NATIVE('\007');break;
10759             case 'o':
10760                 RExC_parse--;   /* function expects to be pointed at the 'o' */
10761                 {
10762                     const char* error_msg;
10763                     bool valid = grok_bslash_o(RExC_parse,
10764                                                &value,
10765                                                &numlen,
10766                                                &error_msg,
10767                                                SIZE_ONLY);
10768                     RExC_parse += numlen;
10769                     if (! valid) {
10770                         vFAIL(error_msg);
10771                     }
10772                 }
10773                 if (PL_encoding && value < 0x100) {
10774                     goto recode_encoding;
10775                 }
10776                 break;
10777             case 'x':
10778                 if (*RExC_parse == '{') {
10779                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
10780                         | PERL_SCAN_DISALLOW_PREFIX;
10781                     char * const e = strchr(RExC_parse++, '}');
10782                     if (!e)
10783                         vFAIL("Missing right brace on \\x{}");
10784
10785                     numlen = e - RExC_parse;
10786                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
10787                     RExC_parse = e + 1;
10788                 }
10789                 else {
10790                     I32 flags = PERL_SCAN_DISALLOW_PREFIX;
10791                     numlen = 2;
10792                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
10793                     RExC_parse += numlen;
10794                 }
10795                 if (PL_encoding && value < 0x100)
10796                     goto recode_encoding;
10797                 break;
10798             case 'c':
10799                 value = grok_bslash_c(*RExC_parse++, UTF, SIZE_ONLY);
10800                 break;
10801             case '0': case '1': case '2': case '3': case '4':
10802             case '5': case '6': case '7':
10803                 {
10804                     /* Take 1-3 octal digits */
10805                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
10806                     numlen = 3;
10807                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
10808                     RExC_parse += numlen;
10809                     if (PL_encoding && value < 0x100)
10810                         goto recode_encoding;
10811                     break;
10812                 }
10813             recode_encoding:
10814                 if (! RExC_override_recoding) {
10815                     SV* enc = PL_encoding;
10816                     value = reg_recode((const char)(U8)value, &enc);
10817                     if (!enc && SIZE_ONLY)
10818                         ckWARNreg(RExC_parse,
10819                                   "Invalid escape in the specified encoding");
10820                     break;
10821                 }
10822             default:
10823                 /* Allow \_ to not give an error */
10824                 if (!SIZE_ONLY && isALNUM(value) && value != '_') {
10825                     ckWARN2reg(RExC_parse,
10826                                "Unrecognized escape \\%c in character class passed through",
10827                                (int)value);
10828                 }
10829                 break;
10830             }
10831         } /* end of \blah */
10832 #ifdef EBCDIC
10833         else
10834             literal_endpoint++;
10835 #endif
10836
10837         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
10838
10839             /* What matches in a locale is not known until runtime, so need to
10840              * (one time per class) allocate extra space to pass to regexec.
10841              * The space will contain a bit for each named class that is to be
10842              * matched against.  This isn't needed for \p{} and pseudo-classes,
10843              * as they are not affected by locale, and hence are dealt with
10844              * separately */
10845             if (LOC && namedclass < ANYOF_MAX && ! need_class) {
10846                 need_class = 1;
10847                 if (SIZE_ONLY) {
10848                     RExC_size += ANYOF_CLASS_SKIP - ANYOF_SKIP;
10849                 }
10850                 else {
10851                     RExC_emit += ANYOF_CLASS_SKIP - ANYOF_SKIP;
10852                     ANYOF_CLASS_ZERO(ret);
10853                 }
10854                 ANYOF_FLAGS(ret) |= ANYOF_CLASS;
10855             }
10856
10857             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
10858              * literal, as is the character that began the false range, i.e.
10859              * the 'a' in the examples */
10860             if (range) {
10861                 if (!SIZE_ONLY) {
10862                     const int w =
10863                         RExC_parse >= rangebegin ?
10864                         RExC_parse - rangebegin : 0;
10865                     ckWARN4reg(RExC_parse,
10866                                "False [] range \"%*.*s\"",
10867                                w, w, rangebegin);
10868
10869                     stored +=
10870                          set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
10871                     if (prevvalue < 256) {
10872                         stored +=
10873                          set_regclass_bit(pRExC_state, ret, (U8) prevvalue, &l1_fold_invlist, &unicode_alternate);
10874                     }
10875                     else {
10876                         nonbitmap = add_cp_to_invlist(nonbitmap, prevvalue);
10877                     }
10878                 }
10879
10880                 range = 0; /* this was not a true range */
10881             }
10882
10883             if (!SIZE_ONLY) {
10884
10885                 /* Possible truncation here but in some 64-bit environments
10886                  * the compiler gets heartburn about switch on 64-bit values.
10887                  * A similar issue a little earlier when switching on value.
10888                  * --jhi */
10889                 switch ((I32)namedclass) {
10890                     int i;  /* loop counter */
10891
10892                 case ANYOF_ALNUMC: /* C's alnum, in contrast to \w */
10893                     DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10894                         PL_PosixAlnum, PL_L1PosixAlnum, "XPosixAlnum", listsv);
10895                     break;
10896                 case ANYOF_NALNUMC:
10897                     DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10898                         PL_PosixAlnum, PL_L1PosixAlnum, "XPosixAlnum", listsv);
10899                     break;
10900                 case ANYOF_ALPHA:
10901                     DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10902                         PL_PosixAlpha, PL_L1PosixAlpha, "XPosixAlpha", listsv);
10903                     break;
10904                 case ANYOF_NALPHA:
10905                     DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10906                         PL_PosixAlpha, PL_L1PosixAlpha, "XPosixAlpha", listsv);
10907                     break;
10908                 case ANYOF_ASCII:
10909                     if (LOC) {
10910                         ANYOF_CLASS_SET(ret, namedclass);
10911                     }
10912                     else {
10913                         _invlist_union(properties, PL_ASCII, &properties);
10914                     }
10915                     break;
10916                 case ANYOF_NASCII:
10917                     if (LOC) {
10918                         ANYOF_CLASS_SET(ret, namedclass);
10919                     }
10920                     else {
10921                         _invlist_union_complement_2nd(properties,
10922                                                     PL_ASCII, &properties);
10923                         if (DEPENDS_SEMANTICS) {
10924                             ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL;
10925                         }
10926                     }
10927                     break;
10928                 case ANYOF_BLANK:
10929                     DO_POSIX(ret, namedclass, properties,
10930                                             PL_PosixBlank, PL_XPosixBlank);
10931                     break;
10932                 case ANYOF_NBLANK:
10933                     DO_N_POSIX(ret, namedclass, properties,
10934                                             PL_PosixBlank, PL_XPosixBlank);
10935                     break;
10936                 case ANYOF_CNTRL:
10937                     DO_POSIX(ret, namedclass, properties,
10938                                             PL_PosixCntrl, PL_XPosixCntrl);
10939                     break;
10940                 case ANYOF_NCNTRL:
10941                     DO_N_POSIX(ret, namedclass, properties,
10942                                             PL_PosixCntrl, PL_XPosixCntrl);
10943                     break;
10944                 case ANYOF_DIGIT:
10945                     /* Ignore the compiler warning for this macro, planned to
10946                      * be eliminated later */
10947                     DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10948                         PL_PosixDigit, PL_PosixDigit, "XPosixDigit", listsv);
10949                     break;
10950                 case ANYOF_NDIGIT:
10951                     DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10952                         PL_PosixDigit, PL_PosixDigit, "XPosixDigit", listsv);
10953                     break;
10954                 case ANYOF_GRAPH:
10955                     DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10956                         PL_PosixGraph, PL_L1PosixGraph, "XPosixGraph", listsv);
10957                     break;
10958                 case ANYOF_NGRAPH:
10959                     DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10960                         PL_PosixGraph, PL_L1PosixGraph, "XPosixGraph", listsv);
10961                     break;
10962                 case ANYOF_HORIZWS:
10963                     /* NBSP matches this, and needs to be added unconditionally
10964                      * to the bit map as it matches even under /d, unlike all
10965                      * the rest of the Posix-like classes (\v doesn't have any
10966                      * matches in the Latin1 range, so it is unaffected.) which
10967                      * Otherwise, we use the nonbitmap, as /d doesn't make a
10968                      * difference in what these match.  It turns out that \h is
10969                      * just a synonym for XPosixBlank */
10970                     _invlist_union(nonbitmap, PL_XPosixBlank, &nonbitmap);
10971                     stored += set_regclass_bit(pRExC_state, ret,
10972                                                UNI_TO_NATIVE(0xA0),
10973                                                &l1_fold_invlist,
10974                                                &unicode_alternate);
10975
10976                     break;
10977                 case ANYOF_NHORIZWS:
10978                     _invlist_union_complement_2nd(nonbitmap,
10979                                                  PL_XPosixBlank, &nonbitmap);
10980                     for (i = 128; i < 256; i++) {
10981                         if (i == 0xA0) {
10982                             continue;
10983                         }
10984                         stored += set_regclass_bit(pRExC_state, ret,
10985                                                    UNI_TO_NATIVE(i),
10986                                                    &l1_fold_invlist,
10987                                                    &unicode_alternate);
10988                     }
10989                     break;
10990                 case ANYOF_LOWER:
10991                 case ANYOF_NLOWER:
10992                 {   /* These require special handling, as they differ under
10993                        folding, matching Cased there (which in the ASCII range
10994                        is the same as Alpha */
10995
10996                     SV* ascii_source;
10997                     SV* l1_source;
10998                     const char *Xname;
10999
11000                     if (FOLD && ! LOC) {
11001                         ascii_source = PL_PosixAlpha;
11002                         l1_source = PL_L1Cased;
11003                         Xname = "Cased";
11004                     }
11005                     else {
11006                         ascii_source = PL_PosixLower;
11007                         l1_source = PL_L1PosixLower;
11008                         Xname = "XPosixLower";
11009                     }
11010                     if (namedclass == ANYOF_LOWER) {
11011                         DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11012                                     ascii_source, l1_source, Xname, listsv);
11013                     }
11014                     else {
11015                         DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass,
11016                             properties, ascii_source, l1_source, Xname, listsv);
11017                     }
11018                     break;
11019                 }
11020                 case ANYOF_PRINT:
11021                     DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11022                         PL_PosixPrint, PL_L1PosixPrint, "XPosixPrint", listsv);
11023                     break;
11024                 case ANYOF_NPRINT:
11025                     DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11026                         PL_PosixPrint, PL_L1PosixPrint, "XPosixPrint", listsv);
11027                     break;
11028                 case ANYOF_PUNCT:
11029                     DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11030                         PL_PosixPunct, PL_L1PosixPunct, "XPosixPunct", listsv);
11031                     break;
11032                 case ANYOF_NPUNCT:
11033                     DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11034                         PL_PosixPunct, PL_L1PosixPunct, "XPosixPunct", listsv);
11035                     break;
11036                 case ANYOF_PSXSPC:
11037                     DO_POSIX(ret, namedclass, properties,
11038                                             PL_PosixSpace, PL_XPosixSpace);
11039                     break;
11040                 case ANYOF_NPSXSPC:
11041                     DO_N_POSIX(ret, namedclass, properties,
11042                                             PL_PosixSpace, PL_XPosixSpace);
11043                     break;
11044                 case ANYOF_SPACE:
11045                     DO_POSIX(ret, namedclass, properties,
11046                                             PL_PerlSpace, PL_XPerlSpace);
11047                     break;
11048                 case ANYOF_NSPACE:
11049                     DO_N_POSIX(ret, namedclass, properties,
11050                                             PL_PerlSpace, PL_XPerlSpace);
11051                     break;
11052                 case ANYOF_UPPER:   /* Same as LOWER, above */
11053                 case ANYOF_NUPPER:
11054                 {
11055                     SV* ascii_source;
11056                     SV* l1_source;
11057                     const char *Xname;
11058
11059                     if (FOLD && ! LOC) {
11060                         ascii_source = PL_PosixAlpha;
11061                         l1_source = PL_L1Cased;
11062                         Xname = "Cased";
11063                     }
11064                     else {
11065                         ascii_source = PL_PosixUpper;
11066                         l1_source = PL_L1PosixUpper;
11067                         Xname = "XPosixUpper";
11068                     }
11069                     if (namedclass == ANYOF_UPPER) {
11070                         DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11071                                     ascii_source, l1_source, Xname, listsv);
11072                     }
11073                     else {
11074                         DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass,
11075                         properties, ascii_source, l1_source, Xname, listsv);
11076                     }
11077                     break;
11078                 }
11079                 case ANYOF_ALNUM:   /* Really is 'Word' */
11080                     DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11081                             PL_PosixWord, PL_L1PosixWord, "XPosixWord", listsv);
11082                     break;
11083                 case ANYOF_NALNUM:
11084                     DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11085                             PL_PosixWord, PL_L1PosixWord, "XPosixWord", listsv);
11086                     break;
11087                 case ANYOF_VERTWS:
11088                     /* For these, we use the nonbitmap, as /d doesn't make a
11089                      * difference in what these match.  There would be problems
11090                      * if these characters had folds other than themselves, as
11091                      * nonbitmap is subject to folding */
11092                     _invlist_union(nonbitmap, PL_VertSpace, &nonbitmap);
11093                     break;
11094                 case ANYOF_NVERTWS:
11095                     _invlist_union_complement_2nd(nonbitmap,
11096                                                     PL_VertSpace, &nonbitmap);
11097                     break;
11098                 case ANYOF_XDIGIT:
11099                     DO_POSIX(ret, namedclass, properties,
11100                                             PL_PosixXDigit, PL_XPosixXDigit);
11101                     break;
11102                 case ANYOF_NXDIGIT:
11103                     DO_N_POSIX(ret, namedclass, properties,
11104                                             PL_PosixXDigit, PL_XPosixXDigit);
11105                     break;
11106                 case ANYOF_MAX:
11107                     /* this is to handle \p and \P */
11108                     break;
11109                 default:
11110                     vFAIL("Invalid [::] class");
11111                     break;
11112                 }
11113
11114                 continue;
11115             }
11116         } /* end of namedclass \blah */
11117
11118         if (range) {
11119             if (prevvalue > (IV)value) /* b-a */ {
11120                 const int w = RExC_parse - rangebegin;
11121                 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
11122                 range = 0; /* not a valid range */
11123             }
11124         }
11125         else {
11126             prevvalue = value; /* save the beginning of the range */
11127             if (RExC_parse+1 < RExC_end
11128                 && *RExC_parse == '-'
11129                 && RExC_parse[1] != ']')
11130             {
11131                 RExC_parse++;
11132
11133                 /* a bad range like \w-, [:word:]- ? */
11134                 if (namedclass > OOB_NAMEDCLASS) {
11135                     if (ckWARN(WARN_REGEXP)) {
11136                         const int w =
11137                             RExC_parse >= rangebegin ?
11138                             RExC_parse - rangebegin : 0;
11139                         vWARN4(RExC_parse,
11140                                "False [] range \"%*.*s\"",
11141                                w, w, rangebegin);
11142                     }
11143                     if (!SIZE_ONLY)
11144                         stored +=
11145                             set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
11146                 } else
11147                     range = 1;  /* yeah, it's a range! */
11148                 continue;       /* but do it the next time */
11149             }
11150         }
11151
11152         /* non-Latin1 code point implies unicode semantics.  Must be set in
11153          * pass1 so is there for the whole of pass 2 */
11154         if (value > 255) {
11155             RExC_uni_semantics = 1;
11156         }
11157
11158         /* now is the next time */
11159         if (!SIZE_ONLY) {
11160             if (prevvalue < 256) {
11161                 const IV ceilvalue = value < 256 ? value : 255;
11162                 IV i;
11163 #ifdef EBCDIC
11164                 /* In EBCDIC [\x89-\x91] should include
11165                  * the \x8e but [i-j] should not. */
11166                 if (literal_endpoint == 2 &&
11167                     ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
11168                      (isUPPER(prevvalue) && isUPPER(ceilvalue))))
11169                 {
11170                     if (isLOWER(prevvalue)) {
11171                         for (i = prevvalue; i <= ceilvalue; i++)
11172                             if (isLOWER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
11173                                 stored +=
11174                                   set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
11175                             }
11176                     } else {
11177                         for (i = prevvalue; i <= ceilvalue; i++)
11178                             if (isUPPER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
11179                                 stored +=
11180                                   set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
11181                             }
11182                     }
11183                 }
11184                 else
11185 #endif
11186                       for (i = prevvalue; i <= ceilvalue; i++) {
11187                         stored += set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
11188                       }
11189           }
11190           if (value > 255) {
11191             const UV prevnatvalue  = NATIVE_TO_UNI(prevvalue);
11192             const UV natvalue      = NATIVE_TO_UNI(value);
11193             nonbitmap = _add_range_to_invlist(nonbitmap, prevnatvalue, natvalue);
11194         }
11195 #ifdef EBCDIC
11196             literal_endpoint = 0;
11197 #endif
11198         }
11199
11200         range = 0; /* this range (if it was one) is done now */
11201     }
11202
11203
11204
11205     if (SIZE_ONLY)
11206         return ret;
11207     /****** !SIZE_ONLY AFTER HERE *********/
11208
11209     /* If folding and there are code points above 255, we calculate all
11210      * characters that could fold to or from the ones already on the list */
11211     if (FOLD && nonbitmap) {
11212         UV start, end;  /* End points of code point ranges */
11213
11214         SV* fold_intersection = NULL;
11215
11216         /* This is a list of all the characters that participate in folds
11217             * (except marks, etc in multi-char folds */
11218         if (! PL_utf8_foldable) {
11219             SV* swash = swash_init("utf8", "Cased", &PL_sv_undef, 1, 0);
11220             PL_utf8_foldable = _swash_to_invlist(swash);
11221             SvREFCNT_dec(swash);
11222         }
11223
11224         /* This is a hash that for a particular fold gives all characters
11225             * that are involved in it */
11226         if (! PL_utf8_foldclosures) {
11227
11228             /* If we were unable to find any folds, then we likely won't be
11229              * able to find the closures.  So just create an empty list.
11230              * Folding will effectively be restricted to the non-Unicode rules
11231              * hard-coded into Perl.  (This case happens legitimately during
11232              * compilation of Perl itself before the Unicode tables are
11233              * generated) */
11234             if (invlist_len(PL_utf8_foldable) == 0) {
11235                 PL_utf8_foldclosures = newHV();
11236             } else {
11237                 /* If the folds haven't been read in, call a fold function
11238                     * to force that */
11239                 if (! PL_utf8_tofold) {
11240                     U8 dummy[UTF8_MAXBYTES+1];
11241                     STRLEN dummy_len;
11242
11243                     /* This particular string is above \xff in both UTF-8 and
11244                      * UTFEBCDIC */
11245                     to_utf8_fold((U8*) "\xC8\x80", dummy, &dummy_len);
11246                     assert(PL_utf8_tofold); /* Verify that worked */
11247                 }
11248                 PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
11249             }
11250         }
11251
11252         /* Only the characters in this class that participate in folds need be
11253          * checked.  Get the intersection of this class and all the possible
11254          * characters that are foldable.  This can quickly narrow down a large
11255          * class */
11256         _invlist_intersection(PL_utf8_foldable, nonbitmap, &fold_intersection);
11257
11258         /* Now look at the foldable characters in this class individually */
11259         invlist_iterinit(fold_intersection);
11260         while (invlist_iternext(fold_intersection, &start, &end)) {
11261             UV j;
11262
11263             /* Look at every character in the range */
11264             for (j = start; j <= end; j++) {
11265
11266                 /* Get its fold */
11267                 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
11268                 STRLEN foldlen;
11269                 const UV f =
11270                     _to_uni_fold_flags(j, foldbuf, &foldlen, allow_full_fold);
11271
11272                 if (foldlen > (STRLEN)UNISKIP(f)) {
11273
11274                     /* Any multicharacter foldings (disallowed in lookbehind
11275                      * patterns) require the following transform: [ABCDEF] ->
11276                      * (?:[ABCabcDEFd]|pq|rst) where E folds into "pq" and F
11277                      * folds into "rst", all other characters fold to single
11278                      * characters.  We save away these multicharacter foldings,
11279                      * to be later saved as part of the additional "s" data. */
11280                     if (! RExC_in_lookbehind) {
11281                         U8* loc = foldbuf;
11282                         U8* e = foldbuf + foldlen;
11283
11284                         /* If any of the folded characters of this are in the
11285                          * Latin1 range, tell the regex engine that this can
11286                          * match a non-utf8 target string.  The only multi-byte
11287                          * fold whose source is in the Latin1 range (U+00DF)
11288                          * applies only when the target string is utf8, or
11289                          * under unicode rules */
11290                         if (j > 255 || AT_LEAST_UNI_SEMANTICS) {
11291                             while (loc < e) {
11292
11293                                 /* Can't mix ascii with non- under /aa */
11294                                 if (MORE_ASCII_RESTRICTED
11295                                     && (isASCII(*loc) != isASCII(j)))
11296                                 {
11297                                     goto end_multi_fold;
11298                                 }
11299                                 if (UTF8_IS_INVARIANT(*loc)
11300                                     || UTF8_IS_DOWNGRADEABLE_START(*loc))
11301                                 {
11302                                     /* Can't mix above and below 256 under LOC
11303                                      */
11304                                     if (LOC) {
11305                                         goto end_multi_fold;
11306                                     }
11307                                     ANYOF_FLAGS(ret)
11308                                             |= ANYOF_NONBITMAP_NON_UTF8;
11309                                     break;
11310                                 }
11311                                 loc += UTF8SKIP(loc);
11312                             }
11313                         }
11314
11315                         add_alternate(&unicode_alternate, foldbuf, foldlen);
11316                     end_multi_fold: ;
11317                     }
11318
11319                     /* This is special-cased, as it is the only letter which
11320                      * has both a multi-fold and single-fold in Latin1.  All
11321                      * the other chars that have single and multi-folds are
11322                      * always in utf8, and the utf8 folding algorithm catches
11323                      * them */
11324                     if (! LOC && j == LATIN_CAPITAL_LETTER_SHARP_S) {
11325                         stored += set_regclass_bit(pRExC_state,
11326                                         ret,
11327                                         LATIN_SMALL_LETTER_SHARP_S,
11328                                         &l1_fold_invlist, &unicode_alternate);
11329                     }
11330                 }
11331                 else {
11332                     /* Single character fold.  Add everything in its fold
11333                      * closure to the list that this node should match */
11334                     SV** listp;
11335
11336                     /* The fold closures data structure is a hash with the keys
11337                      * being every character that is folded to, like 'k', and
11338                      * the values each an array of everything that folds to its
11339                      * key.  e.g. [ 'k', 'K', KELVIN_SIGN ] */
11340                     if ((listp = hv_fetch(PL_utf8_foldclosures,
11341                                     (char *) foldbuf, foldlen, FALSE)))
11342                     {
11343                         AV* list = (AV*) *listp;
11344                         IV k;
11345                         for (k = 0; k <= av_len(list); k++) {
11346                             SV** c_p = av_fetch(list, k, FALSE);
11347                             UV c;
11348                             if (c_p == NULL) {
11349                                 Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
11350                             }
11351                             c = SvUV(*c_p);
11352
11353                             /* /aa doesn't allow folds between ASCII and non-;
11354                              * /l doesn't allow them between above and below
11355                              * 256 */
11356                             if ((MORE_ASCII_RESTRICTED
11357                                  && (isASCII(c) != isASCII(j)))
11358                                     || (LOC && ((c < 256) != (j < 256))))
11359                             {
11360                                 continue;
11361                             }
11362
11363                             if (c < 256 && AT_LEAST_UNI_SEMANTICS) {
11364                                 stored += set_regclass_bit(pRExC_state,
11365                                         ret,
11366                                         (U8) c,
11367                                         &l1_fold_invlist, &unicode_alternate);
11368                             }
11369                                 /* It may be that the code point is already in
11370                                  * this range or already in the bitmap, in
11371                                  * which case we need do nothing */
11372                             else if ((c < start || c > end)
11373                                         && (c > 255
11374                                             || ! ANYOF_BITMAP_TEST(ret, c)))
11375                             {
11376                                 nonbitmap = add_cp_to_invlist(nonbitmap, c);
11377                             }
11378                         }
11379                     }
11380                 }
11381             }
11382         }
11383         SvREFCNT_dec(fold_intersection);
11384     }
11385
11386     /* Combine the two lists into one. */
11387     if (l1_fold_invlist) {
11388         if (nonbitmap) {
11389             _invlist_union(nonbitmap, l1_fold_invlist, &nonbitmap);
11390             SvREFCNT_dec(l1_fold_invlist);
11391         }
11392         else {
11393             nonbitmap = l1_fold_invlist;
11394         }
11395     }
11396
11397     /* And combine the result (if any) with any inversion list from properties.
11398      * The lists are kept separate up to now because we don't want to fold the
11399      * properties */
11400     if (properties) {
11401         if (nonbitmap) {
11402             _invlist_union(nonbitmap, properties, &nonbitmap);
11403             SvREFCNT_dec(properties);
11404         }
11405         else {
11406             nonbitmap = properties;
11407         }
11408     }
11409
11410     /* Here, <nonbitmap> contains all the code points we can determine at
11411      * compile time that we haven't put into the bitmap.  Go through it, and
11412      * for things that belong in the bitmap, put them there, and delete from
11413      * <nonbitmap> */
11414     if (nonbitmap) {
11415
11416         /* Above-ASCII code points in /d have to stay in <nonbitmap>, as they
11417          * possibly only should match when the target string is UTF-8 */
11418         UV max_cp_to_set = (DEPENDS_SEMANTICS) ? 127 : 255;
11419
11420         /* This gets set if we actually need to modify things */
11421         bool change_invlist = FALSE;
11422
11423         UV start, end;
11424
11425         /* Start looking through <nonbitmap> */
11426         invlist_iterinit(nonbitmap);
11427         while (invlist_iternext(nonbitmap, &start, &end)) {
11428             UV high;
11429             int i;
11430
11431             /* Quit if are above what we should change */
11432             if (start > max_cp_to_set) {
11433                 break;
11434             }
11435
11436             change_invlist = TRUE;
11437
11438             /* Set all the bits in the range, up to the max that we are doing */
11439             high = (end < max_cp_to_set) ? end : max_cp_to_set;
11440             for (i = start; i <= (int) high; i++) {
11441                 if (! ANYOF_BITMAP_TEST(ret, i)) {
11442                     ANYOF_BITMAP_SET(ret, i);
11443                     stored++;
11444                     prevvalue = value;
11445                     value = i;
11446                 }
11447             }
11448         }
11449
11450         /* Done with loop; remove any code points that are in the bitmap from
11451          * <nonbitmap> */
11452         if (change_invlist) {
11453             _invlist_subtract(nonbitmap,
11454                               (DEPENDS_SEMANTICS)
11455                                 ? PL_ASCII
11456                                 : PL_Latin1,
11457                               &nonbitmap);
11458         }
11459
11460         /* If have completely emptied it, remove it completely */
11461         if (invlist_len(nonbitmap) == 0) {
11462             SvREFCNT_dec(nonbitmap);
11463             nonbitmap = NULL;
11464         }
11465     }
11466
11467     /* Here, we have calculated what code points should be in the character
11468      * class.  <nonbitmap> does not overlap the bitmap except possibly in the
11469      * case of DEPENDS rules.
11470      *
11471      * Now we can see about various optimizations.  Fold calculation (which we
11472      * did above) needs to take place before inversion.  Otherwise /[^k]/i
11473      * would invert to include K, which under /i would match k, which it
11474      * shouldn't. */
11475
11476     /* Optimize inverted simple patterns (e.g. [^a-z]).  Note that we haven't
11477      * set the FOLD flag yet, so this does optimize those.  It doesn't
11478      * optimize locale.  Doing so perhaps could be done as long as there is
11479      * nothing like \w in it; some thought also would have to be given to the
11480      * interaction with above 0x100 chars */
11481     if ((ANYOF_FLAGS(ret) & ANYOF_INVERT)
11482         && ! LOC
11483         && ! unicode_alternate
11484         /* In case of /d, there are some things that should match only when in
11485          * not in the bitmap, i.e., they require UTF8 to match.  These are
11486          * listed in nonbitmap, but if ANYOF_NONBITMAP_NON_UTF8 is set in this
11487          * case, they don't require UTF8, so can invert here */
11488         && (! nonbitmap
11489             || ! DEPENDS_SEMANTICS
11490             || (ANYOF_FLAGS(ret) & ANYOF_NONBITMAP_NON_UTF8))
11491         && SvCUR(listsv) == initial_listsv_len)
11492     {
11493         int i;
11494         if (! nonbitmap) {
11495             for (i = 0; i < 256; ++i) {
11496                 if (ANYOF_BITMAP_TEST(ret, i)) {
11497                     ANYOF_BITMAP_CLEAR(ret, i);
11498                 }
11499                 else {
11500                     ANYOF_BITMAP_SET(ret, i);
11501                     prevvalue = value;
11502                     value = i;
11503                 }
11504             }
11505             /* The inversion means that everything above 255 is matched */
11506             ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
11507         }
11508         else {
11509             /* Here, also has things outside the bitmap that may overlap with
11510              * the bitmap.  We have to sync them up, so that they get inverted
11511              * in both places.  Earlier, we removed all overlaps except in the
11512              * case of /d rules, so no syncing is needed except for this case
11513              */
11514             SV *remove_list = NULL;
11515
11516             if (DEPENDS_SEMANTICS) {
11517                 UV start, end;
11518
11519                 /* Set the bits that correspond to the ones that aren't in the
11520                  * bitmap.  Otherwise, when we invert, we'll miss these.
11521                  * Earlier, we removed from the nonbitmap all code points
11522                  * < 128, so there is no extra work here */
11523                 invlist_iterinit(nonbitmap);
11524                 while (invlist_iternext(nonbitmap, &start, &end)) {
11525                     if (start > 255) {  /* The bit map goes to 255 */
11526                         break;
11527                     }
11528                     if (end > 255) {
11529                         end = 255;
11530                     }
11531                     for (i = start; i <= (int) end; ++i) {
11532                         ANYOF_BITMAP_SET(ret, i);
11533                         prevvalue = value;
11534                         value = i;
11535                     }
11536                 }
11537             }
11538
11539             /* Now invert both the bitmap and the nonbitmap.  Anything in the
11540              * bitmap has to also be removed from the non-bitmap, but again,
11541              * there should not be overlap unless is /d rules. */
11542             _invlist_invert(nonbitmap);
11543
11544             /* Any swash can't be used as-is, because we've inverted things */
11545             if (swash) {
11546                 SvREFCNT_dec(swash);
11547                 swash = NULL;
11548             }
11549
11550             for (i = 0; i < 256; ++i) {
11551                 if (ANYOF_BITMAP_TEST(ret, i)) {
11552                     ANYOF_BITMAP_CLEAR(ret, i);
11553                     if (DEPENDS_SEMANTICS) {
11554                         if (! remove_list) {
11555                             remove_list = _new_invlist(2);
11556                         }
11557                         remove_list = add_cp_to_invlist(remove_list, i);
11558                     }
11559                 }
11560                 else {
11561                     ANYOF_BITMAP_SET(ret, i);
11562                     prevvalue = value;
11563                     value = i;
11564                 }
11565             }
11566
11567             /* And do the removal */
11568             if (DEPENDS_SEMANTICS) {
11569                 if (remove_list) {
11570                     _invlist_subtract(nonbitmap, remove_list, &nonbitmap);
11571                     SvREFCNT_dec(remove_list);
11572                 }
11573             }
11574             else {
11575                 /* There is no overlap for non-/d, so just delete anything
11576                  * below 256 */
11577                 _invlist_intersection(nonbitmap, PL_AboveLatin1, &nonbitmap);
11578             }
11579         }
11580
11581         stored = 256 - stored;
11582
11583         /* Clear the invert flag since have just done it here */
11584         ANYOF_FLAGS(ret) &= ~ANYOF_INVERT;
11585     }
11586
11587     /* Folding in the bitmap is taken care of above, but not for locale (for
11588      * which we have to wait to see what folding is in effect at runtime), and
11589      * for some things not in the bitmap (only the upper latin folds in this
11590      * case, as all other single-char folding has been set above).  Set
11591      * run-time fold flag for these */
11592     if (FOLD && (LOC
11593                 || (DEPENDS_SEMANTICS
11594                     && nonbitmap
11595                     && ! (ANYOF_FLAGS(ret) & ANYOF_NONBITMAP_NON_UTF8))
11596                 || unicode_alternate))
11597     {
11598         ANYOF_FLAGS(ret) |= ANYOF_LOC_NONBITMAP_FOLD;
11599     }
11600
11601     /* A single character class can be "optimized" into an EXACTish node.
11602      * Note that since we don't currently count how many characters there are
11603      * outside the bitmap, we are XXX missing optimization possibilities for
11604      * them.  This optimization can't happen unless this is a truly single
11605      * character class, which means that it can't be an inversion into a
11606      * many-character class, and there must be no possibility of there being
11607      * things outside the bitmap.  'stored' (only) for locales doesn't include
11608      * \w, etc, so have to make a special test that they aren't present
11609      *
11610      * Similarly A 2-character class of the very special form like [bB] can be
11611      * optimized into an EXACTFish node, but only for non-locales, and for
11612      * characters which only have the two folds; so things like 'fF' and 'Ii'
11613      * wouldn't work because they are part of the fold of 'LATIN SMALL LIGATURE
11614      * FI'. */
11615     if (! nonbitmap
11616         && ! unicode_alternate
11617         && SvCUR(listsv) == initial_listsv_len
11618         && ! (ANYOF_FLAGS(ret) & (ANYOF_INVERT|ANYOF_UNICODE_ALL))
11619         && (((stored == 1 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
11620                               || (! ANYOF_CLASS_TEST_ANY_SET(ret)))))
11621             || (stored == 2 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
11622                                  && (! _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value))
11623                                  /* If the latest code point has a fold whose
11624                                   * bit is set, it must be the only other one */
11625                                 && ((prevvalue = PL_fold_latin1[value]) != (IV)value)
11626                                  && ANYOF_BITMAP_TEST(ret, prevvalue)))))
11627     {
11628         /* Note that the information needed to decide to do this optimization
11629          * is not currently available until the 2nd pass, and that the actually
11630          * used EXACTish node takes less space than the calculated ANYOF node,
11631          * and hence the amount of space calculated in the first pass is larger
11632          * than actually used, so this optimization doesn't gain us any space.
11633          * But an EXACT node is faster than an ANYOF node, and can be combined
11634          * with any adjacent EXACT nodes later by the optimizer for further
11635          * gains.  The speed of executing an EXACTF is similar to an ANYOF
11636          * node, so the optimization advantage comes from the ability to join
11637          * it to adjacent EXACT nodes */
11638
11639         const char * cur_parse= RExC_parse;
11640         U8 op;
11641         RExC_emit = (regnode *)orig_emit;
11642         RExC_parse = (char *)orig_parse;
11643
11644         if (stored == 1) {
11645
11646             /* A locale node with one point can be folded; all the other cases
11647              * with folding will have two points, since we calculate them above
11648              */
11649             if (ANYOF_FLAGS(ret) & ANYOF_LOC_NONBITMAP_FOLD) {
11650                  op = EXACTFL;
11651             }
11652             else {
11653                 op = EXACT;
11654             }
11655         }
11656         else {   /* else 2 chars in the bit map: the folds of each other */
11657
11658             /* Use the folded value, which for the cases where we get here,
11659              * is just the lower case of the current one (which may resolve to
11660              * itself, or to the other one */
11661             value = toLOWER_LATIN1(value);
11662
11663             /* To join adjacent nodes, they must be the exact EXACTish type.
11664              * Try to use the most likely type, by using EXACTFA if possible,
11665              * then EXACTFU if the regex calls for it, or is required because
11666              * the character is non-ASCII.  (If <value> is ASCII, its fold is
11667              * also ASCII for the cases where we get here.) */
11668             if (MORE_ASCII_RESTRICTED && isASCII(value)) {
11669                 op = EXACTFA;
11670             }
11671             else if (AT_LEAST_UNI_SEMANTICS || !isASCII(value)) {
11672                 op = EXACTFU;
11673             }
11674             else {    /* Otherwise, more likely to be EXACTF type */
11675                 op = EXACTF;
11676             }
11677         }
11678
11679         ret = reg_node(pRExC_state, op);
11680         RExC_parse = (char *)cur_parse;
11681         if (UTF && ! NATIVE_IS_INVARIANT(value)) {
11682             *STRING(ret)= UTF8_EIGHT_BIT_HI((U8) value);
11683             *(STRING(ret) + 1)= UTF8_EIGHT_BIT_LO((U8) value);
11684             STR_LEN(ret)= 2;
11685             RExC_emit += STR_SZ(2);
11686         }
11687         else {
11688             *STRING(ret)= (char)value;
11689             STR_LEN(ret)= 1;
11690             RExC_emit += STR_SZ(1);
11691         }
11692         SvREFCNT_dec(listsv);
11693         return ret;
11694     }
11695
11696     /* If there is a swash and more than one element, we can't use the swash in
11697      * the optimization below. */
11698     if (swash && element_count > 1) {
11699         SvREFCNT_dec(swash);
11700         swash = NULL;
11701     }
11702     if (! nonbitmap
11703         && SvCUR(listsv) == initial_listsv_len
11704         && ! unicode_alternate)
11705     {
11706         ARG_SET(ret, ANYOF_NONBITMAP_EMPTY);
11707         SvREFCNT_dec(listsv);
11708         SvREFCNT_dec(unicode_alternate);
11709     }
11710     else {
11711         /* av[0] stores the character class description in its textual form:
11712          *       used later (regexec.c:Perl_regclass_swash()) to initialize the
11713          *       appropriate swash, and is also useful for dumping the regnode.
11714          * av[1] if NULL, is a placeholder to later contain the swash computed
11715          *       from av[0].  But if no further computation need be done, the
11716          *       swash is stored there now.
11717          * av[2] stores the multicharacter foldings, used later in
11718          *       regexec.c:S_reginclass().
11719          * av[3] stores the nonbitmap inversion list for use in addition or
11720          *       instead of av[0]; not used if av[1] isn't NULL
11721          * av[4] is set if any component of the class is from a user-defined
11722          *       property; not used if av[1] isn't NULL */
11723         AV * const av = newAV();
11724         SV *rv;
11725
11726         av_store(av, 0, (SvCUR(listsv) == initial_listsv_len)
11727                         ? &PL_sv_undef
11728                         : listsv);
11729         if (swash) {
11730             av_store(av, 1, swash);
11731             SvREFCNT_dec(nonbitmap);
11732         }
11733         else {
11734             av_store(av, 1, NULL);
11735             if (nonbitmap) {
11736                 av_store(av, 3, nonbitmap);
11737                 av_store(av, 4, newSVuv(has_user_defined_property));
11738             }
11739         }
11740
11741         /* Store any computed multi-char folds only if we are allowing
11742          * them */
11743         if (allow_full_fold) {
11744             av_store(av, 2, MUTABLE_SV(unicode_alternate));
11745             if (unicode_alternate) { /* This node is variable length */
11746                 OP(ret) = ANYOFV;
11747             }
11748         }
11749         else {
11750             av_store(av, 2, NULL);
11751         }
11752         rv = newRV_noinc(MUTABLE_SV(av));
11753         n = add_data(pRExC_state, 1, "s");
11754         RExC_rxi->data->data[n] = (void*)rv;
11755         ARG_SET(ret, n);
11756     }
11757     return ret;
11758 }
11759
11760
11761 /* reg_skipcomment()
11762
11763    Absorbs an /x style # comments from the input stream.
11764    Returns true if there is more text remaining in the stream.
11765    Will set the REG_SEEN_RUN_ON_COMMENT flag if the comment
11766    terminates the pattern without including a newline.
11767
11768    Note its the callers responsibility to ensure that we are
11769    actually in /x mode
11770
11771 */
11772
11773 STATIC bool
11774 S_reg_skipcomment(pTHX_ RExC_state_t *pRExC_state)
11775 {
11776     bool ended = 0;
11777
11778     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
11779
11780     while (RExC_parse < RExC_end)
11781         if (*RExC_parse++ == '\n') {
11782             ended = 1;
11783             break;
11784         }
11785     if (!ended) {
11786         /* we ran off the end of the pattern without ending
11787            the comment, so we have to add an \n when wrapping */
11788         RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
11789         return 0;
11790     } else
11791         return 1;
11792 }
11793
11794 /* nextchar()
11795
11796    Advances the parse position, and optionally absorbs
11797    "whitespace" from the inputstream.
11798
11799    Without /x "whitespace" means (?#...) style comments only,
11800    with /x this means (?#...) and # comments and whitespace proper.
11801
11802    Returns the RExC_parse point from BEFORE the scan occurs.
11803
11804    This is the /x friendly way of saying RExC_parse++.
11805 */
11806
11807 STATIC char*
11808 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
11809 {
11810     char* const retval = RExC_parse++;
11811
11812     PERL_ARGS_ASSERT_NEXTCHAR;
11813
11814     for (;;) {
11815         if (RExC_end - RExC_parse >= 3
11816             && *RExC_parse == '('
11817             && RExC_parse[1] == '?'
11818             && RExC_parse[2] == '#')
11819         {
11820             while (*RExC_parse != ')') {
11821                 if (RExC_parse == RExC_end)
11822                     FAIL("Sequence (?#... not terminated");
11823                 RExC_parse++;
11824             }
11825             RExC_parse++;
11826             continue;
11827         }
11828         if (RExC_flags & RXf_PMf_EXTENDED) {
11829             if (isSPACE(*RExC_parse)) {
11830                 RExC_parse++;
11831                 continue;
11832             }
11833             else if (*RExC_parse == '#') {
11834                 if ( reg_skipcomment( pRExC_state ) )
11835                     continue;
11836             }
11837         }
11838         return retval;
11839     }
11840 }
11841
11842 /*
11843 - reg_node - emit a node
11844 */
11845 STATIC regnode *                        /* Location. */
11846 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
11847 {
11848     dVAR;
11849     register regnode *ptr;
11850     regnode * const ret = RExC_emit;
11851     GET_RE_DEBUG_FLAGS_DECL;
11852
11853     PERL_ARGS_ASSERT_REG_NODE;
11854
11855     if (SIZE_ONLY) {
11856         SIZE_ALIGN(RExC_size);
11857         RExC_size += 1;
11858         return(ret);
11859     }
11860     if (RExC_emit >= RExC_emit_bound)
11861         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
11862                    op, RExC_emit, RExC_emit_bound);
11863
11864     NODE_ALIGN_FILL(ret);
11865     ptr = ret;
11866     FILL_ADVANCE_NODE(ptr, op);
11867     REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (ptr) - 1);
11868 #ifdef RE_TRACK_PATTERN_OFFSETS
11869     if (RExC_offsets) {         /* MJD */
11870         MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n", 
11871               "reg_node", __LINE__, 
11872               PL_reg_name[op],
11873               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] 
11874                 ? "Overwriting end of array!\n" : "OK",
11875               (UV)(RExC_emit - RExC_emit_start),
11876               (UV)(RExC_parse - RExC_start),
11877               (UV)RExC_offsets[0])); 
11878         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
11879     }
11880 #endif
11881     RExC_emit = ptr;
11882     return(ret);
11883 }
11884
11885 /*
11886 - reganode - emit a node with an argument
11887 */
11888 STATIC regnode *                        /* Location. */
11889 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
11890 {
11891     dVAR;
11892     register regnode *ptr;
11893     regnode * const ret = RExC_emit;
11894     GET_RE_DEBUG_FLAGS_DECL;
11895
11896     PERL_ARGS_ASSERT_REGANODE;
11897
11898     if (SIZE_ONLY) {
11899         SIZE_ALIGN(RExC_size);
11900         RExC_size += 2;
11901         /* 
11902            We can't do this:
11903            
11904            assert(2==regarglen[op]+1); 
11905
11906            Anything larger than this has to allocate the extra amount.
11907            If we changed this to be:
11908            
11909            RExC_size += (1 + regarglen[op]);
11910            
11911            then it wouldn't matter. Its not clear what side effect
11912            might come from that so its not done so far.
11913            -- dmq
11914         */
11915         return(ret);
11916     }
11917     if (RExC_emit >= RExC_emit_bound)
11918         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
11919                    op, RExC_emit, RExC_emit_bound);
11920
11921     NODE_ALIGN_FILL(ret);
11922     ptr = ret;
11923     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
11924     REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (ptr) - 2);
11925 #ifdef RE_TRACK_PATTERN_OFFSETS
11926     if (RExC_offsets) {         /* MJD */
11927         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
11928               "reganode",
11929               __LINE__,
11930               PL_reg_name[op],
11931               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? 
11932               "Overwriting end of array!\n" : "OK",
11933               (UV)(RExC_emit - RExC_emit_start),
11934               (UV)(RExC_parse - RExC_start),
11935               (UV)RExC_offsets[0])); 
11936         Set_Cur_Node_Offset;
11937     }
11938 #endif            
11939     RExC_emit = ptr;
11940     return(ret);
11941 }
11942
11943 /*
11944 - reguni - emit (if appropriate) a Unicode character
11945 */
11946 STATIC STRLEN
11947 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
11948 {
11949     dVAR;
11950
11951     PERL_ARGS_ASSERT_REGUNI;
11952
11953     return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
11954 }
11955
11956 /*
11957 - reginsert - insert an operator in front of already-emitted operand
11958 *
11959 * Means relocating the operand.
11960 */
11961 STATIC void
11962 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
11963 {
11964     dVAR;
11965     register regnode *src;
11966     register regnode *dst;
11967     register regnode *place;
11968     const int offset = regarglen[(U8)op];
11969     const int size = NODE_STEP_REGNODE + offset;
11970     GET_RE_DEBUG_FLAGS_DECL;
11971
11972     PERL_ARGS_ASSERT_REGINSERT;
11973     PERL_UNUSED_ARG(depth);
11974 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
11975     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
11976     if (SIZE_ONLY) {
11977         RExC_size += size;
11978         return;
11979     }
11980
11981     src = RExC_emit;
11982     RExC_emit += size;
11983     dst = RExC_emit;
11984     if (RExC_open_parens) {
11985         int paren;
11986         /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
11987         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
11988             if ( RExC_open_parens[paren] >= opnd ) {
11989                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
11990                 RExC_open_parens[paren] += size;
11991             } else {
11992                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
11993             }
11994             if ( RExC_close_parens[paren] >= opnd ) {
11995                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
11996                 RExC_close_parens[paren] += size;
11997             } else {
11998                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
11999             }
12000         }
12001     }
12002
12003     while (src > opnd) {
12004         StructCopy(--src, --dst, regnode);
12005 #ifdef RE_TRACK_PATTERN_OFFSETS
12006         if (RExC_offsets) {     /* MJD 20010112 */
12007             MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
12008                   "reg_insert",
12009                   __LINE__,
12010                   PL_reg_name[op],
12011                   (UV)(dst - RExC_emit_start) > RExC_offsets[0] 
12012                     ? "Overwriting end of array!\n" : "OK",
12013                   (UV)(src - RExC_emit_start),
12014                   (UV)(dst - RExC_emit_start),
12015                   (UV)RExC_offsets[0])); 
12016             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
12017             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
12018         }
12019 #endif
12020     }
12021     
12022
12023     place = opnd;               /* Op node, where operand used to be. */
12024 #ifdef RE_TRACK_PATTERN_OFFSETS
12025     if (RExC_offsets) {         /* MJD */
12026         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
12027               "reginsert",
12028               __LINE__,
12029               PL_reg_name[op],
12030               (UV)(place - RExC_emit_start) > RExC_offsets[0] 
12031               ? "Overwriting end of array!\n" : "OK",
12032               (UV)(place - RExC_emit_start),
12033               (UV)(RExC_parse - RExC_start),
12034               (UV)RExC_offsets[0]));
12035         Set_Node_Offset(place, RExC_parse);
12036         Set_Node_Length(place, 1);
12037     }
12038 #endif    
12039     src = NEXTOPER(place);
12040     FILL_ADVANCE_NODE(place, op);
12041     REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (place) - 1);
12042     Zero(src, offset, regnode);
12043 }
12044
12045 /*
12046 - regtail - set the next-pointer at the end of a node chain of p to val.
12047 - SEE ALSO: regtail_study
12048 */
12049 /* TODO: All three parms should be const */
12050 STATIC void
12051 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
12052 {
12053     dVAR;
12054     register regnode *scan;
12055     GET_RE_DEBUG_FLAGS_DECL;
12056
12057     PERL_ARGS_ASSERT_REGTAIL;
12058 #ifndef DEBUGGING
12059     PERL_UNUSED_ARG(depth);
12060 #endif
12061
12062     if (SIZE_ONLY)
12063         return;
12064
12065     /* Find last node. */
12066     scan = p;
12067     for (;;) {
12068         regnode * const temp = regnext(scan);
12069         DEBUG_PARSE_r({
12070             SV * const mysv=sv_newmortal();
12071             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
12072             regprop(RExC_rx, mysv, scan);
12073             PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
12074                 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
12075                     (temp == NULL ? "->" : ""),
12076                     (temp == NULL ? PL_reg_name[OP(val)] : "")
12077             );
12078         });
12079         if (temp == NULL)
12080             break;
12081         scan = temp;
12082     }
12083
12084     if (reg_off_by_arg[OP(scan)]) {
12085         ARG_SET(scan, val - scan);
12086     }
12087     else {
12088         NEXT_OFF(scan) = val - scan;
12089     }
12090 }
12091
12092 #ifdef DEBUGGING
12093 /*
12094 - regtail_study - set the next-pointer at the end of a node chain of p to val.
12095 - Look for optimizable sequences at the same time.
12096 - currently only looks for EXACT chains.
12097
12098 This is experimental code. The idea is to use this routine to perform 
12099 in place optimizations on branches and groups as they are constructed,
12100 with the long term intention of removing optimization from study_chunk so
12101 that it is purely analytical.
12102
12103 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
12104 to control which is which.
12105
12106 */
12107 /* TODO: All four parms should be const */
12108
12109 STATIC U8
12110 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
12111 {
12112     dVAR;
12113     register regnode *scan;
12114     U8 exact = PSEUDO;
12115 #ifdef EXPERIMENTAL_INPLACESCAN
12116     I32 min = 0;
12117 #endif
12118     GET_RE_DEBUG_FLAGS_DECL;
12119
12120     PERL_ARGS_ASSERT_REGTAIL_STUDY;
12121
12122
12123     if (SIZE_ONLY)
12124         return exact;
12125
12126     /* Find last node. */
12127
12128     scan = p;
12129     for (;;) {
12130         regnode * const temp = regnext(scan);
12131 #ifdef EXPERIMENTAL_INPLACESCAN
12132         if (PL_regkind[OP(scan)] == EXACT) {
12133             bool has_exactf_sharp_s;    /* Unexamined in this routine */
12134             if (join_exact(pRExC_state,scan,&min, &has_exactf_sharp_s, 1,val,depth+1))
12135                 return EXACT;
12136         }
12137 #endif
12138         if ( exact ) {
12139             switch (OP(scan)) {
12140                 case EXACT:
12141                 case EXACTF:
12142                 case EXACTFA:
12143                 case EXACTFU:
12144                 case EXACTFU_SS:
12145                 case EXACTFU_TRICKYFOLD:
12146                 case EXACTFL:
12147                         if( exact == PSEUDO )
12148                             exact= OP(scan);
12149                         else if ( exact != OP(scan) )
12150                             exact= 0;
12151                 case NOTHING:
12152                     break;
12153                 default:
12154                     exact= 0;
12155             }
12156         }
12157         DEBUG_PARSE_r({
12158             SV * const mysv=sv_newmortal();
12159             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
12160             regprop(RExC_rx, mysv, scan);
12161             PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
12162                 SvPV_nolen_const(mysv),
12163                 REG_NODE_NUM(scan),
12164                 PL_reg_name[exact]);
12165         });
12166         if (temp == NULL)
12167             break;
12168         scan = temp;
12169     }
12170     DEBUG_PARSE_r({
12171         SV * const mysv_val=sv_newmortal();
12172         DEBUG_PARSE_MSG("");
12173         regprop(RExC_rx, mysv_val, val);
12174         PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
12175                       SvPV_nolen_const(mysv_val),
12176                       (IV)REG_NODE_NUM(val),
12177                       (IV)(val - scan)
12178         );
12179     });
12180     if (reg_off_by_arg[OP(scan)]) {
12181         ARG_SET(scan, val - scan);
12182     }
12183     else {
12184         NEXT_OFF(scan) = val - scan;
12185     }
12186
12187     return exact;
12188 }
12189 #endif
12190
12191 /*
12192  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
12193  */
12194 #ifdef DEBUGGING
12195 static void 
12196 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
12197 {
12198     int bit;
12199     int set=0;
12200     regex_charset cs;
12201
12202     for (bit=0; bit<32; bit++) {
12203         if (flags & (1<<bit)) {
12204             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
12205                 continue;
12206             }
12207             if (!set++ && lead) 
12208                 PerlIO_printf(Perl_debug_log, "%s",lead);
12209             PerlIO_printf(Perl_debug_log, "%s ",PL_reg_extflags_name[bit]);
12210         }               
12211     }      
12212     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
12213             if (!set++ && lead) {
12214                 PerlIO_printf(Perl_debug_log, "%s",lead);
12215             }
12216             switch (cs) {
12217                 case REGEX_UNICODE_CHARSET:
12218                     PerlIO_printf(Perl_debug_log, "UNICODE");
12219                     break;
12220                 case REGEX_LOCALE_CHARSET:
12221                     PerlIO_printf(Perl_debug_log, "LOCALE");
12222                     break;
12223                 case REGEX_ASCII_RESTRICTED_CHARSET:
12224                     PerlIO_printf(Perl_debug_log, "ASCII-RESTRICTED");
12225                     break;
12226                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
12227                     PerlIO_printf(Perl_debug_log, "ASCII-MORE_RESTRICTED");
12228                     break;
12229                 default:
12230                     PerlIO_printf(Perl_debug_log, "UNKNOWN CHARACTER SET");
12231                     break;
12232             }
12233     }
12234     if (lead)  {
12235         if (set) 
12236             PerlIO_printf(Perl_debug_log, "\n");
12237         else 
12238             PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
12239     }            
12240 }   
12241 #endif
12242
12243 void
12244 Perl_regdump(pTHX_ const regexp *r)
12245 {
12246 #ifdef DEBUGGING
12247     dVAR;
12248     SV * const sv = sv_newmortal();
12249     SV *dsv= sv_newmortal();
12250     RXi_GET_DECL(r,ri);
12251     GET_RE_DEBUG_FLAGS_DECL;
12252
12253     PERL_ARGS_ASSERT_REGDUMP;
12254
12255     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
12256
12257     /* Header fields of interest. */
12258     if (r->anchored_substr) {
12259         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr), 
12260             RE_SV_DUMPLEN(r->anchored_substr), 30);
12261         PerlIO_printf(Perl_debug_log,
12262                       "anchored %s%s at %"IVdf" ",
12263                       s, RE_SV_TAIL(r->anchored_substr),
12264                       (IV)r->anchored_offset);
12265     } else if (r->anchored_utf8) {
12266         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8), 
12267             RE_SV_DUMPLEN(r->anchored_utf8), 30);
12268         PerlIO_printf(Perl_debug_log,
12269                       "anchored utf8 %s%s at %"IVdf" ",
12270                       s, RE_SV_TAIL(r->anchored_utf8),
12271                       (IV)r->anchored_offset);
12272     }                 
12273     if (r->float_substr) {
12274         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr), 
12275             RE_SV_DUMPLEN(r->float_substr), 30);
12276         PerlIO_printf(Perl_debug_log,
12277                       "floating %s%s at %"IVdf"..%"UVuf" ",
12278                       s, RE_SV_TAIL(r->float_substr),
12279                       (IV)r->float_min_offset, (UV)r->float_max_offset);
12280     } else if (r->float_utf8) {
12281         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8), 
12282             RE_SV_DUMPLEN(r->float_utf8), 30);
12283         PerlIO_printf(Perl_debug_log,
12284                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
12285                       s, RE_SV_TAIL(r->float_utf8),
12286                       (IV)r->float_min_offset, (UV)r->float_max_offset);
12287     }
12288     if (r->check_substr || r->check_utf8)
12289         PerlIO_printf(Perl_debug_log,
12290                       (const char *)
12291                       (r->check_substr == r->float_substr
12292                        && r->check_utf8 == r->float_utf8
12293                        ? "(checking floating" : "(checking anchored"));
12294     if (r->extflags & RXf_NOSCAN)
12295         PerlIO_printf(Perl_debug_log, " noscan");
12296     if (r->extflags & RXf_CHECK_ALL)
12297         PerlIO_printf(Perl_debug_log, " isall");
12298     if (r->check_substr || r->check_utf8)
12299         PerlIO_printf(Perl_debug_log, ") ");
12300
12301     if (ri->regstclass) {
12302         regprop(r, sv, ri->regstclass);
12303         PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
12304     }
12305     if (r->extflags & RXf_ANCH) {
12306         PerlIO_printf(Perl_debug_log, "anchored");
12307         if (r->extflags & RXf_ANCH_BOL)
12308             PerlIO_printf(Perl_debug_log, "(BOL)");
12309         if (r->extflags & RXf_ANCH_MBOL)
12310             PerlIO_printf(Perl_debug_log, "(MBOL)");
12311         if (r->extflags & RXf_ANCH_SBOL)
12312             PerlIO_printf(Perl_debug_log, "(SBOL)");
12313         if (r->extflags & RXf_ANCH_GPOS)
12314             PerlIO_printf(Perl_debug_log, "(GPOS)");
12315         PerlIO_putc(Perl_debug_log, ' ');
12316     }
12317     if (r->extflags & RXf_GPOS_SEEN)
12318         PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
12319     if (r->intflags & PREGf_SKIP)
12320         PerlIO_printf(Perl_debug_log, "plus ");
12321     if (r->intflags & PREGf_IMPLICIT)
12322         PerlIO_printf(Perl_debug_log, "implicit ");
12323     PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
12324     if (r->extflags & RXf_EVAL_SEEN)
12325         PerlIO_printf(Perl_debug_log, "with eval ");
12326     PerlIO_printf(Perl_debug_log, "\n");
12327     DEBUG_FLAGS_r(regdump_extflags("r->extflags: ",r->extflags));            
12328 #else
12329     PERL_ARGS_ASSERT_REGDUMP;
12330     PERL_UNUSED_CONTEXT;
12331     PERL_UNUSED_ARG(r);
12332 #endif  /* DEBUGGING */
12333 }
12334
12335 /*
12336 - regprop - printable representation of opcode
12337 */
12338 #define EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags) \
12339 STMT_START { \
12340         if (do_sep) {                           \
12341             Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]); \
12342             if (flags & ANYOF_INVERT)           \
12343                 /*make sure the invert info is in each */ \
12344                 sv_catpvs(sv, "^");             \
12345             do_sep = 0;                         \
12346         }                                       \
12347 } STMT_END
12348
12349 void
12350 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
12351 {
12352 #ifdef DEBUGGING
12353     dVAR;
12354     register int k;
12355     RXi_GET_DECL(prog,progi);
12356     GET_RE_DEBUG_FLAGS_DECL;
12357     
12358     PERL_ARGS_ASSERT_REGPROP;
12359
12360     sv_setpvs(sv, "");
12361
12362     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
12363         /* It would be nice to FAIL() here, but this may be called from
12364            regexec.c, and it would be hard to supply pRExC_state. */
12365         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
12366     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
12367
12368     k = PL_regkind[OP(o)];
12369
12370     if (k == EXACT) {
12371         sv_catpvs(sv, " ");
12372         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT) 
12373          * is a crude hack but it may be the best for now since 
12374          * we have no flag "this EXACTish node was UTF-8" 
12375          * --jhi */
12376         pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
12377                   PERL_PV_ESCAPE_UNI_DETECT |
12378                   PERL_PV_ESCAPE_NONASCII   |
12379                   PERL_PV_PRETTY_ELLIPSES   |
12380                   PERL_PV_PRETTY_LTGT       |
12381                   PERL_PV_PRETTY_NOCLEAR
12382                   );
12383     } else if (k == TRIE) {
12384         /* print the details of the trie in dumpuntil instead, as
12385          * progi->data isn't available here */
12386         const char op = OP(o);
12387         const U32 n = ARG(o);
12388         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
12389                (reg_ac_data *)progi->data->data[n] :
12390                NULL;
12391         const reg_trie_data * const trie
12392             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
12393         
12394         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
12395         DEBUG_TRIE_COMPILE_r(
12396             Perl_sv_catpvf(aTHX_ sv,
12397                 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
12398                 (UV)trie->startstate,
12399                 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
12400                 (UV)trie->wordcount,
12401                 (UV)trie->minlen,
12402                 (UV)trie->maxlen,
12403                 (UV)TRIE_CHARCOUNT(trie),
12404                 (UV)trie->uniquecharcount
12405             )
12406         );
12407         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
12408             int i;
12409             int rangestart = -1;
12410             U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
12411             sv_catpvs(sv, "[");
12412             for (i = 0; i <= 256; i++) {
12413                 if (i < 256 && BITMAP_TEST(bitmap,i)) {
12414                     if (rangestart == -1)
12415                         rangestart = i;
12416                 } else if (rangestart != -1) {
12417                     if (i <= rangestart + 3)
12418                         for (; rangestart < i; rangestart++)
12419                             put_byte(sv, rangestart);
12420                     else {
12421                         put_byte(sv, rangestart);
12422                         sv_catpvs(sv, "-");
12423                         put_byte(sv, i - 1);
12424                     }
12425                     rangestart = -1;
12426                 }
12427             }
12428             sv_catpvs(sv, "]");
12429         } 
12430          
12431     } else if (k == CURLY) {
12432         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
12433             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
12434         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
12435     }
12436     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
12437         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
12438     else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
12439         Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
12440         if ( RXp_PAREN_NAMES(prog) ) {
12441             if ( k != REF || (OP(o) < NREF)) {
12442                 AV *list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
12443                 SV **name= av_fetch(list, ARG(o), 0 );
12444                 if (name)
12445                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
12446             }       
12447             else {
12448                 AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]);
12449                 SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]);
12450                 I32 *nums=(I32*)SvPVX(sv_dat);
12451                 SV **name= av_fetch(list, nums[0], 0 );
12452                 I32 n;
12453                 if (name) {
12454                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
12455                         Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
12456                                     (n ? "," : ""), (IV)nums[n]);
12457                     }
12458                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
12459                 }
12460             }
12461         }            
12462     } else if (k == GOSUB) 
12463         Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
12464     else if (k == VERB) {
12465         if (!o->flags) 
12466             Perl_sv_catpvf(aTHX_ sv, ":%"SVf, 
12467                            SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
12468     } else if (k == LOGICAL)
12469         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);     /* 2: embedded, otherwise 1 */
12470     else if (k == ANYOF) {
12471         int i, rangestart = -1;
12472         const U8 flags = ANYOF_FLAGS(o);
12473         int do_sep = 0;
12474
12475         /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
12476         static const char * const anyofs[] = {
12477             "\\w",
12478             "\\W",
12479             "\\s",
12480             "\\S",
12481             "\\d",
12482             "\\D",
12483             "[:alnum:]",
12484             "[:^alnum:]",
12485             "[:alpha:]",
12486             "[:^alpha:]",
12487             "[:ascii:]",
12488             "[:^ascii:]",
12489             "[:cntrl:]",
12490             "[:^cntrl:]",
12491             "[:graph:]",
12492             "[:^graph:]",
12493             "[:lower:]",
12494             "[:^lower:]",
12495             "[:print:]",
12496             "[:^print:]",
12497             "[:punct:]",
12498             "[:^punct:]",
12499             "[:upper:]",
12500             "[:^upper:]",
12501             "[:xdigit:]",
12502             "[:^xdigit:]",
12503             "[:space:]",
12504             "[:^space:]",
12505             "[:blank:]",
12506             "[:^blank:]"
12507         };
12508
12509         if (flags & ANYOF_LOCALE)
12510             sv_catpvs(sv, "{loc}");
12511         if (flags & ANYOF_LOC_NONBITMAP_FOLD)
12512             sv_catpvs(sv, "{i}");
12513         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
12514         if (flags & ANYOF_INVERT)
12515             sv_catpvs(sv, "^");
12516
12517         /* output what the standard cp 0-255 bitmap matches */
12518         for (i = 0; i <= 256; i++) {
12519             if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
12520                 if (rangestart == -1)
12521                     rangestart = i;
12522             } else if (rangestart != -1) {
12523                 if (i <= rangestart + 3)
12524                     for (; rangestart < i; rangestart++)
12525                         put_byte(sv, rangestart);
12526                 else {
12527                     put_byte(sv, rangestart);
12528                     sv_catpvs(sv, "-");
12529                     put_byte(sv, i - 1);
12530                 }
12531                 do_sep = 1;
12532                 rangestart = -1;
12533             }
12534         }
12535         
12536         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
12537         /* output any special charclass tests (used entirely under use locale) */
12538         if (ANYOF_CLASS_TEST_ANY_SET(o))
12539             for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
12540                 if (ANYOF_CLASS_TEST(o,i)) {
12541                     sv_catpv(sv, anyofs[i]);
12542                     do_sep = 1;
12543                 }
12544         
12545         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
12546         
12547         if (flags & ANYOF_NON_UTF8_LATIN1_ALL) {
12548             sv_catpvs(sv, "{non-utf8-latin1-all}");
12549         }
12550
12551         /* output information about the unicode matching */
12552         if (flags & ANYOF_UNICODE_ALL)
12553             sv_catpvs(sv, "{unicode_all}");
12554         else if (ANYOF_NONBITMAP(o))
12555             sv_catpvs(sv, "{unicode}");
12556         if (flags & ANYOF_NONBITMAP_NON_UTF8)
12557             sv_catpvs(sv, "{outside bitmap}");
12558
12559         if (ANYOF_NONBITMAP(o)) {
12560             SV *lv; /* Set if there is something outside the bit map */
12561             SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
12562             bool byte_output = FALSE;   /* If something in the bitmap has been
12563                                            output */
12564
12565             if (lv && lv != &PL_sv_undef) {
12566                 if (sw) {
12567                     U8 s[UTF8_MAXBYTES_CASE+1];
12568
12569                     for (i = 0; i <= 256; i++) { /* Look at chars in bitmap */
12570                         uvchr_to_utf8(s, i);
12571
12572                         if (i < 256
12573                             && ! ANYOF_BITMAP_TEST(o, i)    /* Don't duplicate
12574                                                                things already
12575                                                                output as part
12576                                                                of the bitmap */
12577                             && swash_fetch(sw, s, TRUE))
12578                         {
12579                             if (rangestart == -1)
12580                                 rangestart = i;
12581                         } else if (rangestart != -1) {
12582                             byte_output = TRUE;
12583                             if (i <= rangestart + 3)
12584                                 for (; rangestart < i; rangestart++) {
12585                                     put_byte(sv, rangestart);
12586                                 }
12587                             else {
12588                                 put_byte(sv, rangestart);
12589                                 sv_catpvs(sv, "-");
12590                                 put_byte(sv, i-1);
12591                             }
12592                             rangestart = -1;
12593                         }
12594                     }
12595                 }
12596
12597                 {
12598                     char *s = savesvpv(lv);
12599                     char * const origs = s;
12600
12601                     while (*s && *s != '\n')
12602                         s++;
12603
12604                     if (*s == '\n') {
12605                         const char * const t = ++s;
12606
12607                         if (byte_output) {
12608                             sv_catpvs(sv, " ");
12609                         }
12610
12611                         while (*s) {
12612                             if (*s == '\n') {
12613
12614                                 /* Truncate very long output */
12615                                 if (s - origs > 256) {
12616                                     Perl_sv_catpvf(aTHX_ sv,
12617                                                    "%.*s...",
12618                                                    (int) (s - origs - 1),
12619                                                    t);
12620                                     goto out_dump;
12621                                 }
12622                                 *s = ' ';
12623                             }
12624                             else if (*s == '\t') {
12625                                 *s = '-';
12626                             }
12627                             s++;
12628                         }
12629                         if (s[-1] == ' ')
12630                             s[-1] = 0;
12631
12632                         sv_catpv(sv, t);
12633                     }
12634
12635                 out_dump:
12636
12637                     Safefree(origs);
12638                 }
12639                 SvREFCNT_dec(lv);
12640             }
12641         }
12642
12643         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
12644     }
12645     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
12646         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
12647 #else
12648     PERL_UNUSED_CONTEXT;
12649     PERL_UNUSED_ARG(sv);
12650     PERL_UNUSED_ARG(o);
12651     PERL_UNUSED_ARG(prog);
12652 #endif  /* DEBUGGING */
12653 }
12654
12655 SV *
12656 Perl_re_intuit_string(pTHX_ REGEXP * const r)
12657 {                               /* Assume that RE_INTUIT is set */
12658     dVAR;
12659     struct regexp *const prog = (struct regexp *)SvANY(r);
12660     GET_RE_DEBUG_FLAGS_DECL;
12661
12662     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
12663     PERL_UNUSED_CONTEXT;
12664
12665     DEBUG_COMPILE_r(
12666         {
12667             const char * const s = SvPV_nolen_const(prog->check_substr
12668                       ? prog->check_substr : prog->check_utf8);
12669
12670             if (!PL_colorset) reginitcolors();
12671             PerlIO_printf(Perl_debug_log,
12672                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
12673                       PL_colors[4],
12674                       prog->check_substr ? "" : "utf8 ",
12675                       PL_colors[5],PL_colors[0],
12676                       s,
12677                       PL_colors[1],
12678                       (strlen(s) > 60 ? "..." : ""));
12679         } );
12680
12681     return prog->check_substr ? prog->check_substr : prog->check_utf8;
12682 }
12683
12684 /* 
12685    pregfree() 
12686    
12687    handles refcounting and freeing the perl core regexp structure. When 
12688    it is necessary to actually free the structure the first thing it 
12689    does is call the 'free' method of the regexp_engine associated to
12690    the regexp, allowing the handling of the void *pprivate; member 
12691    first. (This routine is not overridable by extensions, which is why 
12692    the extensions free is called first.)
12693    
12694    See regdupe and regdupe_internal if you change anything here. 
12695 */
12696 #ifndef PERL_IN_XSUB_RE
12697 void
12698 Perl_pregfree(pTHX_ REGEXP *r)
12699 {
12700     SvREFCNT_dec(r);
12701 }
12702
12703 void
12704 Perl_pregfree2(pTHX_ REGEXP *rx)
12705 {
12706     dVAR;
12707     struct regexp *const r = (struct regexp *)SvANY(rx);
12708     GET_RE_DEBUG_FLAGS_DECL;
12709
12710     PERL_ARGS_ASSERT_PREGFREE2;
12711
12712     if (r->mother_re) {
12713         ReREFCNT_dec(r->mother_re);
12714     } else {
12715         CALLREGFREE_PVT(rx); /* free the private data */
12716         SvREFCNT_dec(RXp_PAREN_NAMES(r));
12717     }        
12718     if (r->substrs) {
12719         SvREFCNT_dec(r->anchored_substr);
12720         SvREFCNT_dec(r->anchored_utf8);
12721         SvREFCNT_dec(r->float_substr);
12722         SvREFCNT_dec(r->float_utf8);
12723         Safefree(r->substrs);
12724     }
12725     RX_MATCH_COPY_FREE(rx);
12726 #ifdef PERL_OLD_COPY_ON_WRITE
12727     SvREFCNT_dec(r->saved_copy);
12728 #endif
12729     Safefree(r->offs);
12730 }
12731
12732 /*  reg_temp_copy()
12733     
12734     This is a hacky workaround to the structural issue of match results
12735     being stored in the regexp structure which is in turn stored in
12736     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
12737     could be PL_curpm in multiple contexts, and could require multiple
12738     result sets being associated with the pattern simultaneously, such
12739     as when doing a recursive match with (??{$qr})
12740     
12741     The solution is to make a lightweight copy of the regexp structure 
12742     when a qr// is returned from the code executed by (??{$qr}) this
12743     lightweight copy doesn't actually own any of its data except for
12744     the starp/end and the actual regexp structure itself. 
12745     
12746 */    
12747     
12748     
12749 REGEXP *
12750 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
12751 {
12752     struct regexp *ret;
12753     struct regexp *const r = (struct regexp *)SvANY(rx);
12754     register const I32 npar = r->nparens+1;
12755
12756     PERL_ARGS_ASSERT_REG_TEMP_COPY;
12757
12758     if (!ret_x)
12759         ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
12760     ret = (struct regexp *)SvANY(ret_x);
12761     
12762     (void)ReREFCNT_inc(rx);
12763     /* We can take advantage of the existing "copied buffer" mechanism in SVs
12764        by pointing directly at the buffer, but flagging that the allocated
12765        space in the copy is zero. As we've just done a struct copy, it's now
12766        a case of zero-ing that, rather than copying the current length.  */
12767     SvPV_set(ret_x, RX_WRAPPED(rx));
12768     SvFLAGS(ret_x) |= SvFLAGS(rx) & (SVf_POK|SVp_POK|SVf_UTF8);
12769     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
12770            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
12771     SvLEN_set(ret_x, 0);
12772     SvSTASH_set(ret_x, NULL);
12773     SvMAGIC_set(ret_x, NULL);
12774     Newx(ret->offs, npar, regexp_paren_pair);
12775     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
12776     if (r->substrs) {
12777         Newx(ret->substrs, 1, struct reg_substr_data);
12778         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
12779
12780         SvREFCNT_inc_void(ret->anchored_substr);
12781         SvREFCNT_inc_void(ret->anchored_utf8);
12782         SvREFCNT_inc_void(ret->float_substr);
12783         SvREFCNT_inc_void(ret->float_utf8);
12784
12785         /* check_substr and check_utf8, if non-NULL, point to either their
12786            anchored or float namesakes, and don't hold a second reference.  */
12787     }
12788     RX_MATCH_COPIED_off(ret_x);
12789 #ifdef PERL_OLD_COPY_ON_WRITE
12790     ret->saved_copy = NULL;
12791 #endif
12792     ret->mother_re = rx;
12793     
12794     return ret_x;
12795 }
12796 #endif
12797
12798 /* regfree_internal() 
12799
12800    Free the private data in a regexp. This is overloadable by 
12801    extensions. Perl takes care of the regexp structure in pregfree(), 
12802    this covers the *pprivate pointer which technically perl doesn't 
12803    know about, however of course we have to handle the 
12804    regexp_internal structure when no extension is in use. 
12805    
12806    Note this is called before freeing anything in the regexp 
12807    structure. 
12808  */
12809  
12810 void
12811 Perl_regfree_internal(pTHX_ REGEXP * const rx)
12812 {
12813     dVAR;
12814     struct regexp *const r = (struct regexp *)SvANY(rx);
12815     RXi_GET_DECL(r,ri);
12816     GET_RE_DEBUG_FLAGS_DECL;
12817
12818     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
12819
12820     DEBUG_COMPILE_r({
12821         if (!PL_colorset)
12822             reginitcolors();
12823         {
12824             SV *dsv= sv_newmortal();
12825             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
12826                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
12827             PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n", 
12828                 PL_colors[4],PL_colors[5],s);
12829         }
12830     });
12831 #ifdef RE_TRACK_PATTERN_OFFSETS
12832     if (ri->u.offsets)
12833         Safefree(ri->u.offsets);             /* 20010421 MJD */
12834 #endif
12835     if (ri->data) {
12836         int n = ri->data->count;
12837         PAD* new_comppad = NULL;
12838         PAD* old_comppad;
12839         PADOFFSET refcnt;
12840
12841         while (--n >= 0) {
12842           /* If you add a ->what type here, update the comment in regcomp.h */
12843             switch (ri->data->what[n]) {
12844             case 'a':
12845             case 's':
12846             case 'S':
12847             case 'u':
12848                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
12849                 break;
12850             case 'f':
12851                 Safefree(ri->data->data[n]);
12852                 break;
12853             case 'p':
12854                 new_comppad = MUTABLE_AV(ri->data->data[n]);
12855                 break;
12856             case 'o':
12857                 if (new_comppad == NULL)
12858                     Perl_croak(aTHX_ "panic: pregfree comppad");
12859                 PAD_SAVE_LOCAL(old_comppad,
12860                     /* Watch out for global destruction's random ordering. */
12861                     (SvTYPE(new_comppad) == SVt_PVAV) ? new_comppad : NULL
12862                 );
12863                 OP_REFCNT_LOCK;
12864                 refcnt = OpREFCNT_dec((OP_4tree*)ri->data->data[n]);
12865                 OP_REFCNT_UNLOCK;
12866                 if (!refcnt)
12867                     op_free((OP_4tree*)ri->data->data[n]);
12868
12869                 PAD_RESTORE_LOCAL(old_comppad);
12870                 SvREFCNT_dec(MUTABLE_SV(new_comppad));
12871                 new_comppad = NULL;
12872                 break;
12873             case 'n':
12874                 break;
12875             case 'T':           
12876                 { /* Aho Corasick add-on structure for a trie node.
12877                      Used in stclass optimization only */
12878                     U32 refcount;
12879                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
12880                     OP_REFCNT_LOCK;
12881                     refcount = --aho->refcount;
12882                     OP_REFCNT_UNLOCK;
12883                     if ( !refcount ) {
12884                         PerlMemShared_free(aho->states);
12885                         PerlMemShared_free(aho->fail);
12886                          /* do this last!!!! */
12887                         PerlMemShared_free(ri->data->data[n]);
12888                         PerlMemShared_free(ri->regstclass);
12889                     }
12890                 }
12891                 break;
12892             case 't':
12893                 {
12894                     /* trie structure. */
12895                     U32 refcount;
12896                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
12897                     OP_REFCNT_LOCK;
12898                     refcount = --trie->refcount;
12899                     OP_REFCNT_UNLOCK;
12900                     if ( !refcount ) {
12901                         PerlMemShared_free(trie->charmap);
12902                         PerlMemShared_free(trie->states);
12903                         PerlMemShared_free(trie->trans);
12904                         if (trie->bitmap)
12905                             PerlMemShared_free(trie->bitmap);
12906                         if (trie->jump)
12907                             PerlMemShared_free(trie->jump);
12908                         PerlMemShared_free(trie->wordinfo);
12909                         /* do this last!!!! */
12910                         PerlMemShared_free(ri->data->data[n]);
12911                     }
12912                 }
12913                 break;
12914             default:
12915                 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
12916             }
12917         }
12918         Safefree(ri->data->what);
12919         Safefree(ri->data);
12920     }
12921
12922     Safefree(ri);
12923 }
12924
12925 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
12926 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
12927 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
12928
12929 /* 
12930    re_dup - duplicate a regexp. 
12931    
12932    This routine is expected to clone a given regexp structure. It is only
12933    compiled under USE_ITHREADS.
12934
12935    After all of the core data stored in struct regexp is duplicated
12936    the regexp_engine.dupe method is used to copy any private data
12937    stored in the *pprivate pointer. This allows extensions to handle
12938    any duplication it needs to do.
12939
12940    See pregfree() and regfree_internal() if you change anything here. 
12941 */
12942 #if defined(USE_ITHREADS)
12943 #ifndef PERL_IN_XSUB_RE
12944 void
12945 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
12946 {
12947     dVAR;
12948     I32 npar;
12949     const struct regexp *r = (const struct regexp *)SvANY(sstr);
12950     struct regexp *ret = (struct regexp *)SvANY(dstr);
12951     
12952     PERL_ARGS_ASSERT_RE_DUP_GUTS;
12953
12954     npar = r->nparens+1;
12955     Newx(ret->offs, npar, regexp_paren_pair);
12956     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
12957     if(ret->swap) {
12958         /* no need to copy these */
12959         Newx(ret->swap, npar, regexp_paren_pair);
12960     }
12961
12962     if (ret->substrs) {
12963         /* Do it this way to avoid reading from *r after the StructCopy().
12964            That way, if any of the sv_dup_inc()s dislodge *r from the L1
12965            cache, it doesn't matter.  */
12966         const bool anchored = r->check_substr
12967             ? r->check_substr == r->anchored_substr
12968             : r->check_utf8 == r->anchored_utf8;
12969         Newx(ret->substrs, 1, struct reg_substr_data);
12970         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
12971
12972         ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
12973         ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
12974         ret->float_substr = sv_dup_inc(ret->float_substr, param);
12975         ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
12976
12977         /* check_substr and check_utf8, if non-NULL, point to either their
12978            anchored or float namesakes, and don't hold a second reference.  */
12979
12980         if (ret->check_substr) {
12981             if (anchored) {
12982                 assert(r->check_utf8 == r->anchored_utf8);
12983                 ret->check_substr = ret->anchored_substr;
12984                 ret->check_utf8 = ret->anchored_utf8;
12985             } else {
12986                 assert(r->check_substr == r->float_substr);
12987                 assert(r->check_utf8 == r->float_utf8);
12988                 ret->check_substr = ret->float_substr;
12989                 ret->check_utf8 = ret->float_utf8;
12990             }
12991         } else if (ret->check_utf8) {
12992             if (anchored) {
12993                 ret->check_utf8 = ret->anchored_utf8;
12994             } else {
12995                 ret->check_utf8 = ret->float_utf8;
12996             }
12997         }
12998     }
12999
13000     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
13001
13002     if (ret->pprivate)
13003         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
13004
13005     if (RX_MATCH_COPIED(dstr))
13006         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
13007     else
13008         ret->subbeg = NULL;
13009 #ifdef PERL_OLD_COPY_ON_WRITE
13010     ret->saved_copy = NULL;
13011 #endif
13012
13013     if (ret->mother_re) {
13014         if (SvPVX_const(dstr) == SvPVX_const(ret->mother_re)) {
13015             /* Our storage points directly to our mother regexp, but that's
13016                1: a buffer in a different thread
13017                2: something we no longer hold a reference on
13018                so we need to copy it locally.  */
13019             /* Note we need to use SvCUR(), rather than
13020                SvLEN(), on our mother_re, because it, in
13021                turn, may well be pointing to its own mother_re.  */
13022             SvPV_set(dstr, SAVEPVN(SvPVX_const(ret->mother_re),
13023                                    SvCUR(ret->mother_re)+1));
13024             SvLEN_set(dstr, SvCUR(ret->mother_re)+1);
13025         }
13026         ret->mother_re      = NULL;
13027     }
13028     ret->gofs = 0;
13029 }
13030 #endif /* PERL_IN_XSUB_RE */
13031
13032 /*
13033    regdupe_internal()
13034    
13035    This is the internal complement to regdupe() which is used to copy
13036    the structure pointed to by the *pprivate pointer in the regexp.
13037    This is the core version of the extension overridable cloning hook.
13038    The regexp structure being duplicated will be copied by perl prior
13039    to this and will be provided as the regexp *r argument, however 
13040    with the /old/ structures pprivate pointer value. Thus this routine
13041    may override any copying normally done by perl.
13042    
13043    It returns a pointer to the new regexp_internal structure.
13044 */
13045
13046 void *
13047 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
13048 {
13049     dVAR;
13050     struct regexp *const r = (struct regexp *)SvANY(rx);
13051     regexp_internal *reti;
13052     int len;
13053     RXi_GET_DECL(r,ri);
13054
13055     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
13056     
13057     len = ProgLen(ri);
13058     
13059     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), char, regexp_internal);
13060     Copy(ri->program, reti->program, len+1, regnode);
13061     
13062
13063     reti->regstclass = NULL;
13064
13065     if (ri->data) {
13066         struct reg_data *d;
13067         const int count = ri->data->count;
13068         int i;
13069
13070         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
13071                 char, struct reg_data);
13072         Newx(d->what, count, U8);
13073
13074         d->count = count;
13075         for (i = 0; i < count; i++) {
13076             d->what[i] = ri->data->what[i];
13077             switch (d->what[i]) {
13078                 /* legal options are one of: sSfpontTua
13079                    see also regcomp.h and pregfree() */
13080             case 'a': /* actually an AV, but the dup function is identical.  */
13081             case 's':
13082             case 'S':
13083             case 'p': /* actually an AV, but the dup function is identical.  */
13084             case 'u': /* actually an HV, but the dup function is identical.  */
13085                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
13086                 break;
13087             case 'f':
13088                 /* This is cheating. */
13089                 Newx(d->data[i], 1, struct regnode_charclass_class);
13090                 StructCopy(ri->data->data[i], d->data[i],
13091                             struct regnode_charclass_class);
13092                 reti->regstclass = (regnode*)d->data[i];
13093                 break;
13094             case 'o':
13095                 /* Compiled op trees are readonly and in shared memory,
13096                    and can thus be shared without duplication. */
13097                 OP_REFCNT_LOCK;
13098                 d->data[i] = (void*)OpREFCNT_inc((OP*)ri->data->data[i]);
13099                 OP_REFCNT_UNLOCK;
13100                 break;
13101             case 'T':
13102                 /* Trie stclasses are readonly and can thus be shared
13103                  * without duplication. We free the stclass in pregfree
13104                  * when the corresponding reg_ac_data struct is freed.
13105                  */
13106                 reti->regstclass= ri->regstclass;
13107                 /* Fall through */
13108             case 't':
13109                 OP_REFCNT_LOCK;
13110                 ((reg_trie_data*)ri->data->data[i])->refcount++;
13111                 OP_REFCNT_UNLOCK;
13112                 /* Fall through */
13113             case 'n':
13114                 d->data[i] = ri->data->data[i];
13115                 break;
13116             default:
13117                 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
13118             }
13119         }
13120
13121         reti->data = d;
13122     }
13123     else
13124         reti->data = NULL;
13125
13126     reti->name_list_idx = ri->name_list_idx;
13127
13128 #ifdef RE_TRACK_PATTERN_OFFSETS
13129     if (ri->u.offsets) {
13130         Newx(reti->u.offsets, 2*len+1, U32);
13131         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
13132     }
13133 #else
13134     SetProgLen(reti,len);
13135 #endif
13136
13137     return (void*)reti;
13138 }
13139
13140 #endif    /* USE_ITHREADS */
13141
13142 #ifndef PERL_IN_XSUB_RE
13143
13144 /*
13145  - regnext - dig the "next" pointer out of a node
13146  */
13147 regnode *
13148 Perl_regnext(pTHX_ register regnode *p)
13149 {
13150     dVAR;
13151     register I32 offset;
13152
13153     if (!p)
13154         return(NULL);
13155
13156     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
13157         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(p), (int)REGNODE_MAX);
13158     }
13159
13160     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
13161     if (offset == 0)
13162         return(NULL);
13163
13164     return(p+offset);
13165 }
13166 #endif
13167
13168 STATIC void
13169 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
13170 {
13171     va_list args;
13172     STRLEN l1 = strlen(pat1);
13173     STRLEN l2 = strlen(pat2);
13174     char buf[512];
13175     SV *msv;
13176     const char *message;
13177
13178     PERL_ARGS_ASSERT_RE_CROAK2;
13179
13180     if (l1 > 510)
13181         l1 = 510;
13182     if (l1 + l2 > 510)
13183         l2 = 510 - l1;
13184     Copy(pat1, buf, l1 , char);
13185     Copy(pat2, buf + l1, l2 , char);
13186     buf[l1 + l2] = '\n';
13187     buf[l1 + l2 + 1] = '\0';
13188 #ifdef I_STDARG
13189     /* ANSI variant takes additional second argument */
13190     va_start(args, pat2);
13191 #else
13192     va_start(args);
13193 #endif
13194     msv = vmess(buf, &args);
13195     va_end(args);
13196     message = SvPV_const(msv,l1);
13197     if (l1 > 512)
13198         l1 = 512;
13199     Copy(message, buf, l1 , char);
13200     buf[l1-1] = '\0';                   /* Overwrite \n */
13201     Perl_croak(aTHX_ "%s", buf);
13202 }
13203
13204 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
13205
13206 #ifndef PERL_IN_XSUB_RE
13207 void
13208 Perl_save_re_context(pTHX)
13209 {
13210     dVAR;
13211
13212     struct re_save_state *state;
13213
13214     SAVEVPTR(PL_curcop);
13215     SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
13216
13217     state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
13218     PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
13219     SSPUSHUV(SAVEt_RE_STATE);
13220
13221     Copy(&PL_reg_state, state, 1, struct re_save_state);
13222
13223     PL_reg_start_tmp = 0;
13224     PL_reg_start_tmpl = 0;
13225     PL_reg_oldsaved = NULL;
13226     PL_reg_oldsavedlen = 0;
13227     PL_reg_maxiter = 0;
13228     PL_reg_leftiter = 0;
13229     PL_reg_poscache = NULL;
13230     PL_reg_poscache_size = 0;
13231 #ifdef PERL_OLD_COPY_ON_WRITE
13232     PL_nrs = NULL;
13233 #endif
13234
13235     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
13236     if (PL_curpm) {
13237         const REGEXP * const rx = PM_GETRE(PL_curpm);
13238         if (rx) {
13239             U32 i;
13240             for (i = 1; i <= RX_NPARENS(rx); i++) {
13241                 char digits[TYPE_CHARS(long)];
13242                 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
13243                 GV *const *const gvp
13244                     = (GV**)hv_fetch(PL_defstash, digits, len, 0);
13245
13246                 if (gvp) {
13247                     GV * const gv = *gvp;
13248                     if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
13249                         save_scalar(gv);
13250                 }
13251             }
13252         }
13253     }
13254 }
13255 #endif
13256
13257 static void
13258 clear_re(pTHX_ void *r)
13259 {
13260     dVAR;
13261     ReREFCNT_dec((REGEXP *)r);
13262 }
13263
13264 #ifdef DEBUGGING
13265
13266 STATIC void
13267 S_put_byte(pTHX_ SV *sv, int c)
13268 {
13269     PERL_ARGS_ASSERT_PUT_BYTE;
13270
13271     /* Our definition of isPRINT() ignores locales, so only bytes that are
13272        not part of UTF-8 are considered printable. I assume that the same
13273        holds for UTF-EBCDIC.
13274        Also, code point 255 is not printable in either (it's E0 in EBCDIC,
13275        which Wikipedia says:
13276
13277        EO, or Eight Ones, is an 8-bit EBCDIC character code represented as all
13278        ones (binary 1111 1111, hexadecimal FF). It is similar, but not
13279        identical, to the ASCII delete (DEL) or rubout control character.
13280        ) So the old condition can be simplified to !isPRINT(c)  */
13281     if (!isPRINT(c)) {
13282         if (c < 256) {
13283             Perl_sv_catpvf(aTHX_ sv, "\\x%02x", c);
13284         }
13285         else {
13286             Perl_sv_catpvf(aTHX_ sv, "\\x{%x}", c);
13287         }
13288     }
13289     else {
13290         const char string = c;
13291         if (c == '-' || c == ']' || c == '\\' || c == '^')
13292             sv_catpvs(sv, "\\");
13293         sv_catpvn(sv, &string, 1);
13294     }
13295 }
13296
13297
13298 #define CLEAR_OPTSTART \
13299     if (optstart) STMT_START { \
13300             DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
13301             optstart=NULL; \
13302     } STMT_END
13303
13304 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
13305
13306 STATIC const regnode *
13307 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
13308             const regnode *last, const regnode *plast, 
13309             SV* sv, I32 indent, U32 depth)
13310 {
13311     dVAR;
13312     register U8 op = PSEUDO;    /* Arbitrary non-END op. */
13313     register const regnode *next;
13314     const regnode *optstart= NULL;
13315     
13316     RXi_GET_DECL(r,ri);
13317     GET_RE_DEBUG_FLAGS_DECL;
13318
13319     PERL_ARGS_ASSERT_DUMPUNTIL;
13320
13321 #ifdef DEBUG_DUMPUNTIL
13322     PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
13323         last ? last-start : 0,plast ? plast-start : 0);
13324 #endif
13325             
13326     if (plast && plast < last) 
13327         last= plast;
13328
13329     while (PL_regkind[op] != END && (!last || node < last)) {
13330         /* While that wasn't END last time... */
13331         NODE_ALIGN(node);
13332         op = OP(node);
13333         if (op == CLOSE || op == WHILEM)
13334             indent--;
13335         next = regnext((regnode *)node);
13336
13337         /* Where, what. */
13338         if (OP(node) == OPTIMIZED) {
13339             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
13340                 optstart = node;
13341             else
13342                 goto after_print;
13343         } else
13344             CLEAR_OPTSTART;
13345
13346         regprop(r, sv, node);
13347         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
13348                       (int)(2*indent + 1), "", SvPVX_const(sv));
13349         
13350         if (OP(node) != OPTIMIZED) {                  
13351             if (next == NULL)           /* Next ptr. */
13352                 PerlIO_printf(Perl_debug_log, " (0)");
13353             else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
13354                 PerlIO_printf(Perl_debug_log, " (FAIL)");
13355             else 
13356                 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
13357             (void)PerlIO_putc(Perl_debug_log, '\n'); 
13358         }
13359         
13360       after_print:
13361         if (PL_regkind[(U8)op] == BRANCHJ) {
13362             assert(next);
13363             {
13364                 register const regnode *nnode = (OP(next) == LONGJMP
13365                                              ? regnext((regnode *)next)
13366                                              : next);
13367                 if (last && nnode > last)
13368                     nnode = last;
13369                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
13370             }
13371         }
13372         else if (PL_regkind[(U8)op] == BRANCH) {
13373             assert(next);
13374             DUMPUNTIL(NEXTOPER(node), next);
13375         }
13376         else if ( PL_regkind[(U8)op]  == TRIE ) {
13377             const regnode *this_trie = node;
13378             const char op = OP(node);
13379             const U32 n = ARG(node);
13380             const reg_ac_data * const ac = op>=AHOCORASICK ?
13381                (reg_ac_data *)ri->data->data[n] :
13382                NULL;
13383             const reg_trie_data * const trie =
13384                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
13385 #ifdef DEBUGGING
13386             AV *const trie_words = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
13387 #endif
13388             const regnode *nextbranch= NULL;
13389             I32 word_idx;
13390             sv_setpvs(sv, "");
13391             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
13392                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
13393
13394                 PerlIO_printf(Perl_debug_log, "%*s%s ",
13395                    (int)(2*(indent+3)), "",
13396                     elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
13397                             PL_colors[0], PL_colors[1],
13398                             (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
13399                             PERL_PV_PRETTY_ELLIPSES    |
13400                             PERL_PV_PRETTY_LTGT
13401                             )
13402                             : "???"
13403                 );
13404                 if (trie->jump) {
13405                     U16 dist= trie->jump[word_idx+1];
13406                     PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
13407                                   (UV)((dist ? this_trie + dist : next) - start));
13408                     if (dist) {
13409                         if (!nextbranch)
13410                             nextbranch= this_trie + trie->jump[0];    
13411                         DUMPUNTIL(this_trie + dist, nextbranch);
13412                     }
13413                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
13414                         nextbranch= regnext((regnode *)nextbranch);
13415                 } else {
13416                     PerlIO_printf(Perl_debug_log, "\n");
13417                 }
13418             }
13419             if (last && next > last)
13420                 node= last;
13421             else
13422                 node= next;
13423         }
13424         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
13425             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
13426                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
13427         }
13428         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
13429             assert(next);
13430             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
13431         }
13432         else if ( op == PLUS || op == STAR) {
13433             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
13434         }
13435         else if (PL_regkind[(U8)op] == ANYOF) {
13436             /* arglen 1 + class block */
13437             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_CLASS)
13438                     ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
13439             node = NEXTOPER(node);
13440         }
13441         else if (PL_regkind[(U8)op] == EXACT) {
13442             /* Literal string, where present. */
13443             node += NODE_SZ_STR(node) - 1;
13444             node = NEXTOPER(node);
13445         }
13446         else {
13447             node = NEXTOPER(node);
13448             node += regarglen[(U8)op];
13449         }
13450         if (op == CURLYX || op == OPEN)
13451             indent++;
13452     }
13453     CLEAR_OPTSTART;
13454 #ifdef DEBUG_DUMPUNTIL    
13455     PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
13456 #endif
13457     return node;
13458 }
13459
13460 #endif  /* DEBUGGING */
13461
13462 /*
13463  * Local variables:
13464  * c-indentation-style: bsd
13465  * c-basic-offset: 4
13466  * indent-tabs-mode: t
13467  * End:
13468  *
13469  * ex: set ts=8 sts=4 sw=4 noet:
13470  */